zunaras
Sep 18, 2013
view7164
view15
0
Goto Top

Outlook 2010 VBA für JPG Bilder komprimieren und Senden

GermansolvedQuestionOutlook MailMicrosoft
Schönen guten Tag,

im Outlook 2010 kann man in der Nachricht über Datei -> Informationen -> Größe von Bildern beim senden anpassen.

Da das Umschalten bei den Mitarbeitern immer vergessen wird, wollte ich mal nachfragen, ob man das über VBA realisieren kann.
Also bei Klick auf Senden nach JPG im Anhang suchen und diese automatisch verkleinern und Nachricht absenden.

Wir arbeiten nicht mit Exchange.

Viele Grüße
Zunaras
comment-contentCommentShareShare
Share on Facebook Share on Twitter Share on Reddit Share on Linkedin

Content-Key: 217226

Url: https://administrator.de/contentid/217226

Printed on: April 23, 2024 at 16:04 o'clock

15 Comments
Latest comment
Goto Top
Member: colinardo
colinardo Sep 18, 2013, updated at Sep 20, 2013 at 12:27:46 (UTC)
Goto Top
Hallo Zunaras,
du könntest die User daran gewöhnen diese Methode anzuwenden um Bilder zu verschicken. Im Explorer > Bilder markieren > Rechtsklick auf die Bilder > Senden an > E-Mail-Empfänger. Dann müssen sie die Bildgröße im Dialog angeben bevor die Mail angezeigt wird.
Die Option die du meinst lässt sich nicht via VBA steuern, man müsste dazu dann schon z.B. eine native .NET-Bibliothek benutzen die die Bilder verkleinert und wieder an die Mail anhängt. Dazu musst du aber entweder ein Plugin schreiben oder eine COM-Bibliothek mit der entsprechenden Funktionen registrieren, oder die Windows API-Funktionen nutzen.
Werde bei Zeiten mal schauen ob sich da was dazu basteln lässt...

Grüße Uwe
Member: Zunaras
Zunaras Sep 18, 2013 at 10:21:44 (UTC)
Goto Top
Hallo colinardo,

vielen Dank für die Rückmeldung.

Das mit dem "senden an" habe ich hier bereits angesprochen. Die Option hat allerdings auch wieder kleinere Probleme.
Es öffnet sich die neue Nachricht. Leider kann man dann die Anhänge nicht sehen. Die Zeile unter dem Betreff fehlt komplett, obwohl die Datei vorhanden ist. Man kann sie wieder sichtbar machen, indem man unten rechts den Personenbereich erweitert. Ich habe das bisher auf jedem Client so gesehen.
Man kann die Anhänge zur Kontrolle nicht mit einem Doppelklick oder sonst wie öffnen.
Das Nachrichten-Fenster hat Priorität. Man kommt nicht an das Hauptfenster von Outlook.
Beim Antworten einer Nachricht entfällt das "senden an".
Wenn die Nachricht verschickt wurde, landet sie in der lokalen Outlook.pst und nicht im IMAP-Konto. Selbst eine eingerichtete Regel zum automatischen Verschieben ins IMAP funktioniert nicht. Muss immer manuell geschehen.

Mehr fällt mir jetzt grad nicht ein. face-wink

Viele Grüße
Zunaras
Member: colinardo
colinardo Sep 18, 2013, updated at Apr 25, 2017 at 11:48:59 (UTC)
Goto Top
So, habe zum Thema mal was zusammengebaut...(funktioniert auch mit Outlook 2013)

Unten stehender Code funktioniert nur im Zusammenhang mit meinem folgendem Assembly (.NET 2.0) das ein COM-Objekt mit einer Funktion zum Ändern der Bildgröße bereitstellt.
Download des Assemblies (selbstextrahierendes RAR-Archiv mit Installationsfunktion)
  • Zuerst installiert man das Assembly als Admin - es ist ein selbsextrahierendes RAR-Archiv das nach dem entpacken fragt ob man es installieren will. (Wer mir nicht vertraut kann das Archiv mit WinRAR entpacken und findet dort den Quellcode des AutoIT-Installers - ich habe halt versucht es so einfach wie möglich für euch zu gestallten)
  • Der Code muss in Oulook im VBA-Editor (ALT-F11) in ThisOutlookSession eingefügt werden.
  • Die max. Bildgröße die die reduzierten Bilder haben sollen legt man in Zeile 4 fest. Im Beispiel werden die Bilder auf 800 Pixel verkleinert, je nachdem welche Bildseite länger ist.
Kurz zur Vorgehensweise des Scripts: Nur Attachments mit den Dateierweiterungen "jpg", "jpeg", "png", "bmp", "gif", "tiff", "tif" werden vor dem Sendevorgang in einen temporären Ordner gesichert, dann mit der benutzerdefinierten COM-Funktion verkleinert, danach die ursprünglichen Attachments entfernt (natürlich nur die Bilder andere Attachments bleiben erhalten) und die verkleinerten Bilder wieder hinzugefügt. Da beim Speichervorgang der Original-Attachments Outlook Dateireferenzen auf diese Dateien im Speicher hält, kann dieser Ordner erst beim nächsten Start von Outlook gelöscht werden. Um Duplikate in diesem Ordner zu vermeiden, werden die Dateinamen mit einem Base36 kodierten String im Dateinamen ergänzt abgespeichert.

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    If Item.Class = olMail Then
        'Fit image in a rect of (n) pixels  
        IMG_FIT_PIXELS = 800
        Dim objMail As MailItem, Att As Attachment, arrDel() 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  
                            'check if folders exist  
                            If Not fso.FolderExists(imgOrigTempFolder) Then
                                MkDir (imgOrigTempFolder)
                            End If
                            If Not fso.FolderExists(imgResizedTempFolder) Then
                                MkDir (imgResizedTempFolder)
                            End If
                            'assemble Paths to images in filesystem  
                            imgOrigPath = imgOrigTempFolder & "\" & fso.GetBaseName(Att.FileName) & "_" & tobase36(CLng((Now() - #1/1/1970#) * 86400)) & "." & strExt  
                            imgResizedPath = imgResizedTempFolder & "\" & Att.FileName  
                            'save attachment in message to filesystem  
                            Att.SaveAsFile (imgOrigPath)
                            'Resize Image with custom function library  
                            Set imageResizer = CreateObject("ImageresizerCom.ImageResizerCom")  
                            imageResizer.ResizeImage imgOrigPath, imgResizedPath, IMG_FIT_PIXELS
                            Set imageResizer = Nothing
                            '-------------  
                            'add image name to array to delete it later  
                            ReDim Preserve arrDel(counter)
                            arrDel(counter) = Att.FileName
                            counter = counter + 1
                            Exit For
                        End If
                    End If
                Next
            Next
            If counter > 0 Then
                'Delete the original Attachments from message  
                For i = 0 To UBound(arrDel)
                    objMail.Attachments(arrDel(i)).Delete
                Next
                '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)
            End If
            
        End If
        Set fso = Nothing
        Set regex = Nothing
    End If
End Sub
Function tobase36(ByVal number As Long) As String
    Dim cList
    cList = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"  
    
    Dim finalString As String

    While Not number = 0
        If CInt(number Mod 36) = 0 Then
            finalString = finalString & Mid(cList, CInt(number Mod 36) + 1, 1)
        Else
            finalString = finalString & Mid(cList, CInt(number Mod 36), 1)
        End If
        number = number / 36
    Wend
    tobase36 = finalString
End Function

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

Eine Abfrage für den Benutzer ob er die Bilder verkleinert senden will habe ich noch nicht eingebaut, werde es aber bei Zeiten nachholen face-wink

Grüße Uwe
Member: Zunaras
Zunaras Sep 19, 2013 at 05:43:52 (UTC)
Goto Top
Hallo colinardo,

ich muss mich bei Dir bedanken. Das ist ja echt der Hammer !
Funktioniert prima!

Beim probieren ist mir aufgefallen, das die verkleinerten JPG nicht im Temp\img_res Ordner landen, sondern im Temp. Und werden wohl dementsprechend nicht gelöscht - wenn so vorgesehen.


Viele Grüße
Zunaras
Member: colinardo
colinardo Sep 19, 2013 at 06:20:55 (UTC)
Goto Top
Zitat von @Zunaras:
Hallo colinardo,
Beim probieren ist mir aufgefallen, das die verkleinerten JPG nicht im Temp\img_res Ordner landen, sondern im Temp. Und werden
wohl dementsprechend nicht gelöscht - wenn so vorgesehen.
kann aus Prinzip eigentlich nicht sein, die Variablen sind alle korrekt gesetzt! Vielleicht meinst du den "img_orig" Ordner dort landen die Originale, welche erst bei einem Neustart von Outlook gelöscht werden. Vielleicht hast du im Temp-Ordner noch alte Dateileichen liegen.
Kann dein Verhalten hier auf mehreren Systemen nicht nachvollziehen.

Grüße Uwe
Member: Zunaras
Zunaras Sep 19, 2013 updated at 07:25:14 (UTC)
Goto Top
Hallo,

wenn ich in %temp% reinschaue, finde ich direkt dort die verkleinerten und versendeten jpg, Es kommen nach jedem Senden auch neue hinzu. Ich habe bislang noch keinen "img_res" Odner gefunden
Der "img_orig" Ordner existiert - bis zum nächsten Neustart von Outlook.

EDIT: Thunderbird macht das!! Ich habe von Outlook auf ein anderes Konto geschickt, das mit Thunderbird läuft. Beim Aufruf des Bildes legt TB das Bild in den %Temp% ab.
Sorry! Ist alles gut.


Jetzt habe ich eine Fehlermeldung bekommen beim versenden einer eMail, wo ich ein kleines Bild zwischen den Text eingebunden habe. Diese soll/brauch er nicht komprimieren.

Der Debugger springt hier in die 2. Zeile:
            'Delete the original Attachments from message  
            For i = 0 To UBound(arrDel) - 1
                objMail.Attachments(arrDel(i)).Delete

Grüße
Zunaras
Member: colinardo
colinardo Sep 19, 2013 updated at 07:56:35 (UTC)
Goto Top
Zitat von @Zunaras:
Ich habe bislang noch keinen "img_res" Odner gefunden
Den wirst du auch nicht sehen, denn sobald die Bilder alle an die Mail angehängt wurden wird der auch sogleich wieder gelöscht, das geht sehr schnell. Dadurch das Outlook beim Anhängen der Bilder diese sowieso in einen eigenen temp-Ordner kopiert sind sie obsolet.
Jetzt habe ich eine Fehlermeldung bekommen beim versenden einer eMail, wo ich ein kleines Bild zwischen den Text eingebunden habe.
Diese soll/brauch er nicht komprimieren.
Diese Inline-Bilder werden bereits berücksichtigt und auch von der Bearbeitung ausgeschlossen.
Der Debugger springt hier in die 2. Zeile:
Stimmt da habe ich noch eine Überprüfung vergessen das überhaupt Bilder bearbeitet wurden, dadurch war das Array(arrDel) leer und es kam ein "Index out of Bounds" - habe es oben korrigiert...

Grüße Uwe
Member: Zunaras
Zunaras Sep 19, 2013 at 08:56:42 (UTC)
Goto Top
Hallo,

ich bedanke mich vielmals für Deine Hilfe face-smile
Das hat mir wahnsinnig geholfen!

Viele liebe Grüße
Zunaras
Member: colinardo
colinardo Sep 19, 2013, updated at Apr 25, 2017 at 11:49:55 (UTC)
Goto Top
Habe den obigen Code noch robuster gemacht und noch erweitert durch einen Dialog, in dem der Nutzer die Möglichkeit hat zu bestimmen ob die Bilder reduziert werden und wenn ja, in welcher Auflösung:

bb1a22ce4132d37388a5fb26bc6a27c2

Den Dialog könnt Ihr hier herunterladen -> Download
Um den Dialog einzubinden, Rechtsklick im VBA-Editor auf den Knoten Formulare > Importieren... und dann die runtergeladene entpackte Datei(*.frm) auswählen.

Zusätzlich muss die folgende Variable vor alle anderen Prozeduren ganz am Anfang von "ThisOutlookSession" eingesetzt werden:
Public RESIZE_RES As Long

back-to-topGeänderter Code für "ThisOutlookSession"
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    If Item.Class = olMail Then
        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 arrFiles() 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
                formResizeImages.Show   'show dialog to choose resolution  
                If RESIZE_RES > 0 Then  'check resolution from dialog  
                    '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, RESIZE_RES
                    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)
                End If
            End If

        End If
        Set fso = Nothing
        Set regex = Nothing
    End If
End Sub
Function tobase36(ByVal number As Long) As String
    Dim cList
    cList = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"  

    Dim finalString As String

    While Not number = 0
        If CInt(number Mod 36) = 0 Then
            finalString = finalString & Mid(cList, CInt(number Mod 36) + 1, 1)
        Else
            finalString = finalString & Mid(cList, CInt(number Mod 36), 1)
        End If
        number = number / 36
    Wend
    tobase36 = finalString
End Function

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

Grüße Uwe
Member: Zunaras
Zunaras Sep 19, 2013 at 13:57:04 (UTC)
Goto Top
Hallo nochmal und vielen Dank!

Wenn ich die Bilder als Originale senden möchte kommt ein Fehler.

Der Debugger springt in die 2. Zeile.

Private Sub btnSendOriginals_Click()
    ThisOutlookSession.RESIZE_RES = 0
    Me.Hide
End Sub

Grüße
Zunaras
Member: colinardo
colinardo Sep 19, 2013 updated at 14:02:38 (UTC)
Goto Top
dann hast du die zusätzliche öffentliche Variable :
Public RESIZE_RES As Long
nicht ganz an den Anfang von "ThisOutlookSession" eingefügt...(am besten in die erste Zeile) diese muss vor allen anderen Prozeduren stehen
und danach mal ein Neustart von Outlook.

Grüße Uwe
Member: Zunaras
Zunaras Sep 20, 2013 at 06:53:18 (UTC)
Goto Top
Hallo,

hm. Schau mal bitte das Bild. Ist das so nicht richtig?

6dacf5f5dc95bd3a306d2c7973b9b01d

Grüß
Zunaras
Member: colinardo
colinardo Sep 20, 2013 at 07:34:08 (UTC)
Goto Top
Ahhh, ich sehe deine Session heißt nicht "ThisOutlookSession" sondern "DieseOutlookSitzung" dann müssen diese beiden Prozeduren in der Form so heißen:
Private Sub btnSendOriginals_Click()
    DieseOutlookSitzung.RESIZE_RES = 0
    Me.Hide
End Sub

Private Sub btnSendReduced_Click()
    DieseOutlookSitzung.RESIZE_RES = Val(comboFormats.Value)
    Me.Hide
End Sub

Grüße Uwe
Member: Zunaras
Zunaras Sep 20, 2013 at 08:05:37 (UTC)
Goto Top
Das ist es gewesen. Funktioniert prima!

Ich danke Dir nochmals viele Male und wünsche ein schönes Wochenende.

Viele Grüße
Zunaras
Member: Zunaras
Zunaras Jun 01, 2018 at 08:28:17 (UTC)
Goto Top
Hallo colinardo,

ich hoffe, ich darf meinen alten Betrag noch mal benutzen und Du liest das hier.

Und zwar bin ich vor einigen Wochen auf Outlook 2016 umgestiegen. Solange der Code im Projekt vorhanden ist, verhält sich Outlook etwas merkwürdig.
Das Bilder verkleinern funktioniert erst nach dem zweiten oder dritten Versuch. Sowie dasselbe beim Löschen von Anhängen. Beim Beantworten von eMail wird nicht immer im Posteingang vermerkt, dass hierauf geantwortet wurde (kein Hinweistext und Symbol). Auch das Verschieben der eMail in einen anderen Ordner funktioniert manchmal nicht, und es kommt ein Hinweis, weil die Nachricht angeblich verändert wurde.

Bei den Verweisen habe ich folgendes aktiviert.
screenshot (29)

Ist hier ein Anpassung gegen eine Spende möglich?

siehe auch Bilder innerhalb der PST nach dem Empfang verkleinern

Viele Grüße
GermansolvedQuestionOutlook MailMicrosoft
Hotly discussed
gleixnerdCheck of ZFW Firewallgleixnerd - 5 CommentsjstrickerWireguard VPN on UDM Pro behind Fritzbox - Handshake did not completejstricker - 3 CommentsAlexWishaHow to set up and configure a Linux GRE tunnelAlexWisha - 3 Comments