![](/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.