Esportare immagini da file excel in jpg utilizzando VBA

Question

Ho un file Excel che include immagini nella colonna B e voglio esportarle in diversi file come .jpg (o qualsiasi altro formato di file di immagine). Il nome del file deve essere generato dal testo della colonna A. Ho cercato seguente macro VBA:

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 

Il risultato è che esso genera file (jpg), senza alcun contenuto. Presumo che la linea Print #1, cell.Offset(0, 1).text. sia errata. Non so di cosa ho bisogno per cambiarlo, cell.Offset(0, 1).pix?

Qualcuno può aiutarmi? Grazie!

Answer 1

Questo codice:

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 

è stato copiato direttamente da here, e funziona benissimo per i casi che ho provato.

Answer 2

Se ricordo correttamente, è necessario utilizzare la proprietà "Forme" del foglio.

Ogni oggetto Forma ha gli attributi TopLeftCell e BottomRightCell che indicano la posizione dell'immagine.

Ecco un pezzo di codice che ho usato un po 'di tempo fa, approssimativamente adattato alle vostre esigenze. Non mi ricordo le specifiche su tutte quelle ChartObjects e quant'altro, ma qui è:

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

Ecco un altro modo intelligente per fare it- utilizzando en visualizzatore esterno che accetta opzioni della riga di comando (IrfanView in questo caso) : * Ho basato il ciclo su ciò che Michal Krzych ha scritto sopra.

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" 

snellita il codice al minimo assoluto, se necessario.

Answer 5

''' Set intervallo da esportare nella cartella

cartelle di lavoro ("il tuo nome della cartella di lavoro"). Sheets ("nome yoursheet"). Selezionare

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