Private Const APIModule = "NNOTES" 

' Writes out a field to a file in CD format.
Declare Function MailGetMessageBodyComposite Lib APIModule Alias "MailGetMessageBodyComposite" ( Byval hNT As Long, Byval N As String, Byval D As String, nD As Long) As Integer
Declare Function ExportRTF Lib "nxrtf" Alias "ExportRTF" (Byval sTempFile As String, Byval flags As Long, hmod As Long, Byval altlibrary As String, Byval sRTFFile As String) As Integer

' Gets the directory used for temporary files.
Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
(Byval nBufferLength As Long, Byval lpBuffer As String) As Long

' Creates a temporary file name.
Declare Function GetTempFileName Lib "kernel32" Alias _
"GetTempFileNameA" (Byval lpszPath As String, Byval lpPrefixString As _
String, Byval wUnique As Long, Byval lpTempFileName As String) As Long

Private Const TMP_PREFIX = "~"
Private Const TMP_FIELD = "tmp"

' Error thrown if you try to export a Notes object other than
' NotesItem or NotesDocument.
Public Const INVALID_TYPE_ERR = 1001

' Class for exporting fields or documents to file. For instance, you can use
' it to export a Notes document to an RTF file.
'
' Example:
'   Dim session As New NotesSession
'   Dim db As NotesDatabase
'   Dim dc As NotesDocumentCollection
'   Set db = session.Currentdatabase
'   Set dc = db.Unprocesseddocuments
'   Dim doc As notesdocument
'   Set doc = dc.GetFirstDocument
'   
'   Dim item_exporter As New Exporter(doc.GetFirstItem("Body"))
'   item_exporter.RTF "c:\tmp\export_item_test.rtf"
'   
'   Dim doc_exporter As New Exporter(doc)
'   doc_exporter.RTF "c:\tmp\export_doc_test.rtf"
'
Public Class Exporter
  Private Document As NotesDocument
  Private FieldName As String
  
  ' The constructor takes a NotesItem or a NotesDocument object.
  Public Sub New(item As Variant)
    If item Isa "NotesItem" Then
      Set Me.Document = item.Parent
      Me.FieldName = item.Name
    Else 
      If item Isa "NotesDocument" Then
        
        Dim tmp_doc As NotesDocument
        Set tmp_doc = item.ParentDatabase.CreateDocument
        Set Me.Document = tmp_doc 
        
        Dim tmp_fld As New NotesRichTextItem(tmp_doc, TMP_FIELD)        
        Dim success As Integer
        success = item.RenderToRTItem(tmp_fld)
        
        Me.FieldName = TMP_FIELD
      Else
        Error INVALID_TYPE_ERR, "Not a valid object type"
      End If
    End If
  End Sub
  
  ' Exports to common data format.
  Private Sub CD(FileName As String)
    Dim file_size As Long 
    
    Dim contents_file As String
    contents_file = TempFile(TMP_PREFIX)
    Call MailGetMessageBodyComposite(Document.handle , FieldName, contents_file, file_size) 
    
    Dim fonts_file As String
    fonts_file = TempFile(TMP_PREFIX)
    Call MailGetMessageBodyComposite(Document.handle , "$Fonts", fonts_file, file_size)
    
    Call Concatenate (contents_file, fonts_file, FileName)   
    
    Kill contents_file
    Kill fonts_file
  End Sub
  
  ' Exports to Rich text format.
  Public Sub RTF(FileName As String)
    Dim cd_file As String
    cd_file = TempFile(TMP_PREFIX)
    
    CD cd_file    
    Call ExportRTF(cd_file, 0, 0, "", FileName)
    
    Kill cd_file
  End Sub
  
     ' Takes two CD record format files and adds them into one file using binary file access
     ' First two bytes (one word) of file is control character so this is stripped from second file
     ' there is always an even number of bytes in CD-records so we can use Integer to transfer
     ' the data. (Function copied from notes.net.)
  Private Sub Concatenate(fileIn1 As String, fileIn2 As String, fileOut1 As String)
    
    Dim twobytes As Integer
    Dim filein As Integer
    Dim fileout As Integer
    
    fileout = Freefile 
    Open fileOut1 For Binary As #fileout
    
    filein = Freefile
    Open fileIn1 For Binary As #filein
    Do Until Eof (filein)
      Get #filein,,twobytes
      Put #fileout,, twobytes
    Loop
    Close #filein
    
    Open fileIn2 For Binary As #filein
    Seek #filein, 3 
    Do Until Eof (filein)
      Get #filein,,twobytes
      Put #fileout,, twobytes
    Loop
    Close
  End Sub 
  
     ' Returns a random file name that is not already in use.
  Private Function TempFile(prefix As String)
    Dim temp_dir As String
    Dim path_len As Long
    temp_dir = Space(255)
    path_len = GetTempPath(255, temp_dir)
    temp_dir = Left$(temp_dir, path_len)
    
    Dim temp_file As String
    temp_file = Space(255)
    Dim file_len As Long
    file_len = GetTempFileName(temp_dir, prefix, 0&, temp_file)
    file_len = Instr(temp_file, Chr$(0))
    If file_len > 1 Then
      temp_file = Left$(temp_file, file_len - 1)
    End If
    
    TempFile = temp_file
  End Function
End Class