Exportieren Sie Bilder von Excel-Datei in JPG mit VBA

Question

Ich habe eine Excel-Datei, die Bilder in Spalte B enthält und ich möchte sie in mehrere Dateien als JPG (oder ein anderes Bilddateiformat) exportieren. Der Name der Datei sollte von Text in Spalte A erzeugt werden, ich folgenden VBA-Makro versucht:

Private Sub CommandButton1_Click() 
Dim oTxt As Object 
For Each cell In Ark1.Range("A1:A" & Ark1.UsedRange.Rows.Count) 
' you can change the sheet1 to your own choice 
saveText = cell.Text 
Open "H:\Webshop_Zpider\Strukturbildene\" & saveText & ".jpg" For Output As #1 
Print #1, cell.Offset(0, 1).text 
Close #1 
Next cell 
End Sub 

Das Ergebnis ist, dass es Dateien (jpg) erzeugt, ohne Inhalt. Ich nehme an, die Zeile Print #1, cell.Offset(0, 1).text. ist falsch. Ich weiß nicht, was ich brauche, um es zu ändern, cell.Offset(0, 1).pix?

Kann mir jemand helfen? Vielen Dank!

Answer 1

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 aus here kopiert und funktioniert wunderbar für die Fälle, die ich getestet.

Answer 2

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

Jedes Shape-Objekt verfügt über Attribute TopLeftCell und BottomRightCell, die die Position des Bilds angeben.

Hier ist ein Stück Code, den ich vor einiger Zeit verwendet habe, ungefähr an Ihre Bedürfnisse angepasst. Ich erinnere mich nicht, die Besonderheiten über all die Chartobjects und so weiter, 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 

Answer 3

Hier ist eine weitere coole Art it- zu tun mit en externem Viewer, den Schalter Befehlszeile (Irfanview in diesem Fall) akzeptiert : * Ich habe die Schleife auf das aufgebaut, 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 

Edit:

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 

Answer 4

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

den Code auf das absolute Minimum Abgespeckt, wenn nötig.

Answer 5

''‘Set-Bereich wollen Sie in den Ordner exportieren

Workbooks ("Arbeitsmappe name"). Sheets ("yoursheet name"). 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