[问题求助] [已解决]小弟有個自動發E-mail的VBS問題

我不是是人

sdt = FormatDateTime(Date)
receiptions = "要發的E-mail"
Subject = "收文 " & sdt
Body = "附件是寄件收文，請查收。"
Attachments = Array("希望可以是當前文件夾內所有的PDF文件")
autoSend = False


' 以下代碼無需修改
Dim xOutLook
Dim xMail

On Error Resume Next
Set xOutLook = GetObject(, "Outlook.Application")
If xOutLook Is Nothing Then
    Set xOutLook = CreateObject("Outlook.Application")
End If
Set xMail = xOutLook.CreateItem(olMailItem)
With xMail
    .Display
    Dim signature
    signature = .HTMLBody
    .To = receiptions
    .Subject = Subject
    .HTMLBody = Body
    .Importance = olImportanceNormal  

    Dim xDoc
    Set xDoc = xMail.Application.ActiveInspector.WordEditor

    If IsArray(Attachments) Then
        Dim attachment
        For Each attachment In Attachments
            .Attachments.Add attachment
        Next
    End If

    .HTMLBody = .HTMLBody & signature

    If autoSend Then
        .Send
    Else
        .Display
    End If
End With
复制代码

這個VBS是上網找的,小弟有個希望,就是可以將當前文件夾內所有PDF都當成附件,例如:C:\Scan 這個文件夾內所有PDF都當成附件

aa77dd@163.com

Dim fso, f
Set fso = CreateObject("Scripting.FileSystemObject")
For Each f in fso.GetFolder("C:\Scan\").Files
   If fso.GetExtensionName(f.Path) = "PDF" Then
        .Attachments.Add f.Path
   End If
Next
复制代码

替换 31-36 行

我不是是人

回复 2# aa77dd@163.com

sdt = FormatDateTime(Date)
receiptions = "要發的E-mail"
Subject = "收文 " & sdt
Body = "附件是寄件收文，請查收。"
Attachments = Array("希望可以是當前文件夾內所有的PDF文件")
autoSend = False


' 以下代碼無需修改
Dim xOutLook
Dim xMail

On Error Resume Next
Set xOutLook = GetObject(, "Outlook.Application")
If xOutLook Is Nothing Then
    Set xOutLook = CreateObject("Outlook.Application")
End If
Set xMail = xOutLook.CreateItem(olMailItem)
With xMail
    .Display
    Dim signature
    signature = .HTMLBody
    .To = receiptions
    .Subject = Subject
    .HTMLBody = Body
    .Importance = olImportanceNormal  

    Dim xDoc
    Set xDoc = xMail.Application.ActiveInspector.WordEditor

Dim fso, f
Set fso = CreateObject("Scripting.FileSystemObject")
For Each f in fso.GetFolder("C:\Scan\").Files
   If fso.GetExtensionName(f.Path) = "PDF" Then
        .Attachments.Add f.Path
   End If
Next

    .HTMLBody = .HTMLBody & signature

    If autoSend Then
        .Send
    Else
        .Display
    End If
End With
复制代码

雖然沒有提示失敗,不過沒有自動附件,小弟有試過把第5行去掉,不過還是不行,小弟才疏學淺,是不是還有甚麼地方要改一改,還望大神賜學

aa77dd@163.com

回复 3# 我不是是人

可能是你的 PDF 文件的扩展名并非全是大写, 所以匹配失败, 稍加修改 加入了一个 UCase 函数, 避免大小写不匹配的问题, 在 win7 64位 Outlook 2003 环境用 VBA 宏实测成功发送附件

        Dim fso, f
        Set fso = CreateObject("Scripting.FileSystemObject")
        For Each f In fso.GetFolder("C:\Scan\").Files
            If UCase(fso.GetExtensionName(f.Path)) = "PDF" Then
                 .Attachments.Add f.Path
            End If
        Next
复制代码

我不是是人

回复 4# aa77dd@163.com

成功了!!! ^ 皿 ^  應該就像大神所說的這邊我的是小寫的.pdf  

親測成功解決問題~~~~成功上附件,成功直接送出~~~

謝謝大神的幫忙