Grafische Zwischenablage in Mail einfügen

Das Rohrpost-System aus Redmond dürfte wohl eines der wichtigsten Kommunikationssysteme weltweit sein. Leider können schon ein Versionswechsel oder die Umstellung von IMAP auf POP zu herben Datenverlusten führen. BackUps sind nirgends wichtiger als hier.
Benutzeravatar
d'r Bastler
Beiträge: 832
Registriert: 29. Aug 2022, 13:20
Hat sich bedankt: 224 Mal
Danksagung erhalten: 118 Mal

Grafische Zwischenablage in Mail einfügen

#1

Beitrag von d'r Bastler »

Moin allerseits,

einfach, weil es nicht einfach ist und weil es an anderer Stelle gefragt wurde (bisher nicht zielführend beantwortet): Hier eine VBA-Version für folgendes Szenario:
Der grafische Inhalt des Clipboards soll per VBA am Cursor einer OL-Mail eingefügt werden und in >step 2< in Größe und Zuschnitt bearbeitet werden.

Erst mal die Basics für VBA in OL:
Outlook öffnen > Datei > Optionen > Menüband anpassen > Klassisches Menüband anpassen > Entwicklertools aktivieren.
Jetzt steht der VBE entweder über dem Punkt Makros im neuen Tab oder über Alt+F11 bzw. Alt+F8 zur Verfügung.

Um den Verweis Microsoft Forms 2.0 Object Library zu aktivieren, der zumindest in meinem OL 2021 nicht verfügbar war, hilft dieser Trick: Im VBE eine Userform einfügen, das Projekt mit Strg+s speichern und die USF wieder entfernen.

Nun zu step 1:
An geeigneter Stelle ein Verzeichnis ClipBoard anlegen. Es wird später maximal eine Datei enthalten.
Im VBE ein neues Modul mdl_ClipToMail anlegen und den folgenden Code oben einfügen. Es sind die API-Funktionen, die das ClipBoard auslesen und in ein Bildobjekt schreiben.

Code: Alles auswählen

Option Explicit

Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long

Type GUID
    Data1 As Long: Data2 As Integer: Data3 As Integer: Data4(0 To 7) As Byte
End Type

Type PicBmp
    Size As Long: Type As Long: hBmp As Long: hPal As Long: Reserved As Long
End Type
Auf diese Funktionen greift die erste Sub SaveClipToPic() zu

Code: Alles auswählen

Private Sub SaveClipToPic()
Dim hBitmap As Long, sPath As String, Pic As PicBmp, IPic As IPicture
Dim IID_IDispatch As GUID
    
sPath = "C:\Users\hbri\Desktop\ClipBoard\Datei.bmp"
    
If OpenClipboard(0&) Then

    hBitmap = GetClipboardData(2) ' 2 = CF_BITMAP
    
    If hBitmap <> 0 Then
        With Pic
            .Size = Len(Pic)
            .Type = 1 ' Bildtyp
            .hBmp = hBitmap
            .hPal = 0
            .Reserved = 0
        End With
        
        With IID_IDispatch
            .Data1 = &H20400
            .Data4(0) = &HC0
            .Data4(7) = &H46
        End With
        
        OleCreatePictureIndirect Pic, IID_IDispatch, True, IPic
        
        SavePicture IPic, sPath
        MsgBox "Bild erfolgreich gespeichert unter: " & sPath
    Else
        MsgBox "Die Zwischenablage enthält kein Bild."
    End If
    
    CloseClipboard
Else
    MsgBox "Die Zwischenablage konnte nicht geöffnet werden."
End If

End Sub
Der dritte Codeblock holt die Bitmap-Datei in den Cursor in einer geöffneten Mail.

Code: Alles auswählen

Private Sub InsertPicAtCursor()
Dim objMail As Outlook.MailItem, objInspector As Outlook.Inspector
Dim objDoc As Object, objSelection As Object, sPath As String
    
sPath = "C:\Users\hbri\Desktop\ClipBoard\Datei.bmp"
    
Set objMail = Application.ActiveInspector.CurrentItem
Set objInspector = objMail.GetInspector
Set objDoc = objInspector.WordEditor
Set objSelection = objDoc.Application.Selection
    
objSelection.InlineShapes.AddPicture sPath, False, True
    
MsgBox "Bild erfolgreich eingefügt!"

End Sub
Letzter Schnipsel fürs Makro-Menü:

Code: Alles auswählen

Sub ClipToMail()
    SaveClipToPic
    InsertPicAtCursor
End Sub
Jetzt steht unter Alt-F8 die letzte Sub zum Aufruf zur Verfügung. Noch mal zum Ablauf:
Neue Mail anlegen oder Clipboard mit Screenshot füllen (hier ist die Reihenfolge egal)
Cursor positionieren
Mit Alt+F8 ClipToMail aufrufen.

step 2 wird dann eine automatische Formatierung des Pics sein. Dazu warte ich aber erst einmal auf Rückmeldungen zu step 1.

Als Ergänzung: Statt grafischem Inhalt, kann natürlich auch Text übergeben werden, kann OL auch noch geschlossen sein und in eine neue Mail schreiben, und die Übergabe aus anderen OFF-Anwendungen erfolgen. Falls gewünscht.

Schöne Grüße!
d'r Bastler von den VBAsteleien.de
Win 10 + Office 2019 & Win11 + Office 2021 + Visio 2019 pro & macOS.X15 + Office2019pro & Android12 & XL365
Benutzeravatar
d'r Bastler
Beiträge: 832
Registriert: 29. Aug 2022, 13:20
Hat sich bedankt: 224 Mal
Danksagung erhalten: 118 Mal

Re: Grafische Zwischenablage in Mail einfügen >step 2<

#2

Beitrag von d'r Bastler »

So - Freunde der spannenden Ideen!

Hier nun also step 2 - also die proportionale Anpassung der eingefügten Grafik. Dazu ist ein dritter Codeblock und eine Anpassung in einem der vorherigen notwendig. Die Anpassung der jeweils letzten Grafik in einer Mail auf 200 px / 5 cm Breite (das hängt von der Bildschirmauflösung ab und geht hier von 96 px/inch aus) funktioniert so:

Code: Alles auswählen

Private Sub SetPicSize()
Dim oMail As MailItem, oInspector As Inspector
Dim oDoc As Object, oShape As Object, dbRation As Double
Dim dbWidth As Double, dbHeight As Double

Set oMail = Application.ActiveInspector.CurrentItem
Set oInspector = Application.ActiveInspector
Set oDoc = oInspector.WordEditor
Set oShape = oDoc.InlineShapes(oDoc.InlineShapes.Count)
    dbRation = oShape.Height / oShape.Width
    dbWidth = 200
    dbHeight = dbWidth * dbRation

    oShape.Width = dbWidth
    oShape.Height = dbHeight
    
End Sub
Ich habe auch die Codes von oben noch einmal überarbeitet (unnötige MsgBoxen eliminiert, die motzen jetzt nur noch bei Fehlern, Nomenklatur standarisiert) und für die Integration des eigentliche dritten Schritts angepasst.
Man kann also den Code im mdlClipToMail vollständig durch diesen ersetzen:

Code: Alles auswählen

Option Explicit

Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long

Type GUID
    Data1 As Long: Data2 As Integer: Data3 As Integer: Data4(0 To 7) As Byte
End Type

Type PicBmp
    Size As Long: Type As Long: hBmp As Long: hPal As Long: Reserved As Long
End Type

Private Sub SaveClipToPic()
Dim hBitmap As Long, sPath As String, Pic As PicBmp, IPic As IPicture
Dim IID_IDispatch As GUID
    
sPath = "C:\Users\hbri\Desktop\ClipBoard\Datei.bmp"
    
If OpenClipboard(0&) Then

    hBitmap = GetClipboardData(2) ' 2 = CF_BITMAP
    
    If hBitmap <> 0 Then
        With Pic
            .Size = Len(Pic)
            .Type = 1 ' Bildtyp
            .hBmp = hBitmap
            .hPal = 0
            .Reserved = 0
        End With
        
        With IID_IDispatch
            .Data1 = &H20400
            .Data4(0) = &HC0
            .Data4(7) = &H46
        End With
        
        OleCreatePictureIndirect Pic, IID_IDispatch, True, IPic
        
        SavePicture IPic, sPath
        'MsgBox "Bild erfolgreich gespeichert unter: " & sPath
    Else
        MsgBox "Die Zwischenablage enthält kein Bild."
    End If
    
    CloseClipboard
Else
    MsgBox "Die Zwischenablage konnte nicht geöffnet werden."
End If

End Sub

Private Sub InsertPicAtCursor()
Dim oMail As Outlook.MailItem, oInspector As Outlook.Inspector
Dim oDoc As Object, oSelection As Object, sPath As String
    
sPath = "C:\Users\hbri\Desktop\ClipBoard\Datei.bmp"
    
Set oMail = Application.ActiveInspector.CurrentItem
Set oInspector = oMail.GetInspector
Set oDoc = oInspector.WordEditor
Set oSelection = oDoc.Application.Selection
    
oSelection.InlineShapes.AddPicture sPath, False, True
    
'MsgBox "Bild erfolgreich eingefügt!"

End Sub

Private Sub SetPicSize()
Dim oMail As MailItem, oInspector As Inspector
Dim oDoc As Object, oShape As Object, dbRation As Double
Dim dbWidth As Double, dbHeight As Double

Set oMail = Application.ActiveInspector.CurrentItem
Set oInspector = Application.ActiveInspector
Set oDoc = oInspector.WordEditor
Set oShape = oDoc.InlineShapes(oDoc.InlineShapes.Count)
    dbRation = oShape.Height / oShape.Width
    dbWidth = 200
    dbHeight = dbWidth * dbRation

    oShape.Width = dbWidth
    oShape.Height = dbHeight
    
End Sub

Sub ClipToMail()
    SaveClipToPic
    InsertPicAtCursor
    SetPicSize
End Sub
Wie schon erwähnt, stehen auch andere Optionen zur Verfügung - wenn sie jemand hier spezifiziert.

Viel Spaß damit!
d'r Bastler von den VBAsteleien.de
Win 10 + Office 2019 & Win11 + Office 2021 + Visio 2019 pro & macOS.X15 + Office2019pro & Android12 & XL365
knobbi38
Beiträge: 25
Registriert: 20. Okt 2024, 14:15
Hat sich bedankt: 2 Mal
Danksagung erhalten: 19 Mal
Kontaktdaten:

Re: Grafische Zwischenablage in Mail einfügen >step 1<

#3

Beitrag von knobbi38 »

Hallo d'r Bastler,

hier ein paar Anpassungen bei den API Deklarationen:

Code: Alles auswählen

Public Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(0 To 7) As Byte
End Type

Public Type PICTDESC
  Size As Long
  Type As Long
  hPic As LongPtr
  hPal As LongPtr
End Type

Public Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" ( _
  ByRef PicDesc As PICTDESC, _
  ByRef RefIID As GUID, _
  ByVal fPictureOwnsHandle As LongPtr, _
  ByRef IPic As IPicture ) As LongPtr

Public Declare PtrSafe Function OpenClipboard Lib "user32" _
    Alias "OpenClipboard" (ByVal hwnd As LongPtr) As Long

Public Declare PtrSafe Function CloseClipboard Lib "user32" _
    Alias "CloseClipboard" () As Long

Public Declare PtrSafe Function GetClipboardData Lib "user32" _
    Alias "GetClipboardDataA" (ByVal wFormat As Long) As LongPtr

Public Const CF_BITMAP = 2      ' Das Objekt in der Zwischenablage ist ein
                                ' Handle eines Bitmaps
Bitte beachte die geänderte Library Angabe bei OleCreatePictureIndirect (). Auch wird die Struktur üblicherweise in der API Doku mit PICTDESC bezeichnet, anstatt mit PicBmp.

Gruß
Knobbi38
Benutzeravatar
d'r Bastler
Beiträge: 832
Registriert: 29. Aug 2022, 13:20
Hat sich bedankt: 224 Mal
Danksagung erhalten: 118 Mal

Re: Grafische Zwischenablage in Mail einfügen >step 1<

#4

Beitrag von d'r Bastler »

Moin Knobbi,

ganz lieben Dank für Deine Ergänzung!

Also habe ich eben mal gebastelt und Deine Änderungen in den vorherigen Code übernommen. Erwartungsgemäß bin ich dann mal gleich gelb markiert hängengeblieben:

Code: Alles auswählen

If OpenClipboard(0&) Then

    hBitmap = GetClipboardData(2) ' 2 = CF_BITMAP
    
    If hBitmap <> 0 Then
        With Pic
            .Size = Len(Pic)
            .Type = 1 ' Bildtyp
            .hPic = hBitmap     ''' >>> hBmp = ...
            .hPal = 0
            '.Reserved = 0      ''' >>>
        End With
Nach Änderung / Auskommentieren der durch '''>>> markierten Zeilen, hat das dann aber klaglos funktioniert.

Was mich neugierig folgende Frage stellen lässt: Es wird weiterhin ein BMP verwendet. Kann man VBA auch dazu bewegen, GIF oder PNG zu verarbeiten? Ich denke da an Transparenz, die beim BMP ja nur für das ganze Bild greift.

Schöne Grüße
d'r Bastler von den VBAsteleien.de
Win 10 + Office 2019 & Win11 + Office 2021 + Visio 2019 pro & macOS.X15 + Office2019pro & Android12 & XL365
knobbi38
Beiträge: 25
Registriert: 20. Okt 2024, 14:15
Hat sich bedankt: 2 Mal
Danksagung erhalten: 19 Mal
Kontaktdaten:

Re: Grafische Zwischenablage in Mail einfügen >step 1<

#5

Beitrag von knobbi38 »

Hallo,

theoretisch sollte das gehen, aber dann müssen die beteiligten Anwendungen das verwendete Clipboard-Format auch gleich interpretieren, was offensichtlich nicht immer sichergestellt ist.

Ich habe hier einen alten Thread gefunden, wo es auch um so ein Problem in Verbindung mit XnView ging. Um sich den Inhalt des Clipboard anschauen und untersuchen zu können, braucht man dann noch ein Tool wie Clipboard Format Spy oder InsideClipboard.

Per Automation sollte das einfacher zu lösen sein. Da könnte man auch auf WIA zurück greifen.

Gruß
Knobbi38
Benutzeravatar
d'r Bastler
Beiträge: 832
Registriert: 29. Aug 2022, 13:20
Hat sich bedankt: 224 Mal
Danksagung erhalten: 118 Mal

Re: Grafische Zwischenablage in Mail einfügen >step 1<

#6

Beitrag von d'r Bastler »

Danke Knobbi,

damit habe ich schon mal meine nächsten Hausaufgaben ;-)

Hier als Fortsetzung des Projekts zwei Snippets, die jeweils aus Word oder Excel eine neue Mail in Outlook bauen. Mit Excel kann man Empfänger, Betreff und Inhalt aus einer Tabelle ziehen. Mit Word muss man sie von Hand eintragen oder sich entsprechende Textmarken bauen.

Für Word: Den Code in ein Modul und dann zu finden unter Alt+F8

Code: Alles auswählen

Option Explicit

Sub OpenMail()
Dim oOutlookApp As Object, oMail As Object

Set oOutlookApp = CreateObject("Outlook.Application")
Set oMail = oOutlookApp.CreateItem(0)

With oMail
    .To = "MailtTo"
    .Subject = "Subject"
    .Body = "Body"
    .Display
End With


Set oMail = Nothing
Set oOutlookApp = Nothing
End Sub
Für Excel: Hier kommt der Code in eine Tabelle und kann per Doppelklick aufgerufen werden

Code: Alles auswählen

Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    
    Cancel = True
    OpenMail Target.Row
    
End Sub


Sub OpenMail(iRow As Integer)
Dim oOutlookApp As Object, oMail As Object

Set oOutlookApp = CreateObject("Outlook.Application")
Set oMail = oOutlookApp.CreateItem(0)

With oMail
    .To = Cells(iRow, 1)
    .Subject = Cells(iRow, 2)
    .Body = Cells(iRow, 3)
    .Display
End With

Set oMail = Nothing
Set oOutlookApp = Nothing
End Sub
Viel Spaß damit!
d'r Bastler von den VBAsteleien.de
Win 10 + Office 2019 & Win11 + Office 2021 + Visio 2019 pro & macOS.X15 + Office2019pro & Android12 & XL365
Benutzeravatar
d'r Bastler
Beiträge: 832
Registriert: 29. Aug 2022, 13:20
Hat sich bedankt: 224 Mal
Danksagung erhalten: 118 Mal

Re: Grafische Zwischenablage in Mail einfügen ...

#7

Beitrag von d'r Bastler »

Moin allerseits,

hier eine Lösung für Word-Dokumente, in denen bitte folgende Textmarken (eine pro Zeile) angelegt werden:
MailTo, Subject und Body, die mit einer beliebigen E-Mail-Adresse und Betreff belegt werden.

Für den Body bietet sich folgender Text (ohne manuelle Zeilenumbrüche!) an:
Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua. At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet.
Dann bekommt ThisDocument diesen neuen Code (ggf. hinzugefügt):

Code: Alles auswählen

Option Explicit

Sub MailByBookMarks()
Dim i As Integer, sText(3) As String, aBookMarks
Dim oOutlookApp As Object, oMail As Object

aBookMarks = Array("MailTo", "Subject", "Body")

For i = 0 To UBound(aBookMarks)
    Selection.GoTo what:=wdGoToBookmark, Name:=aBookMarks(i)
    Selection.EndOf Unit:=wdParagraph, Extend:=wdExtend
    sText(i) = Selection.Text
Next i

Set oOutlookApp = CreateObject("Outlook.Application")
Set oMail = oOutlookApp.CreateItem(0)

With oMail
    .To = sText(0)
    .Subject = sText(1)
    .Body = sText(2) & vbCrLf
    .Display
End With

Set oMail = Nothing
Set oOutlookApp = Nothing
End Sub
Das Makro (sichtbar unter Alt-F8) baut eine neue Mail, in der man seinen Cursor an die gewünschte Position setzt. Und schon kann man mit dem bereits bekannten Makro sein(e) Bild(er) einfügen.

Optionale Schatten und andere Format-Spielereien gibt es später als einzelne Makros nach Fertigstellung.

Und wieder einen Schritt weiter ;) Viel Spaß damit!
d'r Bastler von den VBAsteleien.de
Win 10 + Office 2019 & Win11 + Office 2021 + Visio 2019 pro & macOS.X15 + Office2019pro & Android12 & XL365
knobbi38
Beiträge: 25
Registriert: 20. Okt 2024, 14:15
Hat sich bedankt: 2 Mal
Danksagung erhalten: 19 Mal
Kontaktdaten:

Re: Grafische Zwischenablage in Mail einfügen >step 1<

#8

Beitrag von knobbi38 »

Hallo,

warum so umständlich mit Textmarken? Eine 3-spaltige Tabelle reicht doch vollkommen und lässt sich noch einfacher ansprechen.
Anbei eine kleine Hilfsfunktion zum Auslesen eines Zellinhaltes.

Gruß
Knobbi38
Du hast keine ausreichende Berechtigung, um die Dateianhänge dieses Beitrags anzusehen.
Benutzeravatar
d'r Bastler
Beiträge: 832
Registriert: 29. Aug 2022, 13:20
Hat sich bedankt: 224 Mal
Danksagung erhalten: 118 Mal

Re: Grafische Zwischenablage in Mail einfügen >step 1<

#9

Beitrag von d'r Bastler »

Moin Knobbi,

dass Du es ausgerechnet beim Thema Clipboard so kompliziert machst und einen 6-Zeiler als Anhang hoch lädst ... :mrgreen: Aber natürlich danke für den wirklich bequemen Weg. In Excel ist die Adressierung der Zellen natürlich noch einfacher. Da kann man gleich ganze Reihen von Zellen aus Textbausteinen in eine Mail schicken. Ideal für Service-Hotlines, die die Wünsche ihrer Kunden herzlich ernst nehmen ... :evil:

Jetzt aber für Karthagos (herzlich willkommen übrigens!) noch die Sache mit dem Schatten um eingefügte Clips. Das Snippet (Code ins Modul, Aufruf über Alt-F8) umrahmt alle Bilder einer Mail:

Code: Alles auswählen

Sub ShadowPics()
Dim oMail As MailItem, oInspector As Inspector
Dim oDoc As Object, oShape As Object, iShp As Integer

Set oMail = Application.ActiveInspector.CurrentItem
Set oInspector = Application.ActiveInspector
Set oDoc = oInspector.WordEditor

iShp = 1
For Each oShape In oDoc.InlineShapes
Set oShape = oDoc.InlineShapes(iShp)

    With oShape
        With .Shadow
            .Visible = msoTrue
            .OffsetX = 0
            .OffsetY = 0
            .Transparency = 0.5
            .Blur = 10
            .ForeColor.RGB = RGB(0, 0, 0)
        End With
    End With
    iShp = iShp + 1
Next

End Sub
Weitere Formatierungen gerne auf Anfrage.

Viel Spaß damit!
d'r Bastler von den VBAsteleien.de
Win 10 + Office 2019 & Win11 + Office 2021 + Visio 2019 pro & macOS.X15 + Office2019pro & Android12 & XL365
Karthagos
Beiträge: 1
Registriert: 2. Jan 2025, 14:45
Danksagung erhalten: 1 Mal
Kontaktdaten:

Re: Grafische Zwischenablage in Mail einfügen >step 1<

#10

Beitrag von Karthagos »

Hallo d'rBastler, danke für Deine Mitteilung und die Fertigstellung des Schattenmakros für alle Bilder.
Hut ab, was Du da geleistet hast, funktioniert einwandfrei, nochmals vielen Dank.

Schade, dass es im Office-Forum mit EarlFred so einen Disput gab, war völlig unnötig, gehört aber anscheinend in unserer Internetwelt inzwischen dazu.

Viele Grüße und einen guten Jahresstart
Günther
Folgende Benutzer bedankten sich beim Autor Karthagos für den Beitrag:
d'r Bastler
Antworten

Wer ist online?

Mitglieder in diesem Forum: 0 Mitglieder und 0 Gäste