Forum Discussion

Copper Contributor

Apr 29, 2021

Solved

extract image from Ms Excel using Ms Access Vba

Using MS Access and Vba, I need to extract images contained in an excel file, sheet n. 2 and save them in a directory on the pc. Where can I find information? Thanks in advance Marco Dell'Oca

access

Marco_DellOca

Jun 10, 2021

Woldman

thanks Tieme,

I solved the problem by reading the Excel file from Access in this way:

    Dim XL As Excel.Application
    Dim WB As Excel.Workbook
    Dim WS As Excel.Worksheet
    Dim SH As Excel.Worksheet
    
    Set XL = CreateObject("Excel.Application")
    Set WB = XL.Workbooks.Open(<file Excel path>)
    XL.Visible = False
    WB.Worksheets(sheet_no + 1).Select
    Set WS = WB.ActiveSheet
    Set SH = WB.Worksheets.Item(sheet_no + 1)

    Dim output_folder As String
    Dim image As Object, image_name As String, img_dimension As Variant, img_area As Variant
    
    output_folder = CurrentProject.Path & "\Temp\"

    For Each image In ActiveSheet.Shapes
        image_name = image.TopLeftCell.Row & "_" & image.TopLeftCell.Column
 
        image.Select
        With Selection.ShapeRange
            .Fill.Visible = msoFalse
            .Line.Visible = msoFalse
            .Rotation = 0#
            .ScaleHeight 1#, msoTrue, msoScaleFromTopLeft
            .ScaleWidth 1#, msoTrue, msoScaleFromTopLeft
        End With
        With Selection.ShapeRange.pictureFormat
            .CropLeft = 0#
            .CropRight = 0#
            .CropBottom = 0#
            .CropTop = 0#
            .TransparentBackground = msoFalse
        End With
        Selection.CopyPicture
        Set img_dimension = ActiveSheet.ChartObjects.Add(0, 0, image.Width, image.Height)
        Set img_area = img_dimension.Chart
        img_dimension.Activate
        With img_area
            .ChartArea.Select
            .Paste
            .Export (output_folder & "\" & image_name & ".jpg")
        End With
        img_dimension.Delete
        
successivo:
    Next
    
    Set XL = Nothing
    Set WB = Nothing
    Set WS = Nothing
    Set SH = Nothing
    
Exit Sub
    
err_ExportMyPicture:
    MsgBox "the immage: " & image_name & " was not exported."
    
    
Resume successivo

Thanks a lot for the tip Marco Dell'Oca

Woldman

Iron Contributor

Jun 10, 2021

Marco_DellOca

I use this in Excel (VBA). This subroutine exports pictures by first converting them to a chart object that can be saved to a folder. You can either use this in Excel or port it to Access VBA:

Sub SaveAllPictures()
    Dim shPictures
    Set shPictures = ActiveWorkbook.Sheets(2)
    
    Dim oShape As Shape
    Dim strPictureName As String
    Dim oChartObject As ChartObject
    Dim oChart As Chart
    
    For Each oShape In ActiveSheet.Shapes
        strPictureName = oShape.Name
        
        oShape.Select
        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

        Application.Selection.CopyPicture
        Set oChartObject = ActiveSheet.ChartObjects.Add(0, 0, oShape.Width, oShape.Height)
        Set oChart = oChartObject.Chart
        oChartObject.Activate
        With oChart
            .ChartArea.Select
            .Paste
            .Export ("..." & strPictureName & ".jpg") '<-- add your folder here
        End With
        oChartObject.Delete
    Next
    
    Set shPictures = Nothing
End Sub

Best regards,

Tieme

Marco_DellOca

Copper Contributor

Jun 10, 2021

Woldman

thanks Tieme,

I solved the problem by reading the Excel file from Access in this way:

    Dim XL As Excel.Application
    Dim WB As Excel.Workbook
    Dim WS As Excel.Worksheet
    Dim SH As Excel.Worksheet
    
    Set XL = CreateObject("Excel.Application")
    Set WB = XL.Workbooks.Open(<file Excel path>)
    XL.Visible = False
    WB.Worksheets(sheet_no + 1).Select
    Set WS = WB.ActiveSheet
    Set SH = WB.Worksheets.Item(sheet_no + 1)

    Dim output_folder As String
    Dim image As Object, image_name As String, img_dimension As Variant, img_area As Variant
    
    output_folder = CurrentProject.Path & "\Temp\"

    For Each image In ActiveSheet.Shapes
        image_name = image.TopLeftCell.Row & "_" & image.TopLeftCell.Column
 
        image.Select
        With Selection.ShapeRange
            .Fill.Visible = msoFalse
            .Line.Visible = msoFalse
            .Rotation = 0#
            .ScaleHeight 1#, msoTrue, msoScaleFromTopLeft
            .ScaleWidth 1#, msoTrue, msoScaleFromTopLeft
        End With
        With Selection.ShapeRange.pictureFormat
            .CropLeft = 0#
            .CropRight = 0#
            .CropBottom = 0#
            .CropTop = 0#
            .TransparentBackground = msoFalse
        End With
        Selection.CopyPicture
        Set img_dimension = ActiveSheet.ChartObjects.Add(0, 0, image.Width, image.Height)
        Set img_area = img_dimension.Chart
        img_dimension.Activate
        With img_area
            .ChartArea.Select
            .Paste
            .Export (output_folder & "\" & image_name & ".jpg")
        End With
        img_dimension.Delete
        
successivo:
    Next
    
    Set XL = Nothing
    Set WB = Nothing
    Set WS = Nothing
    Set SH = Nothing
    
Exit Sub
    
err_ExportMyPicture:
    MsgBox "the immage: " & image_name & " was not exported."
    
    
Resume successivo

Thanks a lot for the tip Marco Dell'Oca

Woldman
Iron Contributor
Jun 10, 2021
It is a bit odd to confirm your own answer as best response as responses come from contributors who help.
- Marco_DellOca
  Copper Contributor
  Jun 10, 2021
  Pardon,
  I tried again but couldn't change my choice.
  
  Endless excuses.