Bilder aus Tabellenblatt auf Festplatte exportieren...

Frage:

In einem Tabellenblatt habe ich verschiedene Bilder. Manchmal muss ich ein Bild auf die Festplatte speichern. Dies möchte ich auf zwei Arten erreichen. Das Bild wird angeklickt und dann über einen Button oder eine Taste gespeichert. Oder das Bild wird angeklickt und sofort gespeichert. Wie geht das?

In a spreadsheet I have various images. Sometimes I need to save an image to the hard drive. I want to achieve this in two ways. The image is clicked and saved via a button or a key. Or the image is clicked and saved immediately. How does it work?

Hier noch eine Beispieldatei / Here's a sample file:
Bilder aus Tabellenblatt auf Festplatte exportieren...[XLS 160 KB]

Code gehört in "DieseArbeitsmappe" / Code belongs in "ThisworkBook":

Option Explicit
'-------------------------------------------------------------------------- 
' Module    : DieseArbeitsmappe / Thisworkbook 
' Procedure : Workbook_Open 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 21.12.2012 
' Purpose   : Mit einer Taste (hier F8) ein Makro starten... 
'-------------------------------------------------------------------------- 
Private Sub Workbook_Open()
    Application.OnKey "{F8}", "Modul1.ExportPicture"
End Sub
Private Sub Workbook_Deactivate()
    Application.OnKey "{F8}"
End Sub

Code gehört in ein Modul / Code belongs in a module:

Option Explicit
Private Declare Function MakeSureDirectoryPathExists _
    Lib "imagehlp.dll" (ByVal Pfad As String) As Long
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : ExportPicture 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 21.12.2012 
' Purpose   : Bild exportieren Verzeichnis bei Bedarf erstellen... 
'-------------------------------------------------------------------------- 
Public Sub ExportPicture()
    Dim strPicture As String
    Dim lngPicHeight As Long
    Dim lngPicWidth As Long
    Dim strChart As String
    Dim strSheet As String
    Dim strPath As String
    On Error Resume Next
    strPicture = Selection.Name
    If Not Err.Number = 1004 Then
        On Error GoTo 0
        On Error GoTo Fin
        Application.ScreenUpdating = False
        strSheet = "Tabelle1" ' anpassen!!! 
        strPath = "C:\Temp\" ' anpassen!!! 
        strPath = IIf(Right(strPath, 1) <> "\", strPath & "\", strPath)
        With Selection
            lngPicHeight = .ShapeRange.Height
            lngPicWidth = .ShapeRange.Width
        End With
        Charts.Add
        ActiveChart.Location Where:=xlLocationAsObject, Name:=strSheet
        Selection.Border.LineStyle = 0
        strChart = Selection.Name & " " & Split(ActiveChart.Name, " ")(2)
        With ActiveSheet
            With .Shapes(strChart)
                .Width = lngPicWidth
                .Height = lngPicHeight
            End With
            .Shapes(strPicture).Copy
            With ActiveChart
                .ChartArea.Select
                .Paste
            End With
            MakeSureDirectoryPathExists (strPath)
            .ChartObjects(1).Chart.Export Filename:=strPath & _
                strPicture & ".jpg", FilterName:="jpg"
            .Shapes(strChart).Cut
        End With
    End If
Fin:
    Application.CutCopyMode = False
    If Err.Number <> 0 Then MsgBox "Fehler: Kein Bild! " & _
        "Oder: " & Err.Number & " " & Err.Description
    Application.ScreenUpdating = True
End Sub

Code gehört in ein Modul / Code belongs in a module:

Option Explicit
Private Declare Function MakeSureDirectoryPathExists _
    Lib "imagehlp.dll" (ByVal Pfad As String) As Long
'-------------------------------------------------------------------------- 
' Module    : Modul2 
' Procedure : ExportPicture_1 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 21.12.2012 
' Purpose   : Bild exportieren Verzeichnis bei Bedarf erstellen... 
'-------------------------------------------------------------------------- 
Public Sub ExportPicture_1()
    Dim wksSheet As Worksheet
    Dim strPicture As String
    Dim lngPicHeight As Long
    Dim lngPicWidth As Long
    Dim strChart As String
    Dim strPath As String
    On Error Resume Next
    strPicture = Selection.Name
    If Not Err.Number = 1004 Then
        On Error GoTo 0
        On Error GoTo Fin
        Application.ScreenUpdating = False
        strPath = "C:\Temp\" ' anpassen!!! 
        strPath = IIf(Right(strPath, 1) <> "\", strPath & "\", strPath)
        With Selection
            lngPicHeight = .ShapeRange.Height
            lngPicWidth = .ShapeRange.Width
        End With
        Set wksSheet = Worksheets.Add
        Charts.Add
        ActiveChart.Location Where:=xlLocationAsObject, Name:=wksSheet.Name
        Selection.Border.LineStyle = 0
        strChart = Selection.Name & " " & Split(ActiveChart.Name, " ")(2)
        With wksSheet
            With .Shapes(strChart)
                .Width = lngPicWidth
                .Height = lngPicHeight
            End With
            Tabelle1.Shapes(strPicture).Copy
            With ActiveChart
                .ChartArea.Select
                .Paste
            End With
            MakeSureDirectoryPathExists (strPath)
            .ChartObjects(1).Chart.Export Filename:=strPath & _
                strPicture & ".jpg", FilterName:="jpg"
        End With
    End If
Fin:
    Application.CutCopyMode = False
    If Not wksSheet Is Nothing Then
        Application.DisplayAlerts = False
        wksSheet.Delete
        Application.DisplayAlerts = True
    End If
    Set wksSheet = Nothing
    If Err.Number <> 0 Then MsgBox "Fehler: Kein Bild! " & _
        "Oder: " & Err.Number & " " & Err.Description
    Application.ScreenUpdating = True
End Sub

Code gehört in ein Modul / Code belongs in a module:

Option Explicit
Option Private Module
Private Declare Function MakeSureDirectoryPathExists _
    Lib "imagehlp.dll" (ByVal Pfad As String) As Long
'-------------------------------------------------------------------------- 
' Module    : Modul3 
' Procedure : Test 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 21.12.2012 
' Purpose   : Bild exportieren Verzeichnis bei Bedarf erstellen... 
'-------------------------------------------------------------------------- 
Public Sub Test()
    ExportPicture_2 Application.Caller
End Sub
Public Sub ExportPicture_2(ByVal strShape As String)
    Dim wksSheet As Worksheet
    Dim lngPicHeight As Long
    Dim lngPicWidth As Long
    Dim strChart As String
    Dim strPath As String
    On Error Resume Next
    If Not Err.Number = 1004 Then
        On Error GoTo 0
        On Error GoTo Fin
        Application.ScreenUpdating = False
        strPath = "C:\Temp\" ' anpassen!!! 
        strPath = IIf(Right(strPath, 1) <> "\", strPath & "\", strPath)
        With Tabelle2.Shapes(strShape)
            lngPicHeight = .Height
            lngPicWidth = .Width
        End With
        Set wksSheet = Worksheets.Add
        Charts.Add
        ActiveChart.Location Where:=xlLocationAsObject, Name:=wksSheet.Name
        Selection.Border.LineStyle = 0
        strChart = Selection.Name & " " & Split(ActiveChart.Name, " ")(2)
        With wksSheet
            With .Shapes(strChart)
                .Width = lngPicWidth
                .Height = lngPicHeight
            End With
            Tabelle2.Shapes(strShape).Copy
            With ActiveChart
                .ChartArea.Select
                .Paste
            End With
            MakeSureDirectoryPathExists (strPath)
            .ChartObjects(1).Chart.Export Filename:=strPath & _
                Tabelle2.Shapes(strShape).Name & ".jpg", FilterName:="jpg"
        End With
    End If
Fin:
    Application.CutCopyMode = False
    If Not wksSheet Is Nothing Then
        Application.DisplayAlerts = False
        wksSheet.Delete
        Application.DisplayAlerts = True
    End If
    Set wksSheet = Nothing
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
    Application.ScreenUpdating = True
End Sub

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...