Question

我不知道如何让这件事超越这一点。我的代码发送一封包含MS Access 2010附件的电子邮件。

问题是如果它需要一个固定的文件名，我的文件名会改变，因为我使用的是每个文件末尾的日期。示例：green_12_04_2012.csv。如果文件夹为空或目录更改，我也不知道如何使其失败。它会很好地跳到下一个子而不是崩溃。

我的代码：

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 = "bob@builder.com"
    ''.cc = ""
    ''.bcc = ""
    .Subject = "text here"
    .HTMLBody = "text here"
    .Attachments.Add (strGetFileName & "*.csv")
    .Send
End With
End Sub

我想我到了那儿。

Answer 1

我找到了一个合适的解决方案，除了发布的解决方案之外，我想添加这个以防任何人都在寻找解决方案。我一直工作到凌晨3点，这是一个非常受欢迎的问题，但是在循环附加特定文件夹中的所有文件方面没有任何解决方案。

以下是代码：

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 = "bob@builder.com"
            ''.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

Answer 2

我在其中一个论坛上找到的继承人代码，无法记住在哪里，但我稍微修改了一下这为您提供了文件的完整路径，它使用通配符

搜索文件夹和子文件夹

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

从包含动态名称附件的Access DB发送电子邮件

2 个答案: