Need Folder as well Subfolder images

[pgujju143]

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.

 

[tonyyy]

You might give this a try...

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

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

 

[pgujju143]

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]

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.