size FaceID picture on commandbutton

[RB Smissaert]

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

[007007007]

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]

Another example,

Const ImgFileformat = "Image Files (*.bmp;*.gif;*.tif;*.jpg;*.jpeg)," & _
** "*bmp;*gif;*.tif;*.jpg;*.jpeg"
Sub AddPicturesToComments()
Dim HasCom
Dim Pict As String
Dim Ans As Integer
Set HasCom = ActiveCell.Comment
If Not HasCom Is Nothing Then ActiveCell.Comment.Delete
Set HasCom = Nothing
GetPict:
Pict = Application.GetOpenFilename(ImgFileformat)
If Pict = "False" Then End
Ans = MsgBox("Open : " & Pict, vbYesNo + vbExclamation, "Use this Picture?")
If Ans = vbNo Then GoTo GetPict
With ActiveCell
** .AddComment
** .Comment.Visible = False
** .Comment.Shape.Fill.Transparency = 0#
** .Comment.Shape.Fill.UserPicture Pict
** '.Comment.Shape.LockAspectRatio = msoTrue**
'Coded by chijanzen
** ' .Comment.Shape.Height = 30#**************************
'Coded by chijanzen
End With
'ActiveCell.Select
'ActiveCell.Comment.Shape.ScaleWidth 3, msoFalse, msoScaleFromTopLeft**' Coded by Emily(HK)
'ActiveCell.Comment.Shape.ScaleHeight 4, msoFalse, msoScaleFromTopLeft**' Coded by Emily(HK)

[RB Smissaert]

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

RBS

"007007007" <[email protected]> wrote
in message news:[email protected]...
>
> 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
>