Solved

Graphical button for vb

Posted on 2007-11-14
18
711 Views
Last Modified: 2013-12-26
I need a button that I can edit the source to or that supports unicode so that I dont have to.  Its only real requirement is that it needs to follow the operating systems visual styles.  On xp it should look like an xp button and on vista it should look like a vista button.
0
Comment
Question by:justchat_1
  • 8
  • 5
  • 4
  • +1
18 Comments
 
LVL 48

Expert Comment

by:jpaulino
ID: 20280810
Check in here. You have allot of examples:

http://www.codeproject.com/buttonctrl/
0
 
LVL 14

Expert Comment

by:Matti
ID: 20281531
Hi!

I think this is good, some other controls in it too:
http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=68734&lngWId=1

Matti
0
 
LVL 9

Author Comment

by:justchat_1
ID: 20283088
I need buttons that will work with a manifest file or something similar.  Those buttons only look like xp.
0
 
LVL 9

Author Comment

by:justchat_1
ID: 20283127
jpaulino those were C++ controls
0
 
LVL 48

Expert Comment

by:jpaulino
ID: 20283535
Yes, but some of then you could use in vb
0
 
LVL 9

Author Comment

by:justchat_1
ID: 20283888
Could you give an example because I couldnt find one?
0
 
LVL 48

Expert Comment

by:jpaulino
ID: 20284049
0
 
LVL 9

Author Comment

by:justchat_1
ID: 20284999
none of those are for for vb6 but i looked into converting them but they dont support the vista style either
0
 
LVL 48

Expert Comment

by:jpaulino
ID: 20285053
>> none of those are for for vb6

I didn't understoud that you like to VB6
0
Top 6 Sources for Identifying Threat Actor TTPs

Understanding your enemy is essential. These six sources will help you identify the most popular threat actor tactics, techniques, and procedures (TTPs).

 
LVL 48

Expert Comment

by:jpaulino
ID: 20285069
Don't know if it as something but try in http://www.vbaccelerator.com/
0
 
LVL 9

Author Comment

by:justchat_1
ID: 20285269
Been there already couldnt find anything....you would think that since every other control has been recreated this would be easy to find
0
 
LVL 22

Accepted Solution

by:
danaseaman earned 500 total points
ID: 20285841
Try this ucThemedButton. No subclassing, no extra modules or classes.
Captions are set as UTF-8 in IDE. Example: Caption = CHS: 欢迎
Themed on both XP and Vista.

To make this work add  a Timer to the control and name it tmrHover, tmrHover.Enabled = False, tmrHover.Interval = 55


'ucThemedButton
Option Explicit

Private Const DT_VCENTER = &H4
Private Const DT_CENTER = &H1
Private Const DT_SINGLELINE = &H20

Private Type POINTAPI
   X                    As Long
   Y                    As Long
End Type

' API Declares
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect As Rect) As Long
Private Declare Function DrawTextW Lib "user32" (ByVal hdc As Long, ByVal lpStr As Long, ByVal nCount As Long, lpRect As Rect, ByVal wFormat As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function InflateRect Lib "user32" (lpRect As Rect, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function OleTranslateColor Lib "olepro32.dll" (ByVal OLE_COLOR As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function SetRect Lib "user32" (lpRect As Rect, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
'
Private Const CP_UTF8 = 65001
Private Declare Function GetACP Lib "kernel32" () As Long
Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
'
Private Const S_OK      As Long = &H0
Private Const S_FALSE   As Long = 1
Private Const BP_PUSHBUTTON As Long = 1
Private Declare Function OpenThemeData Lib "uxtheme.dll" (ByVal hWnd As Long, ByVal pszClassList As Long) As Long
Private Declare Function CloseThemeData Lib "uxtheme.dll" (ByVal hTheme As Long) As Long
Private Declare Function DrawThemeBackground Lib "uxtheme.dll" (ByVal hTheme As Long, ByVal lHdc As Long, ByVal iPartId As Long, ByVal iStateId As Long, pRect As Rect, pClipRect As Rect) As Long
Private Declare Function GetThemeBackgroundRegion Lib "uxtheme.dll" (ByVal hTheme As Long, ByVal hdc As Long, ByVal iPartId As Long, ByVal iStateId As Long, pBoundingRect As Rect, pRegion As Long) As Long

Private Type Rect
   Left                 As Long
   Top                  As Long
   Right                As Long
   Bottom               As Long
End Type

Private Enum UxThemePushButtonStates
   PBS_NORMAL = 1
   PBS_HOT = 2
   PBS_PRESSED = 3
   PBS_DISABLED = 4
   PBS_DEFAULTED = 5
End Enum

'Default Property Values:
Const m_def_Caption = "Command"
Const m_def_FocusRectangle = True

'Property Variables:
Private bHasFocus       As Boolean
Private curState        As UxThemePushButtonStates
Private He              As Long
Private m_bOver         As Boolean
Private m_Button        As Integer
Private m_CapRect       As Rect
Private m_Caption       As String
Private m_FocusRectangle As Boolean
Private m_GradRect      As Rect
Private m_MouseX        As Single
Private m_MouseY        As Single
Private m_Shift         As Integer
Private Wi              As Long

'Event Declarations:
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseDown
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseUp
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseMove
Event Click()
Event DblClick()
Event MouseEnter()
Event MouseExit()

Private Function AToW(ByVal st As String, Optional ByVal cpg As Long = -1, Optional lFlags As Long = 0) As String
   Dim stBuffer         As String
   Dim cwch             As Long
   Dim pwz              As Long
   Dim pwzBuffer        As Long

   If cpg = -1 Then cpg = GetACP()
   pwz = StrPtr(st)
   cwch = MultiByteToWideChar(cpg, lFlags, pwz, -1, 0&, 0&)
   stBuffer = String$(cwch + 1, vbNullChar)
   pwzBuffer = StrPtr(stBuffer)
   cwch = MultiByteToWideChar(cpg, lFlags, pwz, -1, pwzBuffer, Len(stBuffer))
   AToW = Left$(stBuffer, cwch - 1)
End Function

Public Property Get Caption() As String
   Caption = m_Caption
End Property

Public Property Let Caption(ByVal New_Caption As String)
   m_Caption = New_Caption
   SetAcccessKey
   DrawButton
   PropertyChanged "Caption"
End Property

'Converts UTF-8 to UTF-16
Public Function DecodeUTF8(ByVal cnvUni As String) As String
   Dim cnvUni2          As String
   If Len(cnvUni) Then
      cnvUni2 = StrConv(cnvUni, vbFromUnicode, 1033)
      DecodeUTF8 = AToW(cnvUni2, CP_UTF8)
   End If
End Function

Private Sub DrawButtonTheme(ByRef tr As Rect, ByVal m_hWnd As Long, _
   ByVal m_Hdc As Long, ByVal m_State As Long)
   
   Dim hTheme        As Long
   Dim lWidthTaken   As Long
   Dim lR            As Long
   Dim hRgn          As Long
   Dim rct           As Rect
   
   hTheme = OpenThemeData(m_hWnd, StrPtr("Button"))
   If (hTheme) Then
      lR = DrawThemeBackground(hTheme, m_Hdc, BP_PUSHBUTTON, m_State, tr, tr)
      If (lR <> S_OK) Then
         Debug.Print "Failed to parent draw theme background"
      End If
      LSet rct = tr
      InflateRect rct, 1, 1 'Needed so we don't clip control
      lR = GetThemeBackgroundRegion(hTheme, _
         m_Hdc, BP_PUSHBUTTON, m_State, rct, hRgn)
      SetWindowRgn m_hWnd, hRgn, True
      DeleteObject hRgn
      CloseThemeData hTheme
   End If

End Sub

Private Sub DrawButton()
   On Error Resume Next
   Cls
   DrawButtonTheme m_GradRect, UserControl.hWnd, UserControl.hdc, curState
   DrawCaption
End Sub

Private Sub DrawCaption()

   Dim lPtr             As Long

   If (bHasFocus) And (m_FocusRectangle) Then
      DrawFocusRect hdc, m_CapRect
   End If

   If Len(m_Caption) Then
      lPtr = StrPtr(DecodeUTF8(m_Caption))
      DrawTextW hdc, lPtr, -1, m_CapRect, DT_SINGLELINE Or DT_VCENTER Or DT_CENTER
   End If
End Sub

'MappingInfo=UserControl,UserControl,-1,Enabled
Public Property Get Enabled() As Boolean

   Enabled = UserControl.Enabled

End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)

   UserControl.Enabled() = New_Enabled
   If Not New_Enabled Then
      curState = PBS_DISABLED
      m_bOver = False
      tmrHover.Enabled = False
   Else
      If m_bOver Then
         If m_Button = 1 Then
            curState = PBS_PRESSED
         Else
            curState = PBS_NORMAL
         End If
      Else
         curState = PBS_HOT
      End If
   End If
   UserControl_Paint

   PropertyChanged "Enabled"

End Property

Public Property Get FocusRectangle() As Boolean
   FocusRectangle = m_FocusRectangle
End Property

Public Property Let FocusRectangle(ByVal New_FocusRectangle As Boolean)
   m_FocusRectangle = New_FocusRectangle
   DrawButton
   PropertyChanged "FocusRectangle"
End Property

Public Property Get Font() As Font
   Set Font = UserControl.Font
End Property

Public Property Set Font(ByVal New_Font As Font)
   Set UserControl.Font = New_Font
   DrawButton
   PropertyChanged "Font"
End Property

Public Property Get ForeColor() As OLE_COLOR
   ForeColor = UserControl.ForeColor
End Property

Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
   UserControl.ForeColor() = New_ForeColor
   DrawButton
   PropertyChanged "ForeColor"
End Property

Private Function isMouseOver() As Boolean
   Dim pt               As POINTAPI
   GetCursorPos pt
   isMouseOver = (WindowFromPoint(pt.X, pt.Y) = hWnd)
End Function

Private Sub SetAcccessKey()
   Dim pos              As Integer

   pos = InStr(1, m_Caption, "&")
   If pos Then
      UserControl.AccessKeys = Mid$(m_Caption, pos + 1, 1)
   End If

End Sub

Private Sub tmrHover_Timer()
   If Not isMouseOver Then
      tmrHover.Enabled = False
      m_bOver = False
      curState = PBS_NORMAL
      DrawButton
      RaiseEvent MouseExit
   End If
End Sub

Private Sub UserControl_AccessKeyPress(KeyAscii As Integer)
   curState = PBS_PRESSED
   DrawButton
   UserControl_MouseUp m_Button, m_Shift, m_MouseX, m_MouseY
End Sub

Private Sub UserControl_DblClick()
   RaiseEvent DblClick
End Sub

Private Sub UserControl_EnterFocus()
   bHasFocus = True
   DrawButton
End Sub

Private Sub UserControl_ExitFocus()
   bHasFocus = False
   DrawButton
End Sub

Private Sub UserControl_InitProperties()

   m_Caption = m_def_Caption
   m_FocusRectangle = m_def_FocusRectangle
   Set UserControl.Font = Ambient.Font
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
   m_Button = Button
   If curState <> PBS_PRESSED Then
      curState = PBS_PRESSED
      DrawButton
   End If
   RaiseEvent MouseDown(Button, Shift, X, Y)
End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
   RaiseEvent MouseMove(Button, Shift, X, Y)

   m_Button = 0
   m_MouseX = X
   m_MouseY = Y
   m_Shift = Shift

   curState = PBS_HOT
   If Button < 2 Then
      If X < 0 Or Y < 0 Or X > Wi Or Y > He Then
         'we are outside the button
         curState = PBS_NORMAL
      Else
         If Button = 1 Then curState = PBS_PRESSED
         If m_bOver = False Then
            m_bOver = True
            RaiseEvent MouseEnter
            DrawButton
         End If
      End If
   End If

   tmrHover.Enabled = True

End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
   RaiseEvent MouseUp(Button, Shift, X, Y)
   RaiseEvent Click

   curState = PBS_NORMAL
   DrawButton

End Sub

Private Sub UserControl_Paint()
   DrawButton
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
   m_Caption = PropBag.ReadProperty("Caption", m_def_Caption)
   m_FocusRectangle = PropBag.ReadProperty("FocusRectangle", m_def_FocusRectangle)
   Set UserControl.Font = PropBag.ReadProperty("Font", Ambient.Font)
   UserControl.Enabled = PropBag.ReadProperty("Enabled", True)
   UserControl.ForeColor = PropBag.ReadProperty("ForeColor", &H80000012)

   SetAcccessKey
   UserControl_Resize

End Sub

Private Sub UserControl_Resize()
   Wi = ScaleWidth
   He = ScaleHeight

   SetRect m_GradRect, 0, 0, Wi, He
   LSet m_CapRect = m_GradRect
   InflateRect m_CapRect, -3, -3
   SetAcccessKey
   curState = PBS_NORMAL
   DrawButton

End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

   With PropBag
      .WriteProperty "Caption", m_Caption, m_def_Caption
      .WriteProperty "Enabled", UserControl.Enabled, True
      .WriteProperty "FocusRectangle", m_FocusRectangle, m_def_FocusRectangle
      .WriteProperty "Font", UserControl.Font, Ambient.Font
      .WriteProperty "ForeColor", UserControl.ForeColor, &H80000012
   End With

End Sub
0
 
LVL 22

Expert Comment

by:danaseaman
ID: 20288939
Forgot to mention ucThemedButton does not require a manifest file since it is rendered direct from UxTheme.dll.
0
 
LVL 9

Author Comment

by:justchat_1
ID: 20289938
Its not rendering correctly for me.  Only the top and left side of the button render, the right and bottom sides appear clipped.   Text is also not visible even though a caption was set.
0
 
LVL 22

Expert Comment

by:danaseaman
ID: 20292597
Set these UserControl parameters:

ScaleMode = vbPixels
AutoRedraw = True
BorderStyle= None
0
 
LVL 9

Author Comment

by:justchat_1
ID: 20293457
One note:
In order to use the control I had to add an hWnd property.

Also:
lPtr = StrPtr(DecodeUTF8(m_Caption))
Should Read:
lPtr = StrPtr(m_Caption) 'the decode function actually breaks unicode support
0
 
LVL 22

Expert Comment

by:danaseaman
ID: 20293682
Also:
'the decode function actually breaks unicode support
DecodeUTF8(m_Caption) allowed you to set the caption as UTF-8 at design time and it will render as UTF-16 at run-time.
Using lPtr = StrPtr(m_Caption) means that you will have to set the caption at run-time since the IDE properties window will not accept unicode..
0
 
LVL 9

Author Comment

by:justchat_1
ID: 20293750
true...but if i need that then i will replace it with a function that detects utf-8 or utf-16 so that both are properly rendered
0

Featured Post

Free Trending Threat Insights Every Day

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

Join & Write a Comment

Suggested Solutions

Since upgrading to Office 2013 or higher installing the Smart Indenter addin will fail. This article will explain how to install it so it will work regardless of the Office version installed.
If you need to start windows update installation remotely or as a scheduled task you will find this very helpful.
Get people started with the utilization of class modules. Class modules can be a powerful tool in Microsoft Access. They allow you to create self-contained objects that encapsulate functionality. They can easily hide the complexity of a process from…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

743 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

12 Experts available now in Live!

Get 1:1 Help Now