PDF olmayan ekleri olmayan seçili e-postaları yönlendirin

Question

Birden çok PDF eki içeren tamamlanmış bir iş e-postası göndermeye çalışıyorum, yalnızca alıcıya PDF dosyalarını göndermek ve excel dosyaları veya yalnızca görüntü dosyaları gibi diğer tüm bağlantılardan kaçınmak istiyorum iletilmelidir.

P.S. Not e-postası, pdfs, excel, imajların kombinasyonu ile 1'den fazla eke sahip olabilir, ancak yalnızca pdfs'nin iletilmesi gerekir. Bu kısmı nasıl kodlayacağımı bulamıyorum. lütfen mevcut kodumun altında görün.

 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 

---

Sana iki makro yarattık

 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

VBA komut dizisini güncellendi.

İlk, Investigate, Anlık Pencereye eklerle ilgili bilgi verir. Dört çeşit bağlantı vardır. Bir “standart” ek, “Değere Göre” türündendir. OLE ekini hiç görmedim ve böyle bir ekin ne olduğunu bilmiyorum. Diğer türleri gördüm ama yıllarca değil.

İkincisi, ForwardEmailsWithoutNonPdfAttachments(), aradığınız işlevi gösterir. Gmail hesabımdaki ekleri içeren e-postaları Outlook hesabım için gönderdim ve silinen PDF olmayan eklerle geri göndermek için makroyu kullandım. Bu eklerin hepsi “Değer” ekleri idi. E-postaları, ilk makronun nedeni olan başka türdeki eklerle iletmeyi denediğinizde ne olacağından emin değilim. Bu makro çok zarif değil ama amacınızı karşılamak için gerekli teknikleri göstermektedir.

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