I'm in the midst of setting up a program to email out to miscellaneous recipients and am looking how to attach a signature through G-Mail. I am either open to attaching a signature previously created within the gmail account, or to create one using VB. Currently the gmail account has a signature made, but doesn't attach with my current code.
Does anybody have any experience with this? Below is my current code, the emails currently send out fine.
Current code:
Code:
Function dealeremail(whichemail As String)Dim rsemail As Recordset, rsclaim As Recordset, subj As String, numparts As Integer, parts As String, partfield As String, qfield As String
Dim fsfile As File, fso As FileSystemObject, srcfolder As Folder, filenm As String, ibp As CDO.IBodyPart
Set cdomsg = CreateObject("CDO.message")
With cdomsg.Configuration.Fields
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smptserverport") = 587
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "xxx@gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "xxx"
.Update
End With
With cdomsg
'.To = "xxx@xxx.com"
.To = rsemail.Fields("Email")
.BCC = "xxx@xxx.com, xxx@xxx.com"
.From = "xxx@gmail.com"
.Subject = subj
.TextBody = msg
Set fso = New FileSystemObject
Set srcfolder = fso.GetFolder("S:\Shared\Warranty Returns\WRA Data Storage\Backups\Dealers\" & rsclaim.Fields("Dealer Number") & "\" & rsclaim.Fields("Serial Number") & " " & rsclaim.Fields("Claim Number") & "\Initial\")
If srcfolder.Files.Count > 0 Then
For Each fsfile In srcfolder.Files
If InStr(1, fsfile.Name, "Thumbs") = 0 Then Set ibp = .addattachment(fsfile.Path)
Next
Else
GoTo attacherror
End If
Set fso = Nothing
Set srcfolder = Nothing
.Send
End With
skip:
Set rsemail = Nothing
Set rsclaim = Nothing
Set cdomsg = Nothing
End If
Exit Function
parterror:
MsgBox "No parts", vbOKOnly
Set rsemail = Nothing
Set rsclaim = Nothing
Set cdomsg = Nothing
Exit Function
attacherror:
MsgBox "Attachment error.", vbOKOnly
Set rsemail = Nothing
Set rsclaim = Nothing
Set cdomsg = Nothing
End Function