R
rjswan
I was wondering if there is a way I can include, in the subject field,
a reference number from the spreadsheet I am emailing. I am hoping to
acheive this in a similar way that the email address is sourced. Below
is a copy of the VB code I am currently using.
Dim WBname As String
' Dim Flds As Variant
Application.ScreenUpdating = False
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") =
"mail.xxxx.com.au"
..Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport")
= 25
..Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate")
= 1
..Item("http://schemas.microsoft.com/cdo/configuration/sendusername") =
"xxxx"
..Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") =
"xxxx"
.Update
End With
For Each ws In ThisWorkbook.Worksheets
If ws.Range("a1").Value Like "?*@?*.?*" Then
ws.Copy
Set wb = ActiveWorkbook
WBname = "c:/ NCF" & ws.Name & ".xls"
wb.SaveAs WBname
wb.Close False
Set wb = Nothing
Set iMsg = CreateObject("CDO.Message")
With iMsg
Set .Configuration = iConf
.To = ws.Range("a1").Value
.Bcc = "(e-mail address removed)"
.From = """xxx"" <[email protected]>"
.Subject = "Loan Revaluation Drawdown Advice: "
.AddAttachment WBname
.TextBody = "Please see attached"
.Send
End With
Set iMsg = Nothing
Kill WBname
End If
Next ws
Set iConf = Nothing
Application.ScreenUpdating = True
Sheets("Register").Select
Thanks
Russell
a reference number from the spreadsheet I am emailing. I am hoping to
acheive this in a similar way that the email address is sourced. Below
is a copy of the VB code I am currently using.
Dim WBname As String
' Dim Flds As Variant
Application.ScreenUpdating = False
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") =
"mail.xxxx.com.au"
..Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport")
= 25
..Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate")
= 1
..Item("http://schemas.microsoft.com/cdo/configuration/sendusername") =
"xxxx"
..Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") =
"xxxx"
.Update
End With
For Each ws In ThisWorkbook.Worksheets
If ws.Range("a1").Value Like "?*@?*.?*" Then
ws.Copy
Set wb = ActiveWorkbook
WBname = "c:/ NCF" & ws.Name & ".xls"
wb.SaveAs WBname
wb.Close False
Set wb = Nothing
Set iMsg = CreateObject("CDO.Message")
With iMsg
Set .Configuration = iConf
.To = ws.Range("a1").Value
.Bcc = "(e-mail address removed)"
.From = """xxx"" <[email protected]>"
.Subject = "Loan Revaluation Drawdown Advice: "
.AddAttachment WBname
.TextBody = "Please see attached"
.Send
End With
Set iMsg = Nothing
Kill WBname
End If
Next ws
Set iConf = Nothing
Application.ScreenUpdating = True
Sheets("Register").Select
Thanks
Russell