[image] Export pictures from excel file into jpg using VBA

I have an Excel file which includes pictures in column B and I want like to export them into several files as .jpg (or any other picture file format). The name of the file should be generated from text in column A. I tried following VBA macro:

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

The result is that it generates files (jpg), without any content. I assume the line Print #1, cell.Offset(0, 1).text. is wrong. I don't know what I need to change it into, cell.Offset(0, 1).pix?

Can anybody help me? Thanks!

This question is related to image excel vba export

The answer is


Here is another cool way to do it- using en external viewer that accepts command line switches (IrfanView in this case) : * I based the loop on what Michal Krzych has written above.

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

''' Set Range you want to export to the folder

Workbooks("your workbook name").Sheets("yoursheet name").Select

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

If i remember correctly, you need to use the "Shapes" property of your sheet.

Each Shape object has a TopLeftCell and BottomRightCell attributes that tell you the position of the image.

Here's a piece of code i used a while ago, roughly adapted to your needs. I don't remember the specifics about all those ChartObjects and whatnot, but here it is:

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

This 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

was copied directly from here, and works beautifully for the cases I tested.


Thanks for the ideas! I used the above ideas to make a macro to do a bulk file conversion--convert every file of one format in a folder to another format.

This code requires a sheet with cells named "FilePath" (which must end in a "\"), "StartExt" (original file extension), and "EndExt" (desired file extension). Warning: it doesn't ask for confirmation before replacing existing files with the same name and extension.

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

New versions of excel have made old answers obsolete. It took a long time to make this, but it does a pretty good job. Note that the maximum image size is limited and the aspect ratio is ever so slightly off, as I was not able to perfectly optimize the reshaping math. Note that I've named one of my worksheets wsTMP, you can replace it with Sheet1 or the like. Takes about 1 second to print the screenshot to target path.

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

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

Slimmed down the code to the absolute minimum if needed.


Examples related to image

Reading images in python Numpy Resize/Rescale Image Convert np.array of type float64 to type uint8 scaling values Extract a page from a pdf as a jpeg How do I stretch an image to fit the whole background (100% height x 100% width) in Flutter? Angular 4 img src is not found How to make a movie out of images in python Load local images in React.js How to install "ifconfig" command in my ubuntu docker image? How do I display local image in markdown?

Examples related to excel

Python: Pandas pd.read_excel giving ImportError: Install xlrd >= 0.9.0 for Excel support Converting unix time into date-time via excel How to increment a letter N times per iteration and store in an array? 'Microsoft.ACE.OLEDB.16.0' provider is not registered on the local machine. (System.Data) How to import an Excel file into SQL Server? Copy filtered data to another sheet using VBA Better way to find last used row Could pandas use column as index? Check if a value is in an array or not with Excel VBA How to sort dates from Oldest to Newest in Excel?

Examples related to vba

Copy filtered data to another sheet using VBA Better way to find last used row Check if a value is in an array or not with Excel VBA Creating an Array from a Range in VBA Excel: macro to export worksheet as CSV file without leaving my current Excel sheet VBA: Convert Text to Number What's the difference between "end" and "exit sub" in VBA? Rename Excel Sheet with VBA Macro Extract Data from PDF and Add to Worksheet Quicker way to get all unique values of a column in VBA?

Examples related to export

Export multiple classes in ES6 modules Why Is `Export Default Const` invalid? How to properly export an ES6 class in Node 4? ES6 export all values from object Export a list into a CSV or TXT file in R How to export database schema in Oracle to a dump file Excel VBA to Export Selected Sheets to PDF How to export all data from table to an insertable sql format? Export pictures from excel file into jpg using VBA -bash: export: `=': not a valid identifier