minimaster
12/18/2009 8:32:00 AM
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