jason52388
06-09-2011, 12:16 PM
This is what I have so far. Can't figure out what I'm doing wrong. I'm trying to import pictures from a folder based on the filenames listed in column C. I'm trying to import them to column A. Any ideas?
Sub Picture2()
Dim picname As String
Dim pasteAt As Integer
Dim lThisRow As Long
lThisRow = 2
Do While (Cells(lThisRow, 3) <> "")
pasteAt = lThisRow
'Dim picname As String
picname = Cells(lThisRow, 3) 'This is the picture name
On Error Resume Next
With Application.FileSearch
.LookIn = "J:\Int'l Growth Strategy\IGS Images\Shanghai Warehouse Catalog Images\"
.SearchSubFolders = True
.Filename = picname & ".jpg"
ActiveSheet.Pictures.Insert(.FoundFiles(i)).Select
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
' This resizes the picture
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
With Selection
'.Left = Range("A6").Left
'.Top = Range("A6").Top
.Left = Cells(pasteAt, 1).Left
.Top = Cells(pasteAt, 1).Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100#
.ShapeRange.Width = 80#
.ShapeRange.Rotation = 0#
End With
End With
lThisRow = lThisRow + 1
Loop
Range("A10").Select
Application.ScreenUpdating = True
End Sub
Sub Picture2()
Dim picname As String
Dim pasteAt As Integer
Dim lThisRow As Long
lThisRow = 2
Do While (Cells(lThisRow, 3) <> "")
pasteAt = lThisRow
'Dim picname As String
picname = Cells(lThisRow, 3) 'This is the picture name
On Error Resume Next
With Application.FileSearch
.LookIn = "J:\Int'l Growth Strategy\IGS Images\Shanghai Warehouse Catalog Images\"
.SearchSubFolders = True
.Filename = picname & ".jpg"
ActiveSheet.Pictures.Insert(.FoundFiles(i)).Select
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
' This resizes the picture
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
With Selection
'.Left = Range("A6").Left
'.Top = Range("A6").Top
.Left = Cells(pasteAt, 1).Left
.Top = Cells(pasteAt, 1).Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100#
.ShapeRange.Width = 80#
.ShapeRange.Rotation = 0#
End With
End With
lThisRow = lThisRow + 1
Loop
Range("A10").Select
Application.ScreenUpdating = True
End Sub