File attachment using SMTP in VB6

Question

I am writing an VB6 application in which I'm making use of cdosys.dll in order to send mails. I am able to attach and send the mails but the problem that I'm facing is the attached file icon image is not getting displayed correctly (default icon image is getting displayed). Also I am not able to attach the files between two paragraphs in the body part. I am using IBM Lotus Notes mail system. Please find below the code that I'm using and also the screenshot of issue that I'm facing

Set objEmail = CreateObject("CDO.Message")
objEmail.MimeFormatted = True

objEmail.To = to address
objEmail.From = from address
objEmail.Subject = "Additional Replacement Letters : " & Format(Now, "mm/dd")
objEmail.TextBody = "Hello Team," & vbCrLf & vbCrLf & "find below the attached letters"


Set fld = FSO.GetFolder(path)
For Each fil In fld.Files
    Set iBp = objEmail.AddAttachment(fil)
Next
objEmail.TextBody = "Revert to me for any concerns"

objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.domain.com"
objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objEmail.Configuration.Fields.Update

objEmail.Send

Please help me how to solve this issue.

Answer 1

First, for the icons of files appearing in the attachments section. If a generic file icon is displayed, it may be because either:

1. your system doesn't have any/the correct MIME type defined for *.doc files (shouldn't be the case if you have Word installed);
2. the client cannot match any extension (and thus an icon) to the MIME type included with an attached file; or
3. if the recipient is viewing the emails through a web-based email system, the provider might not have/provide an image to show as an icon for those types of files.

In most cases it's the client software that is too lazy to display the appropriate icon.

---

Now, if you want the files to appear amid the email body, this is another story. Here an overview of what needs to be done:

• First, you don't add files through IMessage.AddAttachment() but with IMessage.AddRelatedBodyPart();
• When called, IMessage.AddRelatedBodyPart() will return an IBodyPart object;
• Using the IBodyPart object, you need to assign a unique content ID to the piece – you can use the file name, but whatever the CID it must not contain spaces;
• You then need to write your email body in HTML (so you can link to them);

• In the message you'll add links to related parts as such:

  <a href="cid:%CONTENT_ID_OF_THE_FILE%">Link to the file</a>

  where %CONTENT_ID_OF_THE_FILE% is the content ID you set for the file. Example:

  <a href="cid:My_Doc_File.doc">Link to the file</a>

There are two things you'll have to remember if you insert files this way:

1. You won't see any icon aside or elsewhere related to the file(s) attached, i.e. they'll appear as you set them through your HTML code. If you want any, you'll have to add images (not icon files) the same way and refer to them using the <img> tag and their content ID.
2. In many clients, you won't see the files in the attachments section, unless they're not being referred to in the body (or their content ID doesn't match, which is the same thing)

Here is some code. It's pretty complete, as I had to test it because I wasn't sure to remember everything correctly. Also, it is assumed you have among the references for your project Microsoft CDO for Windows 2000 Library and Microsoft Scripting Runtime.

Public Function SendNewLetters(ByVal PathForLetters As String, ByVal FromName As String, ByVal FromEmail As String, ByVal ToName As String, _
                        ByVal ToEmail As String, ByVal SMTPServer As String, ByVal SMTPPort As Long, ByVal SMTPUser As String, _
                        ByVal SMTPPassword As String, Optional ByVal UseSSL As Boolean = False, Optional ByRef ErrorCode As Long = 0, _
                        Optional ErrorDesc As String = vbNullString) As Boolean
On Error GoTo ErrorHandler
Const CdoReferenceTypeName = 1
Dim iMsg As CDO.Message ' Not using CreateObject() because I have the reference added
Dim sFileCID As String, sFileExt As String
Dim sIconImageSrc As String, sIconImageCID As String
Dim iBpAttachment As CDO.IBodyPart ' Will be reused more than once
Dim iBpIconImage As CDO.IBodyPart
Dim oFSO As Scripting.FileSystemObject
Dim oFolder As Scripting.Folder
Dim oFile As Scripting.File
Dim oDictAddedExtIcons As Scripting.Dictionary
    Set iMsg = New CDO.Message
    ' Configure SMTP parameters
    With iMsg.Configuration
        .Fields(cdoSMTPServer) = SMTPServer
        .Fields(cdoSMTPServerPort) = SMTPPort
        .Fields(cdoSMTPUseSSL) = UseSSL
        .Fields(cdoSMTPAuthenticate) = cdoBasic
        .Fields(cdoSendUserName) = SMTPUser
        .Fields(cdoSendPassword) = SMTPPassword
        .Fields(cdoSMTPConnectionTimeout) = 60
        .Fields(cdoSendUsingMethod) = cdoSendUsingPort
        .Fields.Update
    End With
    ' Set From and To fields
    If Len(FromName) > 0 Then
        ' Let's say we already QP-encoded any special chars for the name
        ' and checked the email address
        iMsg.From = FromName & " <" & FromEmail & ">"
    Else
        iMsg.From = FromEmail
    End If
    If Len(ToName) > 0 Then
        ' Same thing here
        iMsg.To = ToName & " <" & ToEmail & ">"
    Else
        iMsg.To = ToEmail
    End If
    ' Set subject (would need QP encoding as well)
    iMsg.Subject = "Additional Replacement Letters : " & Format(Now, "mm/dd")
    ' Build the body
    iMsg.HTMLBody = "<!DOCTYPE HTML PUBLIC ""-//W3C//DTD HTML 4.01 Transitional //EN""><html><body><p>Hello Team,<br/><br/>" & _
                    "Please find below the attached letters</p><div style=""display: table"">"
    ' Will be used to make sure icon images are only added once
    Set oDictAddedExtIcons = New Scripting.Dictionary
    ' Add files here, one new body part for each
    Set oFSO = New Scripting.FileSystemObject
    If oFSO.FolderExists(PathForLetters) Then
        Set oFolder = oFSO.GetFolder(PathForLetters)
        For Each oFile In oFolder.Files
            ' IMPORTANT: Content-IDs should not contain spaces
            sFileCID = Replace$(oFile.Name, " ", "_")
            Set iBpAttachment = iMsg.AddRelatedBodyPart(oFile.Path, oFile.Name, CdoReferenceTypeName)
            iBpAttachment.Fields.Item("urn:schemas:mailheader:content-id") = "<" & sFileCID & ">"
            iBpAttachment.Fields.Update ' Dont' forget that line
            sFileExt = LCase$(GetFileExtension(oFile.Name))
            sIconImageSrc = vbNullString
            Select Case sFileExt
                Case "doc"
                    ' We provide here the path to a 32x32 image of the doc file icon
                    sIconImageSrc = "C:\Users\MyUserName\Desktop\DocIcon.png"
                    ' We could also provide images for other extensions, or
                    '   (more involved) query the DefaultIcon for any extension from
                    '   the registry, load the icon from the ico/exe/dll file and
                    '   find the best size/resize if necessary (already have the
                    '   code, but it's a *lot* of code).
                Case ".."
                    ' Add support for more
            End Select
            If Len(sIconImageSrc) > 0 Then
                If Not oDictAddedExtIcons.Exists(sFileExt) Then
                    sIconImageCID = GetFilePart(sIconImageSrc) ' Is the filename for this and the next line
                    Set iBpIconImage = iMsg.AddRelatedBodyPart(sIconImageSrc, sIconImageCID, CdoReferenceTypeName)
                    ' IMPORTANT: Content-IDs should not contain spaces
                    sIconImageCID = Replace$(sIconImageCID, " ", "_")
                    iBpIconImage.Fields.Item("urn:schemas:mailheader:content-id") = "<" & sIconImageCID & ">"
                    iBpIconImage.Fields.Update ' Dont' forget that line
                    oDictAddedExtIcons.Add sFileExt, sIconImageCID
                    sIconImageSrc = "cid:" & sIconImageCID
                Else
                    sIconImageSrc = "cid:" & oDictAddedExtIcons.Item(sFileExt)
                End If
            End If
            iMsg.HTMLBody = iMsg.HTMLBody & "<div style=""display: table-row""><div style=""text-align: left; " & _
                                            "vertical-align: middle; margin-right: 10px;"">"
            If Len(sIconImageSrc) > 0 Then
                iMsg.HTMLBody = iMsg.HTMLBody & "<a href=""cid:" & sFileCID & """><img src=""" & sIconImageSrc & """ border=""0"" /></a>"
            Else
                iMsg.HTMLBody = iMsg.HTMLBody & "&nbsp;"
            End If
            iMsg.HTMLBody = iMsg.HTMLBody & "</div><div style=""display: table-cell; text-align: left; vertical-align: middle;"">"
            iMsg.HTMLBody = iMsg.HTMLBody & "<a href=""cid:" & sFileCID & """>" & oFile.Name & "</a>"
            iMsg.HTMLBody = iMsg.HTMLBody & "</div></div>"
        Next
    End If
    iMsg.HTMLBody = iMsg.HTMLBody & "</div><br/>"
    iMsg.HTMLBody = iMsg.HTMLBody & "<p>Revert to me for any concerns.</p></body></html>"
    ' Send away!
    iMsg.Send
    SendNewLetters = True
    Exit Function
ErrorHandler:
    ErrorCode = Err.Number
    ErrorDesc = Err.Description
    SendNewLetters = False
End Function

Public Function GetFilePart(ByVal FilePath As String) As String
Dim lPos As Long
    lPos = InStrRev(FilePath, "\")
    If lPos > 0 Then
        GetFilePart = Right$(FilePath, Len(FilePath) - lPos)
    End If
End Function

Public Function GetFileExtension(ByVal FilePath As String, Optional ByVal WithDot As Boolean = False) As String
Dim lPos As Long
    lPos = InStrRev(FilePath, ".")
    If InStr(1, FilePath, ".") Then
        If WithDot Then
            GetFileExtension = Right$(FilePath, Len(FilePath) - lPos + 1)
        Else
            GetFileExtension = Right$(FilePath, Len(FilePath) - lPos)
        End If
    End If
End Function

Here is the image I used for the *.doc icon:

And this is what it would look like when sent:

I hope it works for you!