0

我是 VB 新手，一直在努力尝试创建一个 VBA 宏，该宏将在收到电子邮件时自动执行以下任务：

1) 检查电子邮件是来自内部还是外部。（如果外部忽略）
2) 检查电子邮件是否有附件。（如果没有附件，则忽略）
3）检查附件名称，应如“report”（全名一般为“Report 12198 blah blah.pdf”）。（如果附件名称不是“report”则忽略）
4) 将附件保存在 G:\Test
5) 将电子邮件移动到名为“Completed”的 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
4

3 回答 3

0

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

首先放入“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
于 2013-11-06T14:45:10.840 回答
0

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?

于 2013-11-06T09:21:44.203 回答
0

顺便说一句，如果您想将脚本用作规则，请将函数定义为

Sub GetAttachments(mItem As MailItem)

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

于 2013-11-07T09:41:23.653 回答