VBA将附件保存为主题字段

Question

希望有人能帮忙…提前感谢!

我有许多电子邮件被保存到硬盘驱动器。每封邮件都包含与其他邮件相同名称的附件。我有一个工作宏(感谢谷歌)，将提取附件，保存到一个特定的文件夹与前缀，以防止覆盖。但我真正需要它做的是根据主题字段重命名文件。或. .至少能够从主题行读到一些信息。每封电子邮件都有一组数字，后面有四个字符。例如，主语会读…为您的客户成功处理了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

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