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

mehidy1437

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)
Click to expand...
with this
With ActiveSheet.Shapes.AddPicture(fileName:=PicPath, LinkToFile:=False, SaveWithDocument:=True)
Click to expand...
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

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying
Sort by date Sort by votes
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
Jimmypop said:
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
Click to expand...
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
jolivanes said:
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.
Click to expand...
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
Jimmypop said:
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
Click to expand...
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
You must log in or register to reply here.

Similar threads

C
  • Question Question
VBA Insert Picture Into Cell - Not working
Replies
7
Views
2K
sancarn
sancarn
C
  • Question Question
VBA-Photos to be imported from Sharepoint Site rather than local drive
Replies
1
Views
546
Micron
M
J
  • Question Question
Open directory for multiple times to import photos
Replies
1
Views
576
Micron
M
Q
  • Question Question
Import multiple photos from folders in columns
Replies
2
Views
156
Qba
Q
S
  • Question Question
Insert pictures by vba from an sharepoint folder
2
Replies
11
Views
3K
Georgiboy
Georgiboy

Forum statistics

Threads
1,223,893
Messages
6,175,240
Members
452,621
Latest member
Laura_PinksBTHFT

Share this page

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