vbAccelerator - Contents of code file: frmTest.frm

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmXPThemeExplorer 
   Caption         =   "VB XP Theme Explorer"
   ClientHeight    =   6195
   ClientLeft      =   2925
   ClientTop       =   2145
   ClientWidth     =   9900
   BeginProperty Font 
      Name            =   "Tahoma"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "frmTest.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   6195
   ScaleWidth      =   9900
   Begin VB.CheckBox chkIcon 
      Caption         =   "&Icon"
      Height          =   255
      Left            =   2940
      TabIndex        =   9
      Top             =   1500
      Width           =   2535
   End
   Begin VB.CheckBox chkText 
      Caption         =   "&Text:"
      Height          =   255
      Left            =   2940
      TabIndex        =   8
      Top             =   1140
      Width           =   1035
   End
   Begin VB.CheckBox chkCustomiseSize 
      Caption         =   "&Customise Size"
      Height          =   255
      Left            =   2880
      TabIndex        =   7
      Top             =   60
      Value           =   1  'Checked
      Width           =   2535
   End
   Begin VB.TextBox txtText 
      Enabled         =   0   'False
      Height          =   315
      Left            =   4020
      TabIndex        =   6
      Text            =   "vbAccelerator.com"
      Top             =   1080
      Width           =   2715
   End
   Begin VB.TextBox txtHeight 
      Height          =   315
      Left            =   4020
      TabIndex        =   5
      Text            =   "24"
      Top             =   660
      Width           =   2715
   End
   Begin VB.TextBox txtWidth 
      Height          =   315
      Left            =   4020
      TabIndex        =   4
      Text            =   "96"
      Top             =   360
      Width           =   2715
   End
   Begin VB.PictureBox picSamples 
      AutoRedraw      =   -1  'True
      BackColor       =   &H80000005&
      Height          =   4155
      Left            =   2940
      ScaleHeight     =   4095
      ScaleWidth      =   3555
      TabIndex        =   1
      Top             =   1920
      Width           =   3615
   End
   Begin MSComctlLib.TreeView tvwThemes 
      Height          =   6075
      Left            =   60
      TabIndex        =   0
      Top             =   60
      Width           =   2775
      _ExtentX        =   4895
      _ExtentY        =   10716
      _Version        =   393217
      Indentation     =   450
      LabelEdit       =   1
      LineStyle       =   1
      Style           =   2
      Appearance      =   1
   End
   Begin VB.Label lblInfo 
      Caption         =   "Height:"
      Height          =   255
      Index           =   1
      Left            =   3180
      TabIndex        =   3
      Top             =   720
      Width           =   795
   End
   Begin VB.Label lblInfo 
      Caption         =   "Width:"
      Height          =   255
      Index           =   0
      Left            =   3180
      TabIndex        =   2
      Top             =   360
      Width           =   795
   End
   Begin VB.Menu mnuFileTOP 
      Caption         =   "&File"
      Begin VB.Menu mnuFile 
         Caption         =   "&Close"
         Index           =   0
      End
   End
   Begin VB.Menu mnuHelpTOP 
      Caption         =   "&Help"
      Begin VB.Menu mnuHelp 
         Caption         =   "&About..."
         Index           =   0
      End
   End
End
Attribute VB_Name = "frmXPThemeExplorer"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private m_cUxTheme As cUxTheme
Private m_cSysIml As cVBALSysImageList

Private Sub initThemeTree()
Dim sXmlFile As String
   sXmlFile = App.Path
   If (Right$(sXmlFile, 1) <> "\") Then
      sXmlFile = sXmlFile & "\"
   End If
   sXmlFile = sXmlFile & "uxtheme.xml"
   
Dim xmlTheme As New DOMDocument
   If (xmlTheme.Load(sXmlFile)) Then
      Dim nodClass As IXMLDOMElement
      Dim tvwTop As Node
      Set tvwTop = tvwThemes.Nodes.Add(, , "A", "All")
      For Each nodClass In xmlTheme.selectNodes("ThemeData/Class")
         Dim sClass As String
         sClass = getNodeAttribute(nodClass, "name")
         Dim tvwNodeClass As Node
         Set tvwNodeClass = tvwThemes.Nodes.Add(tvwTop, tvwChild, "C" & sClass,
          sClass)
         Dim nodPart As IXMLDOMElement
         For Each nodPart In nodClass.selectNodes("Part")
            Dim sPart As String
            sPart = getNodeAttribute(nodPart, "name")
            Dim sId As String
            sId = getNodeAttribute(nodPart, "id")
            Dim tvwNodePart As Node
            Set tvwNodePart = tvwThemes.Nodes.Add(tvwNodeClass, tvwChild, "P" &
             sPart & "I:" & sId, sPart & " (" & sId & ")")
            Dim nodState As IXMLDOMElement
            For Each nodState In nodPart.selectNodes("State")
               Dim sState As String
               sState = getNodeAttribute(nodState, "name")
               sId = getNodeAttribute(nodState, "id")
               tvwThemes.Nodes.Add tvwNodePart, tvwChild, "S" & sState & "P" &
                sPart & "I:" & sId, sState & " (" & sId & ")"
            Next
         Next
      Next
      tvwTop.Expanded = True
   Else
      MsgBox "Failed to load the Theme Data as XML from file" & vbCrLf & "'" &
       sXmlFile & "'", vbExclamation
   End If
   
End Sub

Private Function getNodeAttribute(nodThis As IXMLDOMNode, ByVal sAttributeName
 As String) As String
Dim i As Long
   For i = 0 To nodThis.Attributes.length - 1
      If (nodThis.Attributes(i).baseName = sAttributeName) Then
         getNodeAttribute = nodThis.Attributes(i).nodeValue
         Exit For
      End If
   Next i
End Function

Private Sub chkCustomiseSize_Click()
   If (chkCustomiseSize.value = vbChecked) Then
      txtWidth.Enabled = True
      txtHeight.Enabled = True
      m_cUxTheme.TextAlign = m_cUxTheme.TextAlign Or DT_WORD_ELLIPSIS
      m_cUxTheme.UseThemeSize = False
   Else
      txtWidth.Enabled = True
      txtHeight.Enabled = True
      m_cUxTheme.TextAlign = m_cUxTheme.TextAlign And Not DT_WORD_ELLIPSIS
      m_cUxTheme.UseThemeSize = True
   End If
   drawSelectedItems
End Sub

Private Sub chkIcon_Click()
   If (chkIcon.value = vbChecked) Then
      m_cUxTheme.hIml = m_cSysIml.hIml
      m_cUxTheme.IconIndex = m_cSysIml.ItemIndex("C:\pants.txt")
   Else
      m_cUxTheme.hIml = 0
      m_cUxTheme.IconIndex = -1
   End If
   drawSelectedItems
End Sub

Private Sub chkText_Click()
   If (chkText.value = vbChecked) Then
      txtText.Enabled = True
      m_cUxTheme.Text = txtText.Text
   Else
      txtText.Enabled = False
      m_cUxTheme.Text = ""
   End If
   drawSelectedItems
End Sub

Private Sub Form_Load()

   ' Load the theme data:
   initThemeTree
   
   Set m_cSysIml = New cVBALSysImageList
   m_cSysIml.IconSizeX = 16
   m_cSysIml.IconSizeY = 16
   m_cSysIml.Create
   
   ' Set up the theme drawing class:
   Set m_cUxTheme = New cUxTheme
   With m_cUxTheme
      .hWnd = Me.hWnd
      .Width = CLng(txtWidth.Text)
      .Height = CLng(txtHeight.Text)
      .TextAlign = DT_CENTER Or DT_VCENTER Or DT_SINGLELINE Or DT_WORD_ELLIPSIS
   End With
   
   If (tvwThemes.Nodes.Count > 0) Then
      Set tvwThemes.SelectedItem = tvwThemes.Nodes(1)
      drawSelectedItems
   End If
      
End Sub

Private Sub Form_Resize()
   On Error Resume Next
   tvwThemes.Move 2 * Screen.TwipsPerPixelX, 2 * Screen.TwipsPerPixelY,
    tvwThemes.Width, Me.ScaleHeight - 4 * Screen.TwipsPerPixelY
   picSamples.Move tvwThemes.left + tvwThemes.Width + 2 *
    Screen.TwipsPerPixelX, picSamples.tOp, _
      Me.ScaleWidth - (tvwThemes.left + tvwThemes.Width + 4 *
       Screen.TwipsPerPixelX), _
      Me.ScaleHeight - picSamples.tOp - 2 * Screen.TwipsPerPixelY
   drawSelectedItems
End Sub

Private Sub getNodeDetails( _
      ByRef nod As Node, _
      ByRef sClass As String, _
      ByRef lPartId As Long, _
      ByRef lStateId As Long _
   )
   Dim sKey As String
   Dim iPos As Long
   sClass = ""
   lPartId = -1
   lStateId = -1
   sKey = nod.Key
   ' what type of key is it?
   Select Case left(sKey, 1)
   Case "A" ' all
   Case "C" ' class
      sClass = Mid(sKey, 2)
   Case "P" ' part
      sClass = Mid(nod.Parent.Key, 2)
      iPos = InStr(sKey, ":")
      lPartId = CLng(Mid(sKey, iPos + 1))
   Case "S" ' state
      sClass = Mid(nod.Parent.Parent.Key, 2)
      iPos = InStr(nod.Parent.Key, ":")
      lPartId = CLng(Mid(nod.Parent.Key, iPos + 1))
      iPos = InStr(sKey, ":")
      lStateId = CLng(Mid(sKey, iPos + 1))
   End Select

End Sub

Private Sub drawSelectedItems()
   picSamples.Cls

   m_cUxTheme.hdc = picSamples.hdc
   m_cUxTheme.left = 4
   m_cUxTheme.tOp = 4

   Dim sClass As String
   Dim lPartId As Long
   Dim lStateId As Long
   getNodeDetails tvwThemes.SelectedItem, sClass, lPartId, lStateId

   Dim nod As Node
   Dim nodChild As Node
   Dim i As Long
   Dim j As Long
   If (Len(sClass) = 0) Then
      ' nothing specified, draw the classes vertically
      ' and the parts horizontally:
      Set nod = tvwThemes.SelectedItem.Child
      For i = 1 To tvwThemes.SelectedItem.children
         Set nodChild = nod.Child
         m_cUxTheme.left = 4
         For j = 1 To nod.children
            getNodeDetails nodChild, sClass, lPartId, lStateId
            m_cUxTheme.Class = sClass
            m_cUxTheme.Part = lPartId
            m_cUxTheme.State = 1
            m_cUxTheme.Draw
            m_cUxTheme.left = m_cUxTheme.left + m_cUxTheme.Width + 4
            Set nodChild = nodChild.Next
         Next
         m_cUxTheme.tOp = m_cUxTheme.tOp + m_cUxTheme.Height + 4
         Set nod = nod.Next
      Next
            
   ElseIf (lPartId <= 0) Then
      ' if no part or state is specified, then we draw
      'parts vertically and states horizontally:
      m_cUxTheme.Class = sClass
      Set nod = tvwThemes.SelectedItem.Child
      For i = 1 To tvwThemes.SelectedItem.children
         Set nodChild = nod.Child
         m_cUxTheme.left = 4
         For j = 1 To nod.children
            getNodeDetails nodChild, sClass, lPartId, lStateId
            m_cUxTheme.Part = lPartId
            m_cUxTheme.State = lStateId
            m_cUxTheme.Draw
            m_cUxTheme.left = m_cUxTheme.left + m_cUxTheme.Width + 4
            Set nodChild = nodChild.Next
         Next
         m_cUxTheme.tOp = m_cUxTheme.tOp + m_cUxTheme.Height + 4
         Set nod = nod.Next
      Next
      
   ElseIf (lStateId <= 0) Then
      ' if no state specified, draw the states vertically:
      m_cUxTheme.Class = sClass
      m_cUxTheme.Part = lPartId
      Set nod = tvwThemes.SelectedItem.Child
      For i = 1 To tvwThemes.SelectedItem.children
         getNodeDetails nod, sClass, lPartId, lStateId
         m_cUxTheme.State = lStateId
         m_cUxTheme.Draw
         m_cUxTheme.tOp = m_cUxTheme.tOp + m_cUxTheme.Height + 4
         Set nod = nod.Next
      Next
   Else
      ' just draw the selected part & state:
      With m_cUxTheme
         .Class = sClass
         .Part = lPartId
         .State = lStateId
         .Draw
      End With
   End If
   
   picSamples.Refresh
End Sub

Private Sub mnuFile_Click(Index As Integer)
   Unload Me
End Sub

Private Sub mnuHelp_Click(Index As Integer)
   Me.Enabled = False
   frmAbout.Show vbModeless, Me
End Sub

Private Sub tvwThemes_NodeClick(ByVal Node As MSComctlLib.Node)
   drawSelectedItems
End Sub

Private Sub txtHeight_Change()
   If IsNumeric(txtHeight.Text) Then
      m_cUxTheme.Height = CLng(txtHeight.Text)
      drawSelectedItems
   End If
End Sub


Private Sub txtHeight_KeyPress(KeyAscii As Integer)
   Select Case KeyAscii
   Case Asc("0") To Asc("9")
   Case vbKeyBack, vbKeyClear, vbKeyDelete
   Case Else
      KeyAscii = 0
   End Select
End Sub

Private Sub txtText_Change()
   m_cUxTheme.Text = txtText.Text
   drawSelectedItems
End Sub

Private Sub txtWidth_Change()
   If IsNumeric(txtWidth.Text) Then
      m_cUxTheme.Width = CLng(txtWidth.Text)
      drawSelectedItems
   End If
End Sub

Private Sub txtWidth_KeyPress(KeyAscii As Integer)
   Select Case KeyAscii
   Case Asc("0") To Asc("9")
   Case vbKeyBack, vbKeyClear, vbKeyDelete
   Case Else
      KeyAscii = 0
   End Select
End Sub