Question

我正在尝试发送包含多个PDF附件的已完成的工作电子邮件，我希望只将PDF文件发送给收件人，并避免任何其他附件，例如excel文件或图像文件仅转发pdf。

P.S。注意电子邮件可能包含多个附件，其中包含pdfs，excels和images的组合，但只有pdf必须转发。我无法找到如何编写该部分的代码。请参阅下面我现有的代码。

        Sub Send2Recipient()

        ' Send Completed Message to Recipient

        On Error Resume Next

        Dim oApp As Outlook.Application
        Dim objFolder As Outlook.MAPIFolder
        Set oApp = New Outlook.Application
        Set objNS = Application.GetNamespace("MAPI")
        Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
        Set objFolder = objInbox.Folders("Helpdesk")
        Dim oEmail As Outlook.MailItem
        Dim strFile As String
        Dim sFileType As String

        'Require that this procedure be called only when a message is selected
        If Application.ActiveExplorer.Selection.Count = 0 Then
            Exit Sub
        End If

        For Each objItem In Application.ActiveExplorer.Selection
            If objFolder.DefaultItemType = olMailItem Then
                If objItem.Class = olMail Then
                    Response = MsgBox("Forward message (" + item.Subject + ") to Appended Subject")

                    Set myforward = objItem.Forward
                    myforward.Body = "Scan Only"
                    myforward.Subject = "Scan Only"
                    myforward.Recipients.Add "DHL.GB01PREV@dhl.com"
                    myforward.Display
                End If
            End If
        Next

        End Sub

更新了VBA脚本

        Sub Send2New()

        ' Send Completed Message to Accenture

        On Error Resume Next

        Dim oApp As Outlook.Application
        Dim objFolder As Outlook.MAPIFolder
        Set oApp = New Outlook.Application
        Set objNS = Application.GetNamespace("MAPI")
        Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
        'Set objFolder = objInbox.Folders("Helpdesk")
        Dim oEmail As Outlook.MailItem
        Dim strFile As String
        Dim sFileType As String
        Dim bk, fg As Integer

        'Require that this procedure be called only when a message is selected
        If Application.ActiveExplorer.Selection.Count = 0 Then
            Exit Sub
        End If

        For Each objItem In Application.ActiveExplorer.Selection
            If objFolder.DefaultItemType = olMailItem Then
                If objItem.Class = olmail Then
                    Response = MsgBox("Forward message (" + Item.Subject + ") to Appended Subject")

                    Set myforward = objItem.Forward
                    myforward.Body = "Scan Only"
                    myforward.Subject = "Scan Only"
                    myforward.Recipients.Add "xyz@abc.com"
                    myforward.Display

                    bk = myforward.Attachments.Count
                    fg = 1
                    For i = 1 To bk
                        If InStr(LCase(myforward.Attachments(fg).FileName), ".pdf") = 0 Then
                            myforward.Attachments(fg).Delete
                            Else: fg = fg + 1
                        End If
                    Next i

                    End If
            End If
        Next

        End Sub

Answer 1

我为你创建了两个宏。

第一个Investigate输出有关立即窗口附件的信息。附件有四种类型。 “标准”附件的类型为“按价值”。我从未见过OLE附件，也不知道这样的附件是什么。我见过其他类型，但多年没见。

第二个ForwardEmailsWithoutNonPdfAttachments()演示了您寻求的功能。我已将包含从我的Gmail帐户中选择的附件的电子邮件发送到我的Outlook帐户，并使用该宏将其发送回去，同时删除了非PDF附件。这些附件都是“按价值”附件。我不确定如果您尝试使用其他类型的附件转发电子邮件会发生什么，这是第一个宏的原因。这个宏不是很优雅，但它展示了实现目标所需的技术。

Option Explicit
Public Sub Investigate()

  Dim AttachType As String
  Dim Exp As Outlook.Explorer
  Dim InxAttach As Long
  Dim ItemCrnt As MailItem
  Dim NumAttach As Long
  Dim NumSelected As Long

  Set Exp = Outlook.Application.ActiveExplorer

  NumSelected = Exp.Selection.Count

  If NumSelected = 0 Then
    Debug.Print "No emails selected"
  Else
    For Each ItemCrnt In Exp.Selection
      With ItemCrnt
        Debug.Print "From: " & .SenderName & " | Subject: " & .Subject
        For InxAttach = 1 To .Attachments.Count
          ' There are four types of attachment:
          '  *   olByValue       1
          '  *   olByReference   4
          '  *   olEmbeddedItem  5
          '  *   olOLE           6
          With .Attachments(InxAttach)
            Select Case .Type
              Case olByValue
               AttachType = "Val"
              Case olEmbeddeditem
                AttachType = "Ebd"
              Case olByReference
                AttachType = "Ref"
              Case olOLE
                AttachType = "OLE"
              Case Else
                AttachType = "Unk"
            End Select
            Debug.Print AttachType & " " & .FileName & " | " & .DisplayName
          End With  ' .Attachments(InxAttach)
        Next  ' ItemCrnt
      End With
    Next
  End If

End Sub
Sub ForwardEmailsWithoutNonPdfAttachments()

  Dim AttachType As String
  Dim Exp As Outlook.Explorer
  Dim InxAttach As Long
  Dim ItemCopy As MailItem
  Dim ItemOrig As MailItem
  Dim NumAttach As Long
  Dim NumSelected As Long

  Set Exp = Outlook.Application.ActiveExplorer

  NumSelected = Exp.Selection.Count

  If NumSelected = 0 Then
    Debug.Print "No emails selected"
  Else
    For Each ItemOrig In Exp.Selection

      Set ItemCopy = ItemOrig.Copy
      With ItemCopy
        .Subject = "FW: " & .Subject
        ' Delete all original recipients
        Do While .Recipients.Count > 0
          .Recipients.Remove (1)
        Loop
        ' Add new recipient
        .Recipients.Add "tonydallimore23@gmail.com"
        If .Attachments.Count > 0 Then
          For InxAttach = .Attachments.Count To 1 Step -1
            With .Attachments(InxAttach)
              ' This will stop the macro if an attachment is not a regular attachment
              Debug.Assert .Type = olByValue
              If LCase(Right$(.FileName, 4)) <> ".pdf" Then
                .Delete
              End If
            End With  ' .Attachments(InxAttach)
          Next InxAttach
        End If
        .Send
      End With  ' ItemCopy
      Set ItemCopy = Nothing
    Next ItemOrig
  End If

End Sub

转发所选电子邮件而不包含非PDF附件

1 个答案: