Const BIF_RETURNONLYFSDIRS = 1 Const BIF_DONTGOBELOWDOMAIN = 2 Const MAX_PATH = 260
in declarations put this
Type BrowseInfo hWndOwner As Long pIDLRoot As Long pszDisplayName As Long lpszTitle As String ulFlags As Long lpfnCallback As Long lParam As Long iImage As Long End Type Declare Function SHBrowseForFolder Lib "shell32" Alias "SHBrowseForFolderA" (lpbi As BrowseInfo) As Long Declare Function SHGetPathFromIDList Lib "shell32" Alias "SHGetPathFromIDListA" (Byval pidList As Long, Byval lpBuffer As String) As Long Declare Function FindWindow95 Lib "user32" Alias "FindWindowA" (Byval lpClassName As Any, Byval lpWindowName As Any) As Long
add this function to the button
Function ChooseFolder(sPrompt As String) As String Dim lpIDList As Long Dim sBuffer As String * 255 Dim sReturnVal As String Dim szTitle As String Dim tBrowseInfo As BrowseInfo sBuffer = String(Len(sBuffer),Chr(0)) szTitle = sPrompt tBrowseInfo.hWndOwner = FindWindow95("notes",&H0) tBrowseInfo.lpszTitle = szTitle tBrowseInfo.ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN lpIDList = SHBrowseForFolder(tBrowseInfo) If (lpIDList) Then SHGetPathFromIDList lpIDList, sBuffer ChooseFolder = Left(sBuffer, Instr(sBuffer, Chr(0)) - 1) End If End Function
Put this in the click event:
a=choosefolder("Choose a directory to put the attachments into:") Print "Putting files in: " & a Dim uiw As New notesuiworkspace Dim uidoc As notesuidocument Set uidoc = uiw.currentdocument Dim doc As notesdocument Set doc = uidoc.document If uidoc.isnewdoc Then Msgbox "This utility doesn't work for new documents, save the document ( Ctrl S ), and try again." End End If Set rtitem = doc.GetFirstItem( "Body" ) If ( rtitem.Type = RICHTEXT ) Then Forall o In rtitem.EmbeddedObjects If ( o.Type = EMBED_ATTACHMENT ) Then Call o.ExtractFile( a & "\" & o.Source ) Print o.source & " saved to " & a End If End Forall End If
Note the Choose Directory code is originally from Daniel Alvers. Tweet