Lotus Notes Agent - Remove Embedded Images? - lotus-notes

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

Related

Populate a combo box with a list of last 10 latest folders from a directory

I have a combo box that I want to be filled with a list of last 10 latest folders in a specified directory. Say,
There are 40 folders. In the combo box it should list the latest 10 folders.
Thank you,
Private Sub UserForm_Initialize()
Dim name
For Each name In ListDirectory(Path:="C:\Users\AllertonFC\Documents\FA Level 1 & Level 2\", AttrInclude:=vbDirectory, AttrExclude:=vbSystem Or vbHidden)
Me.ComboBox1.AddItem name
Next name
End Sub
Function ListDirectory(Path As String, AttrInclude As VbFileAttribute, Optional AttrExclude As VbFileAttribute = False) As Collection
Dim Filename As String
Dim Attribs As VbFileAttribute
Set ListDirectory = New Collection
' first call to Dir() initializes the list
Filename = Dir(Path, AttrInclude)
While Filename <> ""
Attribs = GetAttr(Path & Filename)
' to be added, a file must have the right set of attributes
If Attribs And AttrInclude And Not (Attribs And AttrExclude) Then
ListDirectory.Add Filename, Path & Filename
End If
' fetch next filename
Filename = Dir
Wend
End Function
This should work, I find it easier to put values into a string and split it at the last minute into an array, also not using Dir, instead using a Scripting.FileSystemObject
Public Sub cBoxFiller()
Dim oFS As Object, SrcFldr As String, oFldr As Object, xFldr As Object
Dim FldrsTxt As String, FldrsAR() As String, GudCtr As Long
Dim cBoxTxt As String, i As Long
SrcFldr = "C:\Users\AllertonFC\Documents\FA Level 1 & Level 2\"
Set oFS = CreateObject("Scripting.FileSystemObject")
Set oFldr = oFS.getfolder(SrcFldr)
' Generate an Array of ALL SubFolders
FldrsTxt = ""
For Each xFldr In oFldr.subFolders
FldrsTxt = IIf(FldrsTxt = "", "", FldrsTxt & vbCrLf) & xFldr.name ' or xFldr.Path
Next xFldr
FldrsAR = Split(FldrsTxt, vbCrLf)
' Done
' Build a String of Last 10 Folders - separated by VbCrLf
GudCtr = 0
For i = UBound(FldrsAR) To LBound(FldrsAR) Step -1
If GudCtr < 10 Then
GudCtr = GudCtr + 1
cBoxTxt = IIf(cBoxTxt = "", "", cBoxTxt & vbCrLf) & FldrsAR(i)
End If
Next i
' Done
' Split into an Array & Assign to the ComboBox
ComboBox1.List = Split(cBoxTxt, vbCrLf)
' Done
End Sub

Getting "The linked document (UNID... cannot be found in the view (UNID ...)" Error Message

I'm getting the error message below:
Upon clicking the doclink which was being attached in the e-mail which was generated by me through clicking the send to managers button. I also tried using NotesURL instead of doclink:
Call rtitem.appendtext(emaildoc.Notesurl)
but the generated URL is different from the doclink. Below is the generated from the doclink itself.
Generated NotesURL: notes://LNCDC#PHGDC/__48257E3E00234910.nsf/0/237B2549EEA393A948257E530042BA4A?OpenDocument
Doclink: Notes://LNCDC/48257E3E00234910/28BD6697AB48F55348257E2D0006CF60/C9B0266FDC0D929E48257E530041D6F9
Can you please help? Below is my agent code.
%REM
Agent Send Email to Managers
%END REM
Option Public
Option Declare
Dim s As NotesSession
Dim db As NotesDatabase
Dim emaildoc As NotesDocument
Dim paydoc As NotesDocument
Dim rtitem As NotesRichTextItem
Dim i As Integer
Dim view As NotesView
Sub Initialize
Set s = New NotesSession
Set db = s.CurrentDatabase
Set view = db.GetView("Pending Claims")
Dim addresses As NotesName
Dim arrpem As Variant
ReDim arrpem(0)
Set paydoc = view.GetFirstDocument
'// Store all PEM names in an array
While Not(paydoc Is Nothing)
ReDim Preserve arrpem(UBound(arrpem) + 1)
arrpem(UBound(arrpem)) = paydoc.PeopleManager(0)
Set paydoc = view.GetNextDocument(paydoc)
Wend
'// Remove all duplicate PEM names and empty entries in the array
arrpem = FullTrim(ArrayUnique (arrpem))
'// Loop the PEM names array
ForAll pem In arrpem
Set emaildoc = New NotesDocument(db)
Set addresses = New NotesName(pem)
If addresses.abbreviated <> "" Then
emaildoc.SendTo = addresses.abbreviated
emaildoc.Subject = "Leave Balances of your Direct Reports"
emaildoc.Form = "Memo"
Set rtitem = New NotesRichTextItem(emaildoc, "Body")
Call rtitem.AppendText("Dear " & addresses.common & ",")
Call rtitem.AddNewLine(2)
'// Remove paydoc value which was used in the PEM names array
Set paydoc = Nothing
'// Get all documents that has matching PEM name in the view
Dim dc As NotesDocumentCollection
Set dc = view.GetAllDocumentsByKey(addresses.Abbreviated, True)
Set paydoc = dc.GetFirstDocument
'// Append doc link of employee
While Not(paydoc Is Nothing)
Call rtitem.AppendText("Doc link of :" & paydoc.FMName(0) & " " & paydoc.LastName(0))
Call rtitem.appenddoclink(emaildoc, "Link to Leave Balance of " & paydoc.FMName(0) & " " & paydoc.LastName(0))
Call rtitem.AddNewLine(1)
Set paydoc = dc.GetNextDocument(paydoc)
Wend
'// Send email per PEM
Call emaildoc.Send(False)
End If
End ForAll
MsgBox "Emails successfully sent."
End Sub
The doclink is pointing back to the document you've created in memory for your email. When sent, that document no longer exists in the original database.
Change your code to be:
Call rtitem.appendtext(paydoc.Notesurl)

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.

Getting the range used to define error bars with VBA

I have an Excel chart. One of the series has X and Y error bars, defined from worksheet ranges.
I want to get via VBA those ranges (not set them). Is this possible?
Jon Peltier has an article about error bars on his blog here
Quoting from that:
Programmatically Defining Custom Error Bars
The command to add error bars using Excel is: {Series}.ErrorBar
Direction:={xlX or xlY}, Include:=xlBoth, Type:=xlCustom, _
Amount:={positive values}, MinusValues:={negative values} Values can be a single numerical value, for example, 1, an comma-separated
array of numerical values in curly braces, such as {1,2,3,4}, or a
range address in R1C1 notation. For values in Sheet1!$G$2:$G$10, enter
the address as Sheet1!R2C7:R10C7. Combine both plus and minus in the
same command. In Excel 2007, if you don’t want to show a particular
error bar, you must enter a value of zero in this command. In 2003,
you can enter a null string “”. In Excel 2003, the range address must
begin with an equals sign, =Sheet1!R2C7:R10C7; Excel 2007 accepts the
address with or without the equals sign. Single values or arrays may
be entered with or without the equals sign in either version of Excel.
In a post on Ozgrid, Jon Peltier says
the range for custom error bar values is not exposed to VBA
If Jon says it can't be done, it can't be done.
I know I'm 8 years late to the party here... but I stumbled upon this while scouring the web for the answer to this same question. I came up empty too, so I decided to devise my own solution, and figured I might as well post it on the off chance that someone else ends up here.
It works by extracting the workbook XML to a temporary folder, locating the error bar reference in the XML, and returning it as a Range object. You therefore have to save changes to the workbook before the function will work. If you change the error bar range without saving, the function will still return the old range from the most recent save. It also will not work on files from Excel 2003 or earlier (.xls).
It's anything but elegant... but at least this is technically possible!
To use: just copy the code below into a standard module, and call GetErrorBarRange(MySeries.ErrorBars, enErrorBarPlus) for the source range of the positive error bar, or GetErrorBarRange(MySeries.ErrorBars, enErrorBarMinus) for the source range of the negative error bar (where MySeries.ErrorBars is some ErrorBars object). Passing the optional third argument AutoSave:=True will save the containing workbook automatically before looking for the error bar source ranges.
' Created by Ryan T. Miller in 2022
' You may use this code in your own work however you wish. It'd be real swell of you
' to leave this credit in if you do, but I'm not gonna force you to.
Option Explicit
Option Private Module
Public Enum EnErrorBarPlusMinus
enErrorBarPlus
enErrorBarMinus
End Enum
Private moFSO As Object
' Get error bar source range from ErrorBars object
Public Function GetErrorBarRange(oErrorBars As ErrorBars, _
PlusMinus As EnErrorBarPlusMinus, _
Optional AutoSave As Boolean) As Range
Dim oFile As Object
Dim strTempDir As String
Dim strSubfolder As String
Dim oSeries As Series
Dim oChart As Chart
Dim oSheet As Object
Dim oWb As Workbook
Dim strPrefix As String
Dim strSeriesName As String
Dim strChartName As String
Dim strSheetName As String
Dim strXMLFile As String
Dim strXPath As String
Dim strCurrentSheet As String
Dim strRelId As String
Dim strDrawingXml As String
Dim strChartXml As String
Dim strErrValType As String
Dim strErrBarType As String
Dim strErrBarFormula As String
Dim rngResult As Range
On Error GoTo CleanUp
If Not (PlusMinus = enErrorBarMinus _
Or PlusMinus = enErrorBarPlus) Then Exit Function
Set moFSO = CreateObject("Scripting.FileSystemObject")
Application.Cursor = xlWait
' Set Series, Chart, Sheet, and Workbook objects
Set oSeries = oErrorBars.Parent
Set oChart = oSeries.Parent.Parent
If TypeOf oChart.Parent Is ChartObject Then
' Chart is on a worksheet
Set oSheet = oChart.Parent.Parent
strPrefix = "work"
Else
' Chart is on its own chart sheet
Set oSheet = oChart
strPrefix = "chart"
End If
Set oWb = oSheet.Parent
If AutoSave Then oWb.Save
' Name of the series, chart & its parent sheet
strSeriesName = oSeries.Name
strChartName = oChart.Parent.Name
strSheetName = oSheet.CodeName
strTempDir = ExtractWorkbookXMLToTemp(oWb)
' Loop over worksheet/chartsheet XML files & find the one where /worksheet/sheetPr/#codeName=strSheetName
' Then get strRelId from /worksheet/drawing/#r:id
' This is the ID which specifies which relationship links the sheet to the drawings.
strSubfolder = moFSO.BuildPath(strTempDir, "xl\" & strPrefix & "sheets")
strXPath = "/x:" & strPrefix & "sheet/x:sheetPr/#codeName"
For Each oFile In moFSO.GetFolder(strSubfolder).Files
strXMLFile = moFSO.BuildPath(strSubfolder, oFile.Name)
strCurrentSheet = GetXPathFromXMLFile(strXMLFile, strXPath)
If strSheetName = strCurrentSheet Then Exit For
Next oFile
strXPath = "/x:" & strPrefix & "sheet/x:drawing/#r:id"
strRelId = GetXPathFromXMLFile(strXMLFile, strXPath)
' Open the _rels XML associated with the correct sheet.
' Then get strDrawingXml from /Relationships/Relationship[#Id='strRelId']/#Target
' This is the name of the drawing XML.
strSubfolder = strSubfolder & "\_rels"
strXMLFile = moFSO.BuildPath(strSubfolder, moFSO.GetFileName(strXMLFile)) & ".rels"
strXPath = "/rel:Relationships/rel:Relationship[#Id='" & strRelId & "']/#Target"
strDrawingXml = GetXPathFromXMLFile(strXMLFile, strXPath)
strDrawingXml = Replace$(Replace$(strDrawingXml, "../", "/"), "/", "\")
' Open the correct drawing XML file (strDrawingXml)
' Then get strRelId from xdr:wsDr//xdr:graphicFrame[xdr:nvGraphicFramePr/xdr:cNvPr/#name='strChartName']/a:graphic/a:graphicData/c:chart/#r:id
' Or, if oSheet is a ChartSheet, there will only be 1 chart, so just get xdr:wsDr//xdr:graphicFrame/a:graphicData/a:graphic/c:chart/#r:id
' This is the ID which specifies which relationship links the drawing to the chart.
strXMLFile = moFSO.BuildPath(strTempDir, "xl" & strDrawingXml)
strXPath = "xdr:wsDr//xdr:graphicFrame" & _
IIf(TypeOf oChart.Parent Is ChartObject, "[xdr:nvGraphicFramePr/xdr:cNvPr/#name='" & strChartName & "']", vbNullString) & _
"/a:graphic/a:graphicData/c:chart/#r:id"
strRelId = GetXPathFromXMLFile(strXMLFile, strXPath)
' Open the _rels associated with the correct drawing XML.
' Then get strChartXml = /Relationships/Relationship[#Id='strRelId']/#Target
' This is the name of the chart XML.
strSubfolder = moFSO.GetParentFolderName(strXMLFile) & "\_rels"
strXMLFile = moFSO.BuildPath(strSubfolder, moFSO.GetFileName(strXMLFile)) & ".rels"
strXPath = "/rel:Relationships/rel:Relationship[#Id='" & strRelId & "']/#Target"
strChartXml = GetXPathFromXMLFile(strXMLFile, strXPath)
strChartXml = Replace$(Replace$(strChartXml, "../", "/"), "/", "\")
' Open the correct chart XML file (strChartXml)
strXMLFile = moFSO.BuildPath(strTempDir, "xl" & strChartXml)
' Get error bar value type. If the error bar is set to a Range then this must be 'cust'.
strXPath = "/c:chartSpace/c:chart//c:ser[c:tx//c:v[text()='" & strSeriesName & "']]/c:errBars/c:errValType/#val"
strErrValType = GetXPathFromXMLFile(strXMLFile, strXPath)
' Get error bar type. This can be "minus", "plus", or "both" depending on which error bar(s) exist(s).
strXPath = "/c:chartSpace/c:chart//c:ser[c:tx//c:v[text()='" & strSeriesName & "']]/c:errBars/c:errBarType/#val"
strErrBarType = GetXPathFromXMLFile(strXMLFile, strXPath)
' Get the Range address for either the "minus" or "plus" error bar and set it to the final result.
If strErrValType = "cust" Then
strXPath = "/c:chartSpace/c:chart//c:ser[c:tx//c:v[text()='" & strSeriesName & "']]/c:errBars"
If PlusMinus = enErrorBarMinus And (strErrBarType = "both" Or strErrBarType = "minus") Then
strXPath = strXPath & "/c:minus/c:numRef/c:f"
ElseIf PlusMinus = enErrorBarPlus And (strErrBarType = "both" Or strErrBarType = "plus") Then
strXPath = strXPath & "/c:plus/c:numRef/c:f"
EndIf
strErrBarFormula = GetXPathFromXMLFile(strXMLFile, strXPath)
strErrBarFormula = "'[" & oWb.Name & "]" & Replace$(strErrBarFormula, "!", "'!")
Set rngResult = Application.Range(strErrBarFormula)
End If
Set GetErrorBarRange = rngResult
CleanUp:
' Delete the temporary extracted XML data
With moFSO
If .FolderExists(strTempDir) Then .DeleteFolder strTempDir
End With
Set moFSO = Nothing
' Free the cursor
Application.Cursor = xlDefault
End Function
' Get the value of an XML node by an XPath search string
Private Function GetXPathFromXMLFile(ByVal strXMLFile As String, ByVal strXPath As String) As String
Dim objXMLDoc As Object
Dim strNS As String
Dim objXMLNode As Object
' Load the XML file
Set objXMLDoc = CreateObject("MSXML2.DOMDocument.6.0")
objXMLDoc.Load strXMLFile
' These are all the XML namespaces related to the current task
strNS = Join$(Array( _
"xmlns:x=""http://schemas.openxmlformats.org/spreadsheetml/2006/main""", _
"xmlns:r=""http://schemas.openxmlformats.org/officeDocument/2006/relationships""", _
"xmlns:mc=""http://schemas.openxmlformats.org/markup-compatibility/2006""", _
"xmlns:x14ac=""http://schemas.microsoft.com/office/spreadsheetml/2009/9/ac""", _
"xmlns:xr=""http://schemas.microsoft.com/office/spreadsheetml/2014/revision""", _
"xmlns:xr2=""http://schemas.microsoft.com/office/spreadsheetml/2015/revision2""", _
"xmlns:xr3=""http://schemas.microsoft.com/office/spreadsheetml/2016/revision3""", _
"xmlns:rel=""http://schemas.openxmlformats.org/package/2006/relationships""", _
"xmlns:xdr=""http://schemas.openxmlformats.org/drawingml/2006/spreadsheetDrawing""", _
"xmlns:a=""http://schemas.openxmlformats.org/drawingml/2006/main""", _
"xmlns:c=""http://schemas.openxmlformats.org/drawingml/2006/chart""", _
"xmlns:c16r2=""http://schemas.microsoft.com/office/drawing/2015/06/chart""" _
))
objXMLDoc.SetProperty "SelectionLanguage", "XPath"
objXMLDoc.SetProperty "SelectionNamespaces", strNS
objXMLDoc.resolveExternals = True
' Select the XML node and return its text value
Set objXMLNode = objXMLDoc.SelectSingleNode(strXPath)
If Not objXMLNode Is Nothing Then
GetXPathFromXMLFile = objXMLNode.Text
End If
End Function
' If workbook path is a OneDrive URL or a network share URL then resolve it to a local path with a drive letter
Private Function LocalFilePath(ByVal strFilePath As String)
strFilePath = OneDriveLocalFilePath(strFilePath)
strFilePath = NetworkLocalFilePath(strFilePath)
LocalFilePath = strFilePath
End Function
' If workbook path is a OneDrive URL then resolve it to a local path with a drive letter
Private Function OneDriveLocalFilePath(ByVal strFilePath As String) As String
Dim strOneDrivePath As String
Dim strLocalPath As String
If strFilePath Like "*my.sharepoint.com*" Then
strOneDrivePath = Environ$("OneDriveCommercial")
If strOneDrivePath = vbNullString Then strOneDrivePath = Environ$("OneDrive")
strLocalPath = strOneDrivePath & "/" & Split(strFilePath, "/", 7)(6)
OneDriveLocalFilePath = Replace$(strLocalPath, "/", "\")
ElseIf strFilePath Like "*d.docs.live.net*" Then
strOneDrivePath = Environ$("OneDriveConsumer")
If strOneDrivePath = vbNullString Then strOneDrivePath = Environ$("OneDrive")
strLocalPath = strOneDrivePath & "/" & Split(strFilePath, "/", 5)(4)
OneDriveLocalFilePath = Replace$(strLocalPath, "/", "\")
Else
OneDriveLocalFilePath = strFilePath
End If
End Function
' If workbook path is a network share URL then resolve it to a local path with a drive letter
Private Function NetworkLocalFilePath(ByVal strFilename As String) As String
On Error Resume Next
Dim ShellScript As Object
Dim i As Long
Dim strDriveLetter As String * 1
Dim strRemotePath As String
Set ShellScript = CreateObject("WScript.Shell")
For i = 97 To 122 ' a to z
strDriveLetter = Chr$(i)
strRemotePath = ShellScript.RegRead("HKEY_CURRENT_USER\Network\" & strDriveLetter & "\RemotePath")
If Err.Number = 0 Then
If strFilename Like strRemotePath & "*" Then
NetworkLocalFilePath = Replace$(strFilename, strRemotePath, UCase$(strDriveLetter) & ":", Count:=1)
Exit Function
End If
Else
Err.Clear
End If
Next i
NetworkLocalFilePath = strFilename
End Function
' Extract workbook XML to temporary directory
Private Function ExtractWorkbookXMLToTemp(oWb As Workbook) As String
Dim strTempDir As String
Dim strExt As String
Dim strTempWb As String
Dim strWbLocal As String
Dim strZipFile As String
On Error GoTo CleanUp
' Create a temporary copy of the workbook
With moFSO
strTempDir = .BuildPath(Environ$("TEMP"), _
Replace$(.GetTempName, ".tmp", vbNullString))
strExt = .GetExtensionName(oWb.Name)
strTempWb = strTempDir & "." & strExt
strWbLocal = LocalFilePath(oWb.FullName)
.CopyFile strWbLocal, strTempWb
End With
' Rename the temporary copy from .xls_ to .zip
strZipFile = strTempDir & ".zip"
Name strTempWb As strZipFile
' Unzip the .zip file to a temporary folder
MkDir strTempDir
UnzipFiles strZipFile, strTempDir
' Return the name of the temporary directory
ExtractWorkbookXMLToTemp = strTempDir
CleanUp:
' Delete the temporary ZIP file
With moFSO
If .FileExists(strZipFile) Then .DeleteFile strZipFile
End With
End Function
' Unzip all the files in 'varZipFile' into the folder 'varDestDir'
Private Sub UnzipFiles(ByVal varZipFile As Variant, ByVal varDestDir As Variant)
Dim oShellApp As Object
Const NO_PROGRESS_DIALOG As Integer = &H4
Set oShellApp = CreateObject("Shell.Application")
If Not varDestDir Like "*\" Then varDestDir = varDestDir & "\"
With oShellApp
.Namespace(varDestDir).CopyHere .Namespace(varZipFile).Items, NO_PROGRESS_DIALOG
End With
On Error Resume Next
With oShellApp
Do Until .Namespace(varZipFile).Items.Count = .Namespace(varDestDir).Items.Count
Application.Wait Date + (VBA.Timer + 1!) / 86400
Loop
End With
On Error GoTo 0
End Sub

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

Resources