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

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

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

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

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

Beliebteste Forumthreads (12 Monate)

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

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

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

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

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread