VBA 将附件另存为主题字段

Question

希望有人可以帮助...在此先感谢！

我有很多电子邮件保存在硬盘上。每封电子邮件都包含与其他电子邮件同名的附件。我有一个工作宏（感谢 go Google），它将提取附件，保存到带有前缀的特定文件夹以防止覆盖。但我真正需要它做的是根据主题字段重命名文件。或者.. 至少能够从主题行中阅读一些信息。每封电子邮件都有一组数字，后跟括号内的四个字符。例如，主题将显示为... 已为您的客户成功处理 123456789 (123A) 应付账款。我希望将文件另存为 123456789_123A，并根据电子邮件中的文件数量添加 _1 或 _2，并从 XLSX 转换为 CSV。

我们运行每两周执行一次此过程，打开每封电子邮件并执行“另存为”操作非常耗时，因为我们要处理大约 70 封电子邮件，每封电子邮件都包含两个附件。

下面是我正在使用的代码。任何帮助将不胜感激！！

Option Explicit
Const csOutlookIn As String = "In"
Const csOutlookOut As String = "Out"
Const csFilePrefix As String = "file"
Sub Extract_Emails_Demo2()
Application.ScreenUpdating = False


Dim sCurrentFolder As String
sCurrentFolder = ActiveWorkbook.Path & "\"

Dim FSO As Scripting.FileSystemObject
Set FSO = New Scripting.FileSystemObject

Dim fldrOutlookIn As Scripting.Folder
Set fldrOutlookIn = FSO.GetFolder(sCurrentFolder & csOutlookIn)

Dim oApp As Outlook.Application
Set oApp = New Outlook.Application

Dim oMail As Outlook.MailItem
Dim oAttach As Outlook.Attachment

Dim fileItem As Scripting.File
Dim sAttachName As String
Dim lcounter As Long
lcounter = 0
Dim scounter As String
For Each fileItem In fldrOutlookIn.Files
Set oMail = oApp.CreateItemFromTemplate(fileItem.Path)
For Each oAttach In oMail.Attachments
lcounter = lcounter + 1
scounter = Format(lcounter, "000")
sAttachName = oAttach.Filename
sAttachName = sCurrentFolder & csOutlookOut & "\" & scounter & "_" & sAttachName
oAttach.SaveAsFile sAttachName
Next oAttach
Set oMail = Nothing
Next fileItem

MsgBox "Finished Extrating Files"
Application.ScreenUpdating = True
End Sub

提前致谢！

Answer 1

请测试下一个适配代码。它不会考虑没有任何附件的邮件，并且会发送包含电子邮件主题但不包含两个数字的消息。它使用两个函数来构建必要的名称以保存附件，打开它们，另存为 csv 并删除 xls* 工作簿：

Sub Extract_Emails_Demo2()
 Const csOutlookIn As String = "In", csOutlookOut As String = "Out"
 Const csFilePrefix As String = "file", prefixName As String = "abcdefg_"

 Dim sCurrentFolder As String
 sCurrentFolder = ActiveWorkbook.Path & "\"

 Dim FSO As Scripting.FileSystemObject
 Set FSO = New Scripting.FileSystemObject

 Dim fldrOutlookIn As Scripting.Folder
 Set fldrOutlookIn = FSO.GetFolder(sCurrentFolder & csOutlookIn)

 Dim oApp As Outlook.Application
 Set oApp = New Outlook.Application

 Dim oMail As Outlook.MailItem
 Dim oAttach As Outlook.Attachment

 Dim fileItem As Scripting.file, sAttachName As String, scounter As String
 Dim lcounter As Long, strSubject As String, arr, strNoPattern As String, strExt As String

 For Each fileItem In fldrOutlookIn.files
    Set oMail = oApp.CreateItemFromTemplate(fileItem.path)
    strSubject = oMail.Subject: lcounter = 0
    For Each oAttach In oMail.Attachments
        'Debug.Print oAttach.DisplayName: Stop
        lcounter = lcounter + 1
        arr = extrAllNumb(strSubject)             'extract an array of found numbers in the subject text
        sAttachName = buildName(arr, strSubject) 'build the name of the attachment to be saved
        If sAttachName = "" Then 'if no any number found in the subject
            strNoPattern = strNoPattern & fileItem & vbCrLf 'build the string of non conform Pattern files
            GoTo LoopEnd                         'skip the following code iteration lines
        End If
        strExt = Split(oAttach.DisplayName, ".")(UBound(Split(oAttach.DisplayName, ".")))
        sAttachName = sAttachName & "_" & lcounter 'add the attachment number
        sAttachName = sCurrentFolder & csOutlookOut & "\" & prefixName & sAttachName & "." & strExt
        oAttach.SaveAsFile sAttachName 'save the attachment using the above built name
        If strExt Like "xls*" Then     'saving excluding extension as pdf, doc, txt etc.
            Dim wb As Workbook, CSVName As String
            Application.ScreenUpdating = False     'some optimization for opening wb and process it
             Set wb = Workbooks.Open(sAttachName)  'open the workbook
             CSVName = Replace(sAttachName, "." & strExt, ".csv") 'build the csv name
             wb.saveas CSVName, xlCSV              'save the wb as csv
             wb.Close False                        'close the wb without saving
            Application.ScreenUpdating = True
             Kill sAttachName                      'delete the original attachment xls* file
        End If
    Next oAttach
LoopEnd:
 Next fileItem
 MsgBox "Finished Extrating Files"
 If strNoPattern <> "" Then MsgBox "Wrong pattern files: " & vbCrLf & strNoPattern
End Sub

Function buildName(arr As Variant, strSubject As String) As String
  Dim lngStart As Long, strChar As String
  If Not IsArray(arr) Then buildName = "": Exit Function
  If UBound(arr) >= 1 Then
    lngStart = InStr(strSubject, arr(0)) + Len(CStr(arr(0)))
    strChar = Mid(strSubject, InStr(lngStart, strSubject, arr(1)) + Len(CStr(arr(1))), 1)
    'buildName = arr(0) & "_" & arr(1) & IIf(strChar = ")", "", strChar)
    buildName = arr(1) & IIf(strChar = ")", "", strChar) & "_" & arr(0)
  Else
    buildName = arr(0)
  End If
End Function

Private Function extrAllNumb(strVal As String) As Variant
    Dim res As Object, El, arr, i As Long
    With CreateObject("VBscript.RegExp")
        .Pattern = "(\d{3,10})"
        .Global = True
        If .Test(strVal) Then
            Set res = .Execute(strVal)
            ReDim arr(res.count - 1)
            For Each El In res
                arr(i) = El: i = i + 1
            Next
        End If
    End With
    extrAllNumb = arr
End Function

如果有什么地方不够清楚，请不要犹豫，要求澄清。

VBA 将附件另存为主题字段

VBA to save attachments as subject field

csv

excel

outlook

vba

office-automation