Help in emailing with attachment

[daze]

I'd like to send emails from query's field "email" with attachment.
I have this code, but it only sends the first record...

Private Sub Command20_Click()
Dim mess_body As String
Dim appOutLook As Outlook.Application
Dim MailOutLook As Outlook.MailItem
Set appOutLook = CreateObject("Outlook.Application")
Set MailOutLook = appOutLook.CreateItem(olMailItem)
Mess_Subject = "Proba 5"
Mess_Text = "Ovo je kreirano u VBA kodu!" ' & [kontakti]![ime]
Set appOutLook = CreateObject("Outlook.Application")
Set MailOutLook = appOutLook.CreateItem(olMailItem)
With MailOutLook
.BodyFormat = olFormatRichText
.To = Me.email
.Subject = Me.Mess_Subject
.HTMLBody = Me.Mess_Text
If Left(Me.Mail_Attachment_Path, 1) <> "<" Then
.Attachments.Add (Me.Mail_Attachment_Path)
End If
.Send
End With
Exit Sub
email_error:
MsgBox "An error was encountered." & vbCrLf & "The error message is: " & Err.Description
Resume Error_out
Error_out:
End Sub

Can id be done with Do Until Loop and how?
THNX

 

[highandwild]

Do you know how to open a recordset and loop through each record in turn and send the email based upon the contents of the table or query?

If so then that is the way forward.

Do you need any help?

 

[daze]

I've seen some examples but never tried it myself.

Some help would be appreciated...

 

[jdraw]

I've seen some examples but never tried it myself.

Some help would be appreciated...

Can you describe what exactly you are trying to do?
Does every email you wish to send have the same attachments?
How do you determine which attachment(s) go with which email?

Here is a sample, taken from
http://www.fmsinc.com/tpapers/queries/index.html#CreateRecordset

Creating and using a RecordSet based on a saved Select query

RecordSets let you programmatically move through a table or query. By assigning a Select query to a RecordSet, you can move through the table. Commands such as MoveNext, MoveFirst, MoveLast, MovePrevious, let you control where you are in the query. By checking the EOF status, you can make sure you stop at the end of the table. Field values are referenced with a ! then field name.

Public Sub BrowseQuery_DAO()
   ' Comments: Browse a query and display its fields in the Immediate Window using DAO

   Const cstrQueryName = "Basics: Top 10 Most Profitable Companies"
   Dim dbs As DAO.Database
   Dim rst As DAO.Recordset

   ' Open pointer to current database
   Set dbs = CurrentDb

   ' Open recordset on saved query
   Set rst = dbs.OpenRecordset(cstrQueryName)

   ' Display data from one record and move to the next record until finished
   Do While Not rst.EOF
     Debug.Print "Company: " & rst![Company] & " Sales: " & rst![Sales] & " Sales: " & rst![Profits]
     rst.MoveNext
   Loop

   rst.Close
   dbs.Close
End Sub

This example prints the company name and sales in the Immediate Window.

 

[daze]

I need to send emails to number of contacts based on query (it collects emails from all contacts) with same subject, message and same attachment daily.

Also I wonder is it possible to collect more records and have them placed in one row devided with ";"?

 

[highandwild]

Hi

Here is some code that I have been developing and it seems to work fine
but would be slow for hundreds of emails.

I send an SQL statement to the SendBulkEmails() function containing the following fields:

[Addressrs] email address
[Subject] subject
[Msg] message
[Attachments] inc path and file name delimited by ";"

This function loops through the records and calls the SendIndividualEmail
function for each one. The four items of data are passed to this function. This SQL can be the name of a saved query if required and can be put together in any way you need as long as it has the four fields in.

The SendIndividualEmail function can be called directly if you want to send just one email without using the query. It sends the email and attaches all files as requested.

If different files are to be attached to each email, e.g. a personal account statement, then this is easily possible by using the [Attachments] field.
I produce a different PDF file for each recipient and prefix each with the
account number. I even merge different personalised word documents and create different excel files for each recipient.

SuspendClickYes
ResumeClickYes

The above two subs will just load and unload the ClickYes utility which prevents you from having to select Yes to send each email. Google ClickYes to download the software. There is a change to the registry that one can make but I'm not sure how this is done. Anybody know?

You will need to make reference to the Outlook Object Library.

See attached database for full code.

Public Function SendBulkEmails(strSQL) As Boolean
Dim rs As Recordset
Call ResumeClickYes
Set rs = CurrentDb.OpenRecordset(strSQL)
Set appOutlook = CreateObject("Outlook.Application")
Do While Not rs.EOF

Call SendIndividualEmail(rs!Address, rs!Subject, rs!Msg, rs!Attachments)

rs.MoveNext

Loop
rs.Close
db.Close
Set appOutlook = Nothing
Call SuspendClickYes
End Function

Public Function SendIndividualEmail(strAddress, strSubject, strMessage, strAttachments As String)

Dim MailOutLook As Outlook.MailItem
Dim X As Integer
Dim varArray() As String
On Error GoTo Err_Handler

'Call ResumeClickYes

Set MailOutLook = appOutlook.CreateItem(olMailItem)

With MailOutLook

.BodyFormat = olFormatRichText

.To = strAddress

.Subject = strSubject

.Body = strMessage

If strAttachments <> "" Then

varArray = Split(strAttachments, ";")
For X = LBound(varArray) To UBound(varArray)
.Attachments.Add varArray(X)
Next

End If

'.DeleteAfterSubmit = False 'This would let Outlook send the message without storing it in your sent bin

.Send

End With

Set MailOutLook = Nothing

Exit_Handler:
'Call SuspendClickYes

Exit Function
Err_Handler:

MsgBox "An error was encountered." & vbCrLf & "The error message is: " & Err.Number * " " & Err.Description
GoTo Exit_Handler
End Function

Private Sub ResumeClickYes()
Dim wnd As Long
Dim uClickYes As Long
Dim Res As Long
' Register a message to send
uClickYes = RegisterWindowMessage("CLICKYES_SUSPEND_RESUME")
' Find ClickYes Window by classname
wnd = FindWindow("EXCLICKYES_WND", 0&)
' Send the message to Resume ClickYes
Res = SendMessage(wnd, uClickYes, 1, 0)
End Sub

Private Sub SuspendClickYes()
Dim wnd As Long
Dim uClickYes As Long
Dim Res As Long
' Register a message to send
uClickYes = RegisterWindowMessage("CLICKYES_SUSPEND_RESUME")
' Find ClickYes Window by classname
wnd = FindWindow("EXCLICKYES_WND", 0&)
' Send the message to Suspend ClickYes
Res = SendMessage(wnd, uClickYes, 0, 0)
End Sub

 

[highandwild]

In addition to my previous email:

It does not cope with BCC and CC which would be fairly easy and it does not cope with sending the same email to many people. All possible enhancements.