Bonjour,
this small utility can help you to add graphical buttons on your VB applications. Any button style is supported, Web buttons, XP, Vista or MAC. You can define a horizontal button bar or a vertical menu bar. MouseEnter and MouseLeave events are simulated. On this sample only a few number of buttons are annexed, for additional skin you can find a lot of buttons image on internet or you can made your personal images with a graphical tool.
Source / Exemple :
Source code of GraphicalButton.vbp
Type=Exe
Form=frmGraphicalButton.frm
Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#C:\WINDOWS\system32\stdole2.tlb#OLE Automation
IconForm="frmGraphicalButton"
Startup="frmGraphicalButton"
ExeName32="Progetto1.exe"
Command32=""
Name="Progetto1"
HelpContextID="0"
CompatibleMode="0"
MajorVer=1
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
VersionCompanyName="."
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1
[MS Transaction Server]
AutoRefresh=1
End of source code of GraphicalButton.vbp
Source code of frmGraphicalButton.frm
VERSION 5.00
Begin VB.Form frmGraphicalButton
BackColor = &H00FFFDF9&
BorderStyle = 4 'Fixed ToolWindow
Caption = "Graphic Buttons"
ClientHeight = 3735
ClientLeft = 45
ClientTop = 285
ClientWidth = 7875
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 249
ScaleMode = 3 'Pixel
ScaleWidth = 525
ShowInTaskbar = 0 'False
StartUpPosition = 2 'CenterScreen
Begin VB.OptionButton Option1
Alignment = 1 'Right Justify
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "V"
ForeColor = &H80000008&
Height = 195
Index = 1
Left = 7320
TabIndex = 4
Top = 120
Width = 375
End
Begin VB.OptionButton Option1
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "H"
ForeColor = &H80000008&
Height = 195
Index = 0
Left = 6840
TabIndex = 3
Top = 120
Value = -1 'True
Width = 435
End
Begin VB.ComboBox Combo1
Height = 315
Left = 5460
Style = 2 'Dropdown List
TabIndex = 2
Top = 60
Width = 1275
End
Begin VB.PictureBox p
Appearance = 0 'Flat
AutoRedraw = -1 'True
AutoSize = -1 'True
BackColor = &H000000FF&
BorderStyle = 0 'None
BeginProperty Font
Name = "Segoe UI"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FFFFFF&
Height = 750
Index = 0
Left = 120
ScaleHeight = 50
ScaleMode = 3 'Pixel
ScaleWidth = 56
TabIndex = 0
Tag = "0"
Top = 600
Width = 840
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
BeginProperty Font
Name = "Lucida Console"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 60
TabIndex = 1
Top = 60
Width = 5295
End
End
Attribute VB_Name = "frmGraphicalButton"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
' SetCapture, ReleaseCapture, GetCapture for to simulate MouseEnter and MouseLeave events
Private Declare Function SetCapture Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function GetCapture Lib "user32" () As Long
' Retrieve pixel color, faster then Point function
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long
Dim sCaption(4) As String, s As Integer, t(255) As String
'******************************************************************************
'
' Buttons definition
'
' imgXYYZ
'
' img = image prefix
' X = n: normal, o: over, c: clicked
' YY = skin number in hex format (2 digit)
' Z = image number
'
' NOTE: only skins "Rosso" and "Blu" have left and right different pictures
' 0, 1 and 2. All the others skins have only picture 0
'
' Each skin is formed by 3 pictures imgnYY0, imgoYY0 and imgcYY0
'
' "Rosso" and "Blu" are formed by 9 pictures imgnYY0, imgoYY0, imgcYY0,
' imgnYY1, imgoYY1, imgcYY1, imgnYY2, imgoYY2, imgcYY2
'
' imgnYY0, imgoYY0, imgcYY0 are for left button images
' imgnYY1, imgoYY1, imgcYY1 are for middle buttons images
' imgnYY2, imgoYY2, imgcYY2 are for right button images
'
' see comments on PICTURE SELECTOR, variable t() store picture selection
'
'******************************************************************************
Private Sub Combo1_Click()
'store skin number
s = Combo1.ListIndex
'change skin layout
ChangeSkin
End Sub
Private Sub Form_Load()
Dim i As Integer
' add skin names
Combo1.AddItem "Rosso"
Combo1.AddItem "Blu"
Combo1.AddItem "XP Met1"
Combo1.AddItem "Vista TkB1"
Combo1.AddItem "Vista Btn1"
Combo1.AddItem "Vista Btn2"
Combo1.AddItem "Blood"
Combo1.AddItem "Dark"
Combo1.AddItem "Haze"
Combo1.AddItem "Mixed_1"
Combo1.AddItem "Vista Btn3"
Combo1.AddItem "Vista TkB2"
Combo1.AddItem "Mixed_2"
Combo1.AddItem "Mixed_3"
Combo1.AddItem "Mixed_4"
Combo1.AddItem "Mixed_5"
Combo1.AddItem "XP HS_1"
Combo1.AddItem "XP HS_2"
Combo1.AddItem "XP HS_3"
Combo1.AddItem "XP Met2"
Combo1.AddItem "MAC2_1"
Combo1.AddItem "LH_1"
Combo1.AddItem "Rnd_1"
Combo1.AddItem "Tabs_1"
Combo1.AddItem "Vista Btn3"
'PICTURE SELECTOR
'determine how many different button picture I'm using
For i = LBound(t) To UBound(t)
'by default all skins are only one button picture, type "0"
t(i) = "00000"
Next i
'"Rosso' is using 3 different button pictures, the first is type "0", all the others type "1" and the last type "2"
t(0) = "01112"
'"Blu" is using same layout as "Rosso"
t(1) = "01112"
'loading button pictures
For i = 1 To 4
Load p(i)
p(i).Visible = True
Next i
'move the first button on upper left corner of the form
p(0).Move 10, 30, 100, 30
'0 create horizontal bar, 1 create vertical menu
CreateButtons 0
'select last skin ("Vista Btn3")
Combo1.ListIndex = Combo1.ListCount - 1
End Sub
Private Sub Option1_Click(Index As Integer)
'set horizontal or vertical button bar
CreateButtons Index
End Sub
Private Sub p_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
'mouse button is left
If Button = 1 Then
'set buttondown image
p(Index).Picture = LoadPicture("imgc" & d2h(s) & Mid$(t(Val(s)), Index + 1, 1) & ".gif")
'print again text this time 1 pixel shifted (tb is true)
PrintText p(Index), sCaption(Index), True
'message the button is pressed
Label1 = sCaption(Index) & " pressed"
End If
End Sub
Private Sub p_MouseMove(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
'simulating MouseEnter and MouseLeave events
If (x < 0) Or (y < 0) Or (x > p(Index).Width) Or (y > p(Index).Height) Then
'mouseleave
ReleaseCapture
'restore normal button image and text
p(Index).Picture = LoadPicture("imgn" & d2h(s) & Mid$(t(Val(s)), Index + 1, 1) & ".gif")
PrintText p(Index), sCaption(Index)
'no events
Label1 = ""
ElseIf GetCapture() <> p(Index).hWnd Then
'mouseenter
SetCapture p(Index).hWnd
'set mousemove image
p(Index).Picture = LoadPicture("imgo" & d2h(s) & Mid$(t(Val(s)), Index + 1, 1) & ".gif")
'print text again because button image is changed
PrintText p(Index), sCaption(Index)
'event mouseover button
Label1 = sCaption(Index) & " over"
End If
End Sub
Private Sub p_MouseUp(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
'restore mouveover image button and normal text
p(Index).Picture = LoadPicture("imgo" & d2h(s) & p(Index).Tag & ".gif")
PrintText p(Index), sCaption(Index)
End Sub
Private Sub PrintText(C As PictureBox, txt As String, Optional tb As Boolean = False)
Dim x1 As Long, y1 As Long
'set button text
C.FontBold = False
x1 = C.TextWidth(txt)
y1 = C.TextHeight(txt)
'positionin text on cener middle of button
C.CurrentX = C.Width \ 2 - x1 \ 2 + Abs(tb) 'tb simulate button down and if true move text 1 pixel on right
C.CurrentY = C.Height \ 2 - y1 \ 2 + Abs(tb) ' one pixel down
'print button text
C.Print txt;
End Sub
Private Sub ChangeSkin()
Dim i As Integer
'select one-by-one all the buttons and is setting
For i = p.lbound To p.UBound
'button caption
sCaption(i) = Combo1.List(s) & "_" & i + 1
'button picture
p(i).Picture = LoadPicture("imgn" & d2h(s) & Mid$(t(s), i + 1, 1) & ".gif")
'get main button color and set form background with this color
If i = 0 Then Me.BackColor = GetPixel(p(0).hDC, 50, 15)
'set buttons background same as form background in case button picture using transparent color
p(i).BackColor = Me.BackColor
'set button forecolor
p(i).ForeColor = CptColor(Me.BackColor)
'finally print the button text
PrintText p(i), sCaption(i)
Next i
'set form forecolor as buttons forecolor
Me.ForeColor = p(0).ForeColor
'set other objects background and foreground color
Label1.ForeColor = p(0).ForeColor
Option1(0).ForeColor = p(0).ForeColor
Option1(1).ForeColor = p(0).ForeColor
Option1(0).BackColor = Me.BackColor
Option1(1).BackColor = Me.BackColor
End Sub
Private Function d2h(n As Integer) As String
'convert from decimal to two digit hex
d2h = Hex$(n)
If Len(d2h) = 1 Then d2h = "0" & d2h
End Function
Private Function CptColor(ByVal lColor As Long) As Long
'convert color on grayscale
lColor = 0.33 * (lColor Mod 256) + 0.59 * ((lColor \ 256) Mod 256) _
+ 0.11 * ((lColor \ 65536) Mod 256)
'if grayscale is dark then CptColor is white else is black
If lColor < 128 Then CptColor = &HFFFFFF Else lColor = &H0&
End Function
Private Sub CreateButtons(indice As Integer)
Dim i As Integer
'reset all buttons
ChangeSkin
' positioning buttons on form
Select Case indice
Case 0 ' Horizontal bar
For i = 1 To 4
p(i).Move p(0).Left + p(0).Width * i, p(0).Top, p(0).Width, p(0).Height
Next i
Case 1 ' vertical menu
For i = 1 To 4
p(i).Move p(0).Left, p(0).Top + p(0).Height * i, p(0).Width, p(0).Height
Next i
Case Else 'do nothing
End Select
End Sub
End of source code of frmGraphicalButton.frm
Source code of GraphicalButton.vbw
frmGraphicalButton = 44, 44, 800, 535, Z, 22, 22, 778, 513, C
End of source code of GraphicalButton.vbw
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.