This script run correctly for send email SQL query result, but I need script to stop send email if the SQL query result is empty.
'Declare Constants
Const CDO_SCHEMA = "http://schemas.microsoft.com/cdo/configuration/"
Const CDO_MAIL_HEADER = "urn:schemas:mailheader:"
'Method used to send mail
Const CDO_SEND_USING_REMOTE = 2 'Send using Remote SMTP Server
'Security method used on remote SMTP server
Const CDO_ANONYMOUS = 0 'Use no authentication
Const CDO_BASIC = 1 'Use the basic (clear text) authentication
Const CDO_NTLM = 2 'Use the NTLM authentication
'Delivery Status Notifications
Const cdoDSNDefault = 0 'No DSN commands are issued
Const cdoDSNNever = 1 'No DSN commands are issued
Const cdoDSNFailure = 2 'Return a DSN if delivery fails
Const cdoDSNSuccess = 4 'Return a DSN if delivery succeeds
Const cdoDSNDelay = 8 'Return a DSN if delivery is delayed
Const cdoDSNSuccessFailOrDelay = 14 'Return a DSN if delivery succeeds, fails, or is delayed
'Set method of sending
strSendMethod = CDO_SEND_USING_REMOTE
'Remote SMTP Server Settings
strSmtpServer = "smtp.abc.com" 'Name or IP of SMTP Server
intSmtpPort = 25 'SMTP Server Port; typically 25
intSmtpTimeout = 60 'Number of seconds to try establishing a connection to the SMTP Server
strAuthenticationMethod = CDO_ANONYMOUS
'SMTP Server Authentication - IF BASIC or NTLM; NOT needed for ANONYMOUS
strUserName = ""
strPassword = ""
strUserSSL = False 'True if SMTP Server uses SSL; False if Not
'Message Settings
strTo = "asdf#abc.com"
'Separate multiple addresses with a semi-colon (;)
strCC = ""
strBCC = ""
strFrom = "no-reply-SalesInfo#abc.com"
strSubject = "Pending Sales Order - Perlu di follow up"
strBodyType = "TEXT"
strAttachment = "D:\File.txt" 'Attachment Path i.e. C:\Temp\File.txt
strDSNotification = cdoDSNDefault 'Delivery Status Option Change as needed
'WScript.Echo "Connecting to database..."
'Connect to database & select all from Table
Set objDB = DBConnect()
Set oRS = objDB.Execute("SELECT S_ORDER 'SO# ',CUSTOMER_NAME'CUSTOMER ',DATE 'Tanggal ',USERID 'INTERNAL ',CALLING 'Approval from ',LIMIT 'LIMIT ',TERM 'TERM ' from abc")
'Dump Records from Table
strOutput = "Please Check This Report :" & vbCrLf
nRec = 1
Do While Not oRS.EOF
strOutput = strOutput & "----- " & nRec & " -----" & vbCrLf
nRec = nRec + 1
For Each oFld In oRS.Fields
strOutput = strOutput & oFld.Name & " = " & oFld.Value & vbCrLf
Next
oRS.MoveNext
Loop
SendEmail strOutput
'WScript.Echo "Script Finished"
'This function sets up DB Connection using specified DSN
Function DBConnect
Set objDB = CreateObject("ADODB.Connection")
objDB.Open "DSN=SQL;uid=sa;pwd=12345"
'Set Conn = Server.CreateObject("ADODB.Connection")
'Conn.open "SQL","sa","12345"
Set DBConnect = objDB
End Function
Sub SendEmail(strBody)
'Create Objects
Set objConfig = CreateObject("CDO.Configuration")
Set objEmail = CreateObject("CDO.Message")
'Prepare email configuration
With objConfig.Fields
.Item(CDO_SCHEMA & "sendusing") = strSendMethod
.Item(CDO_SCHEMA & "smtpserver") = strSmtpServer
.Item(CDO_SCHEMA & "smtpserverport") = intSmtpPort
.Item(CDO_SCHEMA & "smtpconnectiontimeout") = intSmtpTimeout
.Item(CDO_SCHEMA & "smtpauthenticate") = strAuthenticationMethod
If.Item(CDO_SCHEMA & "smtpauthenticate") <> 0 Then
.Item(CDO_SCHEMA & "sendusername") = strUsername
.Item(CDO_SCHEMA & "sendpassword") = strPassword
.Item(CDO_SCHEMA & "smtpusessl") = strUserSSL
End If
.Update
End With
'Create email and send
With objEmail
Set.Configuration = objConfig
.To = strTo
If strCC <> "" Then
.CC = strCC
End If
If strBCC <> "" Then
.BCC = strBCC
End If
.From = strFrom
.Subject = strSubject
If strBodyType = "HTML" Then
.HTMLBody = strBody
ElseIf strBodyType = "TEXT" Then
.TextBody = strBody
End If
If strAttachment <> "" Then
.AddAttachment strAttachment
End If
If strDSNotification <> 0 And strDSNotification <> 1 Then
.Fields(CDO_MAIL_HEADER & "disposition-notification-to") = strFrom
.Fields(CDO_MAIL_HEADER & "return-receipt-to") = strFrom
.DSNOptions = strDSNotification
.Fields.update
End If
.Send
End With
End Sub
Simply make sending email depend on whether your query returned records or not.
Change this line:
SendEmail strOutput
into this:
If nRec > 1 Then SendEmail strOutput
by putting the following condition
if oRS.RecordCount>0 or oRS is Not Nothing then
you will be able to control the email sending.
try the following:
Const CDO_SCHEMA = "http://schemas.microsoft.com/cdo/configuration/"
Const CDO_MAIL_HEADER = "urn:schemas:mailheader:"
'Method used to send mail
Const CDO_SEND_USING_REMOTE = 2 'Send using Remote SMTP Server
'Security method used on remote SMTP server
Const CDO_ANONYMOUS = 0 'Use no authentication
Const CDO_BASIC = 1 'Use the basic (clear text) authentication
Const CDO_NTLM = 2 'Use the NTLM authentication
'Delivery Status Notifications
Const cdoDSNDefault = 0 'No DSN commands are issued
Const cdoDSNNever = 1 'No DSN commands are issued
Const cdoDSNFailure = 2 'Return a DSN if delivery fails
Const cdoDSNSuccess = 4 'Return a DSN if delivery succeeds
Const cdoDSNDelay = 8 'Return a DSN if delivery is delayed
Const cdoDSNSuccessFailOrDelay = 14 'Return a DSN if delivery succeeds, fails, or is delayed
'Set method of sending
strSendMethod = CDO_SEND_USING_REMOTE
'Remote SMTP Server Settings
strSmtpServer = "smtp.abc.com" 'Name or IP of SMTP Server
intSmtpPort = 25 'SMTP Server Port; typically 25
intSmtpTimeout = 60 'Number of seconds to try establishing a connection to the SMTP Server
strAuthenticationMethod = CDO_ANONYMOUS
'SMTP Server Authentication - IF BASIC or NTLM; NOT needed for ANONYMOUS
strUserName = ""
strPassword = ""
strUserSSL = False 'True if SMTP Server uses SSL; False if Not
'Message Settings
strTo = "asdf#abc.com"
'Separate multiple addresses with a semi-colon (;)
strCC = ""
strBCC = ""
strFrom = "no-reply-SalesInfo#abc.com"
strSubject = "Pending Sales Order - Perlu di follow up"
strBodyType = "TEXT"
strAttachment = "D:\File.txt" 'Attachment Path i.e. C:\Temp\File.txt
strDSNotification = cdoDSNDefault 'Delivery Status Option Change as needed
'WScript.Echo "Connecting to database..."
'Connect to database & select all from Table
Set objDB = DBConnect()
Set oRS = objDB.Execute("SELECT S_ORDER 'SO# ',CUSTOMER_NAME'CUSTOMER ',DATE 'Tanggal ',USERID 'INTERNAL ',CALLING 'Approval from ',LIMIT 'LIMIT ',TERM 'TERM ' from abc")
if oRS.RecordCount>0 or oRS is Not Nothing then
'Dump Records from Table
strOutput = "Please Check This Report :" & vbCrLf
nRec = 1
Do While Not oRS.EOF
strOutput = strOutput & "----- " & nRec & " -----" & vbCrLf
nRec = nRec + 1
For Each oFld In oRS.Fields
strOutput = strOutput & oFld.Name & " = " & oFld.Value & vbCrLf
Next
oRS.MoveNext
Loop
SendEmail strOutput
end if
'WScript.Echo "Script Finished"
'This function sets up DB Connection using specified DSN
Function DBConnect
Set objDB = CreateObject("ADODB.Connection")
objDB.Open "DSN=SQL;uid=sa;pwd=12345"
'Set Conn = Server.CreateObject("ADODB.Connection")
'Conn.open "SQL","sa","12345"
Set DBConnect = objDB
End Function
Sub SendEmail(strBody)
'Create Objects
Set objConfig = CreateObject("CDO.Configuration")
Set objEmail = CreateObject("CDO.Message")
'Prepare email configuration
With objConfig.Fields
.Item(CDO_SCHEMA & "sendusing") = strSendMethod
.Item(CDO_SCHEMA & "smtpserver") = strSmtpServer
.Item(CDO_SCHEMA & "smtpserverport") = intSmtpPort
.Item(CDO_SCHEMA & "smtpconnectiontimeout") = intSmtpTimeout
.Item(CDO_SCHEMA & "smtpauthenticate") = strAuthenticationMethod
If.Item(CDO_SCHEMA & "smtpauthenticate") <> 0 Then
.Item(CDO_SCHEMA & "sendusername") = strUsername
.Item(CDO_SCHEMA & "sendpassword") = strPassword
.Item(CDO_SCHEMA & "smtpusessl") = strUserSSL
End If
.Update
End With
'Create email and send
With objEmail
Set.Configuration = objConfig
.To = strTo
If strCC <> "" Then
.CC = strCC
End If
If strBCC <> "" Then
.BCC = strBCC
End If
.From = strFrom
.Subject = strSubject
If strBodyType = "HTML" Then
.HTMLBody = strBody
ElseIf strBodyType = "TEXT" Then
.TextBody = strBody
End If
If strAttachment <> "" Then
.AddAttachment strAttachment
End If
If strDSNotification <> 0 And strDSNotification <> 1 Then
.Fields(CDO_MAIL_HEADER & "disposition-notification-to") = strFrom
.Fields(CDO_MAIL_HEADER & "return-receipt-to") = strFrom
.DSNOptions = strDSNotification
.Fields.update
End If
.Send
End With
End Sub
Related
I'm working to send Emails to each student containing ( student name and his marks ) from excel sheet as shown below
Everything working fine, But when the student name is in Arabic char. the name shows as ( ???? ) as you can see below
I changed the setting for local system to Arabic, but still, get the same problem.
Any advice?
You need to set htmlBody and use utf-8 character set.
Use the following function to make a simple transformation of a text string into html string.
Function StringToHTML(sStr As String) As String
sStr = Replace(sStr, Chr(10), "<br/>")
sStr = Replace(sStr, Chr(13), "<br/>")
sStr = Replace(sStr, Chr(11), "<br/>")
StringToHTML = "<!doctype html><html lang=""en""><body><p>"
StringToHTML = StringToHTML & sStr
StringToHTML = StringToHTML & "</p></body></html>"
End Function
With reference to this, you need to replace the line objEmail.TextBody = mailBody with the following two lines
objEmail.htmlBody = StringToHTML(mailBody)
objEmail.HtmlBodyPart.Charset = "utf-8"
If you face further problems (e.g. the email subject contains arabic chars but doesn't display properly) try adding these two lines
objEmail.TextBodyPart.Charset = "utf-8"
objEmail.BodyPart.Charset = "utf-8"
Edit (following comment)
Your full code should be like this
Sub SendMail()
Dim objEmail
Dim mailBody as String
Const cdoSendUsingPort = 2 ' Send the message using SMTP
Const cdoBasicAuth = 1 ' Clear-text authentication
Const cdoTimeout = 100 ' Timeout for SMTP in seconds
mailServer = "smtp.gmail.com"
SMTPport = 465 '25 'SMTPport = 465
mailusername = "email#some.com"
mailpassword = "password"
''''''''
Dim n As Integer
n = Application.WorksheetFunction.CountA(Range("c:c"))
For i = 2 To n
mailto = Range("c" & i).Value
mailSubject = Range("e" & i).Value
mailBody = "Hi " & Range("b" & i) & "," & vbCrLf & vbCrLf & _
"Below you can find your marks:" & vbCrLf & vbCrLf & _
"Math: - " & Range("F" & i) & vbCrLf & _
"Network: - " & Range("G" & i) & vbCrLf & _
"Physics: - " & Range("H" & i) & vbCrLf & _
"Antenna: - " & Range("I" & i)
Set objEmail = CreateObject("CDO.Message")
Set objConf = objEmail.Configuration
Set objFlds = objConf.Fields
With objFlds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = cdoSendUsingPort
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = mailServer
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = SMTPport
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = cdoTimeout
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoBasicAuth
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = mailusername
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = mailpassword
.Update
End With
objEmail.To = mailto
objEmail.From = mailusername
objEmail.Subject = mailSubject
objEmail.htmlBody = StringToHTML(mailBody)
objEmail.HtmlBodyPart.Charset = "utf-8"
objEmail.Send
Set objFlds = Nothing
Set objConf = Nothing
Set objEmail = Nothing
Next i
End Sub
Function StringToHTML(sStr As String) As String
sStr = Replace(sStr, Chr(10), "<br/>")
sStr = Replace(sStr, Chr(13), "<br/>")
sStr = Replace(sStr, Chr(11), "<br/>")
StringToHTML = "<!doctype html><html lang=""en""><body><p>"
StringToHTML = StringToHTML & sStr
StringToHTML = StringToHTML & "</p></body></html>"
End Function
Does anybody know how to send a link to a word document via email in word vba? I want to use gmail not outlook. I found a solution for outlook:
http://www.rondebruin.nl/win/s1/outlook/bmail10.htm
Is there anyway that can be modified to work using gmail?
I modified: http://www.rondebruin.nl/win/s1/cdo.htm to work with gmail, and it is working fine. I just need to add a link to the body of the email.
You'll need to use the htmlBody property instead of TextBody and use an <a> tag in the HTML.
I didn't know how to send my code...So I posted it as an answer. Hope that's ok. Also I get a strange run time error that I wasn't getting before. Other than that it works.
Thanks!
Danielle
Option Explicit ' Modified for dSavage
'If you have a GMail account then you can try this example to use the GMail smtp server
'The example will send a small text message
'You must change four code lines before you can test the code
'.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "Full GMail mail address"
'.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "GMail password"
'Use your own mail address to test the code in this line
'.To = "Mail address receiver"
'Change YourName to the From name you want to use
'.From = """YourName"" "
'If you get this error : The transport failed to connect to the server
'then try changing the SMTP port from 25 to 465
Sub CDO_Mail_Example()
Dim iMsg As Object
Dim iConf As Object
Dim strbody As String
Dim sAddForm As String
Dim sForm As String
Dim Flds As Variant
Dim iSMTP_Port As Integer
Dim sFirstReviewer As String
Dim sUserName As String
Dim sGmailPassword As String
sFirstReviewer = Range("F4").Value
sUserName = Range("F6").Value & "#indicate1.com"
sGmailPassword = Range("F8").Value
iSMTP_Port = Range("F10").Value '25 at Indicate; 465 away.
sAddForm = Range("I12").Value
'sForm = Range("F4").Value
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
If sAddForm = "Yes" Then
sForm = "Z:\Quality# # Document_Development# Documents_for_Review\12002-01-01 Company Handbook.doc"
Else
sForm = ""
End If
Debug.Print "sForm = " & sForm ' *******************************************
Debug.Print "sUserName = " & sUserName ' *******************************************
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = sUserName
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "Micro5cope"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = iSMTP_Port '25 at Indicate; 465 away.
.Update
End With
strbody = "To " & sFirstReviewer & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2" & vbNewLine & vbNewLine & _
"This is line 3" & vbNewLine & _
"This is line 4" & vbNewLine & vbNewLine & vbNewLine & _
"Z:\Quality\# # Document_Development\# Documents_for_Review\12000-00-00 Tables 9-11 Template OLD - TEST.doc" & vbNewLine & _
sForm & vbNewLine
With iMsg
Set .Configuration = iConf
.To = sFirstReviewer & "#indicate1.com"
.CC = "" 'sUserName & "; " & "johanson111#comcast.net"
.BCC = ""
.From = sUserName
.Subject = "Test Message"
.textbody = strbody
.HtmlBody = "Google Page"
.AddAttachment "Z:\Quality\# # Document_Development\12001-02-01 Document Review Form.pdf"
.AddAttachment "Z:\Quality\# # Document_Development\12001-02 Document Review Draft 9.doc"
.Send
End With
Debug.Print "CC = " & sUserName ' *******************************************
End Sub
I've set up a button in my Excel Sheet that should be able so save a picture of the sheet to my hard drive and then send an Email to a specific address with the picture attached to it, the saving of the picture works fine, but when I try and send the Email using a piece of code I found at http://www.exceltoolset.com/sending-email-with-vba/ it returns the error: -2147220975
Here is the whole sub:
Sub SendKnap_Klik()
Set Sheet = ActiveSheet
Ret = IIf(Environ$("tmp") <> "", Environ$("tmp"), Environ$("temp"))
Output = Ret & "\SkemaSend.png"
zoom_coef = 100 / Sheet.Parent.Windows(1).Zoom
Set area = Sheet.Range(Sheet.PageSetup.PrintArea)
area.CopyPicture xlPrinter
Set chartobj = Sheet.ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
chartobj.Chart.Paste
chartobj.Chart.Export Output, "png"
chartobj.Delete
ReturnValue = SendEMail("Subject", "MyMail#gmail.com", Range("J25").Value, "Body", "smtp.gmail.com", "", Output)
If ReturnValue = True Then
MsgBox "Emailen sent to " & Range("J25") & " was successfull!"
Else
MsgBox "Emailen sent to " & Range("J25") & " was not sent" & vbNewLine & "Error: " & Err.Number
End If
End Sub
Function SendEMail(Subject As String, _
FromAddress As String, _
ToAddress As String, _
MailBody As String, _
SMTP_Server As String, _
BodyFileName As String, _
Optional Attachments As Variant = Empty) As Boolean
Dim MailMessage As CDO.Message
Dim N As Long
Dim FNum As Integer
Dim S As String
Dim Body As String
Dim Recips() As String
Dim Recip As String
Dim NRecip As Long
' ensure required parameters are present and valid.
If Len(Trim(Subject)) = 0 Then
SendEMail = False
Exit Function
End If
If Len(Trim(FromAddress)) = 0 Then
SendEMail = False
Exit Function
End If
If Len(Trim(SMTP_Server)) = 0 Then
SendEMail = False
Exit Function
End If
' Clean up the addresses
Recip = Replace(ToAddress, Space(1), vbNullString)
If Right(Recip, 1) = ";" Then
Recip = Left(Recip, Len(Recip) - 1)
End If
Recips = Split(Recip, ";")
For NRecip = LBound(Recips) To UBound(Recips)
On Error Resume Next
' Create a CDO Message object.
Set MailMessage = CreateObject("CDO.Message")
If Err.Number <> 0 Then
SendEMail = False
Exit Function
End If
Err.Clear
On Error GoTo 0
With MailMessage
.Subject = Subject
.From = FromAddress
.To = Recips(NRecip)
If MailBody <> vbNullString Then
.TextBody = MailBody
Else
If BodyFileName <> vbNullString Then
If Dir(BodyFileName, vbNormal) <> vbNullString Then
' import the text of the body from file BodyFileName
FNum = FreeFile
S = vbNullString
Body = vbNullString
Open BodyFileName For Input Access Read As #FNum
Do Until EOF(FNum)
Line Input #FNum, S
Body = Body & vbNewLine & S
Loop
Close #FNum
.TextBody = Body
Else
' BodyFileName not found.
SendEMail = False
Exit Function
End If
End If ' MailBody and BodyFileName are both vbNullString.
End If
If IsArray(Attachments) = True Then
' attach all the files in the array.
For N = LBound(Attachments) To UBound(Attachments)
' ensure the attachment file exists and attach it.
If Attachments(N) <> vbNullString Then
If Dir(Attachments(N), vbNormal) <> vbNullString Then
.AddAttachment Attachments(N)
End If
End If
Next N
Else
' ensure the file exists and if so, attach it to the message.
If Attachments <> vbNullString Then
If Dir(CStr(Attachments), vbNormal) <> vbNullString Then
.AddAttachment Attachments
End If
End If
End If
With .Configuration.Fields
' set up the SMTP configuration
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = SMTP_Server
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "mymail#gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "pass"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Update
End With
On Error Resume Next
Err.Clear
' Send the message
.Send
If Err.Number = 0 Then
SendEMail = True
Else
SendEMail = False
Exit Function
End If
End With
Next NRecip
SendEMail = True
End Function
I also changed settings on my Gmail account to allow unsecured programs to access the account
What am I doing wrong, should something be changed?
//
// MessageId: CDO_E_SMTP_SEND_FAILED
//
// MessageText:
//
// The message could not be sent to the SMTP server. The transport error code was %2. The server response was %1
//
#define CDO_E_SMTP_SEND_FAILED 0x80040211L
CDO takes it's default settings from Windows Mail/Outlook Express/Microsoft Internet Mail and News.
This VBA code list your configuration:
Set emailConfig = emailObj.Configuration
On Error Resume Next
For Each fld in emailConfig.Fields
Text = Text & vbcrlf & fld.name & " = " & fld
If err.number <> 0 then
Text = Text & vbcrlf & fld.name & " = Error - probably trying to read password - not allowed"
err.clear
End If
Next
Msgbox Replace(Text, "http://schemas.microsoft.com", "")
I have an Outlook mail Entry ID.
I want details of that Entry Id such as To, Subject ,Body, etc.
Emails are still in Inbox not moved anywhere.
Private Sub CommandButton4_Click()
i = 0
j = 1
Dim path, FileName As String
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
Set currentMail = objNameSpace.GetItemFromID("000000000AB85207D8C3664BA439B3CE1603D186070019BED8705003484BACA686B84F9C6E880000006DE67E000019BED8705003484BACA686B84F9C6E880000428CEF9B0000")
MailTo = currentMail.To
MailSubject = currentMail.Subject
MailBody = currentMail.Body
MailDateTime = currentMail.CreationTime
attcount = currentItem.Attachments.Count
For j = 1 To attcount + 1
'FileName = "\\wipfs01\ES Quality\Personal Folders\Mahesh\Tools\Sorting-Telus\Attachment\" & Atmt.FileName
'Atmt.SaveAsFile FileName
Set chk = UserForm2.Controls("chkn" & j)
If chk.Value = True Then
path = SaveAttachment("\\wipfs01\ES Quality\Personal Folders\Mahesh\Tools\Sorting-Telus\Attachment\PO\")
FileName = path & currentItem.Attachments(j).FileName
currentItem.Attachments(j).SaveAsFile FileName
Set currentMail = currentItem
MailTo = currentMail.To
MailSubject = currentMail.Subject
MailBody = currentMail.Body
MailDateTime = currentMail.CreationTime
chk.Visible = False
End If
Next j
'MsgBox MailTo & vbCrLf & MailSubject & vbCrLf & MailBody & vbCrLf & MailDateTime
End Sub
Use Namespace.GetItemFromID to open the message using its entry id.
The following code works to extract the first name and email from a database and send via CDOSys and email to records found.
My hosting service limits the number of recipients to 10 so I'm thinking would it be poosible to restrict the find to the first 10 records, then send and then find the next 10 records and send and so on and so on until the end of the table is reached?
<%
Set OBJdbConnection = CreateObject("ADODB.Connection")
OBJdbConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath("myData.mdb")
SQLQuery = "SELECT FirstName, Email_Address FROM MyTable"
Set Result = OBJdbConnection.Execute(SQLQuery)
if Not Result.EOF then
Do While Not Result.EOF
SendMail Result("FirstName"), Result("Email_Address")
Result.MoveNext
Loop
end if
OBJdbConnection.Close()
Set OBJdbConnection = Nothing
Sub SendMail(TheName, TheAddress)
Dim objMessage, Rcpt
If (TheName <> "" AND TheAddress <> "") Then
smtpServer = "mail.mydomain.com"
body = "Hello World"
Rcpt = Chr(34) & TheName & Chr(34) & "<" & TheAddress & ">"
set objMessage = Server.CreateObject("CDO.Message")
set cdoConfig = Server.CreateObject("CDO.Configuration")
cdoConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
cdoConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = smtpServer
cdoConfig.Fields ("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
cdoConfig.Fields ("http://schemas.microsoft.com/cdo/configuration/sendusername") ="smtp#mydomain.com"
cdoConfig.Fields ("http://schemas.microsoft.com/cdo/configuration/sendpassword") ="123456"
cdoConfig.Fields.Update
set objMessage.Configuration = cdoConfig
objMessage.Subject = "This Month's Sales"
objMessage.From = """Acme Sales"" <me#mydomain.com>"
objMessage.To = Rcpt
objMessage.HTMLBody = body
objMessage.Send
End If
End Sub
set objMessage = Nothing
set cdoConfig = Nothing
%>
I think it can be what you want to do.
<%
if Not Result.EOF then
i = 0
Do While i<10
SendMail Result("FirstName"), Result("Email_Address")
Result.MoveNext
i= i+1
Loop
....
%>