2

この点を超えてこれを機能させる方法がわかりません。以下の私のコードは、添付ファイルを含む電子メールを 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

私はそこに着いていると思います。

4

2 に答える 2

3

適切な解決策を見つけたので、投稿された解決策に加えて、誰かが解決策を探している場合に備えて、これを追加したいと思いました. 私は午前 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
于 2012-12-05T17:42:48.047 に答える
0

フォーラムの 1 つで見つけた heres コードで、場所を思い出せませんが、わずかに変更しました。これにより、ファイルの完全なパスが得られ、ワイルドカードを使用してフォルダーとサブフォルダーが検索されます。

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
于 2012-12-05T04:31:58.107 に答える