Question

我正在尝试使用https://www.slipstick.com/developer/macro-send-files-email/的这段代码的修改版本将所有文件附加在单独的电子邮件中。

Dim fldName As String

Sub SendFilesbyEmail()
' From http://slipstick.me/njpnx
Dim sFName As String

i = 0
fldName = "C:\Users\Test"
sFName = Dir(fldName)
Do While Len(sFName) > 0
'filter for only *.txt
  If Right(sFName, 4) = ".txt" Then
      Call SendasAttachment(sFName)
      i = i + 1
  End If
  sFName = Dir
Loop
MsgBox i & " files were sent"
End Sub

Function SendasAttachment(fName As String)

Dim olApp As Outlook.Application
Dim olMsg As Outlook.MailItem
Dim olAtt As Outlook.Attachments

Dim localfName As String
Dim localfldName As String

Set olApp = Outlook.Application
Set olMsg = olApp.CreateItem(0) ' email
Set olAtt = olMsg.Attachments

' attach file
olAtt.Add (fldName & fName)
localfName = fName

   ' send message
With olMsg
  .Subject = "PDF Import: " & Left(localfName, Len(localfName) - 4)
  .To = "test@test.com"
  .HTMLBody = "Test"
  .Send
End With
End Function

该问题与尝试将文件名放入电子邮件主题有关。

.Subject = "PDF Import: " & Left(localfName, Len(localfName) - 4)

如果我从主题中删除localfName，以便为所有电子邮件发送通用主题，则代码可以正常工作。

当我输入fName或localfName（尝试调试问题）时，会发送第一封电子邮件，但是在第二次迭代中，DIR函数从另一个文件夹返回文件名，并且代码中断，因为该文件是找不到要附加的附件。

Answer 1

我将使用FileSystem对象，然后遍历目录中的所有文件，如下所示：

Sub SendFilesbyEmail()
    Dim objFSO as object
    Dim objFldr as Object
    Dim objFile  as Object

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFldr = objFSO.GetFolder("C:\Users\Test")

    For Each objFile In objFldr.Files 
        strFullPath = objFldr.Path  & "\" & objFile.Name

        If LCase(Trim(objFSO.GetExtensionName(strFullPath))) = "txt" Then
            SendasAttachment(strFullPath)
        End If
    Next


    set objFldr = nothing
    set objFSO = nothing
End Sub


Function SendasAttachment(fullPath As String)

    Dim olApp As Outlook.Application
    Dim olMsg As Outlook.MailItem
    Dim olAtt As Outlook.Attachments

    Dim localfName As String
    Dim localfldName As String

    Set olApp = Outlook.Application
    Set olMsg = olApp.CreateItem(0) ' email
    Set olAtt = olMsg.Attachments

    ' attach file
    olAtt.Add (fullPath)
    localfName = fName

      '  send message
    With olMsg
      .Subject = "PDF Import: " & Left(fullPath, Len(fullPath) - 4)
      .To = "test@test.com"
      .HTMLBody = "Test"
      .Send
    End With
End Function

将文件夹中的所有文件作为单独的附件发送

1 个答案: