Remove attachments like image001.png (typically from sugnatures)

Hi,

found this code - and just pasted it to my existing code (at the bottom)
But it does not work.... :crying: How can I combine these 2 :)
Sorry, I am still a newbie

Code:

---

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)


'if attachments are there
    If Item.Attachments.Count > 0 Then

        'for all attachments
        For i = Item.Attachments.Count To 1 Step -1

            'if the attachment's filename is similar to "image###.png", remove
            If InStr(Item.Attachments(i).FileName, "image") > 0 And Right(Item.Attachments(i).FileName, 4) = ".png" Then
                Item.Attachments.Remove (i)
            End If

        Next
    End If
End Sub

---

My existing code

Code:

---

Option Explicit

Private oReceivedMail As Outlook.MailItem
Private oNewMail As Outlook.MailItem
Private isShowing As Boolean

Public Function isReadyToRun() As Integer
    Dim oFSO As Object
    Dim sRes As Integer
   
    isReadyToRun = Error.doNoError
   
    sRes = Settings.isReadyToRun
    If sRes = Error.doNoError Then
        Set oFSO = CreateObject("Scripting.FileSystemObject")
        If Not oFSO.fileExists(Environ$("APPDATA") + Settings.GetSettingValue("Base", "RootPath") + Settings.GetSettingValue("PurchaseOrder", "TemplateFilePO1") + ".html") And _
            oFSO.fileExists(Environ$("APPDATA") + Settings.GetSettingValue("Base", "RootPath") + Settings.GetSettingValue("PurchaseOrder", "TemplateFilePO2") + ".html") And _
            oFSO.fileExists(Environ$("APPDATA") + Settings.GetSettingValue("Base", "RootPath") + Settings.GetSettingValue("PurchaseOrder", "TemplateFilePO3") + ".html") And _
            oFSO.fileExists(Environ$("APPDATA") + Settings.GetSettingValue("Base", "RootPath") + Settings.GetSettingValue("PurchaseOrder", "TemplateFilePO4") + ".html") And _
            oFSO.fileExists(Environ$("APPDATA") + Settings.GetSettingValue("Base", "RootPath") + Settings.GetSettingValue("PurchaseOrder", "TemplateFilePO5") + ".html") Then
            isReadyToRun = Error.doFileDoesNotExist
        Else
            If isShowing Then isReadyToRun = Error.doFormAlreadyShowing
        End If
    Else
        isReadyToRun = sRes
    End If
   
    Set oFSO = Nothing
End Function

Public Sub Startup()
    isShowing = False
End Sub

Public Sub Shutdown()
    Set oReceivedMail = Nothing
    Set oNewMail = Nothing
End Sub

Public Sub Sync()
    Dim oFSO As Object
   
    Set oFSO = CreateObject("Scripting.FileSystemObject")
   
    If doPing = 0 Then
        If oFSO.fileExists(Settings.GetSettingValue("PurchaseOrder", "LiveTemplatePath") + Settings.GetSettingValue("PurchaseOrder", "TemplateFilePO1") + ".html") Then
            ' We have access to live template file
           
            If oFSO.fileExists(Environ$("APPDATA") + Settings.GetSettingValue("Base", "RootPath") + Settings.GetSettingValue("PurchaseOrder", "TemplateFilePO1") + ".html") Then
                ' remember to delete current cached template before anything else
                Call oFSO.DeleteFile(Environ$("APPDATA") + Settings.GetSettingValue("Base", "RootPath") + Settings.GetSettingValue("PurchaseOrder", "TemplateFilePO1") + ".html")
            End If
           
            Call oFSO.CopyFile(Settings.GetSettingValue("PurchaseOrder", "LiveTemplatePath") + Settings.GetSettingValue("PurchaseOrder", "TemplateFilePO1") + ".html", Environ$("APPDATA") + Settings.GetSettingValue("Base", "RootPath") + Settings.GetSettingValue("PurchaseOrder", "TemplateFilePO1") + ".html", True)
        End If
       
        If oFSO.fileExists(Settings.GetSettingValue("PurchaseOrder", "LiveTemplatePath") + Settings.GetSettingValue("PurchaseOrder", "TemplateFilePO2") + ".html") Then
            ' We have access to live template file
           
            If oFSO.fileExists(Environ$("APPDATA") + Settings.GetSettingValue("Base", "RootPath") + Settings.GetSettingValue("PurchaseOrder", "TemplateFilePO2") + ".html") Then
                ' remember to delete current cached template before anything else
                Call oFSO.DeleteFile(Environ$("APPDATA") + Settings.GetSettingValue("Base", "RootPath") + Settings.GetSettingValue("PurchaseOrder", "TemplateFilePO2") + ".html")
            End If
           
            Call oFSO.CopyFile(Settings.GetSettingValue("PurchaseOrder", "LiveTemplatePath") + Settings.GetSettingValue("PurchaseOrder", "TemplateFilePO2") + ".html", Environ$("APPDATA") + Settings.GetSettingValue("Base", "RootPath") + Settings.GetSettingValue("PurchaseOrder", "TemplateFilePO2") + ".html", True)
        End If
       
        If oFSO.fileExists(Settings.GetSettingValue("PurchaseOrder", "LiveTemplatePath") + Settings.GetSettingValue("PurchaseOrder", "TemplateFilePO3") + ".html") Then
            ' We have access to live template file
           
            If oFSO.fileExists(Environ$("APPDATA") + Settings.GetSettingValue("Base", "RootPath") + Settings.GetSettingValue("PurchaseOrder", "TemplateFilePO3") + ".html") Then
                ' remember to delete current cached template before anything else
                Call oFSO.DeleteFile(Environ$("APPDATA") + Settings.GetSettingValue("Base", "RootPath") + Settings.GetSettingValue("PurchaseOrder", "TemplateFilePO3") + ".html")
            End If
           
            Call oFSO.CopyFile(Settings.GetSettingValue("PurchaseOrder", "LiveTemplatePath") + Settings.GetSettingValue("PurchaseOrder", "TemplateFilePO3") + ".html", Environ$("APPDATA") + Settings.GetSettingValue("Base", "RootPath") + Settings.GetSettingValue("PurchaseOrder", "TemplateFilePO3") + ".html", True)
        End If
       
        If oFSO.fileExists(Settings.GetSettingValue("PurchaseOrder", "LiveTemplatePath") + Settings.GetSettingValue("PurchaseOrder", "TemplateFilePO4") + ".html") Then
            ' We have access to live template file
           
            If oFSO.fileExists(Environ$("APPDATA") + Settings.GetSettingValue("Base", "RootPath") + Settings.GetSettingValue("PurchaseOrder", "TemplateFilePO4") + ".html") Then
                ' remember to delete current cached template before anything else
                Call oFSO.DeleteFile(Environ$("APPDATA") + Settings.GetSettingValue("Base", "RootPath") + Settings.GetSettingValue("PurchaseOrder", "TemplateFilePO4") + ".html")
            End If
           
            Call oFSO.CopyFile(Settings.GetSettingValue("PurchaseOrder", "LiveTemplatePath") + Settings.GetSettingValue("PurchaseOrder", "TemplateFilePO4") + ".html", Environ$("APPDATA") + Settings.GetSettingValue("Base", "RootPath") + Settings.GetSettingValue("PurchaseOrder", "TemplateFilePO4") + ".html", True)
        End If
       
        If oFSO.fileExists(Settings.GetSettingValue("PurchaseOrder", "LiveTemplatePath") + Settings.GetSettingValue("PurchaseOrder", "TemplateFilePO5") + ".html") Then
            ' We have access to live template file
           
            If oFSO.fileExists(Environ$("APPDATA") + Settings.GetSettingValue("Base", "RootPath") + Settings.GetSettingValue("PurchaseOrder", "TemplateFilePO5") + ".html") Then
                ' remember to delete current cached template before anything else
                Call oFSO.DeleteFile(Environ$("APPDATA") + Settings.GetSettingValue("Base", "RootPath") + Settings.GetSettingValue("PurchaseOrder", "TemplateFilePO5") + ".html")
            End If
           
            Call oFSO.CopyFile(Settings.GetSettingValue("PurchaseOrder", "LiveTemplatePath") + Settings.GetSettingValue("PurchaseOrder", "TemplateFilePO5") + ".html", Environ$("APPDATA") + Settings.GetSettingValue("Base", "RootPath") + Settings.GetSettingValue("PurchaseOrder", "TemplateFilePO5") + ".html", True)
        End If
    End If
    Set oFSO = Nothing
End Sub

Private Sub cmdCancel_Click()
    Me.Hide
    isShowing = False
    If Not oNewMail Is Nothing Then
        oNewMail.Delete
    End If
    Set oReceivedMail = Nothing

End Sub

Private Sub cmdSubmit_Click()

    Dim oFSO As Scripting.FileSystemObject
    Dim oFS As Scripting.TextStream
    Dim sTmp, sOrderRef, sText, sTemplate, sTmpSubject As String
    Dim i As Integer
     
   
    If doPing = 0 Then
            ' ping and then go go go
           
                           
                oNewMail.Subject = Replace(oNewMail.Subject, "RE: ", "", , , vbTextCompare)
                oNewMail.Subject = Replace(oNewMail.Subject, "FW: ", "", , , vbTextCompare)
           
                sTmpSubject = oNewMail.Subject
                If txtOrderRef.Value = True Then
                                     
                    'sTmpSubject = "Danoffice" + " " + "ref" + " " + txtOrderRef.Value + " - " + sTmpSubject
                    sTmpSubject = sTmpSubject + " " + "Danoffice" + " " + "ref" + " " + txtOrderRef.Value
                   
                End If
                oNewMail.Subject = sTmpSubject
                               
               
            ' choose template file
           
            If Me.rbPO1 = True Then sTemplate = Settings.GetSettingValue("PurchaseOrder", "TemplateFilePO1")
            If Me.rbPO2 = True Then sTemplate = Settings.GetSettingValue("PurchaseOrder", "TemplateFilePO2")
            If Me.rbPO3 = True Then sTemplate = Settings.GetSettingValue("PurchaseOrder", "TemplateFilePO3")
            If Me.rbPO4 = True Then sTemplate = Settings.GetSettingValue("PurchaseOrder", "TemplateFilePO4")
            If Me.rbPO5 = True Then sTemplate = Settings.GetSettingValue("PurchaseOrder", "TemplateFilePO5")
   
           
            oNewMail.To = oReceivedMail.SenderEmailAddress
                       
            ' if cbCheckMark.value then
                ' Kigger KUN på recipients in i receivedmail og ikke sender.
                For i = 1 To oReceivedMail.Recipients.Count
                    If InStr(1, oReceivedMail.To, oReceivedMail.Recipients.Item(i).AddressEntry, vbTextCompare) Then oNewMail.To = oNewMail.To + ";" + oReceivedMail.Recipients.Item(i).Address
                    If InStr(1, oReceivedMail.CC, oReceivedMail.Recipients.Item(i).AddressEntry, vbTextCompare) Then oNewMail.CC = oNewMail.CC + ";" + oReceivedMail.Recipients.Item(i).Address
                Next
                       
                ' Remove @Danoffice.com from To and CC
                ' HUSK at der SKAL stå " - Danoffice IT" ifm brugeren i AD!!! Ellers virker denne funktion ikke
                'Call SharedFunctionality.doRemoveRecipient(oNewMail, "danoffice")
            'end if
           
            oNewMail.Recipients.ResolveAll
                                   
            Set oFSO = CreateObject("Scripting.FileSystemObject")
           
           
            ' Path to document you want to parse
            Set oFS = oFSO.OpenTextFile(Environ$("APPDATA") + Settings.GetSettingValue("Base", "RootPath") + sTemplate + ".html")
       
            'Copy the open document
            Do Until oFS.AtEndOfStream
                sText = oFS.ReadAll()
            Loop
           
            sText = Replace(sText, "<Contact>", txtcontact.Value, , , vbTextCompare)
            oNewMail.BodyFormat = olFormatHTML
                           
           
            Call SharedFunctionality.CopyAttachments(oReceivedMail, oNewMail)
           
            oNewMail.Display
           
            ' capture signature AFTER the mail has been displayed, otherwise the signature will not have been rendered and will disappear.
            oNewMail.HTMLBody = "<body font-size=11pt>" & sText & oNewMail.HTMLBody & oReceivedMail.HTMLBody & "</body>"
       
            ' exit gracefully and hide form
            Me.Hide
           
            isShowing = False
        Else
            Call Error.doThrowError("PurchaseOrder", Error.doUnableToPing)
        End If
   

    Set oFSO = Nothing
    Set oFS = Nothing
    Set oNewMail = Nothing
    Set oReceivedMail = Nothing
 

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = 0 Then Cancel = True
End Sub

Private Sub UserForm_Activate()
   
    Dim oCurrentItem As Outlook.MailItem
    Dim isThisAForward As Boolean
   
    Set oCurrentItem = SharedFunctionality.doGetCurrentMailItem
   
   
    If Not oCurrentItem Is Nothing Then
       
            Set oReceivedMail = oCurrentItem
           
            Set oNewMail = oReceivedMail.Reply
         
    End If
   
    With Me
        .rbPO1.Value = False
        .rbPO2.Value = False
        .rbPO3.Value = False
        .rbPO4.Value = False
        .rbPO5.Value = False
        .txtcontact.Value = ""
        .txtOrderRef.Value = ""
    End With
   
    isShowing = True
    Set oCurrentItem = Nothing
   
    Me.txtcontact.SetFocus
   
       
End Sub

---

Application_ItemSend code goes in ThisOutlookSession

Quote:

---

Originally Posted by skatonni

Application_ItemSend code goes in ThisOutlookSession

---

Ok, so can I copy the ItemSend code to This Outlook session - and call it from my macro?
Or how is this done?:yes

You could shorten the line

Code:

---

If InStr(Item.Attachments(i).FileName, "image") > 0 And Right(Item.Attachments(i).FileName, 4) = ".png" Then

---

to

Code:

---

IF Item.Attachments(i).FileName Like "image*.*" Then

---

Just move the code to the ThisOutlookSession module and it runs automatically whenever you send a message. You don't have to call it.

I will try - thanks :)