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

Question

I'm new to VB and have been struggling to try and create a VBA macro that will automatically perform the following tasks upon email receival:

1) Checks to see if the email originated internally, or externally. (If external ignore)
2) Checks to see if the email has an attachment. (If no attachment, then ignore)
3) Checks the attachment name, should be like "report" (full name is generally "Report 12198 blah blah.pdf"). (If attachment name is not like "report" then ignore)
4) Save the attachment in G:\\Test
5) Move the email to an Outlook folder named "Completed"

I've seen many sites that have code for saving attachments, moving emails to folders but no one else seems to have had the same issue as me; combining these two.

I initially thought I could use Outlook Rules to help do some of this, but the code I have so far (for saving attachments) doesn't show up as a script.

In addition I've read on a site (can't remember which one) that you can't use a 'For Each' loop when trying to do things such as 'Move' or 'Delete', so I'm not too sure if the code below should be useable.

Any help would be greatly appreciated. This is the code I have at the moment:

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

I think the problem is in the declaration part.
Try to change this:

Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Atmt As Attachment
Dim Item as Object

with this:

Dim ns As outlook.NameSpace
Dim Inbox As outlook.MAPIFolder
Dim Atmt As outlook.Attachment
Dim Item as outlook.MailItem

Then in your code, you only check for the attachments?
I can't seem to find the checking for internal or external?

Answer 2

to check every incoming mail when received you have to do the following:

First put in "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 would be the Sub that is called with every mail you receive. This can be in any module, I would not put it into thisoutlooksession.

the code there could be like below. I did copy my own code and changed it to your Needs, I think it should work. The Folder completed has to be a subfolder of your inbox. The subject of the mail will be changed, as you can see in the code - this is just to make sure you know why the mail is in completed. If the attachment as file already exists in G:\\test, the attachment is ignored. Of course that could be changed in any way (adding timestamp, ideleting existing files,...) Only mails will be moved, that have exactly one attachment with "Report" at the beginning of the Name. Other attachments will be ignored.

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

By the way, if you want to use your script as a rule, define function as

Sub GetAttachments(mItem As MailItem)

It will then appear in the list of functions when editing a rule