Sending Emails from Access DB containing attachmen

问题:

I do not know how to get this thing to work beyond this point. My code below sends an email containing an attachment out of MS Access 2010.

The problem is if it requires a fixed file name, my file name changes as I am using the date at the end of each file. example: green_12_04_2012.csv. I also do not know how to make this not fail if the folder is empty or the directory changes. It would be great for it to just skip to the next sub rather than crashing.

My Code:

Dim strGetFilePath As String
Dim strGetFileName As String

strGetFilePath = "C:\datafiles\myfolder\*.csv"

strGetFileName = Dir(strGetFilePath)

Dim appOutLook As Outlook.Application
Dim MailOutLook As Outlook.MailItem
Set appOutLook = CreateObject("Outlook.Application")
Set MailOutLook = appOutLook.CreateItem(olMailItem)
With MailOutLook
    .BodyFormat = olFormatRichText
    .To = "[e-mail]"
    ''.cc = ""
    ''.bcc = ""
    .Subject = "text here"
    .HTMLBody = "text here"
    .Attachments.Add (strGetFileName & "*.csv")
    .Send
End With
End Sub

I think I am getting there.

回答1:

I found a suitable resolution and in addition to the solution posted, I wanted to add this in-case anyone is searching for the solution. I was up until 3am, this is a very popular question but there was not any resolution in regards to looping an attaching all files in a specific folder.

Here is the code:

Public Sub sendEmail()
    Dim appOutLook As Outlook.Application
    Dim MailOutLook As Outlook.MailItem
    Dim strPath As String
    Dim strFilter As String
    Dim strFile As String

    strPath = "C:\Users\User\Desktop\"      'Edit to your path
    strFilter = "*.csv"
    strFile = Dir(strPath & strFilter)

    If strFile <> "" Then

        Set appOutLook = CreateObject("Outlook.Application")
        Set MailOutLook = appOutLook.CreateItem(olMailItem)

        With MailOutLook
            .BodyFormat = olFormatRichText
            .To = "[e-mail]"
            ''.cc = ""
            ''.bcc = ""
            .Subject = "text here"
            .HTMLBody = "text here"
            .Attachments.Add (strPath & strFile)
            .Send
            '.Display    'Used during testing without sending (Comment out .Send if using this line)
        End With
    Else
        MsgBox "No file matching " & strPath & strFilter & " found." & vbCrLf & _
                "Processing terminated.
        Exit Sub    'This line only required if more code past End If
    End If

End Sub

回答2:

heres code i found on one of the forums and cant remember where, but i modified it slightly this gives you full path of the file, it searches folder and subfolders using wildcard

Function fSearchFileWild(FileName As String, Extenstion As String)
Dim strFileName As String
Dim strDirectory As String

strFileName = "*" & FileName & "*." & Extenstion
strDirectory = "C:\Documents and Settings\"

fSearchFileWild = ListFiles(strDirectory, strFileName, True)

End Function

Public Function ListFiles(strPath As String, Optional strFileSpec As String, _
    Optional bIncludeSubfolders As Boolean, Optional lst As ListBox)
On Error GoTo Err_Handler

Dim colDirList As New Collection
Dim varItem As Variant

Call FillDir(colDirList, strPath, strFileSpec, bIncludeSubfolders)

Dim counter As Integer
counter = 0
Dim file1 As String
Dim file2 As String
Dim file3 As String


For Each varItem In colDirList
    If file1 = "" Then
    file1 = varItem
    counter = 1
    ElseIf file2 = "" Then
    file2 = varItem
    counter = 2
    ElseIf file3 = "" Then
    file3 = varItem
    counter = 3
    End If
Next
'if there is more than 1 file, msgbox displays first 3 files
If counter = 1 Then
ListFiles = file1
ElseIf counter > 1 Then
MsgBox "Search has found Multiple files for '" & strFileSpec & "', first 3 files are: " & vbNewLine _
        & vbNewLine & "file1: " & file1 & vbNewLine _
        & vbNewLine & "file2: " & file2 & vbNewLine _
        & vbNewLine & "file3: " & file3
ListFiles = "null"
Else
ListFiles = "null"
End If



Exit_Handler:

    Exit Function


Err_Handler:

    MsgBox "Error " & Err.Number & ": " & Err.Description

    Resume Exit_Handler

End Function

Private Function FillDir(colDirList As Collection, ByVal strFolder As String, strFileSpec As String, _
    bIncludeSubfolders As Boolean)
    'Build up a list of files, and then add add to this list, any additional folders
    Dim strTemp As String
    Dim colFolders As New Collection
    Dim vFolderName As Variant

    'Add the files to the folder.
    strFolder = TrailingSlash(strFolder)
    strTemp = Dir(strFolder & strFileSpec)
    Do While strTemp <> vbNullString
        colDirList.Add strFolder & strTemp
        strTemp = Dir
    Loop

    If bIncludeSubfolders Then
        'Build collection of additional subfolders.
        strTemp = Dir(strFolder, vbDirectory)
        Do While strTemp <> vbNullString
            If (strTemp <> ".") And (strTemp <> "..") Then
                If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0& Then
                    colFolders.Add strTemp
                End If
            End If
            strTemp = Dir
        Loop
        'Call function recursively for each subfolder.
        For Each vFolderName In colFolders
            Call FillDir(colDirList, strFolder & TrailingSlash(vFolderName), strFileSpec, True)
        Next vFolderName
    End If
End Function

Public Function TrailingSlash(varIn As Variant) As String
    If Len(varIn) > 0& Then
        If Right(varIn, 1&) = "\" Then
            TrailingSlash = varIn
        Else
            TrailingSlash = varIn & "\"
        End If
    End If
End Function