Export Excel-Bilder zu Word Textmarke
04.09.2024 21:52:43
Kinopio
ich beschäftige mich erstmals damit Werte und Bilder aus Excel in eine Word-Vorlage mit Textmarken (innerhalb einer Tabelle in Word) zu bringen.
Werte (Text, Zahlen) klappt soweit gut und ist auch nicht weiter wild.
Probleme habe ich damit, dass in einer Textmarke "B3" (ja, ich war zum testen nicht so kreativ mit der Namensvergabe) Bilder eingefügt werden sollen.
Das klappt grds. auch, ABER leider wird immer das nächste Bild über den vorherigen eingefügt. Das nächste Bild soll aber in der Textmarke unten eingefügt werden. Kann man das irgendwie vorgeben?
Kann mir jemand dabei helfen? Ich bin über jeden Hinweis dankbar.
Ach so: Warum INLINESHAPE weiß ich nicht, habe ich mir im Netz zusammengesucht und das klappt.
Option Explicit
Sub ExcelBilderZuWordTextmarke()
Dim wordApp As Word.Application
Dim wordDoc As Word.Document
Dim strWordFile As String
Dim objTemp As Object
strWordFile = ThisWorkbook.Path & "\TEST.docx"
'##### Word Datei #####
'Prüfen ob Datei Existiert, öffnen oder offene Datei nutzen
If Dir(strWordFile) > "" Then
Set objTemp = GetObject(, "Word.Application")
If objTemp Is Nothing Then
Set wordApp = CreateObject("Word.Application")
wordApp.Documents.Open strWordFile
wordApp.Visible = True
wordApp.Activate
wordApp.WindowState = 1
Else
Set wordApp = objTemp
If wordApp.Documents.Count > 0 Then
For Each wordDoc In wordApp.Documents
If StrComp(wordDoc.FullName, strWordFile, vbTextCompare) = 0 Then
'MsgBox "Datei ist bereits geöffnet !"
Set wordDoc = wordApp.Documents("TEST.docx")
Exit For
Else
Set wordDoc = wordApp.Documents.Open(strWordFile)
Exit For
End If
Next
End If
wordApp.Visible = True
wordApp.Activate
wordApp.WindowState = 1
wordDoc.Fields.Update
End If
Else
MsgBox "Datei existiert nicht :" & vbLf & vbLf & strWordFile, vbCritical + vbOKOnly, "Fehler "
Exit Sub
End If
'Excel Werte in Textmarken einfügen
wordDoc.Bookmarks("A1").Range.Text = ActiveSheet.Range("$B$1")
wordDoc.Bookmarks("A6").Range.Text = ActiveSheet.Range("$B$2")
wordDoc.Bookmarks("AA6").Range.Text = ActiveSheet.Range("$B$3")
wordDoc.Bookmarks("AAA6").Range.Text = ActiveSheet.Range("$B$4")
'##### Bilder aus Excel in Word einfügen #####
Dim shp As Shape, tmpshape As Object
Dim strTmp As String
For Each shp In ActiveSheet.Shapes
If shp.Type = msoPicture Then
'Temp Dateiname
strTmp = ThisWorkbook.Path & "\" & shp.Name & ".jpg"
'Bild Shape kopieren
shp.Copy
'Bild Shape in DAtei exportieren
Set tmpshape = ThisWorkbook.Worksheets("Temp").ChartObjects.Add(0, 0, shp.Width, shp.Height)
tmpshape.Chart.ChartArea.Select
tmpshape.Chart.Paste
tmpshape.Chart.Export Filename:=strTmp, FilterName:="JPG"
tmpshape.Delete
'Hier beginnt mein Problem und meine Unwissenheit
'Ziel: Bilder aus Excel in die TExtmarke einfügen
'ABER Bilder UNTEREINANDER.
With wordDoc.Bookmarks("B3").Range
.InlineShapes.AddPicture Filename:=strTmp, LinkToFile:=False, SaveWithDocument:=True
Kill strTmp 'Datei löschen
End With
End If
Next
End Sub
Vielen DANK und viele Grüße
Kinopio
Anzeige