Advertisement
Tsaukpaetra

Save EML

Jun 13th, 2014
910
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. 'Save EML:
  2.  
  3. 'Export Email:
  4.  
  5. Option Public
  6.  
  7.  
  8.  
  9.  
  10. '** ShellExecute will open a file using the registered file association on the computer.
  11. '** If it returns a value of greater than 32 then the call was successful; otherwise
  12. '** it should return one of the error codes below. The parameters are:
  13. '**     hwnd = an active window handle, or 0
  14. '**     operation = "edit", "explore", "find", "open", or "print"
  15. '**     fileName = a file or directory name
  16. '**     parameters = if fileName is an executable file, the command line parameters
  17. '**                         to pass when launching the application, or "" if no parameters
  18. '**                         are necessary
  19. '**     directory = the default directory to use, or "" if you don't care
  20. '**     displayType = one of the displayType constants listed below
  21.  
  22. '** FindExecutable will determine the executable file that is set up to open a particular
  23. '** file based on the file associations on this computer. If it returns a value of greater than
  24. '** 32 then the call was successful; otherwise it should return one of the error codes
  25. '** below. The parameters are:
  26. '**     fileName = the full path to the file you are trying to find the association for
  27. '**     directory = the default directory to use, or "" if you don't care
  28. '**     retAssociation = the associated executable will be returned as this parameter,
  29. '**                         with a maximum string length of 255 characters (you will want
  30. '**                         to pass a String that's 256 characters long and trim the
  31. '**                         null-terminated result)
  32.  
  33. '** constants for the displayType parameter
  34. Const SW_HIDE = 0
  35. Const SW_SHOWNORMAL = 1
  36. Const SW_NORMAL = 1
  37. Const SW_SHOWMINIMIZED = 2
  38. Const SW_SHOWMAXIMIZED = 3
  39. Const SW_MAXIMIZE = 3
  40. Const SW_SHOWNOACTIVATE = 4
  41. Const SW_SHOW = 5
  42. Const SW_MINIMIZE = 6
  43. Const SW_SHOWMINNOACTIVE = 7
  44. Const SW_SHOWNA = 8
  45. Const SW_RESTORE = 9
  46. Const SW_SHOWDEFAULT = 10
  47. Const SW_MAX = 10
  48.  
  49. '** possible errors returned by ShellExecute
  50. Const ERROR_OUT_OF_MEMORY = 0       'The operating system is out of memory or resources.
  51. Const ERROR_FILE_NOT_FOUND = 2      'The specified file was not found.
  52. Const ERROR_PATH_NOT_FOUND = 3  'The specified path was not found.
  53. Const ERROR_BAD_FORMAT = 11         'The .exe file is invalid (non-Microsoft Win32 .exe or error in .exe image).
  54. Const SE_ERR_FNF = 2                            'The specified file was not found.
  55. Const SE_ERR_PNF = 3                        'The specified path was not found.
  56. Const SE_ERR_ACCESSDENIED = 5       'The operating system denied access to the specified file.
  57. Const SE_ERR_OOM = 8                        'There was not enough memory to complete the operation.
  58. Const SE_ERR_SHARE = 26                 'A sharing violation occurred.
  59. Const SE_ERR_ASSOCINCOMPLETE = 27   'The file name association is incomplete or invalid.
  60. Const SE_ERR_DDETIMEOUT = 28            'The DDE transaction could not be completed because the request timed out.
  61. Const SE_ERR_DDEFAIL = 29               'The DDE transaction failed.
  62. Const SE_ERR_DDEBUSY = 30               'The Dynamic Data Exchange (DDE) transaction could not be completed because other DDE transactions were being processed.
  63. Const SE_ERR_NOASSOC = 31               'There is no application associated with the given file name extension. This error will also be returned if you attempt to print a file that is not printable.
  64. Const SE_ERR_DLLNOTFOUND = 32       'The specified dynamic-link library (DLL) was not found.
  65.  
  66.  
  67. ' // BrowseInfo stucture
  68.  
  69.  
  70. ' // BrowseFlags constants
  71. Const BIF_BROWSEFORCOMPUTER = 1000
  72. Const BIF_BROWSEFORPRINTER = 2000
  73. Const BIF_DONTGOBELOWDOMAIN = 2
  74. Const BIF_RETURNFSANCESTORS = 8
  75. Const BIF_RETURNONLYFSDIRS = 1
  76. Const BIF_STATUSTEXT = 4
  77.  
  78. Const MAX_SIZE = 255
  79.  
  80. ' // Win32 function to browse for a folder, rather than a file or files
  81.  
  82. ' // Win32 function that returns the path of the folder selected
  83.  
  84.  
  85.  
  86.  
  87.  
  88.  
  89.  
  90.  
  91. Dim CONVERT_DB_SERVER As String
  92. Dim CONVERT_DB_NAME As String
  93. Dim CONVERT_FORM As String
  94. Dim CONVERT_FIELD As String
  95. Dim CONVERT_TOFIELD As String
  96. Dim OUTFILENAME As String
  97. Dim crlf As String
  98. Dim SaveTempDoc As Integer
  99. Dim fileNum As Integer
  100. Dim doc As NotesDocument
  101. Dim nstream As NotesStream
  102. Dim x As String
  103. Dim count As Integer
  104. Dim b As String
  105. Declare Function ShellExecute Lib "shell32" Alias "ShellExecuteA" (Byval hwnd As Long, Byval operation As String, Byval fileName As String, _
  106. Byval parameters As String, Byval directory As String, Byval displayType As Long) As Long
  107. Declare Function FindExecutable Lib "shell32" Alias "FindExecutableA" (Byval fileName As String, Byval directory As String, Byval retAssociation As String) As Long
  108. Declare Function GetActiveWindow Lib "user32.dll" () As Long
  109. Type BROWSEINFO
  110.     hwndOwner As Long
  111.     pidlRoot As Long
  112.     pszDisplayName As String
  113.     lpszTitle As String
  114.     ulFlags As Long
  115.     lpfn As Long
  116.     lParam As Long
  117.     iImage As Long
  118. End Type
  119. Declare Function BrowseFolderDlg Lib "shell32.dll" Alias "SHBrowseForFolder" (lpBrowseInfo As BROWSEINFO) As Long
  120. Declare Function GetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDList" (Byval PointerToIDList As Long, Byval pszPath As String) As Long
  121.  
  122. Sub Initialize
  123.     Dim s As New NotesSession
  124.     Dim db As NotesDatabase
  125.     Dim dc As NotesDocumentCollection
  126.     Dim body As NotesItem
  127.     Dim rtitem As NotesRichTextItem
  128.     Dim mimebits As Variant
  129.     Dim n As Integer
  130.     Dim ErrorString As String
  131.     ErrorString = ""
  132.     Dim msgid As Variant
  133.    
  134.     crlf = Chr(13) & Chr(10)
  135.     'Dim mime As NotesMIMEEntity, mime2 As NotesMIMEEntity
  136.    
  137.     '** this is a form that has a rich text field that is set to store contents
  138.     '** in MIME format
  139.     CONVERT_FORM = "MimeConvert"
  140.     importDXL
  141.    
  142.     '** this is the field on the form mentioned above that stores rich text
  143.     '** as MIME
  144.     CONVERT_TOFIELD="MimeRichTextField"
  145.     CONVERT_FIELD = "Body"
  146.    
  147.     CONVERT_TOFIELD="Body"
  148.     CONVERT_FIELD = "Body"
  149.    
  150.     '** do you want to save the temporary doc after you're done with it
  151.     '** (True) or delete it (False)?
  152.     SaveTempDoc = False
  153.     expdir$=BrowseForFolder()
  154.     If expdir$="" Then
  155.         Messagebox "You have not selected a directory", MB_OK, "Select output Directory"
  156.         Exit Sub
  157.     End If
  158.    
  159.     Dim mime As NotesMIMEEntity
  160.     Dim subj As String
  161.     Set nstream=s.CreateStream
  162.     Set db = s.CurrentDatabase
  163.     s.ConvertMime = False ' Do not convert MIME to rich text|
  164.     Set dc = db.UnprocessedDocuments
  165.     Set doc = dc.GetFirstDocument
  166.    
  167.     n=0
  168.     While Not(doc Is Nothing)
  169.         If doc.HasItem("Body") Then
  170.             n=n+1
  171.             If doc.subject(0) ="" Then
  172.                 subj="No subject"
  173.             Else
  174.                 subj=validatefilename(doc.subject(0))
  175.             End If
  176.             OUTFILENAME=expdir$ & "\" & subj & " - " & doc.NoteID & ".eml"
  177.             Set body = doc.GetFirstItem("Body")
  178.            
  179.             fileNum% = Freefile
  180.             fileName$ = OUTFILENAME
  181.             Open filename$  For Output As fileNum%
  182.             If body.Type = MIME_PART Then
  183.                 Set mime = body.GetMimeEntity
  184.                 mimebits=getmultipartmime(mime)
  185.                 Print #fileNum%, mimebits
  186.             Else
  187.                 Call GetRichTextAsHtmlFile(doc, CONVERT_FIELD, OUTFILENAME, True)
  188.                
  189.             End If
  190.             Close fileNum%
  191.         'Kill filename$
  192.             'Sleep 1
  193.         Else
  194.             ErrorString = ErrorString & Chr(13) & Chr(10)  & subj & " - " & doc.NoteID
  195. '           Msgbox ("Could NOT process Notes Item (No Body):" & Chr(13) & Chr(10)  & subj & " - " & doc.NoteID)
  196.         End If
  197.         Set doc = dc.GetNextDocument(doc)
  198.     Wend
  199.    
  200.     fileName$ = "c:\program files\horizon\horizondmsave.exe"
  201.     If isfile(fileName$) Then
  202.         result& = ShellExecute(0, "open", fileName$, "DIR=c:\export", "", SW_SHOW)
  203.     Else
  204.         If Len(ErrorString) = 0 Then
  205.             ErrorString = Cstr(n) & " emails have been exported to " & expdir$
  206.         Else
  207.             ErrorString = Cstr(n) & " emails have been exported to " & expdir$ & crlf & "But some items could be processed because they had no body:" & ErrorString
  208.         End If
  209.         Msgbox ErrorString
  210.     End If 
  211. End Sub
  212. Function remsub(substr As String)
  213.     Dim mystr As String
  214.     For a=1 To Len(substr)
  215.         y=Asc(Mid$(substr,a,1))
  216.         If Not ( y="13" Or y="10") Then
  217.             mystr=mystr+Mid$(substr,a,1)
  218.         End If
  219.     Next
  220.     remsub=mystr
  221. End Function
  222. Function GetBoundary (header As String) As String
  223.     '** get the boundary from the initial header of a multi-part MIME string
  224.     '** normally, the format in Notes is something like:
  225.     '**    Content-Type: multipart/related; boundary="=_related 0012868C85256E16_="
  226.     Dim boundary As String
  227.     boundary = Strright(header, "boundary=""")
  228.    
  229.     '** we want everything from the boundary=" to the closing "
  230.     If (Instr(boundary, """") > 0) Then
  231.         boundary = Strleft(boundary, """")
  232.     End If
  233.    
  234.     If (Len(boundary) > 0) Then
  235.         boundary = "--" & boundary
  236.     End If
  237.    
  238.     GetBoundary = boundary
  239. End Function
  240. Function GetMultipartMime (mime As NotesMIMEEntity) As String
  241.     '** recursively get all the parts of a multi-part MIME entity
  242.     Dim child As NotesMIMEEntity
  243.     Dim mText As String
  244.     Dim boundary As String
  245.    
  246.    
  247.     count=count+1
  248.    
  249.    
  250.     boundary = GetBoundary(mime.Headers)
  251.    
  252.     '** DANGER -- ContentAsText truncates large MIME bodies in R5!!!
  253.     '** ND6 seems to be okay...
  254.     If mime.ContentType<>"text" Then
  255.         Call mime.encodecontent(1727)
  256.         mText = mText & mime.Headers & crlf & crlf
  257.         mText = mText & mime.ContentAsText & crlf
  258.     Else
  259.         mText = mText & mime.Headers & crlf & crlf
  260.         mText = mText & crlf & mime.ContentAsText & crlf
  261.     End If
  262.    
  263.     Set child = mime.GetFirstChildEntity
  264.     While Not(child Is Nothing)
  265.         mText = mText & boundary & crlf
  266.         mText = mText & GetMultipartMime(child)
  267.         Set child = child.GetNextSibling
  268.     Wend
  269.    
  270.     If (Len(boundary) > 0) Then
  271.         mText = mText & boundary & "--" & crlf & crlf
  272.     End If
  273.    
  274.     GetMultipartMime = mText
  275. End Function
  276. Function getlist(field As String)
  277.     Dim values As Variant
  278.     Dim out As String
  279.     Dim session As New NotesSession
  280.     Dim nam As NotesName
  281.     values = doc.GetItemValue( field )
  282.     Forall v In values
  283.         c=c+1
  284.         Set nam=session.CreateName(v)
  285.         If c>1 Then
  286.             out = out +"; "+ nam.abbreviated
  287.         Else
  288.             out=nam.abbreviated
  289.         End If
  290.        
  291.     End Forall
  292.     getlist=out
  293. End Function
  294. Function WriteHtmlStringToFile (htmlBody As String, _
  295. fileName As String, setFileExtension As Integer, isMultiPart As Integer) As Integer
  296.     '** send a NotesStream containing HTML to the specified fileName
  297.     '** (if setFileExtension is True, the fileName will automatically have
  298.     '** either .htm or .mht appended as the file extension, depending
  299.     '** on whether isMultiPart is True (.mht) or False (.htm))
  300.     Dim htmlStart As String, htmlEnd As String
  301.    
  302.    
  303.     '** set our variables, based on isMultiPart and setFileExtension
  304.     If Not  isMultiPart Then
  305. '** non-multi-part files need opening and closing HTML
  306.         htmlStart = "<html><body>"
  307.         htmlEnd = "</body></html>"
  308.     End If
  309.    
  310.     'fileName = fileName & ".eml"
  311.    
  312.     '** open the file for output
  313.     'fileNum = Freefile()
  314.     'Open fileName For Output As fileNum
  315.     Print #fileNum%,"From: " & getlist("From")
  316.     Print #fileNum%,"To: " & getlist("SendTo")
  317.     Print #fileNum%,"Cc: " & getlist("CopyTo")
  318.     Print #fileNum%, "Bcc: " & getlist("BlindCopyTo")
  319.     Print #fileNum%,"Subject: " & doc.subject(0)
  320.     Print #fileNum%, "Date: " & Format(doc.posteddate(0), "dd mmm yyyy  hh:mm:ss")
  321.     msgid=doc.GetItemValue("$MessageID")
  322.     Print #fileNum, "Message-ID: " & msgid(0)
  323.     If Not  ismultipart Then Print  #fileNum%, "MIME-Version: 1.0"
  324.     If Not  ismultipart Then Print #fileNum%,"Content-Type: multipart/alternative;"
  325.     If Not  ismultipart Then Print #fileNum%, Chr(09) & |boundary="| & Cstr(doc.NoteID) & |"|
  326.     Print #1, "X-Priority: " & doc.importance(0)
  327.     Forall i In doc.Items
  328.         If i.text<>"" Then
  329.             If i.name<>"Body" Then
  330.                 Print #1, "X-Notes-Item: " & i.text & "; name=" & i.name
  331.             End If
  332.         End If
  333.     End Forall 
  334.     If Not  ismultipart Then Print #fileNum%, crlf & "--" & Cstr(doc.NoteID)
  335.     If Not  ismultipart Then Print #fileNum%,"Content-Type: text/html;"
  336.     If Not  ismultipart Then Print #fileNum%, Chr(09) & |charset="iso-8859-1"|
  337.     If Not  ismultipart Then Print #fileNum%, "Content-Transfer-Encoding:  quoted-printable" & crlf
  338.     If Not ismultipart Then Print #fileNum%, htmlStart
  339.     Print #fileNum%, htmlBody
  340.     If Not  ismultipart Then Print #fileNum%, htmlEnd & crlf
  341.     If Not ismultpart Then Print #fileNum%, crlf & "--" & Cstr(doc.NoteID) & "--"
  342.    
  343.     'Close #fileNum
  344.     WriteHtmlStringToFile = True
  345.     Exit Function
  346.    
  347. processError:
  348.     Print "Error " & Err & ": " & Error$
  349.     Reset
  350.     WriteHtmlStringToFile = False
  351.     Exit Function
  352.    
  353. End Function
  354. Function RefreshDocFields (doc As NotesDocument) As String
  355.     '** Refresh the fields on a document, and return the NoteID of
  356.     '** the refreshed doc (I don't think this would cause the NoteID
  357.     '** to change, but just in case)
  358.     On Error Resume Next
  359.    
  360.     '** before we save the uidoc, disable any MIME conversion warnings
  361.     '** by setting the MIMEConvertWarning parameter in Notes.ini to 1
  362.     Dim session As New NotesSession
  363.     Dim oldWarningVal As String
  364.     oldWarningVal = session.GetEnvironmentString("MIMEConvertWarning", True)
  365.     Call session.SetEnvironmentVar("MIMEConvertWarning", "1", True)
  366.    
  367.     Dim workspace As New NotesUIWorkspace
  368.     Dim uidoc As NotesUIDocument
  369.     Set uidoc = workspace.EditDocument(True, doc)
  370.     Call uidoc.Save
  371.     RefreshDocFields = uidoc.Document.NoteID
  372.     Call uidoc.FieldSetText ("SaveOptions", "0" )
  373.     Call uidoc.Close(True)
  374.    
  375. %REM
  376.     '** if you're not running this on a Notes client, you could
  377.     '** try to run this in the background by doing everything
  378.     '** using the Notes COM objects, although this is totally
  379.     '** unsupported and probably riddled with memory leaks
  380.     '** if you could actually get it working (plus, it would only
  381.     '** work on a Windows server...)
  382.     Dim oleSession As Variant
  383.     Dim oleDb As Variant
  384.     Dim oleDoc As Variant
  385.     Dim oleWorkspace As Variant
  386.     Dim oleUidoc As Variant
  387.    
  388.     '** first we have to get a handle to the doc as an OLE object
  389.     Set oleSession = CreateObject("Notes.NotesSession")
  390.     Call oleSession.Initialize
  391.     Set oleDb = oleSession.GetDatabase("", doc.ParentDatabase.FilePath)
  392.     Set oleDoc = oleDb.GetDocumentByID(doc.NoteID)
  393.    
  394.     '** if we were able to do that, we can open and save it as a UIDoc
  395.     '** using COM
  396.     If Not (oleDoc Is Nothing) Then
  397.         Set oleWorkspace = CreateObject("Notes.NotesUIWorkspace")
  398.         Set oleUidoc = oleWorkspace.EditDocument(True, oleDoc)
  399.         Call oleUidoc.Save
  400.         RefreshDocFields = oleUidoc.Document.NoteID
  401.         Call oleUidoc.Close(True)
  402.     End If
  403. %END REM
  404.    
  405.     '** reset the MIMEConvertWarning Notes.ini variable and return
  406.     Call session.SetEnvironmentVar("MIMEConvertWarning", oldWarningVal, True)
  407.    
  408. End Function
  409. Function GetRichTextAsHtmlFile (doc As NotesDocument, _
  410. fieldName As String, fileName As String, setFileExtension As Integer) As Integer
  411.     '** convert a rich text field to HTML, and send it to the specified file
  412.     '** (if setFileExtension is True, the fileName will automatically have
  413.     '** either .htm or .mht appended as the file extension, depending
  414.     '** on whether the HTML representation is multi-part or not)
  415.     Dim isMultiPart As Integer
  416.     Dim htmlBody As String
  417.    
  418.     htmlBody = GetRichTextAsHtmlString(doc, fieldName, isMultiPart)
  419.     GetRichTextAsHtmlFile = WriteHtmlStringToFile(htmlBody, fileName, True, isMultiPart)
  420.    
  421. End Function
  422. Function GetRichTextAsHtmlString (doc As NotesDocument, fieldName As String, isMultiPart As Integer) As String
  423. '** get the contents of the given field as HTML by copying them
  424.     '** to a MIME rich text field and reading the MIME field
  425.     Dim session As New NotesSession
  426.     Dim mText As String
  427.     Dim db As NotesDatabase
  428.     Dim newDoc As NotesDocument
  429.     Dim noteID As String
  430.     Dim currentSessionMimeSetting As Integer
  431.    
  432.     Dim rtitem As NotesRichTextItem
  433.     Dim rtitem2 As NotesRichTextItem
  434.     Dim mimeItem As NotesItem
  435.     Dim mime As NotesMIMEEntity
  436.     Dim MimeFieldName As String
  437.    
  438.     '** make sure we can actually get the rich text field we want to
  439.     '** copy, and make sure it's really rich text (error 13 if it's not)
  440.     On Error 13 Resume Next
  441.     Set rtitem = doc.GetFirstItem(fieldName)
  442.     If (rtitem Is Nothing) Then
  443.         Exit Function
  444.     End If
  445.    
  446.     '** save the current ConvertMime setting, because we'll change it
  447.     '** a couple of times
  448.     currentSessionMimeSetting = session.ConvertMime
  449.    
  450.     '** initially set the ConvertMime property to True and create a
  451.     '** temporary document, which allows us to treat the MIME field
  452.     '** as rich text so we can append some real rich text to it
  453.     session.ConvertMime = True
  454.    
  455.     '** create a new document to manipulate the MIME entry with.
  456.     Set db =session.CurrentDatabase
  457.     'Set db = session.GetDatabase(CONVERT_DB_SERVER, CONVERT_DB_NAME)
  458.     Set newDoc = New NotesDocument(db)
  459.    
  460.     '** this document must use a form that already exists in this
  461.     '** database, and the MIME field that we create must be the
  462.     '** same name as a field that's already on the form as a rich text
  463.     '** field that stores its data in MIME format
  464.     newDoc.Form = CONVERT_FORM
  465.     MimeFieldName = CONVERT_TOFIELD
  466.    
  467.     Set rtitem2 = New NotesRichTextItem(newDoc, MimeFieldName)
  468.     Call rtitem2.AppendRTItem(rtitem)
  469.     Call newDoc.Save(True, True)
  470.    
  471.     '** HERE'S THE TRICK: you have to open the temporary doc
  472.     '** as a uidoc, and then save and close it.
  473.     '** This will convert all the rich text in our MIME field back to
  474.     '** MIME format (which is why the field had to exist as a valid
  475.     '** MIME field on a valid form in the first place, so Notes will
  476.     '** know to convert it back)
  477.     noteID = RefreshDocFields(newDoc)
  478.    
  479.     ' Error check if we didn't get a noteID
  480.     If noteID = "" Then
  481.         Msgbox ("Whoops! Dropped the noteID!")
  482.     End If
  483.    
  484.    
  485.     '** after you've done this, you need to reset the reference for
  486.     '** the newDoc variable, so none of the in-memory information
  487.     '** about the document will remain
  488.     Set newDoc = Nothing
  489.    
  490.     '** set ConvertMime to False, reopen the temporary doc,
  491.     '** and now we can get the rich text contents as HTML
  492.     session.ConvertMime = False
  493.     Set newDoc = db.GetDocumentByID(noteID)
  494.     Set mimeItem = newDoc.GetFirstItem(MimeFieldName)
  495.     If Not (mimeItem Is Nothing) Then
  496.         If (mimeItem.Type = MIME_PART) Then
  497.             Set mime = mimeItem.GetMimeEntity
  498.             If Not (mime Is Nothing) Then
  499.                 If (mime.ContentType = "multipart") Then
  500.                     '** for multi-part MIME, which is anything with graphics,
  501.                     '** you need to get the various parts one at a time.
  502.                     '** If you write this to a file, it should be a .mht file so the
  503.                     '** the browser knows what to do with it.
  504.                     '** NOTE: there is a bug in R5 where you can't always
  505.                     '** get the full contents of large sections of multi-part
  506.                     '** MIME -- if you're dealing with large images, they will
  507.                     '** often get cropped off at the bottom
  508.                     isMultipart = True
  509.                     mText = GetMultipartMime(mime)
  510.                 Else
  511.                     '** if we're not dealing with multi-part (thank goodness)
  512.                     '** we can just grab the HTML contents and go
  513.                     isMultipart = False
  514.                     mText = mText & mime.ContentAsText
  515.                 End If
  516.             End If
  517.         End If
  518.     End If
  519.    
  520.     '** delete or save the temporary doc when we're done (depending on
  521.     '** the SaveTempDoc setting)
  522.     If SaveTempDoc Then
  523.         Set rtitem2 = New NotesRichTextItem(newDoc, "HTMLText")
  524.         Call rtitem2.AppendText(mText)
  525.         Call newDoc.Save(True, True)
  526.     Else
  527.         Call newDoc.Remove(True)
  528.     End If
  529.    
  530.     '** set the ConvertMIME setting back to whatever it was
  531.     '** before we started all this, and exit out
  532.     session.ConvertMIME = currentSessionMimeSetting
  533.     GetRichTextAsHtmlString = mText
  534. End Function
  535. Function validatefilename(filename As String)
  536.     Dim l As Integer
  537.     Dim x As Integer
  538.     Dim newname As String
  539.     l=Len(filename)
  540.     For x = 1 To l
  541.         If Mid$(filename,x,1) Like "[-@()~^$#[{}=A-Za-z0-9]" Then
  542.             newname=newname+Mid$(filename,x,1)
  543.         Else
  544.             If Mid$(filename,x,1)=" " Or Mid$(filename,x,1)="]" Or Mid$(filename,x,1)=","  Or Mid$(filename,x,1)="'"  Or Mid$(filename,x,1)="!" Then
  545.                 newname=newname+Mid$(filename,x,1)
  546.             Else
  547.                 newname=newname+"_"
  548.                 'Print Mid$(filename,x,1) " is not valid"
  549.             End If
  550.            
  551.         End If
  552.     Next x
  553.     validatefilename=newname
  554. End Function
  555. Function isFolder(Byval sFolderPath As String) As Integer
  556.     Const ATTR_DIRECTORY = 16
  557.     isFolder = False
  558.     If Dir$(sFolderPath, ATTR_DIRECTORY) <> "" Then isFolder = True
  559. End Function
  560. Function isFile(Byval sFileName As String) As Integer
  561.     On Error Resume Next
  562.     Dim lFileLength As Long
  563.     Const ATTR_NORMAL = 0
  564.    
  565.     isFile = False
  566.     If Dir$(sFileName, ATTR_NORMAL) <> "" Then
  567.         lFileLength = Filelen(sFileName)
  568.         If (lFileLength > 0) Then isFile = True
  569.     End If
  570. End Function
  571. Function BrowseForFolder() As String
  572.     Dim mBrowseInfo As BROWSEINFO
  573.     Dim lngPointerToIDList As Long
  574.     Dim lngResult As Long
  575.     Dim strPathBuffer As String
  576.     Dim strReturnPath As String
  577.     Dim vbNullChar As String
  578.    
  579.     vbNullChar = Chr(0)
  580.    
  581.     On Error Goto lblErrs
  582.    
  583.     mBrowseInfo.hwndOwner = GetActiveWindow()
  584.    
  585. ' // Set the default folder for the dialog box (0 = My Computer,
  586. ' // 5 = My Documents)
  587.     mBrowseInfo.pidlRoot = 0
  588.    
  589.     mBrowseInfo.lpszTitle = "Select the folder you wish to use:"
  590. ' // Pointer to a buffer that receives the display name
  591. ' // of the folder selected by the user
  592.     mBrowseInfo.pszDisplayName = String(MAX_SIZE, Chr(0))
  593. ' // Value specifying the types of folders to be listed
  594. ' // in the dialog box as well as other options
  595.     mBrowseInfo.ulFlags = BIF_RETURNONLYFSDIRS
  596.    
  597. ' // Returns a pointer to an item identifier list that
  598. ' // specifies the location of the selected folder relative
  599. ' // to the root of the name space
  600.     lngPointerToIDList = BrowseFolderDlg(mBrowseInfo)
  601.    
  602.     If lngPointerToIDList <> 0& Then
  603. ' // Create a buffer
  604.         strPathBuffer = String(MAX_SIZE, Chr(0))
  605.        
  606. ' // Now get the selected path
  607.         lngResult = GetPathFromIDList(Byval lngPointerToIDList, Byval strPathBuffer)
  608. ' // And return just that
  609.         strReturnPath = Left$(strPathBuffer, Instr(strPathBuffer, vbNullChar) - 1)
  610.     End If
  611.    
  612.     BrowseForFolder = strReturnPath
  613.    
  614. lblEnd:
  615.     Exit Function
  616.    
  617. lblErrs:
  618.     Messagebox "Unexpected error: " & Error$ & " (" & Cstr(Err) & ").", 0, "Error"
  619.     Resume lblEnd
  620. End Function
  621. Sub importDXL()
  622.     Dim s As New NotesSession
  623.     Dim db As NotesDatabase
  624.     Set nstream=s.CreateStream 
  625.     Set db = s.CurrentDatabase
  626.     On Error Goto myerror
  627.     Dim theCode As String
  628.     theCode = "<?xml version='1.0' encoding='utf-8'?><!DOCTYPE database SYSTEM 'xmlschemas/domino_8_5_3.dtd'><database xmlns='http://www.lotus.com/dxl' version='8.5' maintenanceversion='3.0'><form name='MimeConvert' nocompose='true' noquery='true' publicaccess='false' designerversion='8.5.3'><code event='windowtitle'><formula>""MIME Test Form""</formula></code><actionbar bgcolor='#f0f0f0' bordercolor='black'></actionbar><body><richtext><pardef id='1'/><par def='1'><run>  <field type='richtext' kind='editable' name='Body' storageformat='htmlmime'/></run></par></richtext></body><item name='$$ScriptName' summary='false' sign='true'><text>MimeConvert</text></item></form></database>"
  629.    
  630.     Dim importer As NotesDXLImporter
  631.     Set importer = s.CreateDXLImporter(theCode, db)
  632.     importer.ReplaceDBProperties = False
  633.     importer.ReplicaRequiredForReplaceOrUpdate = False
  634.     importer.ACLImportOption = DXLIMPORTOPTION_REPLACE_ELSE_IGNORE
  635.     importer.DesignImportOption = DXLIMPORTOPTION_REPLACE_ELSE_CREATE
  636.     Call importer.Process
  637.    
  638.     Exit Sub
  639.    
  640. myerror:
  641.     Msgbox "importDXL Error, Could not create/update form: " & Chr(13) & Chr(10) & Err & " - " & Error & "; code line: " & Erl,16, "Agent Error"
  642.     Dim stream As NotesStream
  643.    
  644.     Set stream = s.CreateStream
  645.    
  646.    
  647.     If Not stream.Open("dxlerror.log") Then
  648.         Messagebox "Cannot Open log"
  649.        
  650.     End If
  651.    
  652.     Call stream.WriteText(importer.log, EOL_CRLF)
  653.     Call stream.Close
  654.     Exit Sub
  655.    
  656. End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement