非PDF添付ファイルなしで選択した電子メールを転送する

Question

複数のPDF添付ファイルを含む完成した仕事用電子メールを送信しようとしていますが、PDFファイルのみを受信者に送信し、転送される。

P.S. pdfs、excels、imagesの組み合わせで1つ以上の添付ファイルがある場合がありますが、pdfsのみを転送する必要があります。私はその部分をコード化する方法を見つけることができません。私の既存のコードの下を参照してください。

 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

私はあなたのための2つのマクロを作成しました。

最初のInvestigateは、添付ファイルに関する情報をイミディエイトウィンドウに出力します。添付ファイルには4種類あります。 "標準"添付ファイルは "By Value"タイプのものです。私はOLEの添付ファイルを見たことがないし、そのような添付ファイルが何であるか分からない。私は他のタイプを見たことがありますが、長年はありませんでした。

第2のForwardEmailsWithoutNonPdfAttachments()は、求めている機能を示しています。自分のGmailアカウントの添付ファイルを含む電子メールを自分のOutlookアカウントに送信し、そのマクロを使用してPDF以外の添付ファイルを削除して送り返しました。これらの添付ファイルはすべて「By Value」添付ファイルでした。あなたが最初のマクロの理由である別の種類の添付ファイルで電子メールを転送しようとした場合、どうなるかわかりません。このマクロはそれほどエレガントではありませんが、目的を達成するために必要な技術を示しています。

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