import resize and save images no links on mass in excel using vba

Question

when trying to import and resize cells and pics on mass upto 200 for example. i need to save the images and not just a link to them so i can email xls to someone else who wont have the images or files store on there computer.

    Sub AddOlEObject()

    Dim mainWorkBook As Workbook
    Application.ScreenUpdating = False
    Set mainWorkBook = ActiveWorkbook
    Sheets("Object").Activate           
    where you want your pictures to go
    Folderpath = "folder path"  

    Set fso = CreateObject("Scripting.FileSystemObject")
    NoOfFiles = fso.GetFolder(Folderpath).Files.Count
    Set listfiles = fso.GetFolder(Folderpath).Files
    For Each fls In listfiles
       strCompFilePath = Folderpath & "\" & Trim(fls.Name)
    If strCompFilePath <> "" Then
        If (InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1 _
        Or InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1 _
        Or InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1) Then
            counter = counter + 1
            Sheets("Object").Range("A" & counter).Value = fls.Name
            Sheets("Object").Range("B" & counter).ColumnWidth = 60     'Adjust to fit your pictures
            Sheets("Object").Range("B" & counter).RowHeight = 70           'Adjust to fit your pictures
            Sheets("Object").Range("B" & counter).Activate
            Call insert(strCompFilePath, counter)
            Sheets("Object").Activate
        End If
    End If
    Next
    mainWorkBook.Save
    Application.ScreenUpdating = True

    End Sub

    Function insert(PicPath, counter)
    'MsgBox PicPath
    With ActiveSheet.Pictures.insert(PicPath)
        With .ShapeRange
        .LockAspectRatio = msoTrue
        .Width = 30      'Adjust to change the WIDTH of your pictures
        .Height = 70     'Adjust to change the HEIGHT of your pictures
        End With
    .Left = ActiveSheet.Range("B" & counter).Left
    .Top = ActiveSheet.Range("B" & counter).Top
    .Placement = 1
    .PrintObject = True
    End With
    End Function

Note: sounds like "on mass" but is actually spelled [en masse](https://en.wiktionary.org/wiki/en_masse) (French loan phrase) — RBarryYoung, Apr 27 '22 at 12:52
Use `Shapes.AddPicture` and set `LinkToFile := msoFalse`. See here: https://stackoverflow.com/a/17110977/109122 — RBarryYoung, Apr 27 '22 at 12:59

import resize and save images no links on mass in excel using vba

0 Answers0