Need Folder as well Subfolder images

pgujju143

New Member
Joined
Mar 15, 2016
Messages
39
I have below macro but this is only work for one folder i need subfolders also. we need insert images folder as well as subfolders.

Sub InsertImage_Click()
Dim sPath As String, s As String, r As Range
Dim Shp As Shape
Dim PicRange As Range
Dim c As Range, cell As Range, sname As String
Dim diffwidth As Double, diffHeight As Double
sPath = "D:\Images"
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
Set r = Range("A2", Cells(Rows.Count, "A").End(xlUp))
For Each cell In r
cell.Offset(0, 1).Select
Set c = cell.Offset(0, 1)
s = sPath & cell.Value & ".jpg" 'remove the .jpg if the cell contains the extension
sname = Dir(s)
If sname <> "" Then
Set PicRange = cell
Set Shp = ActiveSheet.Shapes.AddPicture(Filename:=s _
, LinkToFile:=False, SaveWithDocument:=True, Left:=PicRange.Left, Top:=PicRange.Top _
, Width:=PicRange.Width, Height:=PicRange.Height)
Shp.ScaleHeight Factor:=0.5, RelativeToOriginalSize:=msoTrue
Shp.Height = 100
If Shp.Height > 450 Then
cell.EntireRow.RowHeight = 450
Else
cell.EntireRow.RowHeight = Shp.Height
End If
Shp.Left = c.Left
Shp.Top = c.Top
End If
Next
End Sub


Any Help me for resolve this.
Thanks in advance.
 

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"

tonyyy

Well-known Member
Joined
Jun 24, 2015
Messages
1,771
Office Version
  1. 2010
Platform
  1. Windows
You might give this a try...

Code:
Dim sPath As String

Sub StartSubfolderLoop()

sPath = "D:\Images"
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
'True includes subfolders; False excludes subfolders
SubfolderLoop sPath, True

End Sub

Code:
Sub SubfolderLoop(SourceFolderName As String, IncludeSubfolders As Boolean)

' set a reference to Microsoft Scripting Runtime

Dim s As String, r As Range
Dim Shp As Shape
Dim PicRange As Range
Dim c As Range, cell As Range, sname As String
Dim diffwidth As Double, diffHeight As Double

Dim fso As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim SubFolder As Scripting.Folder
Dim FileItem As Scripting.File

Set fso = New Scripting.FileSystemObject
Set SourceFolder = fso.GetFolder(SourceFolderName)

For Each FileItem In SourceFolder.Files
    Set r = Range("A2", Cells(Rows.Count, "A").End(xlUp))
    For Each cell In r
        cell.Offset(0, 1).Select
        Set c = cell.Offset(0, 1)
        s = sPath & cell.Value & ".jpg"    'remove the .jpg if the cell contains the extension
        sname = Dir(s)
        If sname <> "" Then
            Set PicRange = cell
            Set Shp = ActiveSheet.Shapes.AddPicture(Filename:=s _
                , LinkToFile:=False, SaveWithDocument:=True, Left:=PicRange.Left, Top:=PicRange.Top _
                , Width:=PicRange.Width, Height:=PicRange.Height)
            Shp.ScaleHeight Factor:=0.5, RelativeToOriginalSize:=msoTrue
            Shp.Height = 100
            If Shp.Height > 450 Then
                cell.EntireRow.RowHeight = 450
            Else
                cell.EntireRow.RowHeight = Shp.Height
            End If
            Shp.Left = c.Left
            Shp.Top = c.Top
        End If
    Next
Next FileItem

If IncludeSubfolders Then
    For Each SubFolder In SourceFolder.SubFolders
        sPath = SubFolder.Path
        SubfolderLoop SubFolder.Path, True
    Next SubFolder
End If

Set FileItem = Nothing
Set SourceFolder = Nothing
Set fso = Nothing

End Sub

Cheers,

tonyyy
 
Last edited:

pgujju143

New Member
Joined
Mar 15, 2016
Messages
39
Thanks for the reply tony but this macro not run properly what exactly i need.
get image more than 6 time in one style no. i means i have image with style no like abc123 in one folder and style no abcd12345 in subfolder, i want subfolder images as well. this macro work on only style no abc123 and get image 6 time in a cell.


Please help us for get image in folder as well subfolders as per style number only one time.


Thanks in advance
 

tonyyy

Well-known Member
Joined
Jun 24, 2015
Messages
1,771
Office Version
  1. 2010
Platform
  1. Windows
The original request was to provide a method to access a primary folder along with its subfolders. From your post #3 it appears to be doing that.

As for "style no" - it's not clear to me what you're trying to accomplish. I suggest you submit another post with that specific request and perhaps someone else will be able to help.
 
Learn Excel from Bill Jelen

Understanding data is crucial, and the easiest place to start is with Microsoft Excel.

Forum statistics

Threads
1,151,492
Messages
5,764,692
Members
425,230
Latest member
DzOus

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
Top