![](/img/trans.png)
[英]Excel Macro to Save Outlook 2010 attachment, oldest email to newest email
[英]Save attachment then move email in outlook 2010
我是 VB 新手,一直在努力尝试创建一个 VBA 宏,该宏将在收到电子邮件时自动执行以下任务:
1) 检查电子邮件是来自内部还是外部。 (如果外部忽略)
2) 检查电子邮件是否有附件。 (如果没有附件,则忽略)
3)查看附件名称,应该像“report”(全名一般是“Report 12198 blah blah.pdf”)。 (如果附件名称不像“报告”,则忽略)
4) 将附件保存在 G:\\Test
5) 将电子邮件移至名为“已完成”的 Outlook 文件夹
我见过很多网站都有保存附件、将电子邮件移动到文件夹的代码,但似乎没有其他人遇到过与我相同的问题; 结合这两者。
我最初认为我可以使用 Outlook 规则来帮助完成其中的一些工作,但是到目前为止我拥有的代码(用于保存附件)没有显示为脚本。
此外,我在一个网站(不记得是哪个)上读到,在尝试执行诸如“移动”或“删除”之类的操作时不能使用“For Each”循环,因此我不太了解确定下面的代码是否应该可用。
任何帮助将不胜感激。 这是我目前的代码:
Sub GetAttachments()
On Error GoTo GetAttachments_err
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim StringLength As Long
Dim FileName As String
Dim i As Integer
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
i = 0
If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
For Each Item In Inbox.Items
For Each Atmt In Item.Attachments
If Left(Atmt.FileName, 6) Like "*REPORT*" Then
StringLength = Len(Atmt.FileName)
FileName = "G:\Test\" & Left(Atmt.FileName, (StringLength - 13)) & Format(Item.CreationTime, "ddmmmyyyy") & ".pdf"
Atmt.SaveAsFile FileName
i = i + 1
End If
Next Atmt
Next Item
If i > 0 Then
MsgBox "I found " & i & " attached files." _
& vbCrLf & "I have saved them into the Test Folder." _
& vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!"
Else
MsgBox "I didn't find any attached files in your mail.", vbInformation, _
"Finished!"
End If
GetAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
GetAttachments_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 GetAttachments_exit
Exit Sub
End Sub
我认为问题出在声明部分。
尝试改变这一点:
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Atmt As Attachment
Dim Item as Object
有了这个:
Dim ns As outlook.NameSpace
Dim Inbox As outlook.MAPIFolder
Dim Atmt As outlook.Attachment
Dim Item as outlook.MailItem
然后在你的代码中,你只检查附件?
我似乎无法找到内部或外部的检查?
要检查收到的每封邮件,您必须执行以下操作:
首先放入“ThisOutlookSession”
Option Explicit
Private WithEvents objInspectors As Outlook.Inspectors
Public WithEvents myreceivedItems As Outlook.Items
Private Sub Application_Startup()
Set objInspectors = Outlook.Inspectors
Dim folder As Outlook.MAPIFolder
Set folder = oNamespace.GetDefaultFolder(olFolderInbox)
Set myreceivedItems = folder.Items
End Sub
Private Sub myreceivedItems_ItemAdd(ByVal ItemMail As Object)
If ItemMail.Class = olMail Then Call whatdotowithyourincomingmails(ItemMail, true)
End Sub
whatdotowithyourincomingmails 将是您收到的每封邮件都会调用的 Sub。 这可以在任何模块中,我不会把它放到这个outlooksession中。
那里的代码可能如下所示。 我确实复制了我自己的代码并将其更改为您的需求,我认为它应该可以工作。 完成的文件夹必须是收件箱的子文件夹。 正如您在代码中看到的那样,邮件的主题将被更改 - 这只是为了确保您知道邮件完成的原因。 如果附件作为文件已存在于 G:\\test 中,则忽略该附件。 当然,这可以以任何方式更改(添加时间戳,删除现有文件,...)只会移动邮件,这些邮件在名称开头只有一个带有“报告”的附件。 其他附件将被忽略。
Sub whatdotowithyourincomingmails (olitem As Outlook.MailItem, verschieben As Boolean)
'On Error GoTo exit_sub
Dim lngAttCount As Long, i As Long
Dim Datei As String
Dim anzahl_pdf As Integer
Dim anzahl As Integer
lngAttCount = olitem.Attachments.Count
anzahl_pdf = 0
'Zählen pdfs:
If lngAttCount = 0 Then GoTo Ende_nix
For i = lngAttCount To 1 Step -1
With olitem.Attachments.Item(i)
If LCase(Mid(.FileName, 1, 6)) = "report" Then anzahl_pdf = anzahl_pdf + 1
End With
Next i
'verarbeiten wenn 1 pdf
If Not anzahl_pdf = 1 Then GoTo Ende_nix
For i = lngAttCount To 1 Step -1
With olitem.Attachments.Item(i)
If not LCase(Mid(.FileName, 1, 6)) = "report" Then GoTo naechste
Datei = "g:\test\" & .FileName
If CreateObject("Scripting.FileSystemObject").FileExists(Datei) = True Then
GoTo Ende_nix
Else
.SaveAsFile Datei
anzahl = anzahl + 1
End If
End With
naechste:
Next i
olitem.Subject = olitem.Subject & " || autosaveandmove"
If verschieben = True Then
Call movesomewhereelse(olitem, "completed")
End If
Ende_nix:
exit_sub:
End Sub
Sub movesomewhereelse(olitem As MailItem, move_to_as string)
Dim olfolder As MAPIFolder
Dim folderPath As String
'the next line is looking in which Folder the item is; if you are always working with inbox it can be replaced by the path
folderPath = GetPath_auto(olitem)
Set olfolder = GetFolder(folderPath)
On Error GoTo exit_sub
Dim Subfolder As Outlook.MAPIFolder
Set Subfolder = olfolder.Folders(move_to_as)
olitem.UnRead = False
olitem.Move Subfolder
exit_sub: Exit Sub
End Sub
Public Function GetFolder(strFolderPath As String) As MAPIFolder
' strFolderPath needs to be something like
' "Public Folders\All Public Folders\Company\Sales" or
' "Personal Folders\Inbox\My Folder"
On Error GoTo schas
Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim colFolders As Outlook.Folders
Dim objFolder As Outlook.MAPIFolder
Dim arrFolders() As String
Dim i As Long
' On Error Resume Next
strFolderPath = Replace(strFolderPath, "\\", "")
strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")
Set objApp = Application
Set objNS = objApp.GetNamespace("MAPI")
Set objFolder = objNS.Folders.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For i = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(i))
If objFolder Is Nothing Then
Exit For
End If
Next
End If
Set GetFolder = objFolder
GoTo ende
schas:
'MsgBox ("Ordner für verschieben nicht gefunden")
ende:
Set colFolders = Nothing
Set objNS = Nothing
Set objApp = Nothing
End Function
Function GetPath_auto(Item As MailItem) As String
'gibt des gesamten Pfad des items zurück
Dim folder As Outlook.MAPIFolder
Dim folderPath As String
Set folder = Item.Parent
folderPath = folder.Name
Do Until folder.Parent = "Mapi" Or folder.Parent = "Freigegebene Daten" 'Or folder.Parent = "Stamm - Postfach"
Set folder = folder.Parent
folderPath = folder.Name & "\" & folderPath
Loop
GetPath_auto = folderPath
End Function
顺便说一句,如果您想使用脚本作为规则,请将函数定义为
Sub GetAttachments(mItem As MailItem)
然后在编辑规则时它会出现在函数列表中
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.