Advertisement
szabozoltan69

GetDocs

Jan 23rd, 2013
225
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. Sub Initialize
  2. '** This agent will take all the selected documents in a database that uses
  3. '** the basic Microsoft Office Document Library template and send them to
  4. '** another database (in my case, I just used one based on the Doc Library
  5. '** template). The issue is that MS Office docs in an Office Document Library
  6. '** are stored as OLE embedded files, so they're hard to move from one doc
  7. '** to another. This agent uses OLE to open the embedded files with their
  8. '** default applications and save them to the file system, and then attach the
  9. '** saved file to a new document in the new database. If there is no embedded
  10. '** file, the entire rich-text Body field is copied over intact.
  11. '**
  12. '** Obviously, this will only work if the computer you're running this agent on
  13. '** has MS Office installed. I have the code set up to run against "Selected
  14. '** Documents" in a view, although you can easily change it to run against
  15. '** all the docs in the database or some subset thereof.
  16. '**
  17. '** version 1.0 -- initial release
  18. '** version 1.1 -- added an OLE command to keep Excel spreadsheets visible (for
  19. '** some reason, they were getting saved as hidden documents otherwise)
  20. '**
  21. '** Julian Robichaux -- http://www.nsftools.com
  22.                
  23.                 On Error Goto processError
  24.                
  25. '** variables relating to this database (this database should be the MS Office Library)
  26.                 Dim session As New NotesSession
  27.                 Dim db As NotesDatabase
  28.                 Dim dc As NotesDocumentCollection
  29.                 Dim doc As NotesDocument
  30.                 Dim rtitem As NotesRichTextItem
  31.                 Dim oleObj As Variant
  32.                 Dim WarPRFProject As String
  33.                 Dim WarCategories As String
  34.                 Dim WarPRFID As String
  35.                 Dim WarVersionNr As String
  36.                 Dim WarSubVersionNr As String
  37.                 Dim itemList As Variant
  38.                 Dim item As NotesItem
  39.                 Dim item2 As NotesItem
  40.                 Dim WarProject As String
  41.                 Dim WarCategoriesParent As String
  42.                
  43.                
  44.                 Set db = session.CurrentDatabase
  45.                 Set dc = db.UnprocessedDocuments
  46.                 Set doc = dc.GetFirstDocument
  47.                
  48. '** variables relating to the database we're exporting to
  49. '**         Dim exportDbName As String
  50. '**         Dim exportDb As NotesDatabase
  51. '**         Dim newDoc As NotesDocument
  52.                 Dim body As NotesRichTextItem
  53.                 Dim tempDir As String
  54.                 Dim tempMainDir As String
  55.                 Dim fileCount As Integer
  56.                 Dim fileName As String
  57.                 Dim fname As String
  58.                 Dim parent As notesdocument
  59.                 Dim parentsub As notesdocument
  60.                 Dim parentsub2 As notesdocument
  61.                 Dim parentsub3 As notesdocument
  62.                
  63.                
  64. '** MODIFY THESE TWO STRINGS FOR YOUR OWN USE
  65. '**         exportDbName = "JPR\Doc Lib Test.nsf"
  66.                
  67.                
  68. '** try to open the database we're exporting to
  69. '**         Set exportDb = session.GetDatabase("", exportDbName, False)
  70. '**         If (exportDb Is Nothing) Then
  71. '**                         Print "Cannot open export database: " & exportDbName
  72. '**                         Exit Sub
  73. '**         End If
  74.                
  75. '** try to export all the selected docs
  76.                 Do Until (doc Is Nothing)
  77. '**                         Set newDoc = New NotesDocument(exportDb)
  78. '**                         newDoc.Form = "Document"
  79. '**                         newDoc.Categories = doc.Categories
  80. '**                         newDoc.WebCategories = doc.Categories
  81. '**                         newDoc.Subject = doc.Subject(0) & " (created " & Datevalue(doc.Created) & ")"
  82.                              
  83.                                Set rtitem = doc.GetFirstItem("Body")
  84. '**                         Set body = New NotesRichTextItem(newDoc, "Body")
  85.                                fileCount = 0
  86.                                fileName = ""
  87.                                tempMainDir = "S:\OSS\BOJ\Lotus\"
  88.                              
  89.                                If Not (rtitem Is Nothing) Then
  90.                                                If Not (Isempty(rtitem.EmbeddedObjects)) Then
  91.                                                                Forall o In rtitem.EmbeddedObjects
  92.                                                                               If (o.Type = EMBED_OBJECT Or o.Type = EMBED_ATTACHMENT) Then
  93. '** if we have an embedded object in the rich text field,
  94. '** we'll try to save it as a file and attach it to our new doc
  95.                                                                                               fileCount = fileCount + 1
  96.                                                                                               fileName = tempDir & "detachedOleFile" & fileCount
  97.                                                                                               Set item = o.Parent.Parent.GetFirstItem( "PRFProject" )
  98.                                                                                               WarPRFProject = item.Text                                                                                    
  99.                                                                                               Set item = o.Parent.Parent.GetFirstItem( "Categories" )
  100.                                                                                               WarCategories = item.Text                                                                                      
  101.                                                                                               Set item = o.Parent.Parent.GetFirstItem( "PRFID" )
  102.                                                                                               WarPRFID = item.Text                                                                                
  103.                                                                                               Set item = o.Parent.Parent.GetFirstItem( "VersionNr" )
  104.                                                                                               WarVersionNr = item.Text                                                                                      
  105.                                                                                               Set item = o.Parent.Parent.GetFirstItem( "SubVersionNr" )
  106.                                                                                               WarSubVersionNr = item.Text                                                                              
  107.                                                                                              
  108.                                                                                               Set parent = Nothing
  109.                                                                                               Set parent = db.GetDocumentByUNID( doc.ParentDocumentUNID )
  110.                                                                                               If Not (parent Is Nothing) Then
  111.                                                                                                               Set item = parent.GetFirstItem( "PRFID" )
  112.                                                                                                               Set item2 = parent.GetFirstItem( "Categories" )
  113.                                                                                                               WarCategoriesParent = item2.Text
  114.                                                                                                               Set parentsub = Nothing
  115.                                                                                                               Set parentsub = db.GetDocumentByUNID( parent.ParentDocumentUNID )
  116.                                                                                                               If Not (parentsub Is Nothing) Then
  117.                                                                                                                              Set item = parentsub.GetFirstItem( "PRFID" )
  118.                                                                                                                              Set item2 = parentsub.GetFirstItem( "Categories" )
  119.                                                                                                                              WarCategoriesParent = item2.Text
  120.                                                                                                                              Set parentsub2 = Nothing
  121.                                                                                                                              Set parentsub2 = db.GetDocumentByUNID( parentsub.ParentDocumentUNID )
  122.                                                                                                                              If Not (parentsub2 Is Nothing) Then
  123.                                                                                                                                              Set item = parentsub2.GetFirstItem( "PRFID" )
  124.                                                                                                                                              Set item2 = parentsub2.GetFirstItem( "Categories" )
  125.                                                                                                                                              WarCategoriesParent = item2.Text
  126.                                                                                                                                              Set parentsub3 = Nothing
  127.                                                                                                                                              Set parentsub3 = db.GetDocumentByUNID( parentsub2.ParentDocumentUNID )
  128.                                                                                                                                              If Not (parentsub3 Is Nothing) Then
  129.                                                                                                                                                              Set item = parentsub3.GetFirstItem( "PRFID" )
  130.                                                                                                                                                              Set item2 = parentsub3.GetFirstItem( "Categories" )
  131.                                                                                                                                                              WarCategoriesParent = item2.Text
  132.                                                                                                                                              End If
  133.                                                                                                                              End If
  134.                                                                                                               End If
  135.                                                                                               End If
  136.                                                                                              
  137.                                                                                               WarProject = item.Text
  138.                                                                                               If Not (WarProject = WarSubVersionNr) And Not (WarCategories = WarCategoriesParent) Then
  139.                                                                                                               tempDir = tempMainDir & WarProject & "\"
  140.                                                                                                               Call scrubString(tempDir, "/", "_")
  141.                                                                                                               fname = Dir$(tempDir & "\*", 0)
  142.                                                                                                              If (fname = "") Then
  143.                                                                                                                              Mkdir tempDir
  144.                                                                                                               End If
  145.                                                                                                               tempDir = tempMainDir & WarProject & "\"  & WarCategories & "\"
  146.                                                                                                               Call scrubString(tempDir, "/", "_")
  147.                                                                                                               fname = Dir$(tempDir & "\*", 0)
  148.                                                                                                               If (fname = "") Then
  149.                                                                                                                              Mkdir tempDir
  150.                                                                                                               End If
  151.                                                                                               Else
  152.                                                                                                               tempDir = tempMainDir & WarCategories & "\"
  153.                                                                                                               Call scrubString(tempDir, "/", "_")
  154.                                                                                                               fname = Dir$(tempDir & "\*", 0)
  155.                                                                                                               If (fname = "") Then
  156.                                                                                                                              Mkdir tempDir
  157.                                                                                                               End If
  158.                                                                                               End If
  159.                                                                                              
  160.                                                                                              
  161.                                                                                               fileName = tempDir & WarPRFProject & "-" & WarCategories & "-" & WarPRFID & "-" & WarVersionNr & "-" & WarSubVersionNr
  162.                                                                                              
  163.                                                                                              
  164. '** for MS Office documents, this normally works (of course,
  165. '** you need to make sure that a proper version of Office is
  166. '** installed on the computer you're doing this on), although
  167. '** you'll often get an error or two as you call these methods,
  168. '** due to variations in the different Office object models
  169.                                                                                               If (o.Type = EMBED_OBJECT) Then
  170.                                                                                                               fname = Dir$(fileName & ".*", 0)
  171.                                                                                                               If (fname = "") Then
  172.                                                                                                                              Set oleObj = o.Activate(False)
  173. '** this is so Excel spreadsheets don't end up being hidden
  174.                                                                                                                               oleObj.Application.Windows(oleObj.Application.Windows.Count).Visible = True
  175.                                                                                                                              Call oleObj.SaveAs(fileName)
  176.                                                                                                                              Call oleObj.Close
  177.                                                                                                               End If
  178.                                                                                                              
  179. '** try two different ways to shut down the background application
  180. '**                                                                                        Call oleObj.Quit
  181. '**                                                                                        Call oleObj.Application.Quit
  182.                                                                                                               Set oleObj = Nothing
  183.                                                                                               Else
  184.                                                                                                               fileName = tempDir & o.Source
  185.                                                                                                               fname = Dir$(fileName, 0)
  186.                                                                                                               If (fname = "") Then
  187.                                                                                                                              Call o.ExtractFile(fileName)
  188.                                                                                                               End If
  189.                                                                                               End If
  190.                                                                                              
  191. '** usually, MS Office will automatically append a file extension
  192. '** to the end of the file name, so we'll have to use Dir to make
  193. '** sure we get the file we just detached
  194. '**                                                                                        fname = Dir$(fileName & "*", 0)
  195. '**                                                                                        If (fname = "") Then
  196. '**                                                                                                       fileCount = fileCount - 1
  197. '**                                                                                        Else
  198. '**                                                                                                       fName = tempDir & fName
  199. '**                                                                                                       Call body.EmbedObject(EMBED_ATTACHMENT, "", fName)
  200. '**                                                                                                       Kill fname
  201. '**                                                                                        End If
  202.                                                                               End If
  203.                                                                End Forall
  204.                                                End If
  205.                                              
  206. '** in this example, if we found any embedded OLE objects, we're not
  207. '** going to bother with copying over anything else in the Body field, and
  208. '** if we didn't find any embedded objects, we'll copy the whole rich text
  209. '** item intact. You could also set this up to copy the Body item over
  210. '** regardless, although if you did that you'd want to do it before you started
  211. '** checking for OLE objects
  212. '**                                         If (fileCount < 1) Then
  213. '**                                                        Call newDoc.CopyItem(rtitem, "Body")
  214. '**                                         End If
  215.                                End If
  216.                              
  217. '** ComputeWithForm sometimes messes up the Categories field for some reason...
  218. '**                         Call newDoc.ComputeWithForm(True, False)
  219. '**                         Call newDoc.Save(True, True)
  220. '**                         Set newDoc = Nothing
  221.                              
  222.                                Set doc = dc.GetNextDocument(doc)
  223.                 Loop
  224.                
  225.                 Print "Finished exporting " & dc.Count & " docs"
  226.                 Exit Sub
  227.                
  228. processError:
  229. '** more than likely, our errors will have to do with OLE issues,
  230. '** so we're going to be daring and Resume Next when we
  231. '** see any problems (this process is actually quite error-prone,
  232. '** due to differences in all the versions of all the MS Office OLE
  233. '** function libraries)
  234.                 Dim errMsg As String
  235.                 errMsg = "Error " & Err & ": " & Error$
  236.                 Print errMsg
  237. '**         If Not (newDoc Is Nothing) Then
  238. '**                         newDoc.ImportErrMsg = newDoc.ImportErrMsg(0) & errMsg & Chr(13) & Chr(10)
  239. '**         End If
  240.                 Resume Next
  241.                
  242. End Sub
  243.  
  244.  
  245. Function scrubString(strField As String, strBadStuff As String, strGoodStuff As String) As String
  246.                
  247.      'This function will search the passed string for the "bad" stuff to be removed, and will replace it with the "good" stuff
  248.                 Dim intLength As Integer
  249.                 Dim intReplacePos As Integer
  250.                
  251.      'Keep ripping and replacing while "bad" stuff still exists
  252.                 Do While Instr(strField, strBadStuff) > 0
  253.                                intLength = Len(strField)
  254.                                intReplacePos = Instr(strField, strBadStuff)
  255.                                strField = Left(strField, intReplacePos -1) + strGoodStuff + Right(strField, intLength - intReplacePos)
  256.                 Loop
  257.                
  258.      'Return the cleaned up field to the calling routine
  259.                 scrubString = strField
  260.                
  261. End Function
Advertisement
Advertisement
Advertisement
RAW Paste Data Copied
Advertisement