Range - Picture - Outlook Body...

Range (mit Format und Daten Gültigkeit) als Bild in Outlook Body.

Range (with format and data validity) as image in Outlook Body.

Hier noch eine Beispieldatei / Here's a sample file:
Range - Picture - Outlook Body...[ZIP 40 KB]

Option Explicit
' Bedingte Kompilierung für 32/64 Bit
#If Win64 Then
    Private Declare PtrSafe Function SearchTreeForFile Lib "imagehlp.dll" _
        (ByVal RootPath As String, ByVal InputPathName As String, _
        ByVal OutputPathBuffer As String) As Long
    Private Declare PtrSafe Function MakeSureDirectoryPathExists _
        Lib "imagehlp.dll" (ByVal Pfad As String) As Long
#Else
    Private Declare Function SearchTreeForFile Lib "imagehlp.dll" _
        (ByVal RootPath As String, ByVal InputPathName As String, _
        ByVal OutputPathBuffer As String) As Long
    Private Declare Function MakeSureDirectoryPathExists _
        Lib "imagehlp.dll" (ByVal Pfad As String) As Long
#End If
Public Sub Main()
    ' Puffer für Pfad- und Dateiname festlegen
    Dim strPathName As String * 255
    Dim strName As String
    Dim objFSO As Object
    Dim lngCalc As Long
    Dim lngTMP As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
    With Application
        .AskToUpdateLinks = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    ' Verzeichnis im %Temp% Ordner wird erstellt
    Call MakeSureDirectoryPathExists(Environ("Temp") & "\TT\")
    ' Bereich "B3:D7" wird als Bild kopiert
    Call ThisWorkbook.Worksheets("Lieferung").Range("B3:D7").CopyPicture(xlScreen, xlBitmap)
    ' ERST hier die Bildschirmaktualisierung ausschalten, SONST BLEIBT DAS BILD LEER!
    Application.ScreenUpdating = False
    ' Tabellenblatt hinzufügen - dies ist dann automatisch das aktive
    ThisWorkbook.Worksheets.Add
    ' Bild in A1 einfügen
    ThisWorkbook.ActiveSheet.Paste
    ' Bereich als "htm-Datei" im %Temp% Ordner speichern. Dabei wird das Bild automatisch
    ' als PNG-Datei in einen Unterordner abgelegt
    With ThisWorkbook.PublishObjects.Add(xlSourceRange, _
        Environ("Temp") & "\TT\TT.htm", ActiveSheet.Name, "$A:$E", xlHtmlStatic, "TT", "")
        .Publish (True)
        .AutoRepublish = False
    End With
    ' Temporäres Tabellenblatt wieder löschen
    ThisWorkbook.ActiveSheet.Delete
    ' Grafikdatei suchen - hat immer den Namen (hier TT) und 001.png im Namen
    lngTMP = SearchTreeForFile(Environ("Temp"), "\TT\TT_*001.png", strPathName)
    ' Wenn gefunden...
    If lngTMP <> 0 Then
        ' Den Pfad- und Dateiname auf die richtige Länge eindampfen
        strPathName = Left$(strPathName, InStr(1, strPathName, vbNullChar) - 1)
        strName = RTrim(strPathName)
        ' Mail senden - mit dem Pfad- und Dateinamen der Grafikdatei
        Call Mail(strName)
    End If
    ' Ordner im %Temp% wieder löschen
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    objFSO.DeleteFolder (Environ("Temp") & "\TT"), True
Fin:
    ' Objektvariablen zurücksetzen
    Set objFSO = Nothing
    ' Die Applikation aufwecken
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = lngCalc
        .DisplayAlerts = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub
Sub Mail(ByVal strTMP As String)
    Dim objOutApp As Object
    Dim strText1 As String
    Dim strText2 As String
    Dim strText3 As String
    Dim strFile As String
    ' Outlook starten - gleich mit neuer Mail - das ist die 0 - Kontakt wäre 2
    Set objOutApp = CreateObject("Outlook.Application").CreateItem(0)
    ' Die Variable in der richtigen Form mit dem Pfad- und Dateinamen der Grafikdatei befüllen
    strFile = " <img src=""file://" & strTMP & """>"
    ' Texte die später im Body auftauchen sollen. Muss man so nicht machen
    ' Man kann auch alles mit HTML-Code im Body schreiben
    strText1 = "Sehr geehrte Damen und Herren,"
    strText2 = "wir benötigen nächste Woche folgende LKW's:"
    With objOutApp
        ' Standardsignatur aufrufen und...
        .GetInSpector.Display
        ' ... zwischenspeichern
        strText3 = .HTMLBody
        ' An...
        .To = "Mail@dd.de"
        '.CC = "An@WenNoch.de
        ' Versteckte Empfänger...
        '.BCC = "AuchNoch@AnDen.de; UndNoch@AnJene.de"
        ' Anhang...
        '.Attachments.Add "C:\Temp\IrgendwasVonIrgendwo.xlsx"
        ' Betreff...
        .Subject = "Lieferungen " & ThisWorkbook.Worksheets("Lieferung").Range("A1").Text & "/" & Year(Date)
        ' Body...
        .HTMLBody = strText1 & "<br>" & "<br>" & strText2 & "<br>" & "<br>" & strFile & strText3
        ' Hier wird die Mail angezeigt, sonst gleich ".Send"
        .Display
        '.Send
    End With
    Set objOutApp = Nothing
End Sub

Kommentare

  1. Super geht besten Dank
    MaBlu

    AntwortenLöschen
  2. Einen schönen guten Tag, ich habe eine Frage zu einem alten Beitrag aus dem Jahre 2012 unter http://vbanet.blogspot.de/2012/10/excel-word-in-textmarken-bookmarks.html
    Wie ist es möglich, dass ich mir von verschiedenen Tabellenblättern Werte hole, um sie in die Word-Textmarke zu füllen. Ich habe auf mind. drei verschiedenen Tabellenblättern Bereiche und Werte, die ich einfügen muss. Leider komme ich nicht weiter, da er mir immer einen Fehler beim Else wirft, wenn ich ein neues With ThisWorkbook.Worksheets("SLA") angebe. Können Sie mir bei diesem Prblem behilflich sein?

    AntwortenLöschen

Kommentar veröffentlichen

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...