Prev: OLE Problem on Opening
Next: Select one cell insteade of a range
From: minimaster on 17 Dec 2009 08:19
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
From: minimaster on 18 Dec 2009 03:31
Create a userform with 4 commandbuttons on them (w/ default names
CommandButton1, CommandButton2, and so on)
and put the below code into the code module of this new userform.
It basically does the same as J.Walkensbach faceID browser utility,
but this one doesn't suck in Excel 2007 because it is based on a
userform.

'---------------------------------------------------------------------------------------------------------------
Option Explicit
Dim currentFirstButton As Integer

Private Sub UserForm_Initialize()
SetupCmdButtons
Create500Images
SetFacesFast 4, 1, 500 ' we put the faceID's on the images
currentFirstButton = 1
End Sub
Private Sub SetupCmdButtons()
If Controls.count <> 4 Then
MsgBox "There need to be 4 CommandButtons on this form. Not
more and not less. Modify and try again!"
Unload Me
End If

Dim i As Integer
For i = 1 To 4
With Me.Controls(i - 1)
.Top = 1
.Left = i * 18 + 117
.Width = 18
.Height = 18
End With
Next i
SetFacesFast 0, 154, 4
Controls(0).ControlTipText = "Start at 1"
Controls(1).ControlTipText = "back"
Controls(2).ControlTipText = "forward"
Controls(3).ControlTipText = "goto last gallery"
End Sub

Private Sub CommandButton1_Click()
SetFacesFast 4, 1, 500
currentFirstButton = 1
End Sub
Private Sub CommandButton2_Click()
If currentFirstButton > 500 Then
currentFirstButton = currentFirstButton - 500
If currentFirstButton = 8501 Then currentFirstButton = 7501
If currentFirstButton = 5001 Then currentFirstButton = 4001
SetFacesFast 4, currentFirstButton, 500
End If
End Sub
Private Sub CommandButton3_Click()
If currentFirstButton < 10001 Then
currentFirstButton = currentFirstButton + 500
If currentFirstButton = 8001 Then currentFirstButton = 9001
If currentFirstButton = 4501 Then currentFirstButton = 5501
If currentFirstButton = 10001 Then
SetFacesFast 4, currentFirstButton, 100
Else
SetFacesFast 4, currentFirstButton, 500
End If
End If
End Sub
Private Sub CommandButton4_Click()
SetFacesFast 4, 10001, 100
currentFirstButton = 10001
End Sub
Private Sub Create500Images()
Dim i As Integer
Dim j As Integer
Dim jten As Integer
Dim n As Integer

Me.Height = 498
Me.Width = 352
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 + 20
.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 = 3
Next j
Next i
End Sub

Private Sub SetFacesFast(FirstCtrlID As Integer, start As Integer,
count As Integer)
Dim i As Integer
Dim j As Integer
'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

Me.Height = count * 0.91 + 42
Me.Caption = "Excel FaceID's " & CStr(start) & " - " & CStr(start
+ count - 1)
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

For i = start To start + count - 1
oBTN.FaceId = i
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
With Me.Controls(FirstCtrlID + j)
.Picture = oIL(1).Overlay("P", "MM")
.ControlTipText = CStr(i)
End With
j = j + 1
Next i
End Sub
 | 
Pages: 1
Prev: OLE Problem on Opening
Next: Select one cell insteade of a range