Home
Search
 
What's New
Index
Books
Links
Q & A
Newsletter
Banners
 
Feedback
Tip Jar
 
C# Helper...
 
XML RSS Feed
Follow VBHelper on Twitter
 
 
 
MSDN Visual Basic Community
 
 
 
 
 
TitleConvert Outlook emails into Word documents
DescriptionThis example shows how to convert Outlook emails into Word documents in Visual Basic 6.
Keywordsem,ail, Word, Microsoft Word, Outlook Express, Outlook
CategoriesOffice, Utilities
 
Subroutine EmlToWord reads an exported .eml file and converts it into a Word document. It uses the GetFileContents function to read the file into a string. It replaces vbCrLf and vbLf characters with carriage returns and splits the file into lines.

The program then looks through the lines and usees the GetField function to find the field name and value in the lines (for example, "Subject: whoever@someplace.com"). It saves the values of the fields in variables.

When it finishes reading the header fields, the program concatenates the remaining lines into the message body.

Next the program creates a Word server and makes a new document. It adds each field's name (using the Heading 1 style) and text.

The program finishes by saving the Word document with the same name as the email file but with a .doc extension instead of the .eml extension.

 
' Convert a .eml file into a Word file.
Private Sub EmlToWord(ByVal word_app As Word.Application, _
    ByVal file_name As String)
Dim txt As String
Dim lines() As String
Dim line_num As Integer
Dim pos As Integer
Dim field_name As String
Dim field_value As String
Dim field_to As String
Dim field_from As String
Dim field_date As String
Dim field_subject As String
Dim field_return_path As String
Dim field_body As String
Dim i As Integer
Dim word_doc As Word.Document
Dim rng As Word.Range

    ' Get the eml file.
    txt = GetFileContents(file_name)

    ' Process the header.
    txt = Replace$(txt, vbCrLf, vbCr)
    txt = Replace$(txt, vbLf, vbCr)
    lines = Split(txt, vbCr)
    line_num = LBound(lines)
    Do
        ' Get the next field's name and value.
        GetField lines, line_num, field_name, field_value

        Select Case LCase$(field_name)
            Case "to"
                field_to = field_value
            Case "from"
                field_from = field_value
            Case "subject"
                field_subject = field_value
            Case "date"
                field_date = field_value
            Case "return-path"
                field_return_path = field_value
            Case ""
                Exit Do
            Case Else
                ' Ignore everything else.
        End Select
    Loop

    ' Concatenate the rest of the lines.
    field_body = ""
    For i = line_num To UBound(lines)
        field_body = field_body & lines(i) & vbCrLf
    Next i

    ' Put the results in a new Word document.
    Set word_doc = _
        word_app.Documents.Add(DocumentType:=wdNewBlankDocument, _
        Visible:=False)
    word_doc.Activate
    Set rng = word_doc.Range()
    rng.Collapse wdCollapseStart

    rng.InsertAfter "To:" & vbCrLf
    rng.Style = word_doc.Styles("Heading 1")
    rng.Collapse wdCollapseEnd
    rng.InsertAfter field_to & vbCrLf
    rng.Collapse wdCollapseEnd

    rng.InsertAfter "From:" & vbCrLf
    rng.Style = word_doc.Styles("Heading 1")
    rng.Collapse wdCollapseEnd
    rng.InsertAfter field_from & vbCrLf
    rng.Collapse wdCollapseEnd

    rng.InsertAfter "Return-Path:" & vbCrLf
    rng.Style = word_doc.Styles("Heading 1")
    rng.Collapse wdCollapseEnd
    rng.InsertAfter field_return_path & vbCrLf
    rng.Collapse wdCollapseEnd

    rng.InsertAfter "Date:" & vbCrLf
    rng.Style = word_doc.Styles("Heading 1")
    rng.Collapse wdCollapseEnd
    rng.InsertAfter field_date & vbCrLf
    rng.Collapse wdCollapseEnd

    rng.InsertAfter "Subject:" & vbCrLf
    rng.Style = word_doc.Styles("Heading 1")
    rng.Collapse wdCollapseEnd
    rng.InsertAfter field_subject & vbCrLf
    rng.Collapse wdCollapseEnd

    rng.InsertAfter "Body:" & vbCrLf
    rng.Style = word_doc.Styles("Heading 1")
    rng.Collapse wdCollapseEnd
    rng.InsertAfter field_body & vbCrLf
    rng.Collapse wdCollapseEnd

    ' Save the file.
    file_name = Replace$(file_name, ".eml", ".doc")
    word_doc.SaveAs file_name
    word_doc.Close
End Sub
 
The GetFileContents function opens a file, pulls its contents into a string, closes the file, and returns the string.
 
' Get the file's contents.
Private Function GetFileContents(ByVal file_name As String) _
    As String
Dim fnum As Integer

    ' Open the file.
    fnum = FreeFile
    Open file_name For Input As fnum

    ' Grab the file's contents.
    GetFileContents = Input(LOF(fnum), fnum)

    ' Close the file.
    Close fnum
End Function
 
Subroutine GetField searches a line for the colon that ends an email field's name. If it finds a field, it examines the following lines. Any lines that begin with a space or tab are continuations of the field.
 
' Get the next field's name and value.
' Return field_name = "" if there are no more fields.
Private Sub GetField(lines() As String, ByRef line_num As _
    Integer, ByRef field_name As String, ByRef field_value _
    As String)
Dim pos As Integer

    field_name = ""
    field_value = ""

    ' See if this is the end of the header.
    If Len(Trim$(lines(line_num))) = 0 Then Exit Sub

    ' Find the end of the field name.
    pos = InStr(lines(line_num), ":")
    If (pos = 0) Or (Left$(lines(line_num), 1) = " ") Then
        ' The line doesn't start with a field name.
        field_name = "?"
        field_value = lines(line_num)
        line_num = line_num + 1
        Exit Sub
    End If

    ' Get the field name.
    field_name = Left$(lines(line_num), pos - 1)

    ' Get the beginning of the field value.
    field_value = Mid$(lines(line_num), pos + 1)
    line_num = line_num + 1

    ' Get the rest of the field value (if there is any).
    Do While line_num <= UBound(lines)
        ' If the line doesn't begin with a space,
        ' that's the end of the field.
        If (Left$(lines(line_num), 1) <> " ") And _
           (Left$(lines(line_num), 1) <> vbTab) _
                Then Exit Do

        ' Get this part of the field.
        field_value = field_value & vbCrLf & lines(line_num)

        line_num = line_num + 1
    Loop
End Sub
 
 
Copyright © 1997-2006 Rocky Mountain Computer Consulting, Inc.   All rights reserved.
  Updated