VBA: Grafik als JPG Grafik speichern

Ich bin am verzweifeln und würde mich freuen, wenn mir hier jemand bei der Lösung meines Problemes helfen könnte.
Es sind eigentlich 2 Probleme.
Ich habe eine Tabelle mit Spalte A = Grafiken und Spalte B = Namen.
Die Grafiken sollen jetzt mit dem Namen aus Spalte B umgenannt und als jpg Datei abgespeichert werden.
Jetzt (anderes Workbook) eine andere Tabelle in der in Spalte A die Namen stehen und die dazugehörende Grafik in Spalte E eingefügt werden soll.
https://www.herber.de/bbs/user/148805.xlsx
Zu 1.)
Beispieldatei: Tabelle Quelle
Ich möchte den "Namen" aus Spalte "B" nehmen und die "Grafik" aus Spalte "A" mit dem dazugehörigen Namen als JPG Datei abspeichern.
- Angabe Zielordner: z.B. = C:\Test\Bilder
- Inhalt aus Worksheet(Quelle) Zelle B2 (z.B. Sonne)
- Zugehörige Grafik aus A2 selektieren (z.B. Picture 1)
- Grafik abspeichern: ... Zielordner\Sonne.jpg
- Nächste Zeile ... bis Ende Einträge
Zu 2.)
Beispieldatei: Tabelle Ziel
Jetzt (anderes Workbook) Tabelle Ziel, in der in Spalte A die Werte aus Beispieldatei Quelle (Spalte B = Sonne, Wolke, Regen, ...) stehen,
möchte ich nun, in die jeweilige Zeile Spalte E die zugehörige Grafik (z.B. Sonne.jpg) einfügen.
Viele Grüße
Stefan

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Public Sub ImageExport() Dim avntValues As Variant, vntItem As Variant Dim objCell As Range Dim objShape As Shape Dim objChartObject As ChartObject Dim objDictionary As Object With Tabelle1 avntValues = .Range(.Cells(2, 2), .Cells(.Rows.Count, 2).End(xlUp)).Value2 Set objDictionary = CreateObject(Class:="Scripting.Dictionary") For Each vntItem In avntValues objDictionary.Item(Key:=vntItem) = vbNullString Next For Each vntItem In objDictionary.Keys Set objCell = .Columns(2).Find(What:=vntItem, LookIn:=xlValues, LookAt:=xlWhole) For Each objShape In .Shapes If objShape.TopLeftCell.Row = objCell.Row Then Set objChartObject = .ChartObjects.Add(Left:=0, Top:=0, Width:=objShape.Width, Height:=objShape.Height) Call objShape.Copy With objChartObject.Chart Call .Paste Call .Export(Filename:=ThisWorkbook.Path & "\" & vntItem & ".jpg", FilterName:="JPG") Call .Parent.Delete End With Exit For End If Next Next End With Set objDictionary = Nothing Set objCell = Nothing Set objChartObject = Nothing Set objShape = Nothing End Sub

Option Explicit Public Sub ImageExport() Dim avntValues As Variant, vntItem As Variant Dim objCell As Range Dim objShape As Shape Dim objChartObject As ChartObject Dim objDictionary As Object With Tabelle1 avntValues = .Range(.Cells(2, 2), .Cells(.Rows.Count, 2).End(xlUp)).Value2 Set objDictionary = CreateObject(Class:="Scripting.Dictionary") For Each vntItem In avntValues objDictionary.Item(Key:=vntItem) = vbNullString Next For Each vntItem In objDictionary.Keys Set objCell = .Columns(2).Find(What:=vntItem, LookIn:=xlValues, LookAt:=xlWhole) For Each objShape In .Shapes If objShape.TopLeftCell.Row = objCell.Row Then Set objChartObject = .ChartObjects.Add(Left:=0, Top:=0, Width:=objShape.Width, Height:=objShape.Height) Call objShape.Copy With objChartObject.Chart Call .Parent.Activate Call .Paste Call .Export(Filename:=ThisWorkbook.Path & "\" & vntItem & ".jpg", FilterName:="JPG") Call .Parent.Delete End With Exit For End If Next Next End With Set objDictionary = Nothing Set objCell = Nothing Set objChartObject = Nothing Set objShape = Nothing End Sub

Hallo Stefan,
so besser?


Option Explicit
Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" ( _
ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As Long
Public Sub ImageExport()
Dim avntValues As Variant, vntItem As Variant
Dim objCell As Range
Dim objShape As Shape
Dim objChartObject As ChartObject
Dim objDictionary As Object
With Tabelle1
avntValues = .Range(.Cells(2, 2), .Cells(.Rows.Count, 2).End(xlUp)).Value2
Set objDictionary = CreateObject(Class:="Scripting.Dictionary")
For Each vntItem In avntValues
objDictionary.Item(Key:=vntItem) = vbNullString
Next
For Each vntItem In objDictionary.Keys
Set objCell = .Columns(2).Find(What:=vntItem, LookIn:=xlValues, LookAt:=xlWhole)
For Each objShape In .Shapes
If objShape.TopLeftCell.Row = objCell.Row Then
Set objChartObject = .ChartObjects.Add(Left:=0, Top:=0, Width:=objShape.Width, Height:=objShape.Height)
Call OpenClipboard(0)
Call EmptyClipboard
Call CloseClipboard
DoEvents
Call objShape.Copy
With objChartObject.Chart
Call .Parent.Activate
Call .Paste
Call .Export(Filename:=ThisWorkbook.Path & "\" & vntItem & ".jpg", FilterName:="JPG")
Call .Parent.Delete
End With
Exit For
End If
Next
Next
End With
Set objDictionary = Nothing
Set objCell = Nothing
Set objChartObject = Nothing
Set objShape = Nothing
End Sub

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

VBA: Grafik als JPG Grafik speichern

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

309 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA: Grafik als JPG Grafik speichern

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

309 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread