Forum Discussion
Marco_DellOca
Apr 29, 2021Copper Contributor
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
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
- WoldmanIron Contributor
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_DellOcaCopper Contributor
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
- WoldmanIron ContributorIt is a bit odd to confirm your own answer as best response as responses come from contributors who help.