• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 752
  • Last Modified:

Graphical button for vb

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
justchat_1
Asked:
justchat_1
  • 8
  • 5
  • 4
  • +1
1 Solution
 
Jorge PaulinoIT Pro/DeveloperCommented:
Check in here. You have allot of examples:

http://www.codeproject.com/buttonctrl/
0
 
MattiCommented:
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
 
justchat_1Author Commented:
I need buttons that will work with a manifest file or something similar.  Those buttons only look like xp.
0
Cloud Class® Course: Amazon Web Services - Basic

Are you thinking about creating an Amazon Web Services account for your business? Not sure where to start? In this course you’ll get an overview of the history of AWS and take a tour of their user interface.

 
justchat_1Author Commented:
jpaulino those were C++ controls
0
 
Jorge PaulinoIT Pro/DeveloperCommented:
Yes, but some of then you could use in vb
0
 
justchat_1Author Commented:
Could you give an example because I couldnt find one?
0
 
justchat_1Author Commented:
none of those are for for vb6 but i looked into converting them but they dont support the vista style either
0
 
Jorge PaulinoIT Pro/DeveloperCommented:
>> none of those are for for vb6

I didn't understoud that you like to VB6
0
 
Jorge PaulinoIT Pro/DeveloperCommented:
Don't know if it as something but try in http://www.vbaccelerator.com/
0
 
justchat_1Author Commented:
Been there already couldnt find anything....you would think that since every other control has been recreated this would be easy to find
0
 
danaseamanCommented:
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
 
danaseamanCommented:
Forgot to mention ucThemedButton does not require a manifest file since it is rendered direct from UxTheme.dll.
0
 
justchat_1Author Commented:
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
 
danaseamanCommented:
Set these UserControl parameters:

ScaleMode = vbPixels
AutoRedraw = True
BorderStyle= None
0
 
justchat_1Author Commented:
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
 
danaseamanCommented:
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
 
justchat_1Author Commented:
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
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Cloud Class® Course: Microsoft Windows 7 Basic

This introductory course to Windows 7 environment will teach you about working with the Windows operating system. You will learn about basic functions including start menu; the desktop; managing files, folders, and libraries.

  • 8
  • 5
  • 4
  • +1
Tackle projects and never again get stuck behind a technical roadblock.
Join Now