Inserting photo from sub-folder

D

domwan

New Member
Joined
Aug 1, 2011
Messages
3
Hi,

I have folder (namely, A) with hundred of sub folders. And each subfolder would have a folder.jpg to representing the content of that sub folder (there are hundreds sub folder under A).

I would to generate a content list of that folder by Excel. Thus, I would have Excel to adding the folder.jpg to the list from each single sub folder to column A automatically. What I need is just appoint folder A and excel will go to the sub folders to pick all folder.jpg. How could it be done by using VBA?

I am an idiot of VBA. It is highly appreciated if someone could help.

Thanks for all expertise who could help.
 

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.
Sort by date Sort by votes
domwan said:
Hi,

I have folder (namely, A) with hundred of sub folders. And each subfolder would have a folder.jpg to representing the content of that sub folder (there are hundreds sub folder under A).

I would to generate a content list of that folder by Excel. Thus, I would have Excel to adding the folder.jpg to the list from each single sub folder to column A automatically. What I need is just appoint folder A and excel will go to the sub folders to pick all folder.jpg. How could it be done by using VBA?

I am an idiot of VBA. It is highly appreciated if someone could help.

Thanks for all expertise who could help.
Click to expand...

the only thing is inserting a picture doesnt line up with cells. cant assign A1 to egual picture 1. can insert them but will be all over the place or on top of each other.

you could possibly read the names of each sub folder and write that into the cell? is that enough??
 
Upvote 0
bensonsearch said:
the only thing is inserting a picture doesnt line up with cells. cant assign A1 to egual picture 1. can insert them but will be all over the place or on top of each other.

you could possibly read the names of each sub folder and write that into the cell? is that enough??
Click to expand...

Thanks for your comment.

Background is what I have a folder (namely 123) with hundreds of sub folders. Each sub folder (for example, AA, AB, AC, AD...) is containing one photo.

To be more logic, followings are what I would like to

1. In cell A1, I would insert the picture from sub-folder AA
2. In cell A2, I would insert the picture from sub-folder AB
3. In cell A3, I would insert the picture from sub-folder AC and so on

Besides, I also would like to

1. automatic resize the picture while insert
2. the picture from each sub-folder will inserted to cell A1, A2, A3. ...automatically when I point to the folder (123)

Wish it is more clear and could have someone help me. thanks in advance.
 
Upvote 0
domwan said:
Thanks for your comment.

Background is what I have a folder (namely 123) with hundreds of sub folders. Each sub folder (for example, AA, AB, AC, AD...) is containing one photo.

To be more logic, followings are what I would like to

1. In cell A1, I would insert the picture from sub-folder AA
2. In cell A2, I would insert the picture from sub-folder AB
3. In cell A3, I would insert the picture from sub-folder AC and so on

Besides, I also would like to

1. automatic resize the picture while insert
2. the picture from each sub-folder will inserted to cell A1, A2, A3. ...automatically when I point to the folder (123)

Wish it is more clear and could have someone help me. thanks in advance.
Click to expand...

hi
As my last post. You can not insert a picture into a cell. Resize yes. Insert onto sheet yes but not to cell.

Hope I'm wrong and someone can help

Cheers
 
Upvote 0
Along these lines, I have inserted photos into the Add Comments box (see how to below), but I had to do it manually.

I've seen somewhere on this board, a method (with code) of editing the Comments box.

Is there code that will allow you to post photos into the comments box automatically?
A macro, could that do it?


Gary

How to embed photos into Comments:
R-click the cell
Click on Insert Comment
Place the cursor at the top right of the Comment box until it turns into a double arrow, then R-click
Select Format Comment
Select Colors and Lines
Click on the Color Drop Down Box
When the color pallet appears, go to the very bottom and click on Fill Effects
Select the Picturs tab
Click on Select Picture at the bottom
Find the picture and click Insert
Click ok, and then ok again to exit out

You can edit text inside the Coments box as well.

HTH,
GAry
 
Upvote 0
To start you off, you could try this.
you may need to call the different paths from the worksheet by changing the directoy of "Images" to a cell reference on the worksheet.

Code: 
Set Pic = Me.Pictures.Insert(Me.Parent.Path & "\Images\" & Target.Value & ".png")

In this example cell A1 is a validation drop-down with a look-up formula


Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address <> "$A$1" Then Exit Sub
    Dim Pic As Picture
    On Error Resume Next
    Me.Pictures("PicTemp").Delete
    On Error GoTo 0
    Target.Offset(, 10).Select 'just sets where the cursor sits
    Set Pic = Me.Pictures.Insert(Me.Parent.Path & "\Images\" & Target.Value & ".png")
    Pic.Name = "PicTemp"
    
    'scale picture
Me.Pictures("PicTemp").Width = 200
'Me.Pictures("PicTemp").Height = 250'
' use height or width, not both

    'Position the image on screen
Me.Pictures("PicTemp").Top = 150
Me.Pictures("PicTemp").Left = 200

End Sub
 
Upvote 0
Paul-H said:
alternatively, this method will allow you to inserts a picture at the top left position of a TargetCell

http://www.exceltip.com/st/Insert_pictures_using_VBA_in_Microsoft_Excel/486.html
Click to expand...


thanks guys. i have tried re-developing following to insert picture into sheet with designated cell. However, could I have it done automatically instead of insert the path and pick the picture one by one? any one could help?

<TABLE border=0 cellSpacing=0 cellPadding=0 width=72><TBODY><TR style="HEIGHT: 13.5pt" height=18><TD style="WIDTH: 54pt; HEIGHT: 13.5pt">Sub AutoInsert Photo ()</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = "ai,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "bmp,bmz"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "cdr,cgm,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "dib,dwg,dxf,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "emf,emz,eps,exf,exif,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "fpx,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "gfa,gif,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "hdr,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "ico,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "jfif,jpe,jpeg,jpg,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "pcd,pct,pcx,pcz,pict,png,psd,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "raw,rle,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "svg,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "tga,tif,tiff,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "ufo,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "wdp,wmf,wmz,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> </TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> K = InputBox("Insert Row number，1=insert", "Insert Row number", 1)</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> If K = "" Then Exit Sub</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> </TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Dim Rng As Range: Set Rng = ActiveCell</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> OpenFile = Application.GetOpenFilename("Picture Files(*.*),*.*", , "Get Picture from here!")</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"></TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> If OpenFile = False Then</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> myDir = ThisWorkbook.Path & "\"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Else</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> myDir = Left(OpenFile, InStrRev(OpenFile, "\"))</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> End If</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Application.ScreenUpdating = False</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> </TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Filename = Dir(myDir)</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> </TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Do While Filename <> ""</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> If InStr(Pf, LCase(Right(Filename, Len(Filename) - InStrRev(Filename, ".")))) > 0 Then</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Rng.Cells(1 + n \ K, n Mod K + 1).Select</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> ActiveCell = Filename 'Left(Filename, InStrRev(Filename, ".") - 1)</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> </TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> ActiveSheet.Pictures.Insert(myDir & Filename).Select</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> With Selection</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> .Placement = xlMoveAndSize</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> .ShapeRange.LockAspectRatio = msoFalse</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> .Top = ActiveCell.Top</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> .Left = ActiveCell.Left</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> .Height = ActiveCell.Height</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> .Width = ActiveCell.Width</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> End With</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> n = n + 1</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> End If</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Filename = Dir</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Loop</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Application.ScreenUpdating = True</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Rng.Select</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt">End Sub</TD></TR></TBODY></TABLE><TABLE border=0 cellSpacing=0 cellPadding=0 width=72><TBODY><TR style="HEIGHT: 13.5pt" height=18><TD style="WIDTH: 54pt; HEIGHT: 13.5pt">Sub AutoInsert Photo ()</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = "ai,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "bmp,bmz"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "cdr,cgm,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "dib,dwg,dxf,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "emf,emz,eps,exf,exif,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "fpx,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "gfa,gif,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "hdr,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "ico,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "jfif,jpe,jpeg,jpg,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "pcd,pct,pcx,pcz,pict,png,psd,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "raw,rle,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "svg,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "tga,tif,tiff,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "ufo,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "wdp,wmf,wmz,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> </TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> K = InputBox("Insert Row number，1=insert", "Insert Row number", 1)</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> If K = "" Then Exit Sub</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> </TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Dim Rng As Range: Set Rng = ActiveCell</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> OpenFile = Application.GetOpenFilename("Picture Files(*.*),*.*", , "Get Picture from here!")</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"></TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> If OpenFile = False Then</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> myDir = ThisWorkbook.Path & "\"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Else</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> myDir = Left(OpenFile, InStrRev(OpenFile, "\"))</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> End If</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Application.ScreenUpdating = False</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> </TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Filename = Dir(myDir)</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> </TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Do While Filename <> ""</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> If InStr(Pf, LCase(Right(Filename, Len(Filename) - InStrRev(Filename, ".")))) > 0 Then</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Rng.Cells(1 + n \ K, n Mod K + 1).Select</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> ActiveCell = Filename 'Left(Filename, InStrRev(Filename, ".") - 1)</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> </TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> ActiveSheet.Pictures.Insert(myDir & Filename).Select</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> With Selection</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> .Placement = xlMoveAndSize</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> .ShapeRange.LockAspectRatio = msoFalse</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> .Top = ActiveCell.Top</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> .Left = ActiveCell.Left</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> .Height = ActiveCell.Height</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> .Width = ActiveCell.Width</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> End With</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> n = n + 1</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> End If</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Filename = Dir</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Loop</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Application.ScreenUpdating = True</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Rng.Select</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt">End Sub</TD></TR></TBODY></TABLE><TABLE border=0 cellSpacing=0 cellPadding=0 width=72><TBODY><TR style="HEIGHT: 13.5pt" height=18><TD style="WIDTH: 54pt; HEIGHT: 13.5pt">Sub AutoInsert Photo ()</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = "ai,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "bmp,bmz"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "cdr,cgm,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "dib,dwg,dxf,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "emf,emz,eps,exf,exif,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "fpx,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "gfa,gif,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "hdr,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "ico,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "jfif,jpe,jpeg,jpg,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "pcd,pct,pcx,pcz,pict,png,psd,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "raw,rle,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "svg,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "tga,tif,tiff,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "ufo,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "wdp,wmf,wmz,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> </TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> K = InputBox("Insert Row number，1=insert", "Insert Row number", 1)</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> If K = "" Then Exit Sub</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> </TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Dim Rng As Range: Set Rng = ActiveCell</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> OpenFile = Application.GetOpenFilename("Picture Files(*.*),*.*", , "Get Picture from here!")</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"></TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> If OpenFile = False Then</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> myDir = ThisWorkbook.Path & "\"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Else</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> myDir = Left(OpenFile, InStrRev(OpenFile, "\"))</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> End If</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Application.ScreenUpdating = False</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> </TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Filename = Dir(myDir)</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> </TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Do While Filename <> ""</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> If InStr(Pf, LCase(Right(Filename, Len(Filename) - InStrRev(Filename, ".")))) > 0 Then</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Rng.Cells(1 + n \ K, n Mod K + 1).Select</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> ActiveCell = Filename 'Left(Filename, InStrRev(Filename, ".") - 1)</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> </TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> ActiveSheet.Pictures.Insert(myDir & Filename).Select</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> With Selection</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> .Placement = xlMoveAndSize</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> .ShapeRange.LockAspectRatio = msoFalse</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> .Top = ActiveCell.Top</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> .Left = ActiveCell.Left</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> .Height = ActiveCell.Height</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> .Width = ActiveCell.Width</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> End With</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> n = n + 1</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> End If</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Filename = Dir</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Loop</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Application.ScreenUpdating = True</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Rng.Select</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt">End Sub</TD></TR></TBODY></TABLE><TABLE border=0 cellSpacing=0 cellPadding=0 width=72><TBODY><TR style="HEIGHT: 13.5pt" height=18><TD style="WIDTH: 54pt; HEIGHT: 13.5pt">Sub AutoInsert Photo ()</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = "ai,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "bmp,bmz"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "cdr,cgm,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "dib,dwg,dxf,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "emf,emz,eps,exf,exif,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "fpx,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "gfa,gif,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "hdr,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "ico,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "jfif,jpe,jpeg,jpg,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "pcd,pct,pcx,pcz,pict,png,psd,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "raw,rle,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "svg,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "tga,tif,tiff,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "ufo,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "wdp,wmf,wmz,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> </TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> K = InputBox("Insert Row number，1=insert", "Insert Row number", 1)</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> If K = "" Then Exit Sub</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> </TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Dim Rng As Range: Set Rng = ActiveCell</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> OpenFile = Application.GetOpenFilename("Picture Files(*.*),*.*", , "Get Picture from here!")</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"></TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> If OpenFile = False Then</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> myDir = ThisWorkbook.Path & "\"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Else</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> myDir = Left(OpenFile, InStrRev(OpenFile, "\"))</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> End If</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Application.ScreenUpdating = False</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> </TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Filename = Dir(myDir)</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> </TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Do While Filename <> ""</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> If InStr(Pf, LCase(Right(Filename, Len(Filename) - InStrRev(Filename, ".")))) > 0 Then</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Rng.Cells(1 + n \ K, n Mod K + 1).Select</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> ActiveCell = Filename 'Left(Filename, InStrRev(Filename, ".") - 1)</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> </TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> ActiveSheet.Pictures.Insert(myDir & Filename).Select</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> With Selection</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> .Placement = xlMoveAndSize</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> .ShapeRange.LockAspectRatio = msoFalse</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> .Top = ActiveCell.Top</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> .Left = ActiveCell.Left</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> .Height = ActiveCell.Height</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> .Width = ActiveCell.Width</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> End With</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> n = n + 1</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> End If</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Filename = Dir</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Loop</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Application.ScreenUpdating = True</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Rng.Select</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt">End Sub</TD></TR></TBODY></TABLE><TABLE border=0 cellSpacing=0 cellPadding=0 width=72><COLGROUP><COL style="WIDTH: 54pt" width=72></COLGROUP><TBODY><TR style="HEIGHT: 13.5pt" height=18><TD style="WIDTH: 54pt; HEIGHT: 13.5pt">Sub AutoInsertPhoto()</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = "ai,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "bmp,bmz"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "cdr,cgm,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "dib,dwg,dxf,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "emf,emz,eps,exf,exif,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "fpx,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "gfa,gif,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "hdr,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "ico,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "jfif,jpe,jpeg,jpg,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "pcd,pct,pcx,pcz,pict,png,psd,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "raw,rle,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "svg,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "tga,tif,tiff,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "ufo,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Pf = Pf & "wdp,wmf,wmz,"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> </TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> K = InputBox("Insert Row number，1=insert", "Insert Row number", 1)</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> If K = "" Then Exit Sub</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> </TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Dim Rng As Range: Set Rng = ActiveCell</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> OpenFile = Application.GetOpenFilename("Picture Files(*.*),*.*", , "Get Picture from here!")</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"></TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> If OpenFile = False Then</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> myDir = ThisWorkbook.Path & "\"</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Else</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> myDir = Left(OpenFile, InStrRev(OpenFile, "\"))</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> End If</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Application.ScreenUpdating = False</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> </TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Filename = Dir(myDir)</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> </TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Do While Filename <> ""</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> If InStr(Pf, LCase(Right(Filename, Len(Filename) - InStrRev(Filename, ".")))) > 0 Then</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Rng.Cells(1 + n \ K, n Mod K + 1).Select</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> ActiveCell = Filename 'Left(Filename, InStrRev(Filename, ".") - 1)</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> </TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> ActiveSheet.Pictures.Insert(myDir & Filename).Select</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> With Selection</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> .Placement = xlMoveAndSize</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> .ShapeRange.LockAspectRatio = msoFalse</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> .Top = ActiveCell.Top</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> .Left = ActiveCell.Left</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> .Height = ActiveCell.Height</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> .Width = ActiveCell.Width</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> End With</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> n = n + 1</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> End If</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Filename = Dir</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Loop</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Application.ScreenUpdating = True</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt"> Rng.Select</TD></TR><TR style="HEIGHT: 13.5pt" height=18><TD style="HEIGHT: 13.5pt">End Sub</TD></TR></TBODY></TABLE>
 
Upvote 0
You must log in or register to reply here.

Similar threads

H
  • Question Question
Permision Denied-VBA Code to list sub-folders
Replies
4
Views
93
howard
H
H
  • Question Question
Macro to List Folders excluding Data Stamp within E:\Cobian
Replies
0
Views
61
howard
H
Q
  • Question Question
Import multiple photos from folders in columns
Replies
2
Views
211
Qba
Q
R
  • Question Question
VBA copying files from multiple subfolders according to a list
Replies
1
Views
61
John_w
J
KlausW
  • Solved
Rename files from old name in column C and new name in column D
Replies
4
Views
109
Domenic
D

Forum statistics

Threads
1,224,507
Messages
6,179,183
Members
452,893
Latest member
denay

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