Parse Email Body, Attachment and Convert Email to HTML page in VB 6.0¶

Option Explicit

Const CRYPT_MACHINE_KEYSET = 32
Const CRYPT_USER_KEYSET = 4096
Const CERT_SYSTEM_STORE_CURRENT_USER = 65536
Const CERT_SYSTEM_STORE_LOCAL_MACHINE = 131072

Private oTools As New EAGetMailObjLib.Tools

' We generate a html + attachment folder for every email, once the html is create,
' Next time we don't need to parse the email again.
Private Sub GenerateHtmlForEmail(ByVal htmlName As String, _
    ByVal emlFile As String, ByVal tempFolder As String)

On Error GoTo ErrorGenHtml

    Dim oTools As New EAGetMailObjLib.Tools
    Dim oMail As New EAGetMailObjLib.Mail
    oMail.LicenseCode = "TryIt"

    oMail.LoadFile emlFile, False
    If Err.Number <> 0 Then
        MsgBox Err.Description
        Exit Sub
    End If

    On Error Resume Next
    If oMail.IsEncrypted Then
        Set oMail = oMail.Decrypt(Nothing)
        If Err.Number <> 0 Then
            MsgBox Err.Description
        End If
    End If

    If oMail.IsSigned Then
        oMail.VerifySignature
        If Err.Number <> 0 Then
            MsgBox Err.Description
        End If
    End If

On Error GoTo ErrorGenHtml

    ' Decode winmail.dat (TNEF) and RTF body automatically
    ' also convert RTF body to HTML automatically.
    oMail.DecodeTNEF

    Dim html As String
    html = oMail.HtmlBody

    Dim hdr As String
    hdr = hdr & "<font face=""Courier New,Arial"" size=2>"
    hdr = hdr & "<b>From:</b> " + FormatHtmlTag(oMail.From.name & "<" & _
    oMail.From.Address & ">") + "<br>"

    Dim i, addrs
    Set addrs = oMail.ToList

    If (addrs.Count > 0) Then
        hdr = hdr & "<b>To:</b> "
        For i = 0 To addrs.Count - 1
            hdr = hdr & FormatHtmlTag(addrs.Item(i).name & "<" & addrs.Item(i).Address & ">")
            hdr = hdr & ";"
        Next
        hdr = hdr & "<br>"
    End If

    Set addrs = oMail.CcList

    If (addrs.Count > 0) Then
        hdr = hdr & "<b>Cc:</b> "
        For i = 0 To addrs.Count - 1
            hdr = hdr & FormatHtmlTag(addrs.Item(i).name & "<" & addrs.Item(i).Address & ">")
            hdr = hdr & ";"
        Next
        hdr = hdr & "<br>"
    End If

    hdr = hdr & "<b>Subject:</b>" & FormatHtmlTag(oMail.Subject) & "<br>" & vbCrLf

    Dim atts
    Set atts = oMail.AttachmentList
    If (atts.Count > 0) Then

        If Not oTools.ExistFile(tempFolder) Then
            oTools.CreateFolder (tempFolder)
        End If

        hdr = hdr & "<b>Attachments:</b>"
        For i = 0 To atts.Count - 1
            Dim att As Attachment
            Set att = atts.Item(i)

            Dim attname
            attname = tempFolder & "\" & att.name
            att.SaveAs attname, True

            hdr = hdr & "<a href=""" & attname & """ target=""_blank"">" & att.name & "</a> "
            If Len(att.ContentID) > 0 Then
                'show embedded image.
                html = Replace(html, "cid:" + att.ContentID, attname)
            ElseIf InStr(1, att.ContentType, "image/", vbTextCompare) = 1 Then
                'show attached image.
                html = html & "<hr><img src=""" & attname & """>"
            End If
        Next
    End If

    hdr = "<meta HTTP-EQUIV=""Content-Type"" Content=""text-html; charset=utf-8"">" & hdr
    html = hdr & "<hr>" & html
    oTools.WriteTextFile htmlName, html, 65001

    MsgBox emlFile & " has been converted to html successfully!"
    Exit Sub

ErrorGenHtml:
    MsgBox "Failed to generate html file for the email; " & Err.Description

End Sub

Private Function FormatHtmlTag(ByVal src As String) As String
    src = Replace(src, ">", "&gt;")
    src = Replace(src, "<", "&lt;")
    FormatHtmlTag = src
End Function

Private Sub ConvertMailToHtml(ByVal fileName As String)
    Dim pos
    pos = InStrRev(fileName, ".")
    Dim mainName
    Dim htmlName
    mainName = Mid(fileName, 1, pos - 1)
    htmlName = mainName & ".htm"

    Dim tempFolder As String
    tempFolder = mainName
    If Not (oTools.ExistFile(htmlName)) Then
        ' We haven't generate the html for this email, generate it now.
        GenerateHtmlForEmail htmlName, fileName, tempFolder
    End If

End Sub

Private Sub Command1_Click()
    Dim curpath As String
    Dim mailbox As String

    ' Create a folder named "inbox" under current directory
    ' to save the email retrieved.
    curpath = App.Path
    mailbox = curpath & "\inbox"
    oTools.CreateFolder mailbox

    Dim files
    Dim i As Long

    ' Get all *.eml files in specified folder and convert it to HTML one by one.
    files = oTools.GetFiles(mailbox & "\*.eml")
    For i = LBound(files) To UBound(files)
        ConvertMailToHtml files(i)
    Next

    Exit Sub
ErrorHandle:
    MsgBox Err.Description
End Sub