I have the following code, my goal is to send automatic emails to a list of people in an excel document, using a text file as a template:
Set objMessage = CreateObject("CDO.Message")
Set app = CreateObject("Excel.Application")
Set fso = CreateObject("Scripting.FileSystemObject")
For Each f In fso.GetFolder("F:\Billing_Common\autoemail").Files
If LCase(fso.GetExtensionName(f)) = "xls" Then
Set wb = app.Workbooks.Open(f.Path)
set sh = wb.Sheets("Auto Email Script")
row = 2
email = sh.Range("A" & row)
subject = "Billing"
LastRow = sh.UsedRange.Rows.Count
For r = row to LastRow
If App.WorkSheetFunction.CountA(sh.Rows(r)) <> 0 Then
objMessage.Subject = "Billing: Meter Read"
objMessage.From = "billing#energia.ie"
objMessage.To = email
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim emailText
Set emailText = fso.OpenTextFile("F:\Billing_Common\autoemail\Script\Email.txt", ForReading)
BodyText = emailText.ReadAll
objMessage.TextBody = emailText
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusing") = CdoSendUsingPort
'Name or IP of Remote SMTP Server
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "ADDRESS OF SERVER HERE"
'Server port
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objMessage.Configuration.Fields.Update
objMessage.Send
End if
Next
emailText.Close
Set emailText = Nothing
Set fso = Nothing
wb.Close
End If
Next
It throws an error at the objMessage.TextBody, saying type mismatch. If anyone could help me it would be much appreciated!
Thanks!
For sending inline images you need to create an HTMLBody instead of a TextBody and add a RelatedBodyPart with the image (see here):
Set msg = CreateObject("CDO.Message")
...
msg.HTMLBody = "<html>" & vbLf & _
"<head><title>Test</title></head>" & vbLf & _
"<body><p><img src='foo.jpg'></p></body>" & vbLf & _
"</html>"
msg.AddRelatedBodyPart "C:\path\to\your.jpg", "foo.jpg", 0
After the line BodyText = emailText.ReadAll, you ought to assign that, and not the file ("emailText" is the TextFile that was Opened by fso on the previous line), that's why it's complaining about a Type Mismatch...
So just replace objMessage.TextBody = emailText with objMessage.TextBody = BodyText and it should work...
Related
I use the following code assigned to a CommandButton to automatically attach the workbook to an email so users can send it out. Is there a way to attach the workbook without the code, so the people receiving the email do not have the full code, but the sender keeps it in their copy? (The recipients only need to see the data, they do not interact with the form, but the sender interacts with it several times a day.) When I save the Workbook as .xlsx, it gives me an yes/no/help MsgBox that I would like to avoid during the sending - to keep it as a "one-click" operation.
Source_File = ThisWorkbook.FullName
myMail.Attachments.Add Source_File
Option Explicit
Sub CDO_Mail_Workbook()
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim iMsg As Object
Dim iConf As Object
Dim Flds As Variant
Dim MyDate
MyDate = Format(Now(), "dd-mmm-yy")
Set wb = ActiveWorkbook
If Val(Application.Version) >= 12 Then
If wb.FileFormat = 51 And wb.HasVBProject = True Then
MsgBox "There is VBA code in this xlsx file, there will be no VBA code in the file you send." & vbNewLine & _
"Save the file first as xlsm and then try the macro again.", vbInformation
Exit Sub
End If
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Make a copy of the file/Mail it/Delete it
'If you want to change the file name then change only TempFileName
TempFilePath = Environ$("temp") & "\"
'TempFileName = wb.Name & " " & Format(Now, "yyyy-mmm-dd")
TempFileName = "Test" & "-" & Format(Now, "yyyy-mmm-dd")
'FileExtStr = "." & LCase(Right(wb.Name, Len(wb.Name) - InStrRev(wb.Name, ".", , 1)))
FileExtStr = ".xlsm"
Application.DisplayAlerts = False
' wb.SaveAs Filename:=TempFilePath & TempFileName & FileExtStr, FileFormat:=51, AccessMode:=xlExclusive, ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
ActiveWorkbook.SaveCopyAs Filename:=TempFilePath & TempFileName & "Copy" & FileExtStr
Workbooks.Open (TempFilePath & TempFileName & "Copy" & FileExtStr)
ActiveWorkbook.SaveAs Filename:=TempFilePath & TempFileName & "-email" & ".xlsx", FileFormat:=51, AccessMode:=xlExclusive, ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
ActiveWorkbook.Close False
'wb.SaveCopyAs TempFilePath & TempFileName & FileExtStr
Application.DisplayAlerts = True
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.office365.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "noone#noone.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = "1"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Update
End With
With iMsg
Set .Configuration = iConf
'.To = "noone#noone.com"
'.CC = ""
.BCC = ""
.From = "noone#noone.com"
.Subject = "Test - " & MyDate
.TextBody = ""
.AddAttachment TempFilePath & TempFileName & "-email" & ".xlsx"
.Send
End With
'If you not want to delete the file you send delete this line
Kill TempFilePath & TempFileName & "-email" & ".xlsx"
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Application.DisplayAlerts = False
Set wb = Nothing
For Each wb In Application.Workbooks
wb.Save
Next wb
Application.Quit
End Sub
To send a single worksheet with the vba code removed, I've used this:
Option Explicit
'This procedure will send the ActiveSheet in a new workbook
'For more sheets use : Sourcewb.Sheets(Array("Sheet1", "Sheet3")).Copy
Sub CDO_Mail_ActiveSheet_Or_Sheets()
'Working in 97-2007
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim iMsg As Object
Dim iConf As Object
Dim sh As Worksheet
Dim Flds As Variant
Dim MyDate
MyDate = Format(Now(), "dd-mmm-yy")
Dim wb As Workbook
Set wb = ActiveWorkbook
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
'Copy the ActiveSheet to a new workbook
ActiveSheet.Copy
'Or if you want to copy more then one sheet use:
'Sourcewb.Sheets(Array("Sheet1", "Sheet3")).Copy
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
'We exit the sub when your answer is NO in the security dialog that you only
'see when you copy a sheet from a xlsm file with macro's disabled.
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is NO in the security dialog"
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With
'Change all cells in Destwb to values if you want
For Each sh In Destwb.Worksheets
sh.Select
With sh.UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
Next sh
Destwb.Worksheets(1).Select
'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Test" & "-" & Format(Now, "yyyy-mmm-dd")
Application.DisplayAlerts = False
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
.Close savechanges:=False
End With
Application.DisplayAlerts = True
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.office365.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "noone#noone.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = "1"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Update
End With
With iMsg
Set .Configuration = iConf
.To = "noone#noone.com"
'.CC = ""
'.BCC = ""
.From = "noone#noone.com"
.Subject = "Test-" & MyDate
.TextBody = ""
.AddAttachment TempFilePath & TempFileName & FileExtStr
.Send
End With
'If you not want to delete the file you send delete this line
Kill TempFilePath & TempFileName & FileExtStr
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Application.DisplayAlerts = False
Set wb = Nothing
For Each wb In Application.Workbooks
wb.Save
Next wb
Application.Quit
End Sub
How can I get the script to load email addresses one at a time from a text file instead of entering an email in manually?
I keep getting an error that says
line 6
object required:”
code 800A01A8
What am I doing wrong?
Dim fso
Set objEmail = CreateObject("CDO.Message")
objEmail.From = "admin1#fabrikam.com"
Set dict = CreateObject("Scripting.Dictionary")
Set file = fso.OpenTextFile ("C:\e.txt", 1)
row = 0
Do Until file.AtEndOfStream
line = file.Readline
dict.Add row, line
row = row + 1
objEmail.To = file
objEmail.Subject = "Test Email 2"
objEmail.Textbody = "This Is A Test Message"
objEmail.AddAttachment "C:\test.txt"
objEmail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
objEmail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "127.0.0.1"
objEmail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objEmail.Configuration.Fields.Update
objEmail.Send
Loop
In your line 6:
Set file = fso.OpenTextFile ("C:\e.txt", 1)
fso is empty/undefined. You need a
Set fso = CreateObject("Scripting.FileSystemObject")
before.
Your
objEmail.To = file
probably should be
objEmail.To = line
I am writing an application that sends emails to an admin when there is a problem with the data. The account it's sending through is a Network Solutions SMTP server.
The code works most of the time, but about 1 out of 10 sends fail with the error -2147220973 "The transport failed to connect to the server".
Any suggestions on how to handle this?
Set imsg = CreateObject("cdo.message")
Set iconf = CreateObject("cdo.configuration")
Set Flds = iconf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.OurCompany.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoBasic
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 2525
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "me#OurCompany.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"
.Update
End With
With imsg
Set .Configuration = iconf
.To = "me#MyEmail.com" 'CMemail
.From = "resupport#OurCompanycom"
.Subject = ACT
.HTMLBody = "Notification for " & CTName & " of " & CTCname & " " & ACT & ". You must manually Notify them about new docs for " & pname & ". " _
& "<br>Tell " & CTName & " to '" & Nz(DLookup("Notify", "TBLINVOICESETTINGS"), "") & " " & PRName & "_" & pname & ".pdf'"
.Send
End With
Set imsg = Nothing
Set iconf = Nothing
Should the smtpserverport be 25, is it being blocked by firewall?
This piece of code executes correctly :
Sub SMail(pTO As String, pSB As String, pBO As String, pAT As String)
On Error GoTo ErrH: Dim mm As CDO.Message: Set mm = New CDO.Message
mm.Configuration.Fields(cdoSMTPUseSSL) = "True"
mm.Configuration.Fields(cdoSendUsingMethod) = 2
mm.Configuration.Fields(cdoSMTPAuthenticate) = 1
mm.Configuration.Fields(cdoSMTPServer) = "smtp.gmail.com"
mm.Configuration.Fields(cdoSendUserName) = "MyID"
mm.Configuration.Fields(cdoSendPassword) = "MyPW"
'mm.Configuration.Fields(cdoSMTPConnectionTimeout) = 20
'mm.Configuration.Fields(cdoSMTPServerPort) = 25
mm.Configuration.Fields.Update
mm.From = "MyID"
mm.To = pTO
mm.Subject = pSB
mm.TextBody = pBO
mm.AddAttachment (pAT)
mm.send
ErrH: If Err Then MsgBox (Err.Number & " : " & Err.Description)
Set mm = Nothing
End Sub
The code below was posted by HK1 in response to an answer on sending email without Outlook in VBA, dated 20 Jul 12.
The code works well, but I need to add a signature block at the end of the text (basically a jpg file in a local folder), but the best I have been able to come up with is to add the path (text) instead of the image itself to the email body.
Const cdoSendUsingPickup = 1
Const cdoSendUsingPort = 2
Const cdoAnonymous = 0
' Use basic (clear-text) authentication.
Const cdoBasic = 1
' Use NTLM authentication
Const cdoNTLM = 2 'NTLM
Public Sub SendEmail()
Dim imsg As Object
Dim iconf As Object
Dim flds As Object
Dim schema As String
Set imsg = CreateObject("CDO.Message")
Set iconf = CreateObject("CDO.Configuration")
Set flds = iconf.Fields
' send one copy with SMTP server (with autentication)
schema = "http://schemas.microsoft.com/cdo/configuration/"
flds.Item(schema & "sendusing") = cdoSendUsingPort
flds.Item(schema & "smtpserver") = "mail.myserver.com"
flds.Item(schema & "smtpserverport") = 25
flds.Item(schema & "smtpauthenticate") = cdoBasic
flds.Item(schema & "sendusername") = "email#email.com"
flds.Item(schema & "sendpassword") = "password"
flds.Item(schema & "smtpusessl") = False
flds.Update
With imsg
.To = "email#email.com"
.From = "email#email.com"
.Subject = "Test Send"
.HTMLBody = "Test"
'.Sender = "Sender"
'.Organization = "My Company"
'.ReplyTo = "address#mycompany.com"
Set .Configuration = iconf
.Send
End With
Set iconf = Nothing
Set imsg = Nothing
Set flds = Nothing
End Sub
I tried amending the code as follows, but this simply adds the file path to the body text:
With imsg
.To = vRecipients
.From = senderEmail
.CC = vCC
.Subject = vSubject
vBody = Replace(vBody, vbCrLf, "<br>")
vBody = "<FONT face=arial size=2>" & vBody
vBody = vBody & "<br>" & signFile
.HTMLBody = vBody
.Sender = senderName
.ReplyTo = senderEmail
.AddAttachment vAttachments
Set .Configuration = iconf
.Send
End With
Any suggestions?
dwo is correct. You need to use a File System Object or a File Object to read in the text contents of your signFile. Otherwise your code looks like it should work.
Here's a function you can use to read the contents of a file. The function simply assumes that you'll pass in the entire path and file name for a text file that your application has at least read rights to.
Public Function GetTextFileContents(sFilePath as String) As String
If Dir(sFilePath) <> "" Then
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFilePath).OpenAsTextStream(1, -2)
GetTextFileContents = ts.ReadAll
ts.Close
Set ts = Nothing
Set fso = Nothing
End If
End Function
I have a script to auto email a list of address' stored in Excel, but it is only sending to the first address and not looping to the rest, I cannot seem to fix it:
Set objMessage = CreateObject("CDO.Message")
Set app = CreateObject("Excel.Application")
Set fso = CreateObject("Scripting.FileSystemObject")
For Each f In fso.GetFolder("Y:\Billing_Common\autoemail").Files
If LCase(fso.GetExtensionName(f)) = "xls" Then
Set wb = app.Workbooks.Open(f.Path)
set sh = wb.Sheets("Auto Email Script")
row = 2
email = sh.Range("A" & row)
LastRow = sh.UsedRange.Rows.Count
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim f
Set f = fso.OpenTextFile("Y:\Billing_Common\autoemail\Script\Email.txt", ForReading)
BodyText = f.ReadAll
For r = row to LastRow
If App.WorkSheetFunction.CountA(sh.Rows(r)) <> 0 Then
objMessage.Subject = "Billing: Meter Read"
objMessage.From = "billing#energia.ie"
row = row + 1
objMessage.To = email
objMessage.TextBody = BodyText
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
'Name or IP of Remote SMTP Server
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "SERVER ADDRESS HERE"
'Server port
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objMessage.Configuration.Fields.Update
objMessage.Send
End if
Next
f.Close
Set f = Nothing
Set fso = Nothing
wb.Close
End If
Next
Any help would be much appreciated guys!
Thanks!
row = 2
email = sh.Range("A" & row)
...
For r = row to LastRow
...
objMessage.To = email
...
Next
You set email to the value of the cell "A2" and never change it. If you want to send a mail to multiple recipients, you should make that
objMessage.To = sh.Range("A" & r).Value
or (better) build a recipient list (assuming that your used range starts with headers in the first table row):
ReDim recipients(LastRow - row)
For r = row To LastRow
recipients(r - row) = sh.Range("A" & r).Value
Next
objMessage.To = Join(recipients, ";")
and send the message just once. The MTA will handle the rest.
Side note: as Vishnu Prasad Kallummel pointed out in the comments your code doesn't close the Excel instance it started. Unlike other objects created in VBScript, Office applications won't automatically terminate with the script, so you have to handle it yourself:
...
wb.Close
app.Quit