Exportieren Sie Bilder aus einer Excel-Datei mit VBA in jpg

Dieser Code:

Option Explicit

Sub ExportMyPicture()

     Dim MyChart As String, MyPicture As String
     Dim PicWidth As Long, PicHeight As Long

     Application.ScreenUpdating = False
     On Error GoTo Finish

     MyPicture = Selection.Name
     With Selection
           PicHeight = .ShapeRange.Height
           PicWidth = .ShapeRange.Width
     End With

     Charts.Add
     ActiveChart.Location Where:=xlLocationAsObject, Name:="Sheet1"
     Selection.Border.LineStyle = 0
     MyChart = Selection.Name & " " & Split(ActiveChart.Name, " ")(2)

     With ActiveSheet
           With .Shapes(MyChart)
                 .Width = PicWidth
                 .Height = PicHeight
           End With

           .Shapes(MyPicture).Copy

           With ActiveChart
                 .ChartArea.Select
                 .Paste
           End With

           .ChartObjects(1).Chart.Export Filename:="MyPic.jpg", FilterName:="jpg"
           .Shapes(MyChart).Cut
     End With

     Application.ScreenUpdating = True
     Exit Sub

Finish:
     MsgBox "You must select a picture"
End Sub

wurde direkt von hier kopiert und funktioniert wunderbar für die Fälle, die ich getestet habe.

Wenn ich mich recht erinnere, müssen Sie die Eigenschaft "Shapes" Ihres Arbeitsblatts verwenden.

Jedes Shape-Objekt verfügt über ein TopLeftCell- und ein BottomRightCell-Attribut, das die Position des Bildes angibt.

Hier ist ein Stück Code, den ich vor einiger Zeit verwendet habe, ungefähr an Ihre Bedürfnisse angepasst. Ich kann mich nicht an die Einzelheiten zu all diesen ChartObjects und so weiter erinnern, aber hier ist es:

For Each oShape In ActiveSheet.Shapes
    strImageName = ActiveSheet.Cells(oShape.TopLeftCell.Row, 1).Value
    oShape.Select
    'Picture format initialization
    Selection.ShapeRange.PictureFormat.Contrast = 0.5: Selection.ShapeRange.PictureFormat.Brightness = 0.5: Selection.ShapeRange.PictureFormat.ColorType = msoPictureAutomatic: Selection.ShapeRange.PictureFormat.TransparentBackground = msoFalse: Selection.ShapeRange.Fill.Visible = msoFalse: Selection.ShapeRange.Line.Visible = msoFalse: Selection.ShapeRange.Rotation = 0#: Selection.ShapeRange.PictureFormat.CropLeft = 0#: Selection.ShapeRange.PictureFormat.CropRight = 0#: Selection.ShapeRange.PictureFormat.CropTop = 0#: Selection.ShapeRange.PictureFormat.CropBottom = 0#: Selection.ShapeRange.ScaleHeight 1#, msoTrue, msoScaleFromTopLeft: Selection.ShapeRange.ScaleWidth 1#, msoTrue, msoScaleFromTopLeft
    '/Picture format initialization
    Application.Selection.CopyPicture
    Set oDia = ActiveSheet.ChartObjects.Add(0, 0, oShape.Width, oShape.Height)
    Set oChartArea = oDia.Chart
    oDia.Activate
    With oChartArea
        .ChartArea.Select
        .Paste
        .Export ("H:\Webshop_Zpider\Strukturbildene\" & strImageName & ".jpg")
    End With
    oDia.Delete 'oChartArea.Delete
Next

'' 'Legen Sie den Bereich fest, den Sie in den Ordner exportieren möchten

Arbeitsmappen ("Name Ihrer Arbeitsmappe"). Blätter ("Name Ihrer Arbeitsmappe"). Wählen Sie

Dim rgExp As Range: Set rgExp = Range("A1:H31")
''' Copy range as picture onto Clipboard
rgExp.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
''' Create an empty chart with exact size of range copied
With ActiveSheet.ChartObjects.Add(Left:=rgExp.Left, Top:=rgExp.Top, _
Width:=rgExp.Width, Height:=rgExp.Height)
.Name = "ChartVolumeMetricsDevEXPORT"
.Activate
End With
''' Paste into chart area, export to file, delete chart.
ActiveChart.Paste
ActiveSheet.ChartObjects("ChartVolumeMetricsDevEXPORT").Chart.Export "C:\ExportmyChart.jpg"
ActiveSheet.ChartObjects("ChartVolumeMetricsDevEXPORT").Delete

Danke für die Ideen! Ich habe die obigen Ideen verwendet, um ein Makro für die Konvertierung von Massendateien zu erstellen - konvertiere jede Datei eines Formats in einem Ordner in ein anderes Format.

Für diesen Code ist ein Blatt mit den Zellen "FilePath" (das mit "\" enden muss), "StartExt" (ursprüngliche Dateierweiterung) und "EndExt" (gewünschte Dateierweiterung) erforderlich. Warnung: Es wird keine Bestätigung angefordert, bevor vorhandene Dateien mit demselben Namen und derselben Erweiterung ersetzt werden.

Private Sub CommandButton1_Click()
    Dim path As String
    Dim pathExt As String
    Dim file As String
    Dim oldExt As String
    Dim newExt As String
    Dim newFile As String
    Dim shp As Picture
    Dim chrt As ChartObject
    Dim chrtArea As Chart

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    'Get settings entered by user
    path = Range("FilePath")
    oldExt = Range("StartExt")
    pathExt = path & "*." & oldExt
    newExt = Range("EndExt")

    file = Dir(pathExt)

    Do While Not file = "" 'cycle through all images in folder of selected format
        Set shp = ActiveSheet.Pictures.Insert(path & file) 'Import image
        newFile = Replace(file, "." & oldExt, "." & newExt) 'Determine new file name
        Set chrt = ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height) 'Create blank chart for embedding image
        Set chrtArea = chrt.Chart
        shp.CopyPicture 'Copy image to clipboard
        With chrtArea 'Paste image to chart, then export
            .ChartArea.Select
            .Paste
            .Export (path & newFile)
        End With
        chrt.Delete 'Delete chart
        shp.Delete 'Delete imported image

        file = Dir 'Advance to next file
    Loop

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True


End Sub

Neue Versionen von Excel haben alte Antworten überflüssig gemacht. Es hat lange gedauert, um das zu schaffen, aber es macht einen ziemlich guten Job. Beachten Sie, dass die maximale Bildgröße begrenzt ist und das Seitenverhältnis immer etwas geringer ist, da ich die Umformungsmathematik nicht perfekt optimieren konnte. Beachten Sie, dass ich eines meiner Arbeitsblätter als "wsTMP" bezeichnet habe. Sie können es durch "Sheet1" oder ähnliches ersetzen. Es dauert etwa 1 Sekunde, um den Screenshot auf den Zielpfad zu drucken.

Option Explicit

Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Sub weGucciFam()

Dim tmp As Variant, str As String, h As Double, w As Double

Application.PrintCommunication = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
If Application.StatusBar = False Then Application.StatusBar = "EVENTS DISABLED"

keybd_event vbKeyMenu, 0, 0, 0 'these do just active window
keybd_event vbKeySnapshot, 0, 0, 0
keybd_event vbKeySnapshot, 0, 2, 0
keybd_event vbKeyMenu, 0, 2, 0 'sendkeys alt+printscreen doesn't work
wsTMP.Paste
DoEvents
Const dw As Double = 1186.56
Const dh As Double = 755.28

str = "C:\Users\YOURUSERNAMEHERE\Desktop\Screenshot.jpeg"
w = wsTMP.Shapes(1).Width
h = wsTMP.Shapes(1).Height

Application.DisplayAlerts = False
Set tmp = Charts.Add
On Error Resume Next
With tmp
    .PageSetup.PaperSize = xlPaper11x17
    .PageSetup.TopMargin = IIf(w > dw, dh - dw * h / w, dh - h) + 28
    .PageSetup.BottomMargin = 0
    .PageSetup.RightMargin = IIf(h > dh, dw - dh * w / h, dw - w) + 36
    .PageSetup.LeftMargin = 0
    .PageSetup.HeaderMargin = 0
    .PageSetup.FooterMargin = 0
    .SeriesCollection(1).Delete
    DoEvents
    .Paste
    DoEvents
    .Export Filename:=str, Filtername:="jpeg"
    .Delete
End With
On Error GoTo 0
Do Until wsTMP.Shapes.Count < 1
    wsTMP.Shapes(1).Delete
Loop

Application.PrintCommunication = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.StatusBar = False

End Sub

Hier ist ein weiterer cooler Weg, dies zu tun - mit einem externen Viewer, der Befehlszeilenschalter akzeptiert (in diesem Fall IrfanView): * Ich habe die Schleife auf dem basiert, was Michal Krzych oben geschrieben hat.

Sub ExportPicturesToFiles()
    Const saveSceenshotTo As String = "C:\temp\"
    Const pictureFormat As String = ".jpg"

    Dim pic As Shape
    Dim sFileName As String
    Dim i As Long

    i = 1

    For Each pic In ActiveSheet.Shapes
        pic.Copy
        sFileName = saveSceenshotTo & Range("A" & i).Text & pictureFormat

        Call ExportPicWithIfran(sFileName)

        i = i + 1
    Next
End Sub

Public Sub ExportPicWithIfran(sSaveAsPath As String)
    Const sIfranPath As String = "C:\Program Files\IrfanView\i_view32.exe"
    Dim sRunIfran As String

    sRunIfran = sIfranPath & " /clippaste /convert=" & _
                            sSaveAsPath & " /killmesoftly"

    ' Shell is no good here. If you have more than 1 pic, it will
    ' mess things up (pics will over run other pics, becuase Shell does
    ' not make vba wait for the script to finish).
    ' Shell sRunIfran, vbHide

    ' Correct way (it will now wait for the batch to finish):
    call MyShell(sRunIfran )
End Sub

Bearbeiten: 

  Private Sub MyShell(strShell As String)
  ' based on:
    ' http://stackoverflow.com/questions/15951837/Excel-vba-wait-for-Shell-command-to-complete
   ' by Nate Hekman

    Dim wsh As Object
    Dim waitOnReturn As Boolean:
    Dim windowStyle As VbAppWinStyle

    Set wsh = VBA.CreateObject("WScript.Shell")
    waitOnReturn = True
    windowStyle = vbHide

    wsh.Run strShell, windowStyle, waitOnReturn
End Sub

Dim filepath as string
Sheets("Sheet 1").ChartObjects("Chart 1").Chart.Export filepath & "Name.jpg"

Wenn nötig, wurde der Code auf das absolute Minimum reduziert.