保存附件然后在 Outlook 2010 中移动电子邮件

Question

我是 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

Answer 1

我认为问题出在声明部分。
尝试改变这一点：

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

那么在您的代码中，您只检查附件？
我似乎找不到内部或外部检查？

Answer 2

要检查收到的每封邮件，您必须执行以下操作：

首先放入“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

Answer 3

顺便说一句，如果你想使用你的脚本作为一个规则，定义函数为

Sub GetAttachments(mItem As MailItem)

编辑规则时会出现在函数列表中