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