"Grafik .." und "Picture .." speichern?

Forumthread: "Grafik .." und "Picture .." speichern?

01.04.2014 13:43:59

Selma

Hallo Leute,
ich habe dieses Makro um das Bild "Typ aus der Statusleiste: Picture" aus dem Arbeitsblatt "Eingabe" in ein bestimmten Pfad als BMP-Datei zu speichern. Das funktioniert prima.
Mein Problem ist, das von Datei zu Datei das Bild mal "Grafik .." und mal "Picture .." ist.
Was musss ich bitte ändern, damit es im beiden Fällen funktioniert?

Sub GrafikExportieren_Grafik2()
Dim chrDiagramm As ChartObject
Dim strSheetName As String
Dim shBild As Shape
Dim rngZelle As Range
Dim picBild As Picture
Sheets("Eingabe").Select
Set rngZelle = Columns(1).Find("Name", lookat:=xlWhole)
If Not rngZelle Is Nothing Then
Application.ScreenUpdating = False
strSheetName = rngZelle.Offset(0, 1).Value
'Picture
Set picBild = ActiveSheet.Pictures(1)
picBild.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Set chrDiagramm = ActiveSheet.ChartObjects.Add(0, 0, picBild.Width, picBild.Height)
'Grafik
'Set shBild = ActiveSheet.Shapes(1)
'shBild.CopyPicture Appearance:=xlScreen, Format:=xlPicture
'Set chrDiagramm = ActiveSheet.ChartObjects.Add(0, 0, shBild.Width, shBild.Height)
With chrDiagramm.Chart
.Parent.ShapeRange.Line.Visible = msoFalse
.Paste
.Export Filename:="D:\picture\" & strSheetName & ".bmp", FilterName:="bmp"
End With
chrDiagramm.Delete
Set chrDiagramm = Nothing
Set rngZelle = Nothing
Application.ScreenUpdating = True
End If
End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: "Grafik .." und "Picture .." speichern?

01.04.2014 15:01:53

Beverly

Hi,
m.E. sollte es keine Rolle spielen, ob das Bild mal Grafik" oder mal "Picture" heißt.

AW: "Grafik .." und "Picture .." speichern?

02.04.2014 16:58:13

Selma

Hallo Karin,
anbei eine Beispieldatei incl. aktuelles Makro.
Ich habe drei Arbeitsblätter zum Testen eingefügt.
https://www.herber.de/bbs/user/89961.xls
Viele Grüße,
Selma

AW: "Grafik .." und "Picture .." speichern?

02.04.2014 17:38:28

Beverly

Hi Selma,
du hattest nicht geschrieben, dass du auch noch ein ActiveX-Steuerelement in deinem Tabellenblatt hast - diese werden auch als Picture erkannt, können aber nicht auf die genannte Weise verarbeitet werden.

Sub GrafikExportieren_Alle()
Dim chrDiagramm As ChartObject
Dim strSheetName As String
Dim shBild As Shape
Dim rngZelle As Range
Dim shaBild As Picture
Set rngZelle = Columns(1).Find("Name", lookat:=xlWhole)
If Not rngZelle Is Nothing Then
Application.ScreenUpdating = False
strSheetName = rngZelle.Offset(0, 1).Value
For Each shaBild In ActiveSheet.Shapes
If shaBild.Type = msoPicture Then Exit For
Next shaBild
shaBild.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Set chrDiagramm = ActiveSheet.ChartObjects.Add(0, 0, shaBild.Width + 5, shaBild.Height + 5) _
With chrDiagramm.Chart
.Parent.ShapeRange.Line.Visible = msoFalse
.Paste
.export Filename:="D:\Test\" & strSheetName & ".bmp", FilterName:="bmp"
End With
chrDiagramm.Delete
Set chrDiagramm = Nothing
Set rngZelle = Nothing
Application.ScreenUpdating = True
End If
End Sub

Bei der ersten Tabelle hat der Code deshalb funktoiniert, weil das Bild tatsächlich Picture(1) ist. In den anderen beiden Tabellen ist aber jeweils der CommandButton Picture(1) - und deshalb führt das zu einem Fehler. Der hat aber nichts damit zu tun, ob das Bild an sich Picture oder Grafik heißt, denn in diesen beiden Tabellen würde der Code ohne Fehler durchlaufen, stünde dort Picture(2) anstelle Picture(1).

AW: "Grafik .." und "Picture .." speichern?

03.04.2014 09:38:05

Selma

Hallo Karin,
danke für die Erklärung und das Makro.
Ich habe das Makro jetzt an allen drei Arbeitsblättern getestet und es bleibt hier stehen:
For Each shaBild In ActiveSheet.Shapes
Viele Grüße,
Selma

AW: "Grafik .." und "Picture .." speichern?

03.04.2014 09:55:25

Beverly

Hi Selma,
sorry, da ist bei der Variablendeklaration etwas schief gegangen - dieser Teil muss so heißen:

   Dim chrDiagramm As ChartObject
Dim strSheetName As String
Dim rngZelle As Range
Dim shaBild As Shape

AW: "Grafik .." und "Picture .." speichern?

03.04.2014 10:33:29

Selma

Hallo Karin,
es funktioniert prima.
Da ich ca. 250 xls-Dateien habe bei den ich die Bilder in ein zentrales Verzeichnis speichern möchte, habe ich diesen Code jetzt probiert:

Sub SuchBestimmtenOrdner()
rootfolder = GetExcelfolder
Dim StartFS As Object
Dim StartFolder As Object
Set StartFS = CreateObject("Scripting.FileSystemObject")
Set ProjectFolder = StartFS.GetFolder(rootfolder)
If StartFS.FolderExists(ProjectFolder) Then
GrafikExportieren_Alle (ProjectFolder)
End If
Set StartFS = Nothing
Set StartFolder = Nothing
End Sub

Sub GrafikExportieren_Alle(ByVal SuchPath As String)
Dim oFS As Object
Dim oFolder As Object
Dim oFile As Object
Dim chrDiagramm As ChartObject
Dim strSheetName As String
Dim rngZelle As Range
Dim shaBild As Shape
Set oFS = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFS.GetFolder(SuchPath)
For Each oFile In oFolder.Files
If oFile.Name Like "*.xls" Then
Set WB = Workbooks.Open(oFile, 0)
Sheets("Eingabe").Select
Set rngZelle = Columns(1).Find("Name", lookat:=xlWhole)
If Not rngZelle Is Nothing Then
Application.ScreenUpdating = False
strSheetName = rngZelle.Offset(0, 1).Value
For Each shaBild In ActiveSheet.Shapes
If shaBild.Type = msoPicture Then Exit For
Next shaBild
shaBild.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Set chrDiagramm = ActiveSheet.ChartObjects.Add(0, 0, shaBild.Width + 5, shaBild.Height + 5) _
_
With chrDiagramm.Chart
.Parent.ShapeRange.Line.Visible = msoFalse
.Paste
.Export Filename:="D:\image\" & strSheetName & ".bmp", FilterName:="bmp"
End With
chrDiagramm.Delete
Set chrDiagramm = Nothing
Set rngZelle = Nothing
Application.ScreenUpdating = True
End If
WB.Close SaveChanges:=False
End If
Next
Set oFile = Nothing
Set oFolder = Nothing
Set oFS = Nothing
End Sub

Function GetExcelfolder(Optional Caption, Optional StartFolder) As String
If IsMissing(Caption) Then Caption = ""
If IsMissing(StartFolder) Then StartFolder = "D:\"
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "Bitte den Ordner auswählen"
.InitialFileName = StartFolder
.InitialView = msoFileDialogViewThumbnail
.ButtonName = "OK"
.Show
If .SelectedItems.Count > 0 Then
GetExcelfolder = .SelectedItems(1)
End If
End With
End Function

Ich starte das Makro "SuchBestimmtenOrdner" und wählen den Ordner aus in dem die XLS-Dateien liegen.
Dann wird Dein Makro "GrafikExportieren_Alle" gestarten, das Bild soll gespeichert werden und die Datei mit dem Bild ohne Speichern geschlossen werden. Dann soll die nächste Datei geöffnet werden usw.
Leider bleibt das Makro schon bei der erste Datei hier .Paste stehen.
Ich hoffe Du kannst mir dabei auch helfen?!
Viele Grüße,
Selma

AW: "Grafik .." und "Picture .." speichern?

03.04.2014 11:03:39

Beverly

Hi Selma,
das kann ich leider nicht nachvollziehen - bei mir tritt dieser Fehler nicht auf. Kann es sein, dass in der betreffenden Arbeitsmappe im Tabellenblatt "Eingabe" kein Bild vorhanden ist? Dann müsstest du das vorher noch prüfen (ungetestet):

Sub GrafikExportieren_Alle(ByVal SuchPath As String)
Dim oFS As Object
Dim oFolder As Object
Dim oFile As Object
Dim chrDiagramm As ChartObject
Dim strSheetName As String
Dim rngZelle As Range
Dim shaBild As Shape
Dim blnExport As Boolean
Set oFS = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFS.GetFolder(SuchPath)
Application.ScreenUpdating = False
For Each oFile In oFolder.Files
If oFile.Name Like "*.xls" Then
Set WB = Workbooks.Open(oFile, 0)
Sheets("Eingabe").Select
Set rngZelle = Columns(1).Find("Name", lookat:=xlWhole)
If Not rngZelle Is Nothing Then
strSheetName = rngZelle.Offset(0, 1).Value
For Each shaBild In ActiveSheet.Shapes
If shaBild.Type = msoPicture Then
blnExport = True
Exit For
End If
Next shaBild
If blnExport Then
shaBild.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Set chrDiagramm = ActiveSheet.ChartObjects.Add(0, 0, shaBild.Width + 5, _
shaBild.Height + 5)
With chrDiagramm.Chart
.Parent.ShapeRange.Line.Visible = msoFalse
.Paste
.Export Filename:="D:\image\" & strSheetName & ".bmp", _
FilterName:="bmp"
End With
chrDiagramm.Delete
Set chrDiagramm = Nothing
Set rngZelle = Nothing
End If
WB.Close SaveChanges:=False
blnExport = False
End If
End If
Next
Application.ScreenUpdating = True
Set oFile = Nothing
Set oFolder = Nothing
Set oFS = Nothing
End Sub

AW: "Grafik .." und "Picture .." speichern?

03.04.2014 13:31:33

Selma

Vielen Dank Karin!
Viele Grüße,
Selma

Beliebteste Forumthreads (12 Monate)

"Grafik .." und "Picture .." speichern?

Forumthread: "Grafik .." und "Picture .." speichern?

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

"Grafik .." und "Picture .." speichern?

Forumthread: "Grafik .." und "Picture .." speichern?

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread