Set binary/base64 data as attachment in VB Script CDO.Message - iis

I am trying to send out an email with attachment as PDF. I have my attachment data in binary/Base64, but when I am trying to write this to the stream, it is not working. Here is my code. I am using upload class from here - http://www.codeguru.com/csharp/.net/net_asp/article.php/c19297/Pure-ASP-File-Upload.htm
<!--METADATA TYPE="TypeLib" FILE="C:\windows\system32\cdosys.dll" -->
<!-- #include file="upload.asp" -->
<%
' Create the FileUploader
Dim Uploader, File
Set Uploader = New FileUploader
' This starts the upload process
Uploader.Upload()
Dim uploadFileName
Dim uploadFileData
' Check if any files were uploaded
If Uploader.Files.Count > 0 Then
' Loop through the uploaded files
For Each File In Uploader.Files.Items
uploadFileName = File.FileName
uploadFileData = File.FileData
Next
End If
Set ObjMailer = CreateObject("CDO.Message")
Set iConf = Server.CreateObject("CDO.Configuration")
Set Flds = iConf.Fields
With Flds
.Item(cdoSendUsingMethod) = cdoSendUsingPort
.Item(cdoSMTPServer) = "localhost"
.Item(cdoSMTPServerPort) = 5000
.Item(cdoSMTPconnectiontimeout) = 10
.Update
End With
Set ObjMailer.Configuration = iConf
ObjMailer.Subject = "Subject"
ObjMailer.From = "from#testdomain.com"
ObjMailer.To = "to#testdomain.com"
ObjMailer.HTMLBody = "<h1>This is a sample html email body</h1>"
' Code to Attach the Email
Const cdoContentDisposition = "urn:schemas:mailheader:content-disposition"
Dim oPart : Set oPart = ObjMailer.Attachments.Add
oPart.ContentMediaType = "application/pdf"
oPart.Fields(cdoContentDisposition).Value = "attachment;filename=""Test.pdf"""
oPart.Fields.Update
Dim oStreamOut: Set oStreamOut = oPart.GetDecodedContentStream
oStreamOut.Type = 1
oStreamOut.Write uploadFileData
oStreamOut.Flush
ObjMailer.Send
Set ObjMailer = Nothing
Set iConf = Nothing
Set Flds = Nothing
If Err.number <> 0 Then
Response.Write "Error: " & Err.Number
Response.Write "Error (Hex): " & Hex(Err.Number)
Response.Write "Source: " & Err.Source
Response.Write "Description: " & Err.Description
End If
I get following error. I don't know where am I getting wrong.
ADODB.StreamDescription: Arguments are of the wrong type, are out of acceptable range, or are in conflict with one another.
Can somebody help?

Finally, I got this working. Thanks to kul-tigin for pointing the issue for vbArray + vbByte. The data uploaded is multi-byte data and I need to normalize it.
Here is the function I got here to convert the multi-byte array.
Function GetFileDataBinary()
Dim RS, LMultiByte, Binary
Const adLongVarBinary = 205
Set RS = CreateObject("ADODB.Recordset")
LMultiByte = LenB(FileData)
If LMultiByte > 0 Then
RS.Fields.Append "mBinary", adLongVarBinary, LMultiByte
RS.Open
RS.AddNew
RS("mBinary").AppendChunk FileData & ChrB(0)
RS.Update
Binary = RS("mBinary").GetChunk(LMultiByte)
End If
GetFileDataBinary = Binary
End Function
I changed my code like below and it worked just seemlessly.
Dim uploadFileName
Dim uploadFileData
' Check if any files were uploaded
If Uploader.Files.Count > 0 Then
' Loop through the uploaded files
For Each File In Uploader.Files.Items
uploadFileName = File.FileName
uploadFileData = File.GetFileDataBinary
Next
End If
I can call File.GetFileDataBinary because I put my GetFileDataBinary in my upload.asp.

Related

Search number of times a string occurs in text file

I am trying to go read a text file and count the number of times a phrase/string (not word) occurs in the text file, but so far what I have is this:
Const ForReading = 1
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile("D:\VBscript project\testing.txt", ForReading)
strContents = objFile.ReadAll
objFile.Close
i = 0
arrLines = Split(strContents, "")
For Each strLine in arrLines
If InStr(strLine, "hi there") Then
i = i + 1
End If
Next
WScript.Echo "Number of times word occurs: " & i
This will only allow me to count the number of times a word occurs, which does not work when I try to tweak it to count phrases.
Consider the below example:
strPath = "D:\VBscript project\testing.txt"
strPhrase = "hi there"
strContent = ReadTextFile(strPath, 0)
arrContent = Split(strContent, strPhrase)
MsgBox "Number of times phrase occurs: " & UBound(arrContent)
Function ReadTextFile(strPath, lngFormat)
' lngFormat -2 - System default, -1 - Unicode, 0 - ASCII
With CreateObject("Scripting.FileSystemObject").OpenTextFile(strPath, 1, False, lngFormat)
ReadTextFile = ""
If Not .AtEndOfStream Then ReadTextFile = .ReadAll
.Close
End With
End Function
Note that Split-based method is case-sensitive.
strPath = "D:\VBscript project\testing.txt"
strPhrase = "hi there"
strContent = ReadTextFile(strPath, 0)
arrContent = Split(strContent, strPhrase)
MsgBox "Number of times phrase occurs: " & UBound(arrContent)
Function ReadTextFile(strPath, lngFormat)
' lngFormat -2 - System default, -1 - Unicode, 0 - ASCII
With CreateObject("Scripting.FileSystemObject").OpenTextFile(strPath, 1, False, lngFormat)
ReadTextFile = ""
If Not .AtEndOfStream Then ReadTextFile = .ReadAll
.Close
End With
End Function
If I understood you correctly and what you are asking for is really as simple as it looks, you could just change the "hi there" string to a parameter. This way you can dynamically tell your function what to look for.
EDIT: Thanks to #omegastripes I noticed a flaw in my previous code, so this is one that would work.
The code would be like this:
Sub yourSubName (pstrTextToCount)
Const ForReading = 1
Dim objFSO : Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim objFile : Set objFile = objFSO.OpenTextFile("D:\VBscript project\testing.txt", ForReading)
Dim strContents : strContents = objFile.ReadAll
objFile.Close
' You don't need these objects anymore, so release them
Set objFile = Nothing
Set objFSO = Nothing
Dim intTextPosition : intTextPosition = 0
Dim i : i = -1
Do
i = i + 1
intTextPosition = InStr(intTextPosition + 1, strContents, pstrTextToCount)
Loop While (intTextPosition > 0)
Wscript.Echo "Number of times '" & pstrTextToCount & "' occurs: " & i
End Sub
I am assuming your Sub will only do that and this is why I enclosed it into the Sub, End Sub statements. You can add any other coding that you need, but only remember to add your required parameter on the signature of the Sub for it to work.
PS: As a good practice, always Dim your variables and release memory of objects that are no longer needed with Set objName = Nothing
Here a version using Regular Expressions so you can specify if the search needs to be case sensitive.
For testpurpose I use the contents of the script itself as input.
Dim path, phrase, content
path = Wscript.ScriptFullName
phrase = "hi there\^$*+?{}.()|[]"
content = CreateObject("Scripting.FileSystemObject").OpenTextFile(path).ReadAll
Function NumberOfPhrasesInString(phrase, text, IgnoreCase)
Dim regexpr, matches
Set regexpr = New RegExp
phrase = RegExEscape(phrase)
With regexpr
.Pattern = phrase
.Global = True
.IgnoreCase = IgnoreCase
Set matches = .Execute(text)
End With
NumberOfPhrasesInString = matches.count
End Function
Function RegExEscape(str)
Dim special
RegExEscape = str
special = "\^$*+?{.()|[]"
For i=1 To Len(special)
RegExEscape = replace(RegExEscape, Mid(special, i, 1), "\" & Mid(special, i, 1))
Next
End Function
Wscript.Echo "Number of times phrase occurs: " & NumberOfPhrasesInString(phrase, content, false)
As a bonus, since I'm switched to Ruby here also that version
path = __FILE__ # the path to this script for test purposes
phrase = 'HI THERE \ ^ $ * + ? { . ( | ['
puts phrase
content = File.read path
def number_of_phrases_in_string(phrase, text, ignoreCase=false )
escaped = Regexp.escape(phrase)
text.scan(Regexp.new(escaped, ignoreCase)).count.to_s
end
puts "Number of times phrase occurs: " + number_of_phrases_in_string(phrase, content, true)
Or in a single line
puts File.read(__FILE__).scan(Regexp.new(Regexp.escape(phrase), true)).count
The true in the last line defines casesensitivity

How to finda text and get the page no. for acrobat using vba

I want to find the text and get the page number of text found in acrobat using VBA, I am able to find the text but not able to get the page number. for that
Sub Main()
Dim acrApp, acrAVDoc
Set acrApp = CreateObject("AcroExch.app")
Set acrAVDoc = CreateObject("AcroExch.AVDoc")
acrApp.Show
If acrAVDoc.Open("FileName", "") Then
Ok = acrAVDoc.FindText("Text to search", 0, 1, 1)
MsgBox (Ok)
End If
Set acrAVDoc = Nothing
Set acrApp = Nothing
End Sub
I am not able to set the object for
Set acrPDDoc = CreateObject("Acrobat.AV_PAGE_VIEW")
I know this is an old question, but it was one of the top search results when I was looking for the same info. I never found anything that truly met my needs so I made something up by combining several different resources.
The function below is acceptably fast, even on very large documents. It searches page by page, not word by word, so it will find multi-word matches and words with dashes (case insensitive). It returns the matches for all pages separated by commas.
Hope this is helpful to someone in the future.
Sub Demo()
Dim SearchResult As String
SearchResult = AdobePdfSearch("my search string", "C:\Demo\Demo.pdf")
MsgBox SearchResult
End Sub
Function AdobePdfSearch(SearchString As String, strFileName As String) As String
'Note: A Reference to the Adobe Library must be set in Tools|References!
'Note! This only works with Acrobat Pro installed on your PC, will not work with Reader
Dim AcroApp As CAcroApp, AcroAVDoc As CAcroAVDoc, AcroPDDoc As CAcroPDDoc
Dim AcroHiliteList As CAcroHiliteList, AcroTextSelect As CAcroPDTextSelect
Dim PageNumber, PageContent, Content, i, j, iNumPages
Dim strResult As String
Set AcroApp = CreateObject("AcroExch.App")
Set AcroAVDoc = CreateObject("AcroExch.AVDoc")
If AcroAVDoc.Open(strFileName, vbNull) <> True Then Exit Function
Set AcroPDDoc = AcroAVDoc.GetPDDoc
iNumPages = AcroPDDoc.GetNumPages
For i = 0 To iNumPages - 1
Set PageNumber = AcroPDDoc.AcquirePage(i)
Set PageContent = CreateObject("AcroExch.HiliteList")
If PageContent.Add(0, 9000) <> True Then Exit Function
Set AcroTextSelect = PageNumber.CreatePageHilite(PageContent)
' The next line is needed to avoid errors with protected PDFs that can't be read
On Error Resume Next
For j = 0 To AcroTextSelect.GetNumText - 1
Content = Content & AcroTextSelect.GetText(j)
Next j
If InStr(1, LCase(Content), LCase(SearchString)) > 0 Then
strResult = IIf(strResult = "", i + 1, strResult & "," & i + 1)
End If
Content = ""
Next i
AdobePdfSearch = strResult
'Uncomment the lines below if you want to close the PDF when done.
'AcroAVDoc.Close True
'AcroApp.Exit
'Set AcroAVDoc = Nothing: Set AcroApp = Nothing
End Function
sub checks each page of pdf, word by word
Sub FindtextandPageNumber()
Dim FindWord 'Word you want to search
Dim acroAppObj As Object
Dim PDFDocObj As Object
Dim myPDFPageHiliteObj As Object
Dim iword As Integer, iTotalWords As Integer
Dim numOfPage As Integer, Nthpage As Integer
Dim word As String, sPath As String
Set acroAppObj = CreateObject("AcroExch.App")
Set PDFDocObj = CreateObject("AcroExch.PDDoc")
Set myPDFPageHiliteObj = CreateObject("AcroExch.HiliteList")
Check3 = myPDFPageHiliteObj.Add(0, 32767)
FindWord = "Hello"
acroAppObj.Show
sPath = "Test.pdf" 'Path of pdf where you want to search
PDFDocObj.Open (sPath)
numOfPage = PDFDocObj.GetNumPages
word = vbNullString
Set PDFJScriptObj = Nothing
For Nthpage = 0 To numOfPage - 1
Set pAcroPDPage = PDFDocObj.AcquirePage(Nthpage)
Set wordHilite = pAcroPDPage.CreateWordHilite(myPDFPageHiliteObj)
Set PDFJScriptObj = PDFDocObj.GetJSObject
iTotalWords = wordHilite.GetNumText
iTotalWords = PDFJScriptObj.getPageNumWords(Nthpage)
''check the each word
For iword = 0 To iTotalWords - 1
word = Trim(CStr(PDFJScriptObj.getPageNthWord(Nthpage, iword)))
If word <> "" Then
If word = FindWord Then
PageNumber = Nthpage
msgbox PageNumber
End If
word = ""
End If
Next iword
Next Nthpage
End Sub

LotusScript getting data from a view

I am new to lotus script, and I'm trying to get data from a view and save it into a string. But each time I do that I get the error that Initialize Object variable not set on line 36. In my domino designer Line 36 is right under ItemNames(6).
I tried to use the code from my friend and I get the same error, while his works without a problem.
Please help I'm desperate to make this work.
Sub Initialize
On Error GoTo ERRSUB
Dim nSession As New NotesSession
Dim nDb As NotesDatabase
Dim nDoc As NotesDocument
Dim view As NotesView
Dim nitem As NotesItem
Dim strRecord As String
Dim DataString As String
Dim nList List As String
Dim ListCount As Integer
Dim FirstLine As String
Dim counter As Integer
counter = 0
Dim ItemNames(6) As String
ItemNames(0) = "Date"
ItemNames(1) = "Name"
ItemNames(2) = "Name of buyer"
ItemNames(3) = "Naziv of project"
ItemNames(4) = "value"
ItemNames(5) = "source"
ItemNames(6) = "status"
Set nDb = nSession.Currentdatabase
Set view = nDb.Getview("X_view_1")
Set ndoc = view.Getfirstdocument()
Do Until (ndoc Is nothing)
ForAll item In ItemNames
Set nitem = ndoc.Getfirstitem(item)
DataString = nitem.Values & ";"
counter = counter + 1
End ForAll
DataString = DataString & Chr(13)
Set ndoc = view.Getnextdocument(ndoc)
Loop
GoTo DONE
DONE:
MessageBox counter
Exit Sub
ERRSUB:
Call logger("Error",nSession.currentagent.name,"Initialize","","")
GoTo done
End Sub
Line 36 is DataString = nitem.Values & ";". The error is that nitem is not set properly. Probably the item is not available in a certain document. Test for nitem isn't Nothing.
Change your ForAll loop to
ForAll item In ItemNames
Set nitem = ndoc.Getfirstitem(item)
If Not nitem Is Nothing then
DataString = DataString & nitem.Text
End If
DataString = DataString & ";"
counter = counter + 1
End ForAll
I would writ it something like this below.
Among the things I notice in your code:
* You use GoTo in your error handler, should be a Resume instead.
* You have "GoTo DONE" when the code would get there anyway, that is not needed.
* You have several variables declared that you don't use.
* You don't use much error checking, Knut's suggestion is a good one.
Here is my suggestion, this is how I would export a view:
Sub Initialize
Dim session As New NotesSession
Dim db As NotesDatabase
Dim view As NotesView
Dim col As NotesViewEntryCollection
Dim entry As NotesViewEntry
Dim DataString As String
Dim cnt List As Long
On Error GoTo errHandler
Set db = session.Currentdatabase
Set view = db.Getview("X_view_1")
Set col = view.AllEntries
'*** Set counters
cnt("total") = col.Count
cnt("processed") = 0
'*** Loop though all view entries, much faster that documents
Set entry = col.GetFirstEntry()
Do Until entry Is Nothing
'*** Update status bar every 100 documents
If cnt("processed") Mod 100 = 0 Then
Print "Processed " & cnt("processed") & " of " & cnt("total") & " documents."
End If
'*** Read view columns and add to string
ForAll cv In entry.ColumnValues
DataString = cv & ";"
End ForAll
'*** Add line break to string
DataString = DataString & Chr(13)
'*** Update counter and get next entry in view collection
cnt("processed") = cnt("processed") + 1
Set entry = col.GetNextEntry(entry)
Loop
exitSub:
MsgBox "Processed " & cnt("processed") & " of " & cnt("total") & " documents.",,"Finished"
Exit Sub
errHandler:
Call logger("Error",session.CurrentAgent.Name,"Initialize","","")
Resume exitSub
End Sub
Another way to do it would be to read the the value directly from the NotesDocument:
DataString = doc.GetItemValue(item)(0) & ";"
Of course, this will only read the first value of any multi-value fields, but you can fix that like this:
DataString = Join(doc.GetItemValue(item),"~") & ";"
This will put a ~ between each value if there are more than one, then you can process that the way you like.

LotusScript cannot get file attachment from email

I had never run into this problem, but I cannot get a handle on a file attachment on an email. I have code that can either search the document for Embedded Objects or search a field for Embedded Objects -- neither of them are returning the file. I can see the file on the email and I can see the $FILE field which contains the file attachment.
Here is the code:
Function FileDetachFiles(doc As NotesDocument, fieldName As String, getFromField As Integer) As Variant
On Error Goto ProcessError
Dim s As NotesSession
Dim db As NotesDatabase
Dim rtItem As NotesRichTextItem
Dim fileToExtract As String
Dim fileName As String
Dim fileArray() As String
Dim message As String
Dim embedObjects As Variant
Dim attachFile As Integer
Dim x As Integer
Set s = New NotesSession
Set db = s.CurrentDatabase
Const fileImport = "C:\"
attachFile = False
'Let's see if there are attached files...
If getFromField = True Then
'Locate field and get files...
If doc.HasEmbedded Then
If doc.HasItem(fieldName) Then
'Set the first field...
Set rtItem = doc.GetFirstItem(fieldName)
embedObjects = rtItem.EmbeddedObjects
If Isarray(embedObjects) Then
Forall Files In rtItem.EmbeddedObjects
If Files.Type = EMBED_ATTACHMENT Then
fileName = Files.Source
fileToExtract = fileImport & fileName
Redim Preserve fileArray(x)
fileArray(x) = fileToExtract
x = x + 1
Call Files.ExtractFile(fileToExtract)
attachFile = True
End If
End Forall
End If
End If
End If
Else
x = 0
'Go through doc looking for all embedded objects...
If doc.HasEmbedded Then
Forall o In doc.EmbeddedObjects
If o.Type = EMBED_ATTACHMENT Then
fileName = o.Name
fileToExtract = fileImport & fileName
Call o.ExtractFile(fileToExtract)
Redim Preserve fileArray(x)
fileArray(x) = fileToExtract
x = x + 1
attachFile = True
End If
End Forall
End If
End If
If attachFile = True Then
FileDetachFiles = fileArray
End If
Exit Function
ProcessError:
message = "Error (" & Cstr(Err) & "): " & Error$ & " on line " & Cstr(Erl) & " in GlobalUtilities: " & Lsi_info(2) & "."
Messagebox message, 16, "Error In Processing..."
Exit Function
End Function
I tried both routines above -- passing the $FILE and Body field names, as well as searching the document. It does not find any file attachments.
I even tried this:
Extracting attachments as MIME using LotusScript
Which did not find any MIME on the document.
I have never run into this problems -- any ideas would be great.
Thanks!
I had that before, but unfortunately do not remember, where it comes from, it might have to do something with V2- Style Attachments coming from Domino Websites...
Try Evaluate( #AttachmentNames ) to get a Variant containing the names of all attachments. Then loop through this with a Forall- loop and try the NotesDocument.getAttachment( strLoopValue ) - Function to get a handle to the attachment.
For further info read here and follow the links on that page, especially this one
Code would be something like this:
Dim doc as NotesDocument
Dim varAttachmentNamens as Variant
Dim object as NotesEmbeddedObject
REM "Get the document here"
varAttachmentNames = Evaluate( "#AttachmentNames" , doc )
Forall strAttachmentName in varAttachmentNames
Set object = doc.GetAttachment( strAttachmentName )
REM "Do whatever you want..."
End Forall

Lotus Notes Agent - Remove Embedded Images?

I have an agent someone shared years ago which takes attached files, saves them to my hard drive, and removes them from the email. I use it to keep my emails for a while but stay under my corporate mailbox quota. I get a LOT of attachments.
I'm now finding that a lot of the remaining large emails have embedded images rather than "attached files". Can anyone share a script that would actually be able to do the same (save to hard drive, remove from email) with an embedded image?
FWIW, here is the agent I use for detaching attachments. Props to original author, don't know who that was.
Dim sDir As String
Dim s As NotesSession
Dim w As NotesUIWorkspace
Dim db As NotesDatabase
Dim dc As NotesDocumentCollection
Dim doc As NotesDocument
Sub Initialize
Set s = New NotesSession
Set w = New NotesUIWorkspace
Set db = s.CurrentDatabase
Set dc = db.UnprocessedDocuments
Set doc = dc.GetFirstDocument
Dim rtItem As NotesRichTextItem
Dim RTNames List As String
Dim DOCNames List As String
Dim itemCount As Integer
Dim sDefaultFolder As String
Dim vtDir As Variant
Dim iCount As Integer
Dim j As Integer
Dim lngExportedCount As Long
Dim attachmentObject As Variant
Dim text As String
Dim subjectLine As String
Dim attachmentMoved As Boolean
' Prompt the user to ensure they wish to continue extracting the attachments
Dim x As Integer
x = Msgbox("V4 This action will extract all attachments from the " & Cstr (dc.Count) & " document(s) you have selected, and place them into the folder of your choice." & _
Chr(10) & Chr(10) & "Would you like to continue?", 32 + 4, "Export Attachments")
If x <> 6 Then Exit Sub
' Set the folder where the attachments will be exported
sDefaultFolder = s.GetEnvironmentString("LPP_ExportAttachments_DefaultFolder")
If sDefaultFolder = "" Then sDefaultFolder = "F:"
vtDir = w.SaveFileDialog( False, "Export attachments to which folder?", "All files|*.*", sDefaultFolder, "Choose Folder and Click Save")
If Isempty(vtDir) Then Exit Sub
sDir = Strleftback(vtDir(0), "\")
Call s.SetEnvironmentVar("LPP_ExportAttachments_DefaultFolder", sDir)
' Loop through all the selected documents
While Not (doc Is Nothing)
iCount = 0
itemCount = 0
lngExportedCount = 0
Erase RTNames
Erase DocNames
' Find all of the RichText fields in the current document. If any have an embedded object, add the item to the RTNames array.
Forall i In doc.Items
If i.Type = RICHTEXT Then
If Not Isempty(i.EmbeddedObjects) Then
'Msgbox i.Name,64,"Has embedded objects"
End If
Set rtItem = doc.GetfirstItem(i.Name)
'Set rtItem = i
If Not Isempty(rtItem.EmbeddedObjects) Then
RTNames(itemCount) = Cstr(i.Name)
itemCount = itemCount +1
End If
End If
End Forall
' Loop through the RTNames array and see if any of the embedded objects are attachments
attachmentMoved = False
For j = 0 To itemCount-1
Set rtItem = Nothing
Set rtItem = doc.GetfirstItem(RTNames(j))
Forall Obj In rtItem.EmbeddedObjects
If ( Obj.Type = EMBED_ATTACHMENT ) Then
' The embedded object is an attachment. Export it to the chosen directory
Call ExportAttachment(Obj)
' Append to the bottom of the file details on the extracted file and its new location.
Call rtItem.AddNewline(1)
Call rtitem.AppendText("---------------------------------------" + Chr(13) + Chr(10))
text = """" + sDir + "\"+ Obj.Name + """" + Chr(13) + Chr(10) + Chr(9) + "Extracted by: " + s.UserName + " on " + Str$(Today()) + ". "
Call rtitem.AppendText(text )
Call rtItem.AddNewline(1)
' Remove the object from the file and save the document.
Call Obj.Remove
Call doc.Save( False, True ) 'creates conflict doc if conflict exists
attachmentMoved = True
Else
Forall verb In Obj.Verbs
'Msgbox verb, 64, "VERB"
End Forall
End If
End Forall
' If the document had an attachment moved, update the subject line
If attachmentMoved = True Then
Dim item As Notesitem
Set item = doc.GetFirstItem("Subject")
subjectLine = item.Text + "- ATTACHMENT MOVED"
Set item = doc.ReplaceItemValue("Subject", subjectLine)
Call doc.Save( False, True ) 'creates conflict doc if conflict exists
End If
Next
Set doc = dc.GetNextDocument(doc)
Wend
Msgbox "Export Complete.", 64, "Finished"
End Sub
Sub ExportAttachment(o As Variant)
Dim sAttachmentName As String
Dim sNum As String
Dim sTemp As String
' Create the destination filename
sAttachmentName = sDir & "\" & o.Source
' Loop through until the filename is unique
While Not (Dir$(sAttachmentName, 0) = "")
' Get the last three characters of the filename - "_XX"
sNum = Right(Strleftback(sAttachmentName, "."), 3)
' Ensure the first of the three characters is an underscore and the next two are numeric. If they are, add one to the existing number and insert it back in.
If Left(sNum,1) = "_" And Isnumeric(Right(sNum, 2)) Then
sTemp = Strleftback(sAttachmentName, ".")
sTemp = Left(sTemp, Len(sTemp) - 2)
sAttachmentName = sTemp & Format$(Cint(Right(sNum,2)) + 1, "##00") & "." & Strrightback(sAttachmentName, ".")
Else
sAttachmentName = Strleftback(sAttachmentName, ".") & "_01." & Strrightback(sAttachmentName, ".")
End If
Wend
' Save the file
Call o.ExtractFile( sAttachmentName )
End Sub
This is very problematic to do with the script as it currently stands as MIME encoded images won't show up as any type of attachment using the EmbeddedObjects Property.
If the images are stored inline as part of a MIME message, the Notes client will turn them into an attachment for viewing, but programmatically the can only be accessed as parts of the MIME message. It should be achievable to grab the correct part of a multi-part MIME message with the image encoded (using the MIMEEntity classes), stream this out to disc and reconstitute the original file(s) then remove the MIMEEntity that represented it (and took up the space).
More info on the
IBM Support Site
NotesMIMEEntity Class Documentation

Resources