vbAccelerator - Contents of code file: mMain.bas

Attribute VB_Name = "mMain"
Option Explicit

Private Type CommonControlsEx
    dwSize As Long
    dwICC As Long
End Type
Private Declare Function InitCommonControlsEx Lib "Comctl32.dll" (iccex As
 CommonControlsEx) As Boolean
Private Const ICC_BAR_CLASSES = &H4
Private Const ICC_COOL_CLASSES = &H400
Private Const ICC_USEREX_CLASSES = &H200& '// comboex
Private Const ICC_WIN95_CLASSES = &HFF&

Public Type RECT
   left As Long
   top As Long
   right As Long
   bottom As Long
End Type

Private Type SIZEAPI
   cx As Long
   cy As Long
End Type

Private Enum EDrawTextFormat
   DT_BOTTOM = &H8
   DT_CALCRECT = &H400
   DT_CENTER = &H1
   DT_EXPANDTABS = &H40
   DT_EXTERNALLEADING = &H200
   DT_INTERNAL = &H1000
   DT_LEFT = &H0
   DT_NOCLIP = &H100
   DT_NOPREFIX = &H800
   DT_RIGHT = &H2
   DT_SINGLELINE = &H20
   DT_TABSTOP = &H80
   DT_TOP = &H0
   DT_VCENTER = &H4
   DT_WORDBREAK = &H10
   DT_EDITCONTROL = &H2000&
   DT_PATH_ELLIPSIS = &H4000&
   DT_END_ELLIPSIS = &H8000&
   DT_MODIFYSTRING = &H10000
   DT_RTLREADING = &H20000
   DT_WORD_ELLIPSIS = &H40000
End Enum

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 GetThemeBackgroundContentRect Lib "uxtheme.dll" _
   (ByVal hTheme As Long, ByVal hdc As Long, _
    ByVal iPartId As Long, ByVal iStateId As Long, _
    pBoundingRect As RECT, pContentRect As RECT) As Long
Private Declare Function DrawThemeText Lib "uxtheme.dll" _
   (ByVal hTheme As Long, ByVal hdc As Long, ByVal iPartId As Long, _
    ByVal iStateId As Long, ByVal pszText As Long, _
    ByVal iCharCount As Long, ByVal dwTextFlag As Long, _
    ByVal dwTextFlags2 As Long, pRect As RECT) As Long
Private Declare Function DrawThemeIcon Lib "uxtheme.dll" _
   (ByVal hTheme As Long, ByVal hdc As Long, ByVal iPartId As Long, _
    ByVal iStateId As Long, pRect As RECT, _
    ByVal himl As Long, ByVal iImageIndex As Long) As Long
Private Declare Function DrawThemeEdge Lib "uxtheme.dll" _
   (ByVal hTheme As Long, ByVal hdc As Long, ByVal iPartId As Long, _
   ByVal iStateId As Long, pDestRect As RECT, _
   ByVal uEdge As Long, ByVal uFlags As Long, _
   pContentRect As RECT) As Long
Private Declare Function IsThemePartDefined Lib "uxtheme.dll" _
   (ByVal hTheme As Long, ByVal iPartId As Long, ByVal iStateId As Long) As Long
Private Declare Function GetThemePartSize Lib "uxtheme.dll" _
   (ByVal hTheme As Long, ByVal hdc As Long, ByVal iPartId As Long, _
   ByVal iStateId As Long, prc As RECT, eSize As Long, psz As SIZEAPI) As Long
Private Enum THEMESIZE
    TS_MIN = 0             '// minimum size
    TS_TRUE = 1            '// size without stretching
    TS_DRAW = 2             ' // size that theme mgr will use to draw part
End Enum
Private Declare Function GetThemeInt Lib "uxtheme.dll" _
   (ByVal hTheme As Long, ByVal iPartId As Long, _
    ByVal iStateId As Long, ByVal iPropId As Long, _
    piVal As Long) As Long

Private Const PROGRESSCHUNKSIZE = 2411
Private Const PROGRESSSPACESIZE = 2412

Private Type OSVERSIONINFO
   dwOSVersionInfoSize As Long
   dwMajorVersion As Long
   dwMinorVersion As Long
   dwBuildNumber As Long
   dwPlatformId As Long
   lPtrSzCSDVersion As Long
   szCSDVersion As String * 128      '  Maintenance string for PSS usage
End Type

Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" _
   (lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function GetVersion Lib "kernel32" () As Long



'#define TM_PART(val, prefix, name)          prefix##_##name = val,
'    TM_PART(1, BP, PUSHBUTTON)
'#define BEGIN_TM_CLASS_PARTS(name)
'  enum name##PARTS { name##PartFiller0,
'#define BEGIN_TM_PART_STATES(name)
'  enum name##STATES { name##StateFiller0,
' #define BEGIN_TM_PART_STATES(name)
' {L#name L"STATES", TMT_ENUMDEF, TMT_ENUMDEF},
' #define BEGIN_TM_CLASS_PARTS(name)
' {L#name L"PARTS", TMT_ENUMDEF, TMT_ENUMDEF},
    
'    TM_PROP(2411, TMT, PROGRESSCHUNKSIZE, INT)    // size of progress control
 chunks
'    TM_PROP(2412, TMT, PROGRESSSPACESIZE, INT)    // size of progress control
 spaces


Public Sub Draw(ByVal hWnd As Long, ByVal hdc As Long)
   Dim lR As Long
   lR = GetVersion()
   Debug.Print lR And &HFF&, (lR And &HFF00&) \ &H100, (lR And &HFF0000) \
    &H10000, (lR And &H7F000000) / &H1000000
   
   Dim osVer As OSVERSIONINFO
   osVer.dwOSVersionInfoSize = 24 'Len(osVer)
   lR = GetVersionEx(osVer)
   Debug.Print lR, osVer.dwMajorVersion, osVer.dwMinorVersion
   
   'Exit Sub
   
   Dim hTheme As Long
   hTheme = 0
   hTheme = OpenThemeData(hWnd, StrPtr("Button"))
   'hTheme = OpenThemeData(hWnd, StrPtr("Status"))
   'hTheme = OpenThemeData(hWnd, StrPtr("Window"))
   
   Dim iChunkSize As Long, hR As Long
   hR = GetThemeInt(hTheme, 0, 0, PROGRESSCHUNKSIZE, iChunkSize)
   Debug.Print "Chunk Size: ", hR, iChunkSize
   hR = GetThemeInt(hTheme, 0, 0, PROGRESSSPACESIZE, iChunkSize)
   Debug.Print "Chunk Spacing: ", hR, iChunkSize
   
   Dim iPart As Long, iState As Long
'   For iState = 1 To &HFFF&
'      For iPart = 1 To &HFFF&
'         Debug.Assert (IsThemePartDefined(hTheme, iPart, iState) = 0)
'      Next iPart
'   Next iState
   
   '...
   Dim rc As RECT
   For iState = 1 To 6
      For iPart = 1 To 30
         rc.left = (iState - 1) * 96
         rc.top = (iPart - 1) * 32
         rc.bottom = rc.top + 8 '31
         rc.right = rc.left + 8 '96
         DrawMyControl hdc, hTheme, rc, "Test", iPart, iState
      Next iPart
   Next iState
   '...
   If (hTheme) Then
      CloseThemeData hTheme
   End If

End Sub

Private Sub DrawMyControl( _
   ByVal hdc As Long, _
   ByVal hTheme As Long, _
   rc As RECT, _
   ByVal sText As String, _
   ByVal iPart As Long, _
   ByVal iState As Long _
   )
Dim rcContent As RECT
Dim buttonText As String
Dim hR As Long

   If (hTheme) Then
      'Debug.Print iPart, iState, "Defined:", IsThemePartDefined(hTheme, iPart,
       iState)
      hR = DrawThemeBackground(hTheme, hdc, iPart, _
                iState, rc, rc)
      'Debug.Print hR
      '// Always check your result codes.

      'hR = GetThemeBackgroundContentRect(hTheme, _
      '          hdc, iPart, iState, rc, rcContent)
      'Debug.Print hR
      'hR = DrawThemeText(hTheme, hdc, iPart, iState, _
      '          StrPtr(sText), -1, _
      '          DT_CENTER Or DT_VCENTER Or DT_SINGLELINE, _
      '          0, rcContent)
      'Debug.Print hR
    Else
    End If

End Sub

Public Sub DrawStatusBar( _
   ByVal hWnd As Long, _
   ByVal hdc As Long, _
   rc As RECT _
   )
Dim hTheme As Long
   hTheme = OpenThemeData(hWnd, StrPtr("Status"))
   
Dim hR As Long
   ' Background to status bar:
   hR = DrawThemeBackground(hTheme, hdc, 4, 0, rc, rc)
   
   ' Panels:
Dim lSize As Long
   lSize = (rc.right - rc.left - 64 * 3) - 24
   
Dim sz As SIZEAPI
   'hR = GetThemePartSize(hTheme, hdc, 3, 0, rc, TS_MIN, sz)
   'Debug.Print sz.cx, sz.cy

Dim tR As RECT
Dim rcContent As RECT
   LSet tR = rc
   tR.right = lSize
      
   hR = DrawThemeBackground(hTheme, hdc, 1, _
                0, tR, tR)
   hR = GetThemeBackgroundContentRect(hTheme, _
                hdc, 1, 0, tR, rcContent)

   hR = DrawThemeText(hTheme, hdc, 1, 0, _
                StrPtr("Panel 1"), -1, _
                DT_CENTER Or DT_VCENTER Or DT_SINGLELINE, _
                0, rcContent)
   
   Dim i As Long
   Dim iPart As Long
   iPart = 1
   For i = 1 To 3
      If (i = 3) Then
         iPart = 2
      End If
      tR.left = tR.right
      tR.right = tR.left + 64
      hR = DrawThemeBackground(hTheme, hdc, iPart, _
                   0, tR, tR)
      hR = GetThemeBackgroundContentRect(hTheme, _
                hdc, iPart, 0, tR, rcContent)

      hR = DrawThemeText(hTheme, hdc, 1, 0, _
                StrPtr("Panel " & i + 1), -1, _
                DT_CENTER Or DT_VCENTER Or DT_SINGLELINE, _
                0, rcContent)
   
   Next i
      
   tR.left = tR.right
   tR.right = tR.left + 24
   hR = DrawThemeBackground(hTheme, hdc, 3, _
                   0, tR, tR)
   
   If (hTheme) Then
      CloseThemeData hTheme
   End If
   
End Sub


Public Sub Main()
   On Error Resume Next
   ' Call InitCommonControls:
   Dim tIccex As CommonControlsEx
   With tIccex
       .dwSize = LenB(tIccex)
       .dwICC = ICC_BAR_CLASSES
   End With
   'We need to make this call to make sure the common controls are loaded
   InitCommonControlsEx tIccex
   On Error GoTo 0

   frmDraw.Show
End Sub