因此，我有一个宏，用于创建目录，重命名附件并在消息进入Outlook时按规则保存它。问题是如果3封电子邮件中的地址为
1个城市的主要大街123
456主街，城市2
789主要圣城3
它将保存在适当的文件夹中，并将根据地址适当地命名文件，但是当您进入文件时，所有文件都具有相同的信息，因此将附件保存为456 main st作为所有3个文件名。
这是我的代码：
Private Function CreateDir(FldrPath As String)
Dim Elm As Variant
Dim CheckPath As String
CheckPath = ""
For Each Elm In Split(FldrPath, "\")
CheckPath = CheckPath & Elm & "\"
If Len(Dir(CheckPath, vbDirectory)) = 0 Then
MkDir CheckPath
Debug.Print CheckPath & " Folder Created"
End If
Debug.Print CheckPath & " Folder Exist"
Next
End Function
Sub SaveEagleView(itm As Outlook.MailItem)
Dim strSubject As String, strExt As String
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim NextFriday As Date
Dim sFileName As String
Dim varAddress As Variant
Dim City As Variant
Dim fdObj As Object
Dim JobArea As String
Dim JobCity As Variant
Dim myPath As String
Dim myFinalPath As String
Dim objMsg As MailItem
Dim sFileExt As String
Set objMsg = Application.CreateItem(olMailItem)
Dim enviro As String
NextFriday = Date + 8 - Weekday(Date, vbFriday)
Set myfolder = Outlook.ActiveExplorer.CurrentFolder
Set fdObj = CreateObject("Scripting.FileSystemObject")
'Loop through emails in folder
For i = 1 To myfolder.Items.Count
Set myitem = myfolder.Items(i)
msgtext = myitem.Body
'Search for Specific Text
delimitedMessage = Right$(msgtext, Len(msgtext) - InStr(1, msgtext, "Address: ") - 8)
varAddress = Split(delimitedMessage, ",")
'Assign the job address from email to variable
sFileName = varAddress(0)
JobCity = RTrim(LTrim(varAddress(1)))
'Define office area based on job city
If JobCity = "Panama City" Or JobCity = "Mexico Beach" Or JobCity = "Panama City Beach" Or JobCity = "Lynn Haven" Or JobCity = "Port Saint Joe" Then
JobArea = "Panama"
ElseIf JobCity = "Daytona Beach" Or JobCity = "Port Orange" Or JobCity = "Deltona" Or JobCity = "Ormond Beach" Or JobCity = "Deland" Then
JobArea = "Daytona"
ElseIf JobCity = "Orlando" Then
JobArea = "Orlando"
ElseIf JobCity = "Jacksonville" Or JobCity = "Jacksonville Beach" Then
JobArea = "Jacksonville"
Else
JobArea = JobCity
End If
For Each objAtt In itm.Attachments
saveFolder = "C:\Users\admin\OneDrive\Documents\EagleView\" & Format$(NextFriday, "yyyy-mm-dd") & "\" & JobArea & "\"
CreateDir saveFolder
If Right(objAtt.FileName, 3) = "PDF" Then
sFileExt = ".pdf"
File = saveFolder & sFileName & sFileExt
objAtt.SaveAsFile File
End If
' With objMsg
' .To = "Careers@Email.com"
' .CC = "CustomerService@Email.com"
' .Subject = "New EagleView Needs Uploaded"
' .BodyFormat = olFormatPlain
' .Body = "A new EagleView has been received for the " & JobArea & " office. The file name is " & sFileName & " and needs to be uploaded. Thanks!"
' .Send
' End With
' Set objMsg = Nothing
Next
Next
Set objAtt = Nothing
End Sub
创建电子邮件的代码已被注释掉，因为它无法正常工作，但我想确保文件保存正常工作，然后再继续尝试使工作正常。
感谢您的所有帮助！
经过编辑以提供更多信息：
因此，电子邮件的正文中将包含以下内容：
•地址：州12345-1234市圣大街123
代码的编写方式应该并且似乎应该遍历该规则所适用的电子邮件，提取街道地址并将该值应用于sFileName，并且该部分可以正常工作遍历，并为每封通过的电子邮件获取正确的文件名；但是，它只是一次又一次地将该名称应用于同一文件。
运行规则说
在邮件到达后应用此规则
来自admin@email.com
并在主题中使用EagleView
并在其中加上$
并且仅在此计算机上
移到
并运行Project1.SaveEagleView
答案 0 :(得分：0)
我尚未测试此代码，它是简化版本，因此它所做的只是保存文件，并且我假设电子邮件已正确传递给该过程。
我看到的第一个问题是，如果一封电子邮件包含多个PDF附件-它将以相同的名称保存在同一文件夹中（因此第一个将被覆盖）。
Sub SaveEagleView(itm As MailItem)
Const SAVE_PATH As String = "C:\Users\admin\OneDrive\Documents\EagleView\"
Dim msgText As String
Dim delimitedMessage As String
Dim varAddress As Variant
Dim sFileName As String
Dim JobCity As String
Dim JobArea As String
Dim objAtt As Attachment
Dim NextFriday As String
Dim Save_Folder As String
NextFriday = Format(Date + 8 - Weekday(Date, vbFriday), "yyyy-mm-dd")
msgText = itm.Body
delimitedMessage = Right$(msgText, Len(msgText) - InStr(1, msgText, "Address: ") - 8)
varAddress = Split(delimitedMessage, ",")
sFileName = varAddress(0)
JobCity = Trim(varAddress(1)) 'TRIM does both LTRIM & RTRIM.
Select Case JobCity
Case "Panama City", "Mexico Beach", "Panama City Beach", "Lynn Haven", "Port Saint Joe"
JobArea = "Panama"
Case "Daytona Beach", "Port Orange", "Deltona", "Ormand Beach", "Deland"
JobArea = "Daytona"
Case "Jacksonville", "Jacksonville Beach"
JobArea = "Jacksonville"
Case Else
JobArea = JobCity 'Orlando would fall in here to.
End Select
Save_Folder = SAVE_PATH & NextFriday & "\" & JobArea & "\"
If Len(Dir(Save_Folder)) = 0 Then
MkDir Save_Folder
End If
If itm.Attachments > 0 Then
For Each objAtt In itm.Attachments
If GetExt(objAtt.FileName) = "PDF" Then
objAtt.SaveAsFile Save_Folder & sFileName & ".pdf"
End If
Next objAtt
End If
End Sub
Public Function GetExt(FileName As String) As String
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
GetExt = oFSO.GetExtensionName(FileName)
Set oFSO = Nothing
End Function
也很重要-
Tools〜Options Editor标签中，选中Require Variable Declaration。 这会将Option Explicit放在每个新模块的顶部，并强制您在使用前声明每个变量。
您的代码中有6个未声明的变量。拼写错误的变量将导致创建一个新变量，而旧变量将保留旧值或不保留任何值-可能导致混乱，甚至没有错误消息。
修改：
我不确定您是如何通过规则运行脚本的，因为它已将参数传递给了它。
我要做的方法是，每当电子邮件移动到该文件夹（手动移动或按规则移动）时，观察一个文件夹并运行脚本。
将此代码添加到ThisOutlookSession中，它将调用SaveEagleView过程，并将移至该文件夹的电子邮件传递给该过程。
您可能需要将过程MailItem中的SaveEagleView更改为Object。
第一行必须在模块的最顶部-在执行任何过程之前。
Dim WithEvents EagleView As Items
Private Sub Application_Startup()
Dim ns As Outlook.NameSpace
Set ns = Application.GetNamespace("MAPI")
'Rename to correct account/folder.
With ns.Folders.Item("EagleView").Folders.Item("Inbox")
Set EagleView = .Folders.Item("EagleView").Items
End With
End Sub
Private Sub EagleView_ItemAdd(ByVal Item As Object)
SaveEagleView Item
End Sub
Private Sub Application_Quit()
Set EagleView = Nothing
End Sub