Saving Attachment to local drive & sending E-mail

ardy

Registered User.
Local time
Today, 08:17
Joined
Sep 24, 2012
Messages
98
Hello All:
I have an applet in Access(2007). The applet logs calls and enables users to attach files to the call and if they choose, send an e-mail out. Not a VB programmer but I understand it. More of a spaghetti programmer.
These are my issues…….
1. Need to be able to attach to outlook all files saved in the strPath. So the code enables users to save one attachment to a path described in srtPath. I want to be able to save all files as attachment to an e-mail.
2. Need to be able to save more than one file to srtPath directory. users might attach more than a single file to the table. the current code only saves one of the files to the strPath. i want to save all of the files.
3. Last but not least delete all files under srtPath directory after sending the e-mail ( I am sure IO can figure this out – currently not in the code.)
-------------------------------------
The code that sends the e-mail
Code:
  Private Sub Form_Close()
  ' Attaching and sending e-mail
   
      Dim N As String
      Dim S As String
      
          N = Forms!Contact_Calls_NRSS!Lbl_Notes
          S = Forms!Contact_Calls_NRSS!Lbl_Subject
  ' Sending E-mail
              Set db = CurrentDb
              Set rs = db.OpenRecordset("Calls_Tmp")
          Do While Not rs.EOF
              varEmailAdd = varEmailAdd & rs!E_mailAdd & ";"
              rs.MoveNext
          Loop
              rs.Close
              Set rs = Nothing
   
      varEmailAdd = Left(varEmailAdd, Len(varEmailAdd) - 1)
      MsgBox "Sending E-mail To The Following E-mail Addresses.." & vbNewLine _
      & vbNewLine _
      & varEmailAdd & vbNewLine _
      & vbNewLine _
      & "Please make sure to use GWMP e-mail address in the FROM: in Outlook"
   
  ' ----------------------------  Send Email Using Outlook
   
  ' Prevent 429 error, if outlook not open
          On Error Resume Next
              Err.Clear
          Set oOutlook = GetObject(, "Outlook.application")
              If Err.Number <> 0 Then
                  Set oOutlook = New Outlook.Application
              End If
   
          Set oEmailItem = oOutlook.CreateItem(olMailItem)
              With oEmailItem
                  .To = varEmailAdd
                  .BCC = ""
                  .Subject = S
                  .Body = N
                   .Attach [B]‘ some how attaching all the files in strPath of the Function(SaveAttachment)[/B]
                  .Display
              End With
   
          Set oEmailItem = Nothing
          Set oOutlook = Nothing
          
          DoCmd.Close acForm, "Contact_Calls_NRSS", acSaveYes
          
  End Sub
The function to save the file to local drive
Code:
  Function SaveAttachment()
      Dim db As DAO.Database
      Dim rst As DAO.Recordset2
      Dim rstAttachment As DAO.Recordset2
      Dim fld As DAO.Field2
      Dim strPath As String
      Dim intz As Integer
      Dim Directory As String
      Dim Root As String
      Dim Path As String
   
          Directory = "temp\"
          Root = "C:\"
          Path = Root & Directory
  ' check to see if the directory exist
          If Len(Dir(Path, vbDirectory)) = 0 Then
              MkDir Path
          End If
  ‘ [B]if there are more than 1 attachments, I think this needs to be a loop that saves them all[/B]
  Set db = CurrentDb
          Set rst = db.OpenRecordset("Attachment", dbOpenDynaset)
               rst.FindLast "ID = " & Forms!Attachment_NR!Lbl_AttachID
          Set rstAttachment = rst.Fields("Attach").Value
          Set fld = rstAttachment.Fields("Filedata")
          strPath = Path & rstAttachment.Fields("Filename")
   
              fld.SaveToFile strPath
   
      rstAttachment.Close
      rst.Close
          Set rstAttachment = Nothing
          Set rst = Nothing
          Set db = Nothing
   
  DoCmd.Close acForm, "Attachment_NR", acSaveYes
   
  End Function
 
Last edited:
  • Like
Reactions: Rx_
I don't save files in access databases and I do not use multi value fields, so cannot help with extracting files to a folder. As to attaching all files in a folder to an emails, that's different.

Replace the line
Code:
.Attach ‘ some how attaching all the files in strPath of the Function(SaveAttachment)in your code,

with

Code:
'.Attach ‘ some how attaching all the files in strPath of the Function(SaveAttachment)
       Dim strFile As String
       strFile = Dir(strPath & "*.*")
       Do While strFile <> ""
             .Attachments.Add strPath & strFile
          strFile = Dir
       Loop
 
  • Like
Reactions: Rx_
Thanks for reply cronk...... I really appreciate it.....

I think I will find a solution for saving all attach files in the table (I mean attach to a record file) to the strFile directory........
Your solution will help me half way which is great.........I have been changing this code so many times that I can't tell which way is up anymore....LOL.....

Could you help me incorporate your code to this.... I keep getting errors when i do it......:banghead:
Code:
Private Sub Form_Close()
' Attaching and sending e-mail after close of the dialogbox

    Dim N As String
    Dim S As String
    Dim strFile As String
    
        N = Forms!Contact_Calls_NRSS!Lbl_Notes
        S = Forms!Contact_Calls_NRSS!Lbl_Subject
        strFile = "C:\Temp\"
        
' Sending E-mail
            Set db = CurrentDb
            Set rs = db.OpenRecordset("Calls_Tmp")
        Do While Not rs.EOF
            varEmailAdd = varEmailAdd & rs!E_mailAdd & ";"
            rs.MoveNext
        Loop
            rs.Close
            Set rs = Nothing

    varEmailAdd = Left(varEmailAdd, Len(varEmailAdd) - 1)
    MsgBox "Sending E-mail To The Following E-mail Addresses.." & vbNewLine _
    & vbNewLine _
    & varEmailAdd & vbNewLine _
    & vbNewLine _
    & "Please make sure to use GWMP e-mail address in the FROM: in Outlook"

' ----------------------------  Send Email Using Outlook

' Prevent 429 error, if outlook not open
        On Error Resume Next
            Err.Clear
        Set oOutlook = GetObject(, "Outlook.application")
            If Err.Number <> 0 Then
                Set oOutlook = New Outlook.Application
            End If

        Set oEmailItem = oOutlook.CreateItem(olMailItem)
            With oEmailItem
                .To = varEmailAdd
                .BCC = ""
                .Subject = S
                .Body = N
                .Display
            End With
                
        Set oEmailItem = Nothing
        Set oOutlook = Nothing
        
        DoCmd.Close acForm, "Contact_Calls_NRSS", acSaveYes
        
End Sub
 
Please be encouraged to post any solution for the rest of us.
This kind of thing is on my "to do" list for the end of Jan 2017.
Would really enjoy taking this thread and adding a little more functionality.
Sharing your achievements and challenges would be very beneficial!
 
#ardy

What is the error and on what line is it occurring?
 
OK.... Here is the result... I modify the code a bit got rid of strPath.......

This is the complete code.......
Run-time error '-2147024894(80070002)':
Cannot find this file. Verify the path and file name are correct.
Code:
Private Sub Form_Close()
' Attaching and sending e-mail

    Dim N As String
    Dim S As String
    Dim strFile As String
    
        N = Forms!Contact_Calls_NRSS!Lbl_Notes
        S = Forms!Contact_Calls_NRSS!Lbl_Subject
        strFile = "C:\Temp\"
        
' Sending E-mail
            Set db = CurrentDb
            Set rs = db.OpenRecordset("Calls_Tmp")
        Do While Not rs.EOF
            varEmailAdd = varEmailAdd & rs!E_mailAdd & ";"
            rs.MoveNext
        Loop
            rs.Close
            Set rs = Nothing

    varEmailAdd = Left(varEmailAdd, Len(varEmailAdd) - 1)
    MsgBox "Sending E-mail To The Following E-mail Addresses.." & vbNewLine _
    & vbNewLine _
    & varEmailAdd & vbNewLine _
    & vbNewLine _
    & "Please make sure to use GWMP e-mail address in the FROM: in Outlook"

' ----------------------------  Send Email Using Outlook

' Prevent 429 error, if outlook not open
'        On Error Resume Next
'            Err.Clear
        Set oOutlook = GetObject(, "Outlook.application")
            If Err.Number <> 0 Then
                Set oOutlook = New Outlook.Application
            End If

        Set oEmailItem = oOutlook.CreateItem(olMailItem)
            With oEmailItem
                .To = varEmailAdd
                .BCC = ""
                .Subject = S
                .Body = N
                strFile = Dir(strFile & "*.*")
                Do While strFile <> ""
             [COLOR=Red][B].Attachments.Add strPath & strFile ' It has issue with this line[/B][/COLOR]
          strFile = Dir
       Loop
                .Display
            End With
                
        Set oEmailItem = Nothing
        Set oOutlook = Nothing
        
        DoCmd.Close acForm, "Contact_Calls_NRSS", acSaveYes
        
End Sub
 
Last edited:
Add the following line before the line causing the problem debug.print strPath & strFile This will show you what you are trying to add as an attachment. Then think about what strPath that you removed, is supposed to be doing. Incidentally, it is not praying, nor crossing your fingers nor examining sheep entrails that makes code work. Learn how to step through your code and examine the value of the variables.
 
Incidentally, it is not praying, nor crossing your fingers nor examining sheep entrails that makes code work.

Now you tell me. This would have come in handy a few years ago when I first joined the forum!
 
Thank you all for your help....... Cronk.... Added debug gives me the same as error...... I will figure this out eventually, I always do........ Thank you all.
 
Hint:
To add an attachment, you need to supply the full path and file name. Use debug.print to show exactly what you are trying to have attached.
 

Users who are viewing this thread

Back
Top Bottom