Import picture in excel from a folder with VBA not as link

mehidy1437

Active Member
Joined
Nov 15, 2019
Messages
348
Office Version
  1. 365
  2. 2016
  3. 2013
Platform
  1. Windows
  2. Mobile
  3. Web
Hi Guys,

I'm using this code to import image in excel sheets.
It's working fine.
Only issue is it's import the image as link.
But I want to bring/place the image in sheet not as a link.
So, if I send the file to any computer, picture should be always in the sheet.


I have tried to changes this part
With ActiveSheet.Pictures.insert(PicPath)
with this
With ActiveSheet.Shapes.AddPicture(fileName:=PicPath, LinkToFile:=False, SaveWithDocument:=True)
But it's not import any picture

VBA code
VBA Code:
Sub AddOlEObject()

Dim mainWorkBook As Workbook

Set mainWorkBook = ActiveWorkbook
Sheets("Object").Activate

 Dim folderPath As String
 folderPath = Application.InputBox("Put the folder path in inputbox")

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, "jpeg", vbTextCompare) > 1 _
    Or InStr(1, strCompFilePath, "gif", vbTextCompare) > 1 _
        Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1) Then
        counter = counter + 1
        Sheets("Object").Range("A" & counter).Value = fls.Name
        Sheets("Object").Range("B" & counter).ColumnWidth = 25
        Sheets("Object").Range("B" & counter).RowHeight = 150
        Sheets("Object").Range("B" & counter).Activate
        Call insert(strCompFilePath, counter) '''see insert function code in below
        Sheets("Object").Activate
    End If
End If
Next

'mainWorkBook.Save

End Sub

Function insert(PicPath, counter)
    'msgBox PicPath
    
    With ActiveSheet.Pictures.insert(PicPath)
        With .ShapeRange
            .LockAspectRatio = msoFalse
            .Width = 130
            .Height = 140
        End With
        
        'With .ShapeRange
         '   .LockAspectRatio = msoTrue
          '  .Width = 24
           ' .Height = 140
        'End With
        
        .Left = ActiveSheet.Range("B" & counter).Left
        .Top = ActiveSheet.Range("B" & counter).Top
        .Placement = 1
        .PrintObject = True
    End With
End Function
 

Excel Facts

How to create a cell-sized chart?
Tiny charts, called Sparklines, were added to Excel 2010. Look for Sparklines on the Insert tab.
Hi there

Test below and let us know?

VBA Code:
Sub AddOlEObject()
    Dim mainWorkBook As Workbook
    Set mainWorkBook = ActiveWorkbook
    Sheets("Object").Activate
    Dim folderPath  As String
    folderPath = Application.InputBox("Put the folder path in inputbox")
    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, "jpeg", vbTextCompare) > 1 _
               Or InStr(1, strCompFilePath, "gif", vbTextCompare) > 1 _
               Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1) Then
            counter = counter + 1
            Sheets("Object").Range("A" & counter).Value = fls.Name
            Sheets("Object").Range("B" & counter).ColumnWidth = 25
            Sheets("Object").Range("B" & counter).RowHeight = 150
            Sheets("Object").Range("B" & counter).Activate
            Call insert(strCompFilePath, counter)        '''see insert function code in below
            Sheets("Object").Activate
        End If
    End If
Next
'mainWorkBook.Save
End Sub


Function insert(PicPath, counter)
    'msgBox PicPath
    With ActiveSheet.Pictures.insert(PicPath)
        With .ShapeRange
            .LockAspectRatio = msoFalse
            .Width = 130
            .Height = 140
            LinkToFile = FALSE
            SaveWithDocument = TRUE
        End With
        'With .ShapeRange
        '   .LockAspectRatio = msoTrue
        '  .Width = 24
        ' .Height = 140
        'End With
        .Left = ActiveSheet.Range("B" & counter).Left
        .Top = ActiveSheet.Range("B" & counter).Top
        .Placement = 1
        .PrintObject = TRUE
    End With
End Function
 
Upvote 0
Got the support & solution with ChatGPT.
VBA Code:
Function insert(PicPath, counter)
    'msgBox PicPath
    
    Dim shp As Shape
    Set shp = ActiveSheet.Shapes.AddPicture(PicPath, msoFalse, msoTrue, _
        ActiveSheet.Range("B" & counter).Left, ActiveSheet.Range("B" & counter).Top, _
        130, 140)
    
    shp.Placement = xlMoveAndSize 'Embed the picture in the worksheet
    shp.PrintObject = True 'Allows picture to be printed
    
End Function
 
Upvote 0
Solution
Hi there

Test below and let us know?

VBA Code:
Sub AddOlEObject()
    Dim mainWorkBook As Workbook
    Set mainWorkBook = ActiveWorkbook
    Sheets("Object").Activate
    Dim folderPath  As String
    folderPath = Application.InputBox("Put the folder path in inputbox")
    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, "jpeg", vbTextCompare) > 1 _
               Or InStr(1, strCompFilePath, "gif", vbTextCompare) > 1 _
               Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1) Then
            counter = counter + 1
            Sheets("Object").Range("A" & counter).Value = fls.Name
            Sheets("Object").Range("B" & counter).ColumnWidth = 25
            Sheets("Object").Range("B" & counter).RowHeight = 150
            Sheets("Object").Range("B" & counter).Activate
            Call insert(strCompFilePath, counter)        '''see insert function code in below
            Sheets("Object").Activate
        End If
    End If
Next
'mainWorkBook.Save
End Sub


Function insert(PicPath, counter)
    'msgBox PicPath
    With ActiveSheet.Pictures.insert(PicPath)
        With .ShapeRange
            .LockAspectRatio = msoFalse
            .Width = 130
            .Height = 140
            LinkToFile = FALSE
            SaveWithDocument = TRUE
        End With
        'With .ShapeRange
        '   .LockAspectRatio = msoTrue
        '  .Width = 24
        ' .Height = 140
        'End With
        .Left = ActiveSheet.Range("B" & counter).Left
        .Top = ActiveSheet.Range("B" & counter).Top
        .Placement = 1
        .PrintObject = TRUE
    End With
End Function
Thanks for your support, I will test the code & update here.
I already got a solution through ChatGPT
But I will try this code also.
 
Upvote 0
Re: "Got the support & solution with ChatGPT."
Would have been polite if you mentioned in your post that you had cross posted so people don't waste time if there is a solution elsewhere.
 
Upvote 0
Re: "Got the support & solution with ChatGPT."
Would have been polite if you mentioned in your post that you had cross posted so people don't waste time if there is a solution elsewhere.
It's not a cross post, after posting it here.
I thought lets try with ChatGPT, if I can get the support from this tools or not?
After trying couple of conversation with ChatGPT, its generate the solution for me.
Hope you got the situation.
 
Upvote 0
Hi there

Test below and let us know?

VBA Code:
Sub AddOlEObject()
    Dim mainWorkBook As Workbook
    Set mainWorkBook = ActiveWorkbook
    Sheets("Object").Activate
    Dim folderPath  As String
    folderPath = Application.InputBox("Put the folder path in inputbox")
    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, "jpeg", vbTextCompare) > 1 _
               Or InStr(1, strCompFilePath, "gif", vbTextCompare) > 1 _
               Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1) Then
            counter = counter + 1
            Sheets("Object").Range("A" & counter).Value = fls.Name
            Sheets("Object").Range("B" & counter).ColumnWidth = 25
            Sheets("Object").Range("B" & counter).RowHeight = 150
            Sheets("Object").Range("B" & counter).Activate
            Call insert(strCompFilePath, counter)        '''see insert function code in below
            Sheets("Object").Activate
        End If
    End If
Next
'mainWorkBook.Save
End Sub


Function insert(PicPath, counter)
    'msgBox PicPath
    With ActiveSheet.Pictures.insert(PicPath)
        With .ShapeRange
            .LockAspectRatio = msoFalse
            .Width = 130
            .Height = 140
            LinkToFile = FALSE
            SaveWithDocument = TRUE
        End With
        'With .ShapeRange
        '   .LockAspectRatio = msoTrue
        '  .Width = 24
        ' .Height = 140
        'End With
        .Left = ActiveSheet.Range("B" & counter).Left
        .Top = ActiveSheet.Range("B" & counter).Top
        .Placement = 1
        .PrintObject = TRUE
    End With
End Function
I have tried this code, but it doesn't embed the image in the sheet.
It gives the same result: images are added as links.
 
Upvote 0

Forum statistics

Threads
1,224,817
Messages
6,181,149
Members
453,021
Latest member
Justyna P

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top