HELP!! Script to send multiple attachments via email

[dwcolt]

Help! For the life of me I cannot figure out what I'm doing wrong. I have a Microsoft Access query that lists the full directory path for a number of files. I tried to write a script that will create a new email message in Outlook that attaches each of the files listed in the query. The user will then input the recipient and subject, and can send the email from Outlook.

The script works great, EXCEPT that it repeats the same attachment. For example, the query might return 3 files. Instead of inserting each of the 3 files as an attachment, it inserts the first file 3 times. This is obviously a problem with my loop below, but I can't figure out. Can anyone tell me what I'm doing wrong? Thanks in advance!!!

------------------
Private Sub EmailMarkedDocuments_Click()
Dim MyDB As Database
Dim MyRS As Recordset
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookAttach As Outlook.Attachment
Dim TheAttachment As String

Set objOutlook = CreateObject("Outlook.Application")
Set objOutlookMsg = objOutlook.CreateItem(0) 'olMailItem
Set MyDB = CurrentDb
Set MyRS = MyDB.OpenRecordset("CheckForMarkedQuery")
TheAttachment = MyRS![FilePath]

MyRS.MoveFirst

With objOutlookMsg
Do Until MyRS.EOF
MyRS.MoveNext
Set objOutlookAttach = .Attachments.Add(TheAttachment)

Loop
End With

objOutlookMsg.Display


End Sub

 

[RuralGuy]

See if this link helps at all: http://granite.ab.ca/access/email/recordsetloop.htm

 

[dwcolt]

Thanks, but this seems to have the same loop structure that I already have. Any other ideas?

 

[pbaldy]

Looks like Allan is offline. You set this before the loop, so its value never changes:

TheAttachment = MyRS![FilePath]

It should be inside the loop, and both it and the Set line should be before the MoveNext.

 

[dwcolt]

BINGO!!!!!! That was exactly it. Script works perfectly now! Thanks so much.

 

[pbaldy]

We were happy to help!

 

[RuralGuy]

We were happy to help!

Absolutely! Thanks for stepping into the gap Paul.

 

[pbaldy]

No problemo Allan. I normally try not to jump in, but your "light" was off so I figured you had gone to bed.

 

[dwcolt]

Thanks everyone for the help! Here is the final script that solved the problem:

Private Sub EmailMarkedDocuments_Click()

On Error GoTo Email_Err_Clear

Dim MyDB As Database
Dim MyRS As Recordset
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookAttach As Outlook.Attachment
Dim TheAttachment As String
Dim QDF As QueryDef
Dim prm As Parameter


Me.CourtClipResults.Requery
If (DCount("[Description]", "CheckForMarkedQuery") < 1) Then
MsgBox "You must check at least one document in order to send the email.", 0, "CW Case Management System"
Else
CheckIfOutlookOpen

Set objOutlook = CreateObject("Outlook.Application")
Set objOutlookMsg = objOutlook.CreateItem(0) 'olMailItem


Set MyDB = CurrentDb
Set QDF = MyDB.QueryDefs("CheckforMarkedQuery")
For Each prm In QDF.Parameters
prm.Value = Eval(prm.Name)
Next prm
Set MyRS = QDF.OpenRecordset
MyRS.MoveFirst


With objOutlookMsg
Do Until MyRS.EOF
TheAttachment = MyRS![FilePath]
Set objOutlookAttach = .Attachments.Add(TheAttachment)
MyRS.MoveNext
Loop
End With
objOutlookMsg.Display

End If
Email_Err_Clear:
Exit Sub

End Sub

 

[pbaldy]

Is it me, or has it been two years?

 

[speakers_86]

Wow, I've replied two MONTHS later and took heat for it. This guy took it to another level.

 

[dwcolt]

Well, to add some context, I received a PM from another member asking about this solution. I don't have enough posts to be able to respond to a PM, so I had to post my solution here!

 

[speakers_86]

The fact that you even logged in to this site two years later with only 13 posts is impressive.

 

[dwcolt]

The fact that you even logged in to this site two years later with only 13 posts is impressive.

I'll have to chalk that up to email notification; I would have had no clue otherwise!

 

[Kiwiman]

Howzit

It's not quantity that is important but quality. I like the fact that you can make a post one day and say yep that's me done for a couple of years. Catch ya later.

 

[Lin100]

Hi.

I ran the code below and it gives me an error message
"User-defined type not defined". The yellow highlight is at the code

Dim objOutlook As Outlook.Application

/////////////////////////////////////////////////////////////////////////////

Thanks everyone for the help! Here is the final script that solved the problem:

Private Sub EmailMarkedDocuments_Click()

On Error GoTo Email_Err_Clear

Dim MyDB As Database
Dim MyRS As Recordset
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookAttach As Outlook.Attachment
Dim TheAttachment As String
Dim QDF As QueryDef
Dim prm As Parameter


Me.CourtClipResults.Requery
If (DCount("[Description]", "CheckForMarkedQuery") < 1) Then
MsgBox "You must check at least one document in order to send the email.", 0, "CW Case Management System"
Else
CheckIfOutlookOpen

Set objOutlook = CreateObject("Outlook.Application")
Set objOutlookMsg = objOutlook.CreateItem(0) 'olMailItem


Set MyDB = CurrentDb
Set QDF = MyDB.QueryDefs("CheckforMarkedQuery")
For Each prm In QDF.Parameters
prm.Value = Eval(prm.Name)
Next prm
Set MyRS = QDF.OpenRecordset
MyRS.MoveFirst


With objOutlookMsg
Do Until MyRS.EOF
TheAttachment = MyRS![FilePath]
Set objOutlookAttach = .Attachments.Add(TheAttachment)
MyRS.MoveNext
Loop
End With
objOutlookMsg.Display

End If
Email_Err_Clear:
Exit Sub

End Sub

 

[pbaldy]

The Outlook reference has to be checked in Tools/References.