Private Sub send_Click()
Dim appOutLook As Outlook.Application, MailOutLook As Outlook.MailItem
Dim rsParent As DAO.Recordset2, rsChild As DAO.Recordset2
Dim fso As Object, SourceFolder As Object, SourceFile As Object
Const strPath As String = "P:\WISSEL\Expeditie\21- Data Expeditie\Expeditool\temp"
'create the attachments folder
If Dir(strPath, vbDirectory) = "" Then
MkDir strPath
End If
'extract files from table and save to folder
Set rsParent = Me.Recordset
rsParent.OpenRecordset
Set rsChild = rsParent.Fields("shipattachment").Value
While Not rsChild.EOF
rsChild.Fields("FileData").SaveToFile (strPath & "\" & rsChild.Fields("FileName"))
rsChild.MoveNext
Wend
rsChild.Close
Set rsChild = Nothing
'open email and attach files
Set appOutLook = CreateObject("Outlook.Application")
Set MailOutLook = appOutLook.CreateItem(olMailItem)
With MailOutLook
.BodyFormat = olFormatRichText
.To = "[EMAIL="bruce@logistics.com"]bruce@logistics.com[/EMAIL]"
'.CC = " "
.Subject = "Expedition T1 -" & Me.contract & ""
.HTMLBody = "Your text " & [B][COLOR=red]Me.company[/COLOR][/B] & " here." 'or restore code to export report to HTML and open and read file
Set fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = fso.GetFolder(strPath)
For Each SourceFile In SourceFolder.Files
.Attachments.Add SourceFile.PATH 'SourceFolder.Path contains the path+filename
Next
.Display 'display email after processing all attachments
'.DeleteAfterSubmit = True 'this would let Outlook send email without saving to Sent bin
'.Send
'close fso objects
Set SourceFile = Nothing
Set SourceFolder = Nothing
Set fso = Nothing
End With
Kill strPath & "\*.*" 'delete all files in the folder
RmDir strPath 'delete folder
End Sub