Sending email with or without attachments

[KenGra]

Hi,
I'm very new to VBA and I don't know where to start looking for the answer to my problem. I'm working on a database for work that email's the current record after the form is completed. I have a attachment field in the table called Photo and some record's have a photo attached and other's don't. The code below works great with records that have a photo attached, but I get a path not found if I try to email a record that does not have a photo. I know that I need to put some form of code to check the photo field for a attachment, but I'm having a brain fade as to just what the code is.

Private Sub eMail_Report_Click()
Dim oFilesys, oTxtStream As Object
Dim txtHTML As String
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)
 
Set oTxtStream = Nothing
Set oFilesys = Nothing
Dim rsParent As DAO.Recordset2
Dim rsChild As DAO.Recordset2
Set db = CurrentDb
Set rsParent = Me.Recordset
rsParent.OpenRecordset
Set rsChild = rsParent.Fields("Photo").Value
While Not rsChild.EOF
If Dir("C:\dbtemp", vbDirectory) = "" Then
MkDir ("C:\dbtemp")
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:\dbtemp\")
rsChild.MoveNext
Wend
 
' Build the Email to be sent
With MailOutLook
.BodyFormat = olFormatRichText
.To = "somebody@somewhere.com"
'.CC = " "
 .Subject = "some txt here"
 .HTMLBody = "body txt"

Dim fso As Object, SourceFolder As Object, SourceFile As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = fso.GetFolder("C:\dbtemp\")
For Each SourceFile In SourceFolder.Files
.Attachments.Add SourceFolder.Path & "\" & SourceFile.Name
  
.Display
Next
'Send email
'.DeleteAfterSubmit = True 'This would let Outlook send the note without storing it in your sent bin
'.Send
Kill "C:\dbtemp\*.*" ' delete all files in the folder
RmDir "C:\dbtemp\" ' delete folder


End With

End Sub

I know this is something simple but could anybody help point me in the right direction.:banghead:
Regards,
Ken

 

[ted.martin]

Try replacing this part of your code

Dim fso As Object, SourceFolder As Object, SourceFile As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = fso.GetFolder("C:\dbtemp\")
For Each SourceFile In SourceFolder.Files
.Attachments.Add SourceFolder.Path & "\" & SourceFile.Name
  
.Display
Next

with a more simple IF based on whether the photo file exists?

 

[KenGra]

Hi, thanks for the pointer, I have modified my code and everything is working as it should.
Regards
Ken

 

[Dave1970]

Hi Ken,

I'm having the same issue as you were, but seem to be having a difficult time with the IF statement. Would you be willing to post the updated IF statement that worked for you?

Cheers.

 

[KenGra]

Hi Ken,

I'm having the same issue as you were, but seem to be having a difficult time with the IF statement. Would you be willing to post the updated IF statement that worked for you?

Cheers.

Hi,
This is what worked for me.

Private Sub Command18_Click()
Dim oFilesys, oTxtStream As Object
Dim txtHTML As String
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)


Set oTxtStream = Nothing
Set oFilesys = Nothing
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("Photo").Value
While Not rsChild.EOF
If Dir("C:\dbtemp", vbDirectory) = "" Then
MkDir ("C:\dbtemp")
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:\dbtemp\")
rsChild.MoveNext
Wend
With MailOutLook
.BodyFormat = olFormatRichText
.To = "email@here.com"
'.CC = " "
.Subject = "Enter Text"
.HTMLBody = "Enter Text"
' Grab Attachments for Email if there are any
If Dir("C:\dbtemp", vbDirectory) = "" Then
  .Display
  Exit Sub
Else
End If
Dim fso As Object, SourceFolder As Object, SourceFile As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = fso.GetFolder("C:\dbtemp\")
For Each SourceFile In SourceFolder.Files
.Attachments.Add SourceFolder.Path & "\" & SourceFile.Name
.Display
Next
'Send email
'.DeleteAfterSubmit = True 'This would let Outlook send the note without storing it in your sent bin
'.Send
Kill "C:\dbtemp\*.*" ' delete all files in the folder
RmDir "C:\dbtemp\" ' delete folder
End With

End Sub

I just check for the dbtemp directory that is created if there are any attachments, and if its not there I just display the constructed eMail and send it.
Hope this helps

Regards
Ken

 

[Dave1970]

Much appreciated Ken, this worked perfectly.