Option Public
Option Declare
Dim gCounter&
Sub Initialize
      Dim s As New NotesSession
      Dim coll As NotesDocumentCollection
      Dim BasePath$

      BasePath$ = InputBox ("Export data to path...: ", "Export", "C:\")
     
      '# add backslash at the end
      If right (BasePath$,1) <> "\" Then BasePath$ = BasePath$ & "\"
     
      Print "Using BasePath : " & BasePath$
     
      Set coll = s.currentdatabase.Unprocesseddocuments
      If coll Is Nothing Then
              MessageBox "No documents selected"
      Else
              Print "Processing " & coll.count & " documents..."
              Call ExportToDXL (coll, BasePath$)
              Call ExportToFile (coll, BasePath$)
              MessageBox "Export completed."
      End If        
End Sub

Function ExportToDXL (Coll As NotesDocumentCollection, BasePath As String)
      Dim session As New NotesSession
      Dim stream As NotesStream
      Dim DXLfilename$
      Dim doc As NotesDocument
      Dim tdoc As NotesDocument
      Dim exporter As NotesDXLExporter
     
      If coll Is Nothing Then Exit function
      Set doc = coll.getfirstdocument
      While Not doc Is Nothing
              Set tdoc = coll.getNextDocument (doc)
              '# Open xml file named after current database
              Set stream = session.CreateStream
              DXLfilename$ = BasePath$ & doc.universalid & ".dxl"
              If Not stream.Open(DXLfilename$) Then
                      MessageBox "Cannot open " & DXLfilename$,, "Error"
                      Exit Function
              End If
             
              '# kick off the exporter process
              Set exporter = session.CreateDXLExporter
              Call exporter.SetInput(doc)
              Call exporter.SetOutput(stream)
              Call exporter.Process
             
              Set doc = tdoc
      Wend
End Function

Function ExportToFile (coll As NotesDocumentCollection, BasePath As String)
        On Error GoTo ErrH
        Dim doc As NotesDocument
        Dim tdoc As NotesDocument
        Dim rtitem As variant
        Dim targetpath$, fname$
        Dim FieldList(0) As String
        Dim oba As Variant
       
        '# define which fields to scan for attachments
        FieldList (0) = "Body"
       
        If coll Is Nothing Then Exit Function
       
        Set doc = coll.getfirstdocument
        While Not doc Is Nothing
                Set tdoc = coll.getNextDocument (doc)
                If doc.Hasembedded Then
                        targetpath$ = BasePath$ & doc.universalid & "\"
                       
                        If Dir$ (BasePath$ & doc.universalid, 16) = "" Then MkDir targetpath$
                       
                        '# loop list of fields
                        ForAll f In FieldList
                                 Set rtitem = doc.GetFirstItem(f)
                                 If Not rtitem Is Nothing Then
                                        If (rtitem.Type = RICHTEXT ) Then
                                                '# make sure the field contains some objects and detach
                                                If IsArray(rtitem.embeddedObjects) Then
                                                        ForAll o In rtitem.EmbeddedObjects
                                                                If ( o.Type = EMBED_ATTACHMENT ) Then
                                                                        Fname$=o.Name
                                                                        If FileExists (fname$) Then fname$ = CStr(gCounter&) & Fname$
                                                                        Call o.ExtractFile(targetPath$ & Fname$)
                                                                        gCounter& = gCounter& + 1
                                                                End If
                                                        End ForAll
                                                End If

                                        End If
                                End If
                        End ForAll
                End If
                Set doc = tdoc
        Wend
continue:
        Exit Function
       
errH:
        Stop
        Print "Error " & Err() & " in line " & Erl() & " - " & Error
        Resume continue
End Function