Question

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

1）检查电子邮件是在内部还是外部发起的。（如果外部忽略）
2）检查电子邮件是否有附件。（如果没有附件，则忽略）
3）检查附件名称，应该像＆＃34;报告＆＃34; （全名一般是＃34;报告12198 blah blah.pdf＆＃34;）。（如果附件名称不是＆＃34;报告＆＃34;然后忽略）
4）将附件保存在G：\ Test
中 5）将电子邮件移动到名为＆＃34;已完成＆＃34;

的Outlook文件夹

我见过很多网站都有代码来保存附件，将电子邮件移动到文件夹但其他人似乎没有和我一样的问题;将这两者结合起来。

我最初认为我可以使用Outlook规则来帮助完成其中的一些操作，但到目前为止我的代码（用于保存附件）并没有显示为脚本。

此外，我已经在网站上阅读了（无法记住哪一个）您无法使用“每个人”的网站。在尝试执行诸如“移动”等操作时循环或者＆＃39;删除＆＃39;，所以我不太确定下面的代码是否可用。

非常感谢任何帮助。这是我目前的代码：

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。这可以在任何模块中，我不会把它放在这个展望中。

下面的代码可能如下所示。我确实复制了我自己的代码并将其更改为您的需求，我认为它应该可行。完成的文件夹必须是收件箱的子文件夹。邮件的主题将被更改，正如您在代码中看到的那样 - 这只是为了确保您知道邮件已完成的原因。如果作为文件的附件已存在于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)

编辑规则时，它将出现在功能列表中

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

3 个答案: