Assign faceid to image on userform
create an empty userform and put this code into its code module. I
tested it with Excel 2007.
'------------------------------------------------------------------------
Option Explicit
Private Sub UserForm_Initialize()
create500Images ' we create 500 image controls
SetFaces 1 ' we put the faceID's on them
End Sub
Private Sub create500Images()
Dim i As Integer
Dim j As Integer
Dim jten As Integer
Dim n As Integer
Me.Height = 478
Me.Width = 356
For i = 1 To 25
jten = 1
For j = 1 To 20
With Me.Controls.Add("Forms.Image.1", "cmdNewControl")
.Top = (i - 1) * 17 + Fix(n / 100) * 6
.Left = (j - 1) * 17 + jten
.Width = 18
.Height = 18
.BorderColor = vbButtonShadow 'Me.BackColor
.BackColor = Me.BackColor
End With
n = n + 1
If j = 10 Then jten = 6
Next j
Next i
End Sub
Private Sub SetFaces(start As Integer)
Dim i As Integer
Me.Caption = "Excel FaceID's " & CStr(start) & " - " & CStr(start
+ 499)
For i = start To start + 499
With Me.Controls(i - 1)
.Picture = IconBitMap(i)
.ControlTipText = CStr(i)
End With
Next i
End Sub
Function IconBitMap(BfaceID As Integer) As stdole.IPictureDisp
'From Microsoft Office 11.0 Object Library
Dim oBTN As Office.CommandBarButton
'From Microsoft Windows Common Controls 6.0
Dim oIL(0 To 1) As MSComctlLib.ImageList
'From OLE Automation
Dim oIPD As stdole.IPictureDisp
Dim i As Integer
On Error Resume Next
CommandBars("tmpFACEPUMP").Delete
On Error GoTo 0
With CommandBars.Add("tmpFACEPUMP", , , True)
Set oBTN = .Controls.Add(msoControlButton, , , , True)
End With
For i = 0 To 1
Set oIL(i) = New ImageList
With oIL(i)
.ImageHeight = 16
.ImageWidth = 16
.UseMaskColor = True
.MaskColor = IIf(i = 0, vbWhite, vbBlack)
.BackColor = IIf(i = 0, vbButtonFace, vbBlack)
End With
Next
On Error Resume Next
oBTN.FaceId = BfaceID
With oIL(0).ListImages
.Clear
.Add 1, "M", oBTN.Mask
End With
With oIL(1).ListImages
.Clear
.Add 1, "MM", oIL(0).Overlay("M", "M")
.Add 2, "P", oBTN.Picture
End With
Set oIPD = Nothing
Set IconBitMap = oIL(1).Overlay("P", "MM")
End Function
|