|
|
|
| Title | Convert Outlook emails into Word documents |
|---|
| Description | This example shows how to convert Outlook emails into Word documents in Visual Basic 6. |
|---|
| Keywords | em,ail, Word, Microsoft Word, Outlook Express, Outlook |
|---|
| Categories | Office, 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
|
| |
|
| |
|
|
