01.07.2023, 23:02
Hallo, 
im folgenden Beispiel wird über "Application.Caller" ein Range, der als verknüpfte Grafik im Tabellenblatt ist, als Bild gespeichert. Auch nur ein Shape bzw. Bilder. Allen wurde dasselbe Makro zugewiesen. Ausreichend Kommentare im Code:
[attachment=48624]
im folgenden Beispiel wird über "Application.Caller" ein Range, der als verknüpfte Grafik im Tabellenblatt ist, als Bild gespeichert. Auch nur ein Shape bzw. Bilder. Allen wurde dasselbe Makro zugewiesen. Ausreichend Kommentare im Code:
Code:
' Veröffentlicht auf CEF "https://www.clever-excel-forum.de/index.php" am 01.07.2023 von Case.
' In der Rubrik Beispiele und Workshops unter "mit VBA".
' Variablendeklaration erforderlich. Fehler werden leichter gefunden bzw. fallen erst auf.
Option Explicit
' Makro wird in der Makroliste nicht angezeigt.
' #############################################
' Wenn du einem Bild dann mit Recter Maustaste - Makro zuweisen das Makro zuweisen möchtest, erscheint es NICHT in der Liste.
' Bei Makroname im Feld dann einfach "Main" eingeben und OK klicken. Makro ist nur nicht sichtbar.
Option Private Module
' API Deklaration
Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr
Private Declare PtrSafe Function GetActiveWindow Lib "user32.dll" () As LongPtr
' Das Makro läuft NICHT für sich. Es muss von einem Objekt (z. B. Bild/Shape) aufgerufen werden - wegen "Application.Caller".
' Wenn es ohne den "Caller" laufen soll, dann alle "Application.Caller" mit dem Index ODER Name des Shapes austauschen.
Public Sub Main()
' Variablendeklaration
Dim chtChartObject As ChartObject
Dim chtChart As Chart
Dim lngHeight As Long
Dim lngWith As Long
' Konstante "strPath" - Pfad MIT abschließendem Backslash angeben!!!
Const strPath As String = "C:\TMP\"
' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke.
On Error GoTo Fin
' Bildschirmaktualisierung ausschalten.
Application.ScreenUpdating = False
' Fehleranzeige ausschalten.
Application.DisplayAlerts = False
' Mit With beziehe ich mich auf ein bestimmtes Objekt - hier Tabelle1 (Codename VOR der Klammer im VBA-Editor).
' Alles was sich auf dieses Objekt bezieht muss mit einem Punkt beginnen.
' Da Objekt selber muss ich nicht mehr nennen.
With Tabelle1
' Über "Application.Caller" wird das Shape automatisch erkannt.
.Shapes(Application.Caller).CopyPicture 1, -4147
' Breite des Bildes auslesen.
lngWith = .Shapes(Application.Caller).Width
' Höhe des Bildes auslesen.
lngHeight = .Shapes(Application.Caller).Height
End With
' Diagrammblatt hinzufügen.
Set chtChart = Charts.Add
' Diagramm innerhalb des Diagrammblattes anlegen mit Position x und y, Breite und Höhe.
Set chtChartObject = chtChart.ChartObjects.Add(0, 0, lngWith, lngHeight)
' With siehe oben.
With chtChartObject.Chart
' In neueren Excelversionen MU(SS das gemacht werden, sonst bleibt das Bild leer.
.ChartArea.Select
' Kein Rahmen.
.ChartArea.Border.LineStyle = xlNone
' Bild einfügen.
.Paste
' Export - speichern. Es sind verscjiedene Extensionen möglich.
.Export Filename:=strPath & Tabelle1.Shapes(Application.Caller).Name & ".gif", FilterName:="GIF"
'.Export Filename:=strPath & Tabelle1.Shapes(Application.Caller).Name & ".png", FilterName:="PNG"
'.Export Filename:=strPath & Tabelle1.Shapes(Application.Caller).Name & ".jpg", FilterName:="JPG"
'.Export Filename:=strPath & Tabelle1.Shapes(Application.Caller).Name & ".bmp", FilterName:="BMP"
' ###############################################################################################
' Es geht auch im TEMP-Ordner. Dann aber auch bei "ShellExecute" oder "Shell" die andere Codezeile nehmen!!!
'.Export Filename:=Environ("Temp") & Application.PathSeparator & Tabelle1.Shapes(Application.Caller).Name & ".gif", FilterName:="GIF"
End With
' Über API wird der Explorer mit dem entsprechenden Verzeichnis ausgerufen. Neues Fenster bei jedem Aufruf.
ShellExecute GetActiveWindow, "explore", strPath, vbNullString, vbNullString, 1
' Falls TEMP Ordner genommen wird
'ShellExecute GetActiveWindow, "explore", Environ("Temp"), vbNullString, vbNullString, 1
' Oder auch einfach über Shell. API Deklarationen von oben werden dann nicht benötigt.
'Shell "Explorer.exe /E,strPath", vbNormalFocus
' Mit TEMP-Ordner
'Shell "Explorer.exe /E," & Environ("Temp"), vbNormalFocus
Fin:
' Wenn das Chart/Diagramm existiert, dann lösche es wieder. Wird If Then - also Wenn Dann in EINE
' Codezeile geschrieben, dann OHNE End If!!! Sonst MIT End If!!!
If Not chtChart Is Nothing Then chtChart.Delete
' Bildschirmaktualisierung ausschalten - geht nach Ende das Makros eigentlich automatisch.
' Habe mir aber angewöhnt das immer zu schreiben, denn andere Eigenschaften SOLLTE (M)man(n)
' noch einschalten, wenn ausgeschaltet (Application.DisplayAlerts). Also es schadet nicht. :-)
Application.ScreenUpdating = True
' Wird eigentlich auch wieder am Ende eingeschaltet. Kann problematisch werden, wenn ein Fehler auftritt
' und der nicht abgefangen wird, ODER wenn prozessübergreifend prgrammiert wird. Also lieber einschalten!!!
Application.DisplayAlerts = True
' Wenn ein Fehler aufgetreten ist gib ihn mit Nummer rund Beschreibung aus, sonst weiter.
If Err.Number <> 0 Then MsgBox "Error: " & Err.Number & " " & Err.Description
' Objektvariablen zurücksetzen. Geht auch automatisch, aber siehe oben.
Set chtChart = Nothing
Set chtChartObject = Nothing
End Sub
' VORSICHT!!! WMIC ist die Holzhammermethode. Der killt den Exporer komplett. Der startet dann wieder neu ohne ein Fenster anzuzeigen.
' Hilfreich, wenn viel getestet wurde und ein Haufen Explorerfenster offen sind.
Public Sub Main_Terminate_Explorer()
Shell "wmic Process where ""name='Explorer.exe'"" call terminate", vbHide
End Sub