Bilder innerhalb der PST nach dem Empfang verkleinern

Dim WithEvents m_objMailItem As MailItem
Dim WithEvents m_objExpl As Explorer
Dim m_IsMailFolder As Boolean
 
Private Sub m_objExpl_Close()
    If Application.Explorers.Count > 0 Then
        Set m_objExpl = Application.ActiveExplorer
    Else
        Set m_objExpl = Nothing
        Set m_objMailItem = Nothing
    End If
End Sub
 
Private Sub m_objExpl_FolderSwitch()
    Dim objFolder As MAPIFolder
    Set objFolder = m_objExpl.CurrentFolder
    If objFolder.DefaultItemType = olMailItem Then
        m_IsMailFolder = True
    Else
        m_IsMailFolder = False
    End If
    Set objFolder = Nothing
End Sub
 
Private Sub m_objExpl_SelectionChange()
    If m_IsMailFolder Then
        Dim objItem As Object
        Dim objAction As Outlook.Action
        If m_objExpl.Selection.Count > 0 Then
            Set objItem = m_objExpl.Selection(1)
            If objItem.Class = olMail Then
                Set m_objMailItem = objItem
                If m_objMailItem.Attachments.Count > 0 Then
                    Set objAction = m_objMailItem.Actions("Bilder verkleinern")  
                    If objAction Is Nothing Then
                        Set objAction = m_objMailItem.Actions.Add
                        With objAction
                            .Enabled = True
                            .Name = "Bilder verkleinern"  
                            .ShowOn = olMenu
                        End With
                        m_objMailItem.Save
                    End If
                End If
            End If
        End If
        Set objItem = Nothing
        Set objAction = Nothing
    End If
End Sub

Private Sub m_objMailItem_CustomAction(ByVal Action As Object, ByVal Response As Object, Cancel As Boolean)
    Cancel = True
    Select Case Action.Name
        Case "Bilder verkleinern"  
            resizeMailImages m_objMailItem
    End Select
End Sub

Sub resizeMailImages(Item As MailItem)
    Dim objMail As MailItem, Att As Attachment, arrFiles() As String, tempfolder As String, imgOrigTempFolder As String, imgResizedTempFolder As String, counter As Integer
    Set fso = CreateObject("Scripting.FilesystemObject")  
    Set regex = CreateObject("vbscript.regexp")  
    regex.IgnoreCase = True
    regex.Global = True
    Set objMail = Item
    tempfolder = Environ("Temp")  
    imgOrigTempFolder = tempfolder & "\img_orig"        'temp folder for original attachments  
    imgResizedTempFolder = tempfolder & "\img_res"      'temp folder for resized attachments  
    counter = 0     'counter for arrDel() Array  
    If objMail.Attachments.Count > 0 Then               'if there are attachments ...  
        'valid extensions for image resizing  
        arrValidExt = Array("jpg", "jpeg", "png", "bmp", "gif", "tiff", "tif")  
    
        For Each Att In objMail.Attachments
            strExt = LCase(fso.GetExtensionName(Att.FileName))  'get extension of attachment  
            For i = 0 To UBound(arrValidExt)
                If strExt = arrValidExt(i) Then         'if extension ist valid to be resized  
                    'check if attachment is normal attachment not inline  
                    patternFix = Replace(Att.FileName, ".", "\.", , , vbTextCompare)  
                    patternFix = Replace(patternFix, "[", "\[", , , vbTextCompare)  
                    patternFix = Replace(patternFix, "]", "\]", , , vbTextCompare)  
                    patternFix = Replace(patternFix, "^", "\^", , , vbTextCompare)  
                    patternFix = Replace(patternFix, "$", "\$", , , vbTextCompare)  
                    patternFix = Replace(patternFix, "+", "\+", , , vbTextCompare)  
                    patternFix = Replace(patternFix, "(", "\(", , , vbTextCompare)  
                    patternFix = Replace(patternFix, ")", "\)", , , vbTextCompare)  
                    regex.pattern = "<img [^>]*src=""[^""]*(" & patternFix & ")[^""]*"""  
                    Set myMatches = regex.Execute(objMail.HTMLBody)
                    If myMatches.Count = 0 Then     'attachment ist normal attachment not inline  
                        ReDim Preserve arrFiles(counter)
                        arrFiles(counter) = Att.FileName
                        counter = counter + 1
                        Exit For
                    End If
                End If
            Next
        Next
        
        If counter > 0 Then
            'check if folders exist  
            If Not fso.FolderExists(imgOrigTempFolder) Then
                MkDir (imgOrigTempFolder)
            End If
            If Not fso.FolderExists(imgResizedTempFolder) Then
                MkDir (imgResizedTempFolder)
            Else
                If fso.GetFolder(imgResizedTempFolder).Files.Count > 0 Then
                    fso.GetFolder(imgResizedTempFolder).Delete (True)
                End If
                MkDir (imgResizedTempFolder)
            End If
            
            'Resize Images  
            Set imageResizer = CreateObject("ImageresizerCom.ImageResizerCom")  
            For i = 0 To UBound(arrFiles)
                'assemble Paths to images in filesystem  
                imgOrigPath = imgOrigTempFolder & "\" & fso.GetBaseName(arrFiles(i)) & "_" & tobase36(CLng((Now() - #1/1/1970#) * 86400)) & "." & LCase(fso.GetExtensionName(arrFiles(i)))  
                imgResizedPath = imgResizedTempFolder & "\" & arrFiles(i)  
                'save attachment in message to filesystem  
                objMail.Attachments(arrFiles(i)).SaveAsFile (imgOrigPath)
                'Resize Image with custom function library  
                imageResizer.ResizeImage imgOrigPath, imgResizedPath, 500
            Next
            Set imageResizer = Nothing
             'Delete the original Attachments from message  
            For i = 0 To UBound(arrFiles)
                objMail.Attachments(arrFiles(i)).Delete
            Next
            're-add resized images as attachments  
            For Each file In fso.GetFolder(imgResizedTempFolder).Files
                objMail.Attachments.Add file.Path
            Next
            'delete folder with resized images  
            fso.GetFolder(imgResizedTempFolder).Delete (True)
            'Speichere Mail  
            objMail.Save
        End If
    
    End If
    Set fso = Nothing
    Set regex = Nothing
End Sub

Private Sub Application_Startup()
  '...  
  Set m_objExpl = Application.ActiveExplorer
End Sub

Private Sub Application_Startup()

  Set m_objExpl = Application.ActiveExplorer

Private Sub Application_Startup()
    On Error Resume Next
    Set fso = CreateObject("Scripting.FilesystemObject")  
    tempfolder = Environ("Temp")  
    imgOrigTempFolder = tempfolder & "\img_orig"  
    imgResizedTempFolder = tempfolder & "\img_res"  
    If fso.FolderExists(imgOrigTempFolder) Then
        fso.GetFolder(imgOrigTempFolder).Delete
    End If
    If fso.FolderExists(imgResizedTempFolder) Then
        fso.GetFolder(imgResizedTempFolder).Delete
    End If

    Set m_objExpl = Application.ActiveExplorer
    Set fso = Nothing
End Sub