Consulting

Results 1 to 5 of 5

Thread: Remove attachments like image001.png (typically from sugnatures)

  1. 08-26-2015, 06:46 AM #1
    bmdo
    bmdo is offline
    VBAX Regular
    Joined
    Jan 2015
    Posts
    25
    Location

    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.... How can I combine these 2
    Sorry, I am still a newbie

    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

    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
    Reply With Quote Reply With Quote
  2. 08-26-2015, 02:14 PM #2
    skatonni
    skatonni is offline
    VBAX Mentor skatonni's Avatar
    Joined
    Jun 2006
    Posts
    347
    Location
    Application_ItemSend code goes in ThisOutlookSession
    To debug, mouse-click anywhere in the code. Press F8 repeatedly to step through the code. http://www.cpearson.com/excel/DebuggingVBA.aspx

    If your problem has been solved in your thread, mark the thread "Solved" by going to the "Thread Tools" dropdown at the top of the thread. You might also consider rating the thread by going to the "Rate Thread" dropdown.
    Reply With Quote Reply With Quote
  3. 08-31-2015, 02:40 AM #3
    bmdo
    bmdo is offline
    VBAX Regular
    Joined
    Jan 2015
    Posts
    25
    Location
    Quote Originally Posted by skatonni View Post
    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?
    Reply With Quote Reply With Quote
  4. 08-31-2015, 04:22 AM #4
    gmayor
    gmayor is offline
    VBAX Guru gmayor's Avatar
    Joined
    Aug 2014
    Posts
    3,118
    Location
    You could shorten the line 
    If InStr(Item.Attachments(i).FileName, "image") > 0 And Right(Item.Attachments(i).FileName, 4) = ".png" Then
    to 
    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.
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com
    Reply With Quote Reply With Quote
  5. 09-01-2015, 06:20 AM #5
    bmdo
    bmdo is offline
    VBAX Regular
    Joined
    Jan 2015
    Posts
    25
    Location
    I will try - thanks
    Reply With Quote Reply With Quote
« Previous Thread | Next Thread »

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  

Forum Rules