我对编程非常陌生，并且一直在使用Excel中的VBA（宏录制器）。
我将按月发送大约500份批量支出，收入和预算报告，这些报告都有自己独特的主题。示例主题行将是＆＃34;报告001＆＃34;我想将Excel附件保存为＆＃34;项目A 2016＆＃34;。如果主题是＆＃34;报告002＆＃34;然后将文件另存为＆＃34; Project B 2015＆＃34;等
另一个想法是引用一个使用vLookup的Excel表来保存文件名是合适的。这一切都是新的，而且我没有方向。
**更新** 7/7/2017
根据我的需求编写的代码发布在下面。该代码基于http://www.fontstuff.com/outlook/oltut01pfv.htm。
代码会收集包含特定主题的电子邮件，并在我的桌面上保存具有特定命名约定的文件。
我可以提高代码效率吗？由于这是一个包含4个电子邮件主题的块，并且我可以批量生成500个，是否可以创建一个引用csv文件的循环？
Sub GetAttachments6()
' This Outlook macro checks a named subfolder in the Outlook Inbox
' (here the "Sales Reports" folder) for messages with attached
' files of a specific type (here file with an "xls" extension)
' and saves them to disk. Saved files are timestamped. The user
' can choose to view the saved files in Windows Explorer.
' NOTE: make sure the specified subfolder and save folder exist
' before running the macro.
On Error GoTo SaveAttachmentsToFolder_err
' Declare variables
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim varResponse As VbMsgBoxResult
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("AutoRunReport") ' Enter correct subfolder name.
i = 0
' Check subfolder for messages and exit of none found
If SubFolder.Items.Count = 0 Then
MsgBox "There are no messages in the AutoRunReport folder.", vbInformation, _
"Nothing Found"
Exit Sub
End If
' Check each message for attachments
For Each Item In SubFolder.Items
For Each Atmt In Item.Attachments
If Left(Item.Subject, 36) = "Monthly Auto Gen Report CY LD01_0210" Then
FileName = "C:\Users\drowan\Desktop\TestTestTest\" & "LAB 2016 11 ENY 2016 0290000210 ADMIN" & ".pdf"
Atmt.SaveAsFile FileName
i = i + 1
End If
If Left(Item.Subject, 36) = "Monthly Auto Gen Report PY LD01_0210" Then
FileName = "C:\Users\drowan\Desktop\TestTestTest\" & "LAB 2016 11 ENY 2015 0290000210 ADMIN" & ".pdf"
Atmt.SaveAsFile FileName
i = i + 1
End If
If Left(Item.Subject, 37) = "Monthly Auto Gen Report PPY LD01_0210" Then
FileName = "C:\Users\drowan\Desktop\TestTestTest\" & "LAB 2016 11 ENY 2014 0290000210 ADMIN" & ".pdf"
Atmt.SaveAsFile FileName
i = i + 1
End If
If Left(Item.Subject, 36) = "Monthly Auto Gen Report CY LD01_0215" Then
FileName = "C:\Users\drowan\Desktop\TestTestTest\" & "LAB 2016 11 ENY 2016 0290000215 HR" & ".pdf"
Atmt.SaveAsFile FileName
i = i + 1
End If
Next Atmt
Next Item
' Show summary message
If i > 0 Then
varResponse = MsgBox("I found " & i & " attached files." _
& vbCrLf & "I have saved them into the C:\Desktop\TestTestTest folder." _
& vbCrLf & vbCrLf & "Would you like to view the files now?" _
, vbQuestion + vbYesNo, "Finished!")
' Open Windows Explorer to display saved files if user chooses
If varResponse = vbYes Then
Shell "Explorer.exe /e,C:\Users\drowan\Desktop\TestTestTest\", vbNormalFocus
End If
Else
MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
End If
' Clear memory
SaveAttachmentsToFolder_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
' Handle Errors
SaveAttachmentsToFolder_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume SaveAttachmentsToFolder_exit
End Sub
答案 0 :(得分：0)
这里有一些代码可以解析附件名称并从中
计算文件名它适用于给出的四个例子
Sub GetAttachments6()
' This Outlook macro checks a named subfolder in the Outlook Inbox
' (here the "Sales Reports" folder) for messages with attached
' files of a specific type (here file with an "xls" extension)
' and saves them to disk. Saved files are timestamped. The user
' can choose to view the saved files in Windows Explorer.
' NOTE: make sure the specified subfolder and save folder exist
' before running the macro.
On Error GoTo SaveAttachmentsToFolder_err
Dim folderItems As Items
Set folderItems = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("AutoRunReport").Items
If folderItems.Count = 0 Then ' Check subfolder for messages and exit of none found
MsgBox "There are no messages in the AutoRunReport folder.", _
vbInformation, "Nothing Found"
GoTo ok_exit
End If
Dim Item As Object
Dim Atmt As Attachment
Dim subjElm() As String ' array of subject line elements
Dim fileName As String
Dim year As String
Dim deptNum As String
Dim deptName As String
Dim saveLocation As String
saveLocation = "C:\Users\drowan\Desktop\TestTestTest\"
Const sep As String = " " ' separator between elements of resulting filename
Dim filePrefix As String
filePrefix = "LAB" & sep & "2016" & sep & "11" & sep & "ENY" ' begining of each filename
' guesses and assumptions made:
' LD01_0215 and 0290000xxx signify department numbers
' last digit of department number (eg. LD01_0215) is department type
' cy, py, ppy .. are year codes
' "Monthly Auto Gen Report CY LD01_0210" ==> "LAB 2016 11 ENY 2016 0290000210 ADMIN"
' "Monthly Auto Gen Report PY LD01_0210" ==> "LAB 2016 11 ENY 2015 0290000210 ADMIN"
' "Monthly Auto Gen Report PPY LD01_0210" ==> "LAB 2016 11 ENY 2014 0290000210 ADMIN"
' "Monthly Auto Gen Report CY LD01_0215" ==> "LAB 2016 11 ENY 2016 0290000215 HR"
Dim i As Integer
i = 0
For Each Item In folderItems ' Check each message for attachments
For Each Atmt In Item.Attachments
subjElm = Split(LCase(Item.Subject), " ", , vbTextCompare) ' split subject line into an array of words (zero based array)
' lcase function converts subject line to lower case
' 0 1 2 3 4 5 ' resulting index values of each element
' [Monthly][Auto][Gen][Report][PY][LD01_0210] ' example subject line split into elements
Select Case Trim(subjElm(4))
Case "cy"
year = "2016"
Case "py"
year = "2015"
Case "ppy"
year = "2014"
Case Else ' unspecified year
year = "noYear"
End Select
deptNum = "029000" & Split(subjElm(5), "_")(1) ' [LD01_0210] ==> [LD01][0210]
Select Case Right(Trim(subjElm(5)), 1) ' last character of LD01_0210
Case "0"
deptName = "ADMIN"
Case "5"
deptName = "HR"
Case Else ' unspecified department
deptName = "noDeptName"
End Select
fileName = saveLocation & filePrefix & sep & year & sep & deptNum & sep & deptName & ".xls"
Debug.Print "file path: " & fileName
Atmt.SaveAsFile fileName
i = i + 1
Next Atmt
Next Item
If i > 0 Then ' Show summary message
Dim varResponse As VbMsgBoxResult
varResponse = MsgBox("I found " & i & " attached file(s)." & vbCrLf _
& "I have saved them into the following folder:" & vbCrLf & vbCrLf _
& saveLocation & vbCrLf & vbCrLf _
& "Would you like to view the files now?" _
, vbQuestion + vbYesNo, "Finished!")
If varResponse = vbYes Then
Shell "Explorer.exe /e," & saveLocation, vbNormalFocus ' Open Windows Explorer to display saved files
Else
MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
End If
End If
GoTo ok_exit
' Handle Errors
SaveAttachmentsToFolder_err:
MsgBox "An unexpected error has occurred." & vbCrLf _
& "Please note and report the following information." & vbCrLf & vbCrLf _
& "Macro Name:" & vbTab & "GetAttachments" & vbCrLf & vbCrLf _
& "Error Number:" & vbTab & Err.Number & vbCrLf & vbCrLf _
& "Error Description:" & vbTab & Err.Description _
, vbCritical, "Error!"
ok_exit:
Set Atmt = Nothing ' Clear memory
Set Item = Nothing
Set folderItems = Nothing
End Sub