GetDocs

Sub Initialize
'** This agent will take all the selected documents in a database that uses
'** the basic Microsoft Office Document Library template and send them to
'** another database (in my case, I just used one based on the Doc Library
'** template). The issue is that MS Office docs in an Office Document Library
'** are stored as OLE embedded files, so they're hard to move from one doc
'** to another. This agent uses OLE to open the embedded files with their
'** default applications and save them to the file system, and then attach the
'** saved file to a new document in the new database. If there is no embedded
'** file, the entire rich-text Body field is copied over intact.
'**
'** Obviously, this will only work if the computer you're running this agent on
'** has MS Office installed. I have the code set up to run against "Selected
'** Documents" in a view, although you can easily change it to run against
'** all the docs in the database or some subset thereof.
'**
'** version 1.0 -- initial release
'** version 1.1 -- added an OLE command to keep Excel spreadsheets visible (for
'** some reason, they were getting saved as hidden documents otherwise)
'**
'** Julian Robichaux -- http://www.nsftools.com

                On Error Goto processError

'** variables relating to this database (this database should be the MS Office Library)
                Dim session As New NotesSession
                Dim db As NotesDatabase
                Dim dc As NotesDocumentCollection
                Dim doc As NotesDocument
                Dim rtitem As NotesRichTextItem
                Dim oleObj As Variant
                Dim WarPRFProject As String
                Dim WarCategories As String
                Dim WarPRFID As String
                Dim WarVersionNr As String
                Dim WarSubVersionNr As String
                Dim itemList As Variant
                Dim item As NotesItem
                Dim item2 As NotesItem
                Dim WarProject As String
                Dim WarCategoriesParent As String


                Set db = session.CurrentDatabase
                Set dc = db.UnprocessedDocuments
                Set doc = dc.GetFirstDocument

'** variables relating to the database we're exporting to
'**         Dim exportDbName As String
'**         Dim exportDb As NotesDatabase
'**         Dim newDoc As NotesDocument
                Dim body As NotesRichTextItem
                Dim tempDir As String
                Dim tempMainDir As String
                Dim fileCount As Integer
                Dim fileName As String
                Dim fname As String
                Dim parent As notesdocument
                Dim parentsub As notesdocument
                Dim parentsub2 As notesdocument
                Dim parentsub3 As notesdocument


'** MODIFY THESE TWO STRINGS FOR YOUR OWN USE
'**         exportDbName = "JPR\Doc Lib Test.nsf"


'** try to open the database we're exporting to
'**         Set exportDb = session.GetDatabase("", exportDbName, False)
'**         If (exportDb Is Nothing) Then
'**                         Print "Cannot open export database: " & exportDbName
'**                         Exit Sub
'**         End If

'** try to export all the selected docs
                Do Until (doc Is Nothing)
'**                         Set newDoc = New NotesDocument(exportDb)
'**                         newDoc.Form = "Document"
'**                         newDoc.Categories = doc.Categories
'**                         newDoc.WebCategories = doc.Categories
'**                         newDoc.Subject = doc.Subject(0) & " (created " & Datevalue(doc.Created) & ")"

                               Set rtitem = doc.GetFirstItem("Body")
'**                         Set body = New NotesRichTextItem(newDoc, "Body")
                               fileCount = 0
                               fileName = ""
                               tempMainDir = "S:\OSS\BOJ\Lotus\"

                               If Not (rtitem Is Nothing) Then
                                               If Not (Isempty(rtitem.EmbeddedObjects)) Then
                                                               Forall o In rtitem.EmbeddedObjects
                                                                              If (o.Type = EMBED_OBJECT Or o.Type = EMBED_ATTACHMENT) Then
'** if we have an embedded object in the rich text field,
'** we'll try to save it as a file and attach it to our new doc
                                                                                              fileCount = fileCount + 1
                                                                                              fileName = tempDir & "detachedOleFile" & fileCount
                                                                                              Set item = o.Parent.Parent.GetFirstItem( "PRFProject" )
                                                                                              WarPRFProject = item.Text
                                                                                              Set item = o.Parent.Parent.GetFirstItem( "Categories" )
                                                                                              WarCategories = item.Text
                                                                                              Set item = o.Parent.Parent.GetFirstItem( "PRFID" )
                                                                                              WarPRFID = item.Text
                                                                                              Set item = o.Parent.Parent.GetFirstItem( "VersionNr" )
                                                                                              WarVersionNr = item.Text
                                                                                              Set item = o.Parent.Parent.GetFirstItem( "SubVersionNr" )
                                                                                              WarSubVersionNr = item.Text

                                                                                              Set parent = Nothing
                                                                                              Set parent = db.GetDocumentByUNID( doc.ParentDocumentUNID )
                                                                                              If Not (parent Is Nothing) Then
                                                                                                              Set item = parent.GetFirstItem( "PRFID" )
                                                                                                              Set item2 = parent.GetFirstItem( "Categories" )
                                                                                                              WarCategoriesParent = item2.Text
                                                                                                              Set parentsub = Nothing
                                                                                                              Set parentsub = db.GetDocumentByUNID( parent.ParentDocumentUNID )
                                                                                                              If Not (parentsub Is Nothing) Then
                                                                                                                             Set item = parentsub.GetFirstItem( "PRFID" )
                                                                                                                             Set item2 = parentsub.GetFirstItem( "Categories" )
                                                                                                                             WarCategoriesParent = item2.Text
                                                                                                                             Set parentsub2 = Nothing
                                                                                                                             Set parentsub2 = db.GetDocumentByUNID( parentsub.ParentDocumentUNID )
                                                                                                                             If Not (parentsub2 Is Nothing) Then
                                                                                                                                             Set item = parentsub2.GetFirstItem( "PRFID" )
                                                                                                                                             Set item2 = parentsub2.GetFirstItem( "Categories" )
                                                                                                                                             WarCategoriesParent = item2.Text
                                                                                                                                             Set parentsub3 = Nothing
                                                                                                                                             Set parentsub3 = db.GetDocumentByUNID( parentsub2.ParentDocumentUNID )
                                                                                                                                             If Not (parentsub3 Is Nothing) Then
                                                                                                                                                             Set item = parentsub3.GetFirstItem( "PRFID" )
                                                                                                                                                             Set item2 = parentsub3.GetFirstItem( "Categories" )
                                                                                                                                                             WarCategoriesParent = item2.Text
                                                                                                                                             End If
                                                                                                                             End If
                                                                                                              End If
                                                                                              End If

                                                                                              WarProject = item.Text
                                                                                              If Not (WarProject = WarSubVersionNr) And Not (WarCategories = WarCategoriesParent) Then
                                                                                                              tempDir = tempMainDir & WarProject & "\"
                                                                                                              Call scrubString(tempDir, "/", "_")
                                                                                                              fname = Dir$(tempDir & "\*", 0)
                                                                                                             If (fname = "") Then
                                                                                                                             Mkdir tempDir
                                                                                                              End If
                                                                                                              tempDir = tempMainDir & WarProject & "\"  & WarCategories & "\"
                                                                                                              Call scrubString(tempDir, "/", "_")
                                                                                                              fname = Dir$(tempDir & "\*", 0)
                                                                                                              If (fname = "") Then
                                                                                                                             Mkdir tempDir
                                                                                                              End If
                                                                                              Else
                                                                                                              tempDir = tempMainDir & WarCategories & "\"
                                                                                                              Call scrubString(tempDir, "/", "_")
                                                                                                              fname = Dir$(tempDir & "\*", 0)
                                                                                                              If (fname = "") Then
                                                                                                                             Mkdir tempDir
                                                                                                              End If
                                                                                              End If


                                                                                              fileName = tempDir & WarPRFProject & "-" & WarCategories & "-" & WarPRFID & "-" & WarVersionNr & "-" & WarSubVersionNr


'** for MS Office documents, this normally works (of course,
'** you need to make sure that a proper version of Office is
'** installed on the computer you're doing this on), although
'** you'll often get an error or two as you call these methods,
'** due to variations in the different Office object models
                                                                                              If (o.Type = EMBED_OBJECT) Then
                                                                                                              fname = Dir$(fileName & ".*", 0)
                                                                                                              If (fname = "") Then
                                                                                                                             Set oleObj = o.Activate(False)
'** this is so Excel spreadsheets don't end up being hidden
                                                                                                                              oleObj.Application.Windows(oleObj.Application.Windows.Count).Visible = True
                                                                                                                             Call oleObj.SaveAs(fileName)
                                                                                                                             Call oleObj.Close
                                                                                                              End If

'** try two different ways to shut down the background application
'**                                                                                        Call oleObj.Quit
'**                                                                                        Call oleObj.Application.Quit
                                                                                                              Set oleObj = Nothing
                                                                                              Else
                                                                                                              fileName = tempDir & o.Source
                                                                                                              fname = Dir$(fileName, 0)
                                                                                                              If (fname = "") Then
                                                                                                                             Call o.ExtractFile(fileName)
                                                                                                              End If
                                                                                              End If

'** usually, MS Office will automatically append a file extension
'** to the end of the file name, so we'll have to use Dir to make
'** sure we get the file we just detached
'**                                                                                        fname = Dir$(fileName & "*", 0)
'**                                                                                        If (fname = "") Then
'**                                                                                                       fileCount = fileCount - 1
'**                                                                                        Else
'**                                                                                                       fName = tempDir & fName
'**                                                                                                       Call body.EmbedObject(EMBED_ATTACHMENT, "", fName)
'**                                                                                                       Kill fname
'**                                                                                        End If
                                                                              End If
                                                               End Forall
                                               End If

'** in this example, if we found any embedded OLE objects, we're not
'** going to bother with copying over anything else in the Body field, and
'** if we didn't find any embedded objects, we'll copy the whole rich text
'** item intact. You could also set this up to copy the Body item over
'** regardless, although if you did that you'd want to do it before you started
'** checking for OLE objects
'**                                         If (fileCount < 1) Then
'**                                                        Call newDoc.CopyItem(rtitem, "Body")
'**                                         End If
                               End If

'** ComputeWithForm sometimes messes up the Categories field for some reason...
'**                         Call newDoc.ComputeWithForm(True, False)
'**                         Call newDoc.Save(True, True)
'**                         Set newDoc = Nothing

                               Set doc = dc.GetNextDocument(doc)
                Loop

                Print "Finished exporting " & dc.Count & " docs"
                Exit Sub

processError:
'** more than likely, our errors will have to do with OLE issues,
'** so we're going to be daring and Resume Next when we
'** see any problems (this process is actually quite error-prone,
'** due to differences in all the versions of all the MS Office OLE
'** function libraries)
                Dim errMsg As String
                errMsg = "Error " & Err & ": " & Error$
                Print errMsg
'**         If Not (newDoc Is Nothing) Then
'**                         newDoc.ImportErrMsg = newDoc.ImportErrMsg(0) & errMsg & Chr(13) & Chr(10)
'**         End If
                Resume Next

End Sub


Function scrubString(strField As String, strBadStuff As String, strGoodStuff As String) As String

     'This function will search the passed string for the "bad" stuff to be removed, and will replace it with the "good" stuff
                Dim intLength As Integer
                Dim intReplacePos As Integer

     'Keep ripping and replacing while "bad" stuff still exists
                Do While Instr(strField, strBadStuff) > 0
                               intLength = Len(strField)
                               intReplacePos = Instr(strField, strBadStuff)
                               strField = Left(strField, intReplacePos -1) + strGoodStuff + Right(strField, intLength - intReplacePos)
                Loop

     'Return the cleaned up field to the calling routine
                scrubString = strField

End Function