VB Script to send multiple attachments

[dwcolt]

Help! I'm hoping that someone can point me to a VB script that will do a fairly simple task.

I have a Microsoft Access table that lists the full directory path for a number of files.

I am looking for a script that will create a new email message in Outlook that attaches each of the files listed in the table. The user will then input the recipient and subject, and can send the email from Outlook.

Any help would be greatly appreciated! Thanks in advance.

 

[dwcolt]

Ok, I've written some code that mostly works, but here's the problem: I have 3 files that come up in the query below. I want the code to insert those 3 files into the email as attachments. The code is inserting the first file 3 times, instead or inserting each of the 3 files. What am I doing wrong with my loop?

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

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

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

.Subject = "Documents from Colt / Wallerstein LLP for Matter: " & (DLookup("[MatterName]", "MatterList", "ID=Forms!CourtClipForm!CourtClipMatter"))
.HTMLBody = "Please see the attached documents."


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

Loop
End With

objOutlookMsg.Display

End If

End Sub

 

[PHV]

Set objOutlook = CreateObject("Outlook.Application")
Set objOutlookMsg = objOutlook.CreateItem(0) 'olMailItem
Set MyDB = CurrentDb
Set MyRS = MyDB.OpenRecordset("CheckForMarkedQuery")
MyRS.MoveFirst
With objOutlookMsg
.Subject = "Documents from Colt / Wallerstein LLP for Matter: " & (DLookup("[MatterName]", "MatterList", "ID=Forms!CourtClipForm!CourtClipMatter"))
.HTMLBody = "Please see the attached documents."
Do Until MyRS.EOF
Set objOutlookAttach = .Attachments.Add(MyRS![FilePath])
MyRS.MoveNext
Loop
End With
objOutlookMsg.Display

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[dwcolt]

Fantastic! Script works perfectly now. Thanks so much.