时间戳

首页 > 解决方案 > Outlook VBA 脚本使用电子邮件正文中的信息自动保存附件以命名文件

outlook - Outlook VBA 脚本使用电子邮件正文中的信息自动保存附件以命名文件

问题描述

需要一个 VBA 脚本来自动保存附件，但需要使用电子邮件正文中的信息来命名保存的文件。电子邮件示例：

配送信息：

留言号码：246439839

本地号码：2395945852 远程 CSID：2399318665 远程 CID：2392780330 总页数：1

接收时间：2016 年 6 月 8 日上午 7:09:50 PDT 传输时间：32.000 秒

文件名将是：NM-246439839-LN-2395945852-CSID-2399318665-CID-2392780330.pdf

文件始终为 PDF 格式

本地号码、远程 CSID 和远程 CID 并不总是被填充（这就是为什么我需要它们都能够使用填充的任何一个进行过滤）。

消息 # 需要成为文件名的一部分，以确保每个文件的名称都是唯一的。

电子邮件是 HTML 格式，并且始终相同，因此可以使用标签，如果需要，我可以发布 HTML。

我已经创建了监视文件夹的脚本，然后根据文件名对文件进行排序/移动到适当的位置。这些电子邮件来自我们新的传真提供商，他们无法像我们以前的系统一样将这些添加到主题行。

目前使用：

Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
    saveFolder = "c:\Data\Fax"
    For Each objAtt In itm.Attachments
        objAtt.SaveAsFile saveFolder & "\" & objAtt.DisplayName
        Set objAtt = Nothing
    Next
End Sub

感谢您提供任何帮助。

标签： outlookrenameattachmentautosave

解决方案

只需参考示例代码，您可以根据需要对其进行更新：

Public p As String 'File Save location, also unzip the file storage location
Public Sub SaveAttach(Item As Outlook.MailItem)
    p = "C:\Users\Administrator.TXV6HLXTU3ZW8KD\Desktop\"
    SaveAttachment Item, p, "*.rar"  'Here *.rar can be changed to other regular expressions
    ' MsgBox "File saved."
End Sub

' save file
' path is the save path, condition is the attachment name match condition
Private Sub SaveAttachment(ByVal Item As Object, path$, Optional condition$ = "*")
    Dim olAtt As Attachment
    Dim i As Integer
    Dim m As Long
    Dim s As String
    If Item.Attachments.Count > 0 Then
        For i = 1 To Item.Attachments.Count
            Set olAtt = Item.Attachments(i)
            If olAtt.FileName Like condition Then
                olAtt.SaveAsFile path & olAtt.FileName
        'The following section is to extract the rar file, p is the save location
                s = "C:\Program Files\WinRAR\WinRAR.exe" & " X " & path & olAtt.FileName & " " & p 'Note Find the Decompression software location
                m = Shell(s, vbHide)
            End If
        Next
    End If
    Set olAtt = Nothing
End Sub

然后在Outlook中新建一个规则，选择执行脚本的动作，选择脚本这个方法，就可以将收到的邮件自动保存附件并解压到桌面。

推荐阅读