It is easy with Stephen Bullen's routine PastePicture to get an Office
FaceID on a CommandButton, but how do you set the size of picture?
..Picture.Height and .Width are read-only.
Any suggestions?

RBS

Listed for your ref.
"Code by www.VBA.com.tw"
(Put into Mudule one)
Dim FolderName As String

Sub LoadPictures()
Dim k As Integer, r As Integer
Dim sExt As String
k = 1
r = 1
Application.ScreenUpdating = False
Del_msoPicture 'Pls clear of all pic in any worksheet
GetFolder
With Application.FileSearch
.NewSearch
.LookIn = FolderName
.SearchSubFolders = False
.Filename = "*.*"
.FileType = msoFileTypeAllFiles 'Search file types I
.Execute() 0 Then
For i = 1 To .FoundFiles.Count
sExt = UCase(Right(.FoundFiles(i), 3))
'Get Roo
name
If sExt = "JPG" Or sExt = "GIF" Then
'Merge jpg o
gif file
Set rng = Cells(r, k).Resize(5, 3)
Set Pic
ActiveSheet.Pictures.Insert(.FoundFiles(i)) 'Setup pic
'pic situation
With Pic
.Top = rng.Cells(1).Top
.Left = rng.Cells(1, 1).Left
.Height = rng.Height
.Width = rng.Width
End With
k = k + 4
Columns(k - 1).Interior.ColorIndex = 34
Columns(k - 1).ColumnWidth = 2
If k = 17 Then
r = r + 6
k = 1
Rows(r - 1).Interior.ColorIndex = 34
Rows(r - 1).RowHeight = 8
End If
End If
Next i
Else
MsgBox "No any pic"
End If
End With
Application.ScreenUpdating = True
End Sub

--------------------------------------------------------------------------------

Sub GetFolder() '取得資料夾
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
If fd.Show = -1 Then
FolderName = fd.SelectedItems(1)
Else
End
End If
End Sub

--------------------------------------------------------------------------------

Sub Del_msoPicture()
'刪除工作表圖片
'Const msoPicture = 13
On Error Resume Next
'預防工作表中無圖片
Cells.Interior.ColorIndex = xlNone
'清除儲存格背景色
Dim aryGroup() As String, i As Integer
Dim Sh As Shape
For Each shp In ActiveSheet.Shapes
If shp.Type = 13 Then 'msoPicture 類型
ReDim Preserve aryGroup(i)
aryGroup(i) = shp.Name
i = i + 1
End If
Next shp
ActiveSheet.DrawingObjects(aryGroup).Delete
On Error GoTo 0
End Su

--
00700700
-----------------------------------------------------------------------
007007007's Profile: http://www.excelforum.com/member.php...fo&userid=2911
View this thread: http://www.excelforum.com/showthread.php?threadid=49890

Before I give this a try, would this work with a button on a userform?

RBS

"007007007" wrote
in message ...

Listed for your ref.
"Code by www.VBA.com.tw"
(Put into Mudule one)
Dim FolderName As String

Sub LoadPictures()
Dim k As Integer, r As Integer
Dim sExt As String
k = 1
r = 1
Application.ScreenUpdating = False
Del_msoPicture 'Pls clear of all pic in any worksheet
GetFolder
With Application.FileSearch
NewSearch
LookIn = FolderName
SearchSubFolders = False
Filename = "*.*"
FileType = msoFileTypeAllFiles 'Search file types If
Execute() 0 Then
For i = 1 To .FoundFiles.Count
sExt = UCase(Right(.FoundFiles(i), 3))
'Get Root
name
If sExt = "JPG" Or sExt = "GIF" Then
'Merge jpg or
gif file
Set rng = Cells(r, k).Resize(5, 3)
Set Pic =
ActiveSheet.Pictures.Insert(.FoundFiles(i)) 'Setup pic
'pic situation
With Pic
Top = rng.Cells(1).Top
Left = rng.Cells(1, 1).Left
Height = rng.Height
Width = rng.Width
End With
k = k + 4
Columns(k - 1).Interior.ColorIndex = 34
Columns(k - 1).ColumnWidth = 2
If k = 17 Then
r = r + 6
k = 1
Rows(r - 1).Interior.ColorIndex = 34
Rows(r - 1).RowHeight = 8
End If
End If
Next i
Else
MsgBox "No any pic"
End If
End With
Application.ScreenUpdating = True
End Sub

--------------------------------------------------------------------------------

Sub GetFolder() '取得資料夾
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
If fd.Show = -1 Then
FolderName = fd.SelectedItems(1)
Else
End
End If
End Sub

--------------------------------------------------------------------------------

Sub Del_msoPicture()
'刪除工作表圖片
'Const msoPicture = 13
On Error Resume Next
'預防工作表中無圖片
Cells.Interior.ColorIndex = xlNone
'清除儲存格背景色
Dim aryGroup() As String, i As Integer
Dim Sh As Shape
For Each shp In ActiveSheet.Shapes
If shp.Type = 13 Then 'msoPicture 類型
ReDim Preserve aryGroup(i)
aryGroup(i) = shp.Name
i = i + 1
End If
Next shp
ActiveSheet.DrawingObjects(aryGroup).Delete
On Error GoTo 0
End Sub


--
007007007
------------------------------------------------------------------------
007007007's Profile:
http://www.excelforum.com/member.php...o&userid=29111
View this thread: http://www.excelforum.com/showthread...hreadid=498901