how to send attachments on current record open

[sspreyer]

hi to all you access gods

i have googled the hell out of this struggle to get any code to work . i have a attachment field to my records call "Attachment"i would like to be able to click command button and add all attachments that are in the attachment field of the current record in to email Primary key name in my table is id



thanks in advance

shane

[June7]

This requires code that saves the attachments outside the db then code to attach them to Outlook email object.

https://www.accessforums.net/program...ent-23686.html

https://www.accessforums.net/program...ook-21903.html

[sspreyer]

thanks for help june7
i have now got some code from the post u have shared to me i keep get error compile error invalid use of me keyword
code:

Private Sub ID_CLICK()
 Dim dbs As DAO.Database
 Dim rst As DAO.Recordset
 Const strTable = "assets" '<- Replace this with your table with attachment
 Const strField = "Files" '<- Replace this with the fieldname of your attachment
 Set dbs = CurrentDb
 Set rst = dbs.OpenRecordset("SELECT * FROM assets WHERE ID=" & Me.ID) here my problem i dont understand the error 
 'rst.MoveNext ' Uncomment this line to go to the 2nd row in the Table.
 OpenFirstAttachmentAsTempFile rst, strField
 rst.Close
 End Sub

[June7]

Assuming that code is actually behind a form then the Me qualifier should work.

[sspreyer]

Assuming that code is actually behind a form then the Me qualifier should work.

Thanks for your time june7
Have created a command button on form add this code in module Is that right sorry knowledge is not great on vba
Thanks again

shane

[June7]

That sounds good. Keep going. Test. Debug. Fix. Test again. Debug again. etc.

[sspreyer]

right i got some code that is now collecting the attachments from the current record but it not seeming to attach them to email can you see any problems with code any help much Appreciated
code:

Private Sub cmdEmail_Click()
Dim appOutLook As Outlook.Application
Dim MailOutLook As Outlook.MailItem
Dim OutlookAttach As Outlook.Attachment
Set appOutLook = CreateObject("Outlook.Application")
Set MailOutLook = appOutLook.CreateItem(olMailItem)
 
Dim db As DAO.Database
Dim rsParent As DAO.Recordset2
Dim rsChild As DAO.Recordset2
Set db = CurrentDb
Set rsParent = Me.Recordset
rsParent.OpenRecordset
Set rsChild = rsParent.Fields("Attachments").Value
While Not rsChild.EOF
If Dir("C:\Users\Shane\Documents\Reports for daz", vbDirectory) = "" Then
MkDir ("C:\Users\Shane\Documents\Reports for daz")
Else
'do nothing for the "C:\dbtemp" directory already exists
'MsgBox "C:\dbtemp\ directory already exists"
End If
rsChild.OpenRecordset
rsChild.Fields("FileData").SaveToFile ("C:\Users\Shane\Documents\Reports for daz\")
rsChild.MoveNext
Wend
With MailOutLook
.BodyFormat = olFormatRichText
.To = "email address"
.CC = " "
.Subject = "test"
Dim fso As Object, SourceFolder As Object, SourceFile As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = fso.GetFolder("C:\Users\Shane\Documents\Reports for daz\")
For Each SourceFile In SourceFolder.Files
.Attachments.Add SourceFolder.Path & "\" & SourceFile.Name
Next
'Send email
'.DeleteAfterSubmit = True 'This would let Outlook send the note without storing it in your sent bin
'.Send
'Kill "C:\Users\Shane\Documents\Reports for daz\*.*" ' delete all files in the folder
'RmDir "C:\dbtemp\" ' delete folder
End With
 

End Sub

cheers

shane

[sspreyer]

hi
right i have played a little bit more get error file or directory can find even tho i no the directory is right ??

cheers shane
code :

Function SaveAttachment()
Dim db As DAO.Database
Dim rsParent As DAO.Recordset2
Dim rsChild As DAO.Recordset2
Set db = CurrentDb
Set rsParent = Me.Recordset
rsParent.OpenRecordset
Set rsChild = rsParent.Fields("Attachments").Value
While Not rsChild.EOF
If Dir("C:\Users\Shane\Documents\Reports for daz", vbDirectory) = "" Then
MkDir ("C:\Users\Shane\Documents\Reports for daz")
Else
'do nothing for the "C:\dbtemp" directory already exists
'MsgBox "C:\dbtemp\ directory already exists"
End If
rsChild.OpenRecordset
rsChild.Fields("FileData").SaveToFile ("C:\Users\Shane\Documents\Reports for daz\")
rsChild.MoveNext
Wend
 
End Function
 

Private Sub cmdEmail2_Click()
 Dim outlookApp As Outlook.Application
 Dim outlookNamespace As NameSpace
 Dim objMailItem  As MailItem
 Dim objFolder As MAPIFolder
 Dim strAttachementPath As String
 Dim rst As DAO.Recordset2
 Dim rstAttachment As DAO.Recordset2
 Dim db As DAO.Database
 Dim strHTML
 
'Call SaveAttachment
Set outlookApp = CreateObject("Outlook.Application")
 Set outlookNamespace = outlookApp.GetNamespace("mapi")
 Set objFolder = outlookNamespace.GetDefaultFolder(olFolderInbox)
 Set objMailItem = objFolder.Items.Add(olMailItem)
    Set db = CurrentDb
     Set rst = db.OpenRecordset("Assets", dbOpenDynaset)
     rst.FindFirst "ID = " & Me!ID
    Set rstAttachment = rst.Fields("Attachments").Value
strAttachementPath = CurrentProject.Path & "C:\Users\Shane\Documents\Reports for daz\" _
 & rstAttachment.Fields("Filename")
' Build HTML for message body.
 'strHTML = "<HTML><HEAD>"
 'strHTML = "<br>"
 'strHTML = strHTML & "<FONT Face=Calibri><b>ID: </b></br>" & [ID] & "<br>"
 'strHTML = strHTML & "<FONT Face=Calibri><b>Date: </b></br>" & [Date] & "<br>"
 'strHTML = strHTML & "<FONT Face=Calibri><b>Time: </b></br>" & [Time] & "<br>"
 'strHTML = strHTML & "<FONT Face=Calibri><b>Technician: </b></br>" & [Technician] & "<br>"
 'strHTML = strHTML & "<FONT Face=Calibri><b>Area: </b></br>" & [Area] & "<br>"
 'strHTML = strHTML & "<FONT Face=Calibri><b>Blast No.: </b></br>" & [shot number] & "<br><br>"
 'strHTML = strHTML & "<FONT Face=Calibri><b>Comments: </b></br>" & [Comments] & "<br>"
 'strHTML = strHTML & "</FONT></br><BODY>"
'strHTML = strHTML & "<FONT Face=Arial Color=#ff0000 Size=5>Job #: 123456</FONT></br>"
'strHTML = strHTML & "<FONT Size=3>For: <FONT Size=2></B>a name here</br>"
'strHTML = strHTML & "<FONT Size=3><B>Description: </B><FONT Size=2>description of work to be done</FONT></br>"
 strHTML = strHTML & "</BODY></HTML>"
' Build the Email to be sent
With objMailItem
    .BodyFormat = olFormatHTML
    .To = "EMAIL ADDRESS HERE"
    .Subject = "" '"Site Inspection for " & [Area] & " At " & [Date]
'    .Body = "Some text here"
    .HTMLBody = strHTML
' Grab Attachments for Email if there are any
    If rstAttachment.RecordCount > 0 Then
       Call SaveAttachment
  
        strAttachementPath = CurrentProject.Path & "C:\Users\Shane\Documents\Reports for daz" _
        & rstAttachment.Fields("Filename")
              .Attachments.Add (strAttachementPath) ' im get a error here file path incorrect directory
    End If
     .Display
 End With
 
 outlookApp.ActiveWindow
 'SendKeys ("%s")
MsgBox "Mail Sent!", vbOKOnly, "Mail Sent"
'Kill "C:\Users\Shane\Documents\Reports for daz\*.*" ' delete all files in the folder
End Sub

[ItsMe]

I didn't totally scrutinize all of the code. But this stands out. Especially since you get an error at adding attachment.

You are going to need a file name. If rstAttachments is not getting interpreted, you will need to spell it out. Start by adding a backslash though. See if that helps.

strAttachementPath = CurrentProject.Path & "C:\Users\Shane\Documents\Reports for daz" _
& rstAttachment.Fields("Filename")


should have a backslash after daz

strAttachementPath = CurrentProject.Path & "C:\Users\Shane\Documents\Reports for daz\" _
& rstAttachment.Fields("Filename")

[sspreyer]

Thanks itsme
I try that still no good it still says path not found can't understand why ?? Weird one

Cheers
Shane

[June7]

Try code with a different folder, say C:\Test