Anpassung code:Bilder aus Tabelle exportieren
Karel
unterstehende Code hab ich von Josef Ehrensberger, alle bilder in Excel mappe werden exportiert funktioniert wonderbar, Alle bilder werden Komprimiert exportiert.
Meine Fragen wie kan ich Bilder exportieren ohne dass die komprimiert werden wie jetzt.
Code:
Option Explicit
'BILDER exportieren
Sub savePictures()
Dim objShp As Shape
Dim strPath As String
On Error GoTo Errexit
strPath = fncBrowseForFolder
If strPath = "" Then Exit Sub
Application.ScreenUpdating = False
For Each objShp In ActiveSheet.Shapes
If objShp.Type = msoPicture Then
Exportieren objShp, strPath & "\" & objShp.Name & ".gif"
End If
Next
Errexit:
Application.ScreenUpdating = True
End Sub
Private Function Exportieren(myShape As Shape, FileName As String)
'Idea by Nepumuk
Dim myChart As Chart, myChartObject As ChartObject
Set myChart = Charts.Add
Set myChartObject = ActiveChart.ChartObjects.Add(0, 0, _
myShape.Width, myShape.Height)
myShape.Copy
With myChartObject
With .Chart
.ChartArea.Border.LineStyle = xlLineStyleNone
.Paste
.Export FileName:=FileName, _
FilterName:="GIF", Interactive:=False
End With
.Delete
End With
Application.DisplayAlerts = False
myChart.Delete
Application.DisplayAlerts = True
Set myChart = Nothing
Set myChartObject = Nothing
Set myShape = Nothing
End Function
Private Function fncBrowseForFolder(Optional ByVal defaultPath = "") As String
Dim objFlderItem As Object, objShell As Object, objFlder As Object
Set objShell = CreateObject("Shell.Application")
Set objFlder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, defaultPath)
If objFlder Is Nothing Then GoTo Errexit
Set objFlderItem = objFlder.Self
fncBrowseForFolder = objFlderItem.Path
Errexit:
Set objShell = Nothing
Set objFlder = Nothing
Set objFlderItem = Nothing
End Function
Karel