Access To Outlook Attachments Error
Recently, I wrote a small module for an Access 95
application we use at work. The idea was to allow the use
to attach documents from a list of doc names and file
paths stored in a table related to a specific record in
Access.
Each time the module is launched, the only document
attached in the resultant email is the last document in
the list. I have stepped through this and watched at the
next document in the list overwrites the previously
attached document. Is there a solution to this problem?
Code sample below... Thanks
------------------------ Code Segment ---------------------
Set GoOutlook = New Outlook.Application
Set GoNameSpace = GoOutlook.GetNamespace("MAPI")
GoNameSpace.Logon , , True, True
Dim NewMail As Outlook.MailItem
Dim SQL As String
Dim Rs As Recordset
Dim Use_path As String
Dim Counter As Integer
On Error GoTo 0
Set NewMail = GoOutlook.CreateItem(olMailItem)
With NewMail
.To = Emailaddress
.Subject = Subjects
.CC = CC
.Body = Chr(13) & Email_Message
SQL = "SELECT DISTINCTROW Documents.Document_Name,
Documents.Document_Path, Documents.[Document Description],
Documents.Doc_ID FROM [Tracking Table] INNER JOIN
Documents ON [Tracking Table].Doc_ID = Documents.Doc_ID
WHERE ((Not (Documents.Document_Name) Is Null) AND
((Documents.Doc_ID)='" & Report_ID & "')) OR ((Not
(Documents.Document_Path) Is Null) AND ((Documents.Doc_ID)
='" & Report_ID & "')) OR ((Not (Documents.[Document
Description]) Is Null) AND ((Documents.Doc_ID)='" &
Report_ID & "'));"
Set Rs = CurrentDb.OpenRecordset(SQL)
On Error Resume Next
Rs.MoveLast
If Rs.RecordCount > 0 Then
On Error GoTo 0
Rs.MoveFirst
Counter = 0
Do
If Rs("Document_Path") <> "" Then
Use_path = Rs("Document_Path")
Else
Use_path = StaticPath
End If
If Right(Use_path, 1) <> "\" Then Use_path
= Use_path & "\"
If Dir(Use_path & Rs("Document_Name")) = Rs
("Document_Name") Then
DocumentName = Use_path & Rs
("Document_Name")
DocName = Rs("Document_Name")
End If
Rs.MoveNext
If DocumentName <> ""
Then .Attachments.Add DocumentName, olByValue, 1, DocName
DoEvents
Loop While Not Rs.EOF
End If
Rs.Close
Set Rs = Nothing
On Error GoTo 0
.Display
DoEvents
End With
Set GoNameSpace = Nothing
Set GoOutlook = Nothing
