Option Explicit
Private colEmailTo As Collection
Private colEmailCC As Collection
Private colEmailBCC As Collection
Private colAttachment As Collection
Private sSubject As String
Private sBody As String
Private sSignatureTextPath As String
Private sSignatureHTMLPath As String
Private Sub Class_Initialize()
'Create collections to hold defined items
Set colEmailTo = New Collection
Set colEmailCC = New Collection
Set colEmailBCC = New Collection
Set colAttachment = New Collection
End Sub
Private Sub Class_Terminate()
'Release all collections
Set colEmailTo = Nothing
Set colEmailCC = Nothing
Set colEmailBCC = Nothing
Set colAttachment = Nothing
End Sub
'---------------------------------------------------------------------------------------
' Writing to properties/collections
'---------------------------------------------------------------------------------------
Public Property Let AddToRecipient(s As String)
'Add a "To" recipient
If EmailIsValid(s) Then
colEmailTo.Add s
Else
MsgBox "Sorry, but " & s & " does not appear" & vbNewLine & _
"to be a valid email address", vbOKOnly, "Invalid address!"
End If
End Property
Public Property Let AddCCRecipient(s As String)
'Add a "CC" recipient
If EmailIsValid(s) Then
colEmailCC.Add s
Else
MsgBox "Sorry, but " & s & " does not appear" & vbNewLine & _
"to be a valid email address", vbOKOnly, "Invalid address!"
End If
End Property
Public Property Let AddBCCRecipient(s As String)
'Add a "BCC" recipient
If EmailIsValid(s) Then
colEmailBCC.Add s
Else
MsgBox "Sorry, but " & s & " does not appear" & vbNewLine & _
"to be a valid email address", vbOKOnly, "Invalid address!"
End If
End Property
Public Property Let AttachFile(s As String)
'Add an attachement
If AttachmentPathValid(s) Then
colAttachment.Add s
Else
MsgBox "Sorry, but " & s & " does not appear" & vbNewLine & _
"to exist!", vbOKOnly, "Invalid file path!"
End If
End Property
Public Property Let AddSignatureHTML(s As String)
'Check if HTML file exists
Dim sTemp As String
Dim sHTML As String
'Look for signature file assuming Windows Vista/7 folder structure
sTemp = Dir("C:\Users\" & Environ("username") & _
"\AppData\Roaming\Microsoft\Signatures\" & s & ".htm")
If Len(sTemp) > 0 Then
sTemp = "C:\Users\" & Environ("username") & _
"\AppData\Roaming\Microsoft\Signatures\" & s & ".htm"
GoTo ValidPath
End If
'Test if system is Windows XP or earlier
sTemp = Dir("C:\Documents and Settings\" & Environ("username") & _
"\Application Data\Microsoft\Signatures\" & s & ".htm")
If Len(sTemp) > 0 Then
sTemp = "C:\Documents and Settings\" & Environ("username") & _
"\Application Data\Microsoft\Signatures\" & s & ".htm"
GoTo ValidPath
End If
'File can not be located. Inform user
MsgBox "Sorry, but I cannot locate the " & s & " signature file!", _
vbOKOnly, "Invalid signature!"
ValidPath:
'Test if HTML contains an image
If InStr(1, SignatureText(sTemp), "<v:imagedata src=") Then<br /> MsgBox " sorry,="" but="" i="" could="" not="" use="" your="" html="" signature="" file."="" &="" vbnewline="" _
"(Unfortunately this routine doesn't handle HTML signatures" & vbNewLine & _
"with images. Please try a plain text signature or an HTML" & vbNewLine & _
"signature that does not have any images embedded.", vbOKOnly + vbInformation, _
"Signature discarded."
Exit Property
Else
sSignatureHTMLPath = sTemp
End If
End Property
Public Property Let AddSignatureText(s As String)
'Check if text file exists
Dim sTemp As String
'Look for signature file assuming Windows Vista/7 folder structure
sTemp = Dir("C:\Users\" & Environ("username") & _
"\AppData\Roaming\Microsoft\Signatures\" & s & ".txt")
If Len(sTemp) > 0 Then
sSignatureTextPath = "C:\Users\" & Environ("username") & _
"\AppData\Roaming\Microsoft\Signatures\" & s & ".txt"
Exit Property
End If
'Test if system is Windows XP or earlier
sTemp = Dir("C:\Documents and Settings\" & Environ("username") & _
"\Application Data\Microsoft\Signatures\" & s & ".txt")
If Len(sTemp) > 0 Then
sSignatureTextPath = "C:\Documents and Settings\" & Environ("username") & _
"\Application Data\Microsoft\Signatures\" & s & ".txt"
Exit Property
End If
'File can not be located. Inform user
MsgBox "Sorry, but I cannot locate the " & s & " signature file!", _
vbOKOnly, "Invalid signature!"
End Property
Public Property Let Subject(s As String)
'Record the subject
sSubject = s
End Property
Public Property Let Body(s As String)
'Record the Body
sBody = s
End Property
'---------------------------------------------------------------------------------------
' Public Class Methods
'---------------------------------------------------------------------------------------
Public Sub Send()
'Method to preview the email
Dim objOL As Object
Dim objMail As Object
'Bind to Outlook
Set objOL = CreateObject("Outlook.Application")
'Create a new email
Set objMail = objOL.CreateItem(0)
CreateMessage objMail
'Preview the message
objMail.Send
'Release all objects
Set objMail = Nothing
Set objOL = Nothing
End Sub
Public Sub Preview()
'Method to preview the email
Dim objOL As Object
Dim objMail As Object
'Bind to Outlook
Set objOL = CreateObject("Outlook.Application")
'Create a new email
Set objMail = objOL.CreateItem(0)
CreateMessage objMail
'Preview the message
objMail.display
'Release all objects
Set objMail = Nothing
Set objOL = Nothing
End Sub
'---------------------------------------------------------------------------------------
' Internal Methods
'---------------------------------------------------------------------------------------
Private Function AttachmentPathValid(sFilePath As String) As Boolean
'Check if attachment exists
'Check if file/folder exists
If Len(Dir(sFilePath)) = 0 Then GoTo Invalid
'Ensure that user did not supply a folder
If Right(sFilePath, 1) = Application.PathSeparator Then GoTo Invalid
'Tests passed
AttachmentPathValid = True
Exit Function
Invalid:
End Function
Private Sub CreateMessage(ByRef oMailItem As Object)
'Create Outlook email based on data stored in internal class collections
Dim lIterate As Long
Dim sTemp As String
With oMailItem
'Add TO Recipients
If colEmailTo.count > 0 Then
For lIterate = 1 To colEmailTo.count
sTemp = sTemp & colEmailTo.Item(lIterate) & ";"
Next lIterate
.To = Left(sTemp, Len(sTemp) - 1)
sTemp = vbNullString
End If
'Add CC Recipients
If colEmailCC.count > 0 Then
For lIterate = 1 To colEmailCC.count
sTemp = sTemp & colEmailCC.Item(lIterate) & ";"
Next lIterate
.CC = Left(sTemp, Len(sTemp) - 1)
sTemp = vbNullString
End If
'Add BCC Recipients
If colEmailBCC.count > 0 Then
For lIterate = 1 To colEmailBCC.count
sTemp = sTemp & colEmailBCC.Item(lIterate) & ";"
Next lIterate
.BCC = Left(sTemp, Len(sTemp) - 1)
sTemp = vbNullString
End If
'Add subject
.Subject = sSubject
'Add body
If Len(sSignatureTextPath) > 0 Then
'Body and plain text signature
.Body = sBody & vbNewLine & vbNewLine & SignatureText(sSignatureTextPath)
ElseIf Len(sSignatureHTMLPath) > 0 Then
'Convert body to HTML and append signature
.HTMLBody = ConvertTextToHTML(sBody) & "
" & sTemp
Else
'Body with no signature
.Body = sBody
End If
'Add any attachments
If colAttachment.count > 0 Then
For lIterate = 1 To colAttachment.count
.Attachments.Add colAttachment.Item(lIterate)
Next lIterate
End If
End With
End Sub
Private Function EmailIsValid(sEmailAddress As String) As Boolean
'Check if email address is valid
'NOTE: This is a very basic validation, only checking for the provision of
' an email domain and suffix. Much more complicated verification could
' be done if desired.
Dim aryAddress() As String
On Error GoTo Invalid
'Split email into recipient and domain
aryAddress() = Split(sEmailAddress, "@")
'Check if there is a . Must be at least 2nd character
If Not InStr(1, aryAddress(1), ".") > 2 Then GoTo Invalid
'Tests passed
EmailIsValid = True
Exit Function
Invalid:
'Function returns FALSE by default
End Function
Private Function SignatureText(ByVal sFile As String) As String
'Extracts contents of signature file
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
SignatureText = ts.readall
ts.Close
End Function
Private Function ConvertTextToHTML(ByVal sText As String) As String
'Convert plain text into HTML for email body
ConvertTextToHTML = Replace(sText, "&", "&")
ConvertTextToHTML = Replace(sText, "<", "<")
ConvertTextToHTML = Replace(sText, ">", ">")
ConvertTextToHTML = Replace(sText, vbNewLine, "
")
ConvertTextToHTML = Replace(sText, vbCrLf, "
")
End Function
