Download image from excel to desktop using vba

[RodrigoFinguer]

Hello,

I have some images in column "E:E" for each cell and I need to download them and save with the number of the material in the column "B:B".
The images do not follow the correct sequence, beginning in 1 to n, so, first of all, we need to select the image and then save it in desktop.
For example, the title of the first image is “Image4”, and I need to download it with text “1677.jpg”, in desktop. The number "1677" is in cell "B3" and the image is in cell "E3".

The lines have the same size and the images have the same hseight of the cell.

Best regards,
Finguer

 

[Domenic]

Try...

Option Explicit

Sub ExportImages()


    If TypeName(ActiveSheet) <> "Worksheet" Then
        MsgBox "No worksheet is active!", vbExclamation
        Exit Sub
    End If
    
    Dim saveToFolder As String
    Dim saveAsFilename As String
    Dim currentShape As Shape
    Dim shapeCount As Long
    
    Application.ScreenUpdating = False
    
    saveToFolder = "C:\Users\Domenic\Desktop\"
    If Right(saveToFolder, 1) <> "\" Then
        saveToFolder = saveToFolder & "\"
    End If
    
    shapeCount = 0
    For Each currentShape In ActiveSheet.Shapes
        If currentShape.Type = msoPicture Then
            If Not Intersect(Columns("E:E"), currentShape.TopLeftCell) Is Nothing Then
                saveAsFilename = Cells(currentShape.TopLeftCell.Row, "B").Value & ".jpg"
                ExportImage saveToFolder, saveAsFilename, currentShape
                shapeCount = shapeCount + 1
            End If
        End If
    Next currentShape
    
    Application.ScreenUpdating = True
    
    MsgBox "Images exported: " & shapeCount, vbInformation, "Exported Images"
    
End Sub


Sub ExportImage(ByVal saveToFolder As String, ByVal saveAsFilename As String, ByVal shapeToExport As Shape)


    Dim ws As Worksheet
    
    Set ws = shapeToExport.Parent
    
    With ws.ChartObjects.Add(Left:=0, Top:=0, Width:=shapeToExport.Width, Height:=shapeToExport.Height)
        .Activate
        With .Chart
            .ChartArea.Format.Line.Visible = msoFalse
            shapeToExport.Copy
            .Paste
            .Export fileName:=saveToFolder & saveAsFilename, filtername:="JPG"
        End With
        .Delete
    End With
    
End Sub

Hope this helps!

 

[RodrigoFinguer]

Try...

Option Explicit

Sub ExportImages()


    If TypeName(ActiveSheet) <> "Worksheet" Then
        MsgBox "No worksheet is active!", vbExclamation
        Exit Sub
    End If
    
    Dim saveToFolder As String
    Dim saveAsFilename As String
    Dim currentShape As Shape
    Dim shapeCount As Long
    
    Application.ScreenUpdating = False
    
    saveToFolder = "C:\Users\Domenic\Desktop\"
    If Right(saveToFolder, 1) <> "\" Then
        saveToFolder = saveToFolder & "\"
    End If
    
    shapeCount = 0
    For Each currentShape In ActiveSheet.Shapes
        If currentShape.Type = msoPicture Then
            If Not Intersect(Columns("E:E"), currentShape.TopLeftCell) Is Nothing Then
                saveAsFilename = Cells(currentShape.TopLeftCell.Row, "B").Value & ".jpg"
                ExportImage saveToFolder, saveAsFilename, currentShape
                shapeCount = shapeCount + 1
            End If
        End If
    Next currentShape
    
    Application.ScreenUpdating = True
    
    MsgBox "Images exported: " & shapeCount, vbInformation, "Exported Images"
    
End Sub


Sub ExportImage(ByVal saveToFolder As String, ByVal saveAsFilename As String, ByVal shapeToExport As Shape)


    Dim ws As Worksheet
    
    Set ws = shapeToExport.Parent
    
    With ws.ChartObjects.Add(Left:=0, Top:=0, Width:=shapeToExport.Width, Height:=shapeToExport.Height)
        .Activate
        With .Chart
            .ChartArea.Format.Line.Visible = msoFalse
            shapeToExport.Copy
            .Paste
            .Export fileName:=saveToFolder & saveAsFilename, filtername:="JPG"
        End With
        .Delete
    End With
    
End Sub

Hope this helps!

Yeah, that worked, thank you very much!!