vbAccelerator - Contents of code file: frmGuiResTrace.frm

VERSION 5.00
Object = "{9DC93C3A-4153-440A-88A7-A10AEDA3BAAA}#3.5#0"; "vbalDTab6.ocx"
Object = "{E910F8E1-8996-4EE9-90F1-3E7C64FA9829}#1.0#0"; "vbaListView6.ocx"
Begin VB.Form frmGuiResTrace 
   Caption         =   "vbAccelerator GUI Resource Tracer"
   ClientHeight    =   2985
   ClientLeft      =   4485
   ClientTop       =   3645
   ClientWidth     =   8280
   BeginProperty Font 
      Name            =   "Tahoma"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "frmGuiResTrace.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   2985
   ScaleWidth      =   8280
   Begin VB.PictureBox picWindows 
      BorderStyle     =   0  'None
      Height          =   2715
      Left            =   420
      ScaleHeight     =   2715
      ScaleWidth      =   2220
      TabIndex        =   5
      Top             =   120
      Width           =   2220
      Begin vbalListViewLib6.vbalListViewCtl lvwWindows 
         Height          =   2415
         Left            =   0
         TabIndex        =   6
         Top             =   60
         Width           =   2115
         _ExtentX        =   3731
         _ExtentY        =   4260
         BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
            Name            =   "MS Sans Serif"
            Size            =   8.25
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         View            =   1
         MultiSelect     =   -1  'True
         LabelEdit       =   0   'False
         FullRowSelect   =   -1  'True
         AutoArrange     =   0   'False
         BorderStyle     =   0
         HeaderButtons   =   0   'False
         HeaderTrackSelect=   0   'False
         HideSelection   =   0   'False
         InfoTips        =   0   'False
      End
   End
   Begin vbalDTab6.vbalDTabControl tabWindows 
      Align           =   3  'Align Left
      Height          =   2985
      Left            =   0
      TabIndex        =   4
      Top             =   0
      Width           =   360
      _ExtentX        =   635
      _ExtentY        =   5265
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      BeginProperty SelectedFont {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Pinnable        =   -1  'True
      Pinned          =   0   'False
   End
   Begin VB.PictureBox picTabInfo 
      BorderStyle     =   0  'None
      Height          =   2055
      Left            =   1080
      ScaleHeight     =   2055
      ScaleWidth      =   3855
      TabIndex        =   1
      Top             =   840
      Visible         =   0   'False
      Width           =   3855
      Begin VB.PictureBox picTrace 
         AutoRedraw      =   -1  'True
         BackColor       =   &H00000000&
         Height          =   1755
         Left            =   0
         ScaleHeight     =   1695
         ScaleWidth      =   3195
         TabIndex        =   2
         Top             =   0
         Width           =   3255
      End
      Begin VB.Label lblMinMax 
         Height          =   195
         Left            =   60
         TabIndex        =   3
         Top             =   1860
         Width           =   3795
      End
   End
   Begin vbalDTab6.vbalDTabControl tabTrace 
      Align           =   4  'Align Right
      Height          =   2985
      Left            =   540
      TabIndex        =   0
      Top             =   0
      Width           =   7740
      _ExtentX        =   13653
      _ExtentY        =   5265
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      BeginProperty SelectedFont {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin VB.Menu mnuFileTOP 
      Caption         =   "&File"
      Begin VB.Menu mnuFile 
         Caption         =   "&Close Trace"
         Enabled         =   0   'False
         Index           =   1
      End
      Begin VB.Menu mnuFile 
         Caption         =   "-"
         Index           =   2
      End
      Begin VB.Menu mnuFile 
         Caption         =   "&Save..."
         Enabled         =   0   'False
         Index           =   3
         Shortcut        =   ^S
      End
      Begin VB.Menu mnuFile 
         Caption         =   "-"
         Index           =   5
      End
      Begin VB.Menu mnuFile 
         Caption         =   "E&xit"
         Index           =   6
      End
   End
End
Attribute VB_Name = "frmGuiResTrace"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private m_cTraces As New Collection
Private m_cSysIls As cVBALSysImageList
Private WithEvents m_tmr As CTimer
Attribute m_tmr.VB_VarHelpID = -1

Implements ITraceEvent
Implements IEnumWindowsSink

Private Sub updateTrace(cTrace As cGuiResTrace)
   
   If (cTrace.IsValidProcessId) Then
      lblMinMax.Caption = "GDI: Now=" & cTrace.Current(GR_GDIOBJECTS) & ",
       Min=" & cTrace.Min(GR_GDIOBJECTS) & ", Max=" & cTrace.Max(GR_GDIOBJECTS)
       & "    USER: Now=" & cTrace.Current(GR_USEROBJECTS) & ", Min=" &
       cTrace.Min(GR_USEROBJECTS) & ", Max=" & cTrace.Max(GR_USEROBJECTS) & "  
        App:" & cTrace.Filename
   Else
      lblMinMax.Caption = "ENDED. GDI: Last=" & cTrace.Current(GR_GDIOBJECTS) &
       ", Min=" & cTrace.Min(GR_GDIOBJECTS) & ", Max=" &
       cTrace.Max(GR_GDIOBJECTS) & "    USER: Last=" &
       cTrace.Current(GR_USEROBJECTS) & ", Min=" & cTrace.Min(GR_USEROBJECTS) &
       ", Max=" & cTrace.Max(GR_USEROBJECTS) & "    App:" & cTrace.Filename
   End If
   lblMinMax.Refresh

   cTrace.DrawTrace picTrace.hdc, 0, 0, picTrace.ScaleWidth \
    Screen.TwipsPerPixelX, picTrace.ScaleHeight \ Screen.TwipsPerPixelY, True
   picTrace.Refresh
   
End Sub

Private Sub showInListView(ByVal hwnd As Long, ByVal lPid As Long)
   ' check if already there:
   If (lvwWindows.ListItems.Exists("C" & hwnd)) Then
      ' ok
      lvwWindows.ListItems("C" & hwnd).Tag = ""
   Else
      ' add
      Dim cT As New cGuiResTrace
      Dim sExeName As String
      sExeName = cT.ExeNameForPid(lPid)
      Dim itm As cListItem
      Set itm = lvwWindows.ListItems.Add(, "C" & hwnd, WindowTitle(hwnd),
       m_cSysIls.ItemIndex(sExeName, True), m_cSysIls.ItemIndex(sExeName, True))
      itm.SubItems(1).Caption = lPid
   End If
End Sub

Private Sub enableMenus()
Dim bEn As Boolean
   bEn = (tabTrace.Tabs.Count > 0)
   mnuFile(1).Enabled = bEn
   mnuFile(3).Enabled = bEn
End Sub

Private Sub newTrace(ByVal lPid As Long)
   Dim cTraceExist As cGuiResTrace
   On Error Resume Next
   Set cTraceExist = m_cTraces.Item("C" & lPid)
   On Error GoTo 0
   If Not (cTraceExist Is Nothing) Then
      tabTrace.Tabs.Item("C" & lPid).Selected = True
   Else
      On Error GoTo errorHandler
      Dim cTrace As cGuiResTrace
      Set cTrace = New cGuiResTrace
      cTrace.fInit lPid, Me
      m_cTraces.Add cTrace, "C" & lPid
      tabTrace.Tabs.Add "C" & lPid, , _
         cTrace.ExeName & " (" & cTrace.ProcessId & ")", _
         m_cSysIls.ItemIndex(cTrace.Filename, True)
      tabTrace.Tabs.Item("C" & lPid).Selected = True
      Form_Resize
      enableMenus
   End If
   Exit Sub
   
errorHandler:
   MsgBox "Failed to open the process for resource inspection " &
    Err.Description, vbExclamation
   Exit Sub
End Sub
Private Sub closeTrace()
   If (tabTrace.Tabs.Count > 0) Then
      Dim bJunk As Boolean
      tabTrace_TabClose tabTrace.SelectedTab, bJunk
      Dim sKey As String
      sKey = tabTrace.SelectedTab.Key
      tabTrace.Tabs.Remove sKey
   End If
End Sub
Private Sub saveTrace()
Dim sFIle As String
Dim cD As New GCommonDialog
   
   If (cD.VBGetSaveFileName( _
      sFIle, _
      Filter:="Trace XML File (*.xml)|*.XML|All Files (*.*)|*.*", _
      DefaultExt:="XML", _
      Owner:=Me.hwnd)) Then
      
      On Error Resume Next
      Kill sFIle

      On Error GoTo errorHandler
      Dim cTrace As cGuiResTrace
      Set cTrace = m_cTraces(tabTrace.SelectedTab.Key)
      cTrace.Save sFIle
   End If
   Exit Sub

errorHandler:
   MsgBox "Failed to save trace: " & Err.Description, vbExclamation
   Exit Sub
End Sub
Private Sub saveAllTraces()

End Sub

Private Sub Form_Load()

   ' Check we're running on 2000 or XP
   Dim lMajor As Long
   GetWindowsVersion lMajor
   If (lMajor >= 5) Then

      ' Set up ImageList:
      Set m_cSysIls = New cVBALSysImageList
      m_cSysIls.IconSizeX = 16
      m_cSysIls.IconSizeY = 16
      m_cSysIls.Create
      
      ' Set up ListView:
      lvwWindows.Columns.Add , "WINDOW", "Window"
      lvwWindows.Columns.Add , "PROCESS", "PID"
      lvwWindows.ImageList(eLVSmallIcon) = m_cSysIls
      
      ' Set up RHS tab:
      Dim cT As cTab
      Set cT = tabWindows.Tabs.Add("WINDOWS", , "Windows")
      cT.CanClose = False
      Set cT.Panel = picWindows
         
      ' Set up main tabs:
      tabTrace.ImageList = m_cSysIls.hImagelist
      
      ' Windows & Processes Update:
      m_tmr_ThatTime
      Set m_tmr = New CTimer
      m_tmr.Interval = 2000
   
   Else
      Dim ctl As Control
      For Each ctl In Me.Controls
         On Error Resume Next
         ctl.Enabled = False
      Next
      Me.Show
      Me.Refresh
      MsgBox "This application only runs on Windows 2000 or above.",
       vbExclamation
   End If
   
End Sub

Private Sub Form_Resize()
   On Error Resume Next
   tabTrace.Width = Me.ScaleWidth - tabWindows.Width - 2 * Screen.TwipsPerPixelX
   If (tabTrace.Tabs.Count > 0) Then
      tabTrace_TabSelected tabTrace.SelectedTab
   End If
End Sub

Private Sub IEnumWindowsSink_EnumWindow(ByVal hwnd As Long, bStop As Boolean)
   If (IsWindowVisible(hwnd)) Then
      Dim lStyle As Long
      Dim lExStyle As Long
      Dim bAdd As Boolean
      lExStyle = GetWindowLong(hwnd, GWL_EXSTYLE)
      If (lExStyle And WS_EX_TOOLWINDOW) = 0 Then
         If (lExStyle And WS_EX_APPWINDOW) = WS_EX_APPWINDOW Then
            bAdd = True
         Else
            If (GetWindow(hwnd, GW_OWNER) = 0) Then
               bAdd = True
            End If
         End If
         If (bAdd) Then
            Dim lPid As Long
            Dim lThreadId As Long
            lThreadId = GetWindowThreadProcessId(hwnd, lPid)
            showInListView hwnd, lPid
         End If
      End If
   End If
End Sub

Private Property Get IEnumWindowsSink_Identifier() As Long
   IEnumWindowsSink_Identifier = Me.hwnd
End Property

Private Sub ITraceEvent_NewTrace(ByVal lProcessId As Long)
   '
   Dim cTrace As cGuiResTrace
   Set cTrace = m_cTraces.Item("C" & lProcessId)
   If (tabTrace.Tabs.Item("C" & lProcessId).Selected = True) Then
      updateTrace cTrace
   End If
   '
End Sub

Private Sub ITraceEvent_ProcessExit(ByVal lProcessId As Long)
   '
   Dim cTrace As cGuiResTrace
   Set cTrace = m_cTraces.Item("C" & lProcessId)
   If (tabTrace.Tabs.Item("C" & lProcessId).Selected = True) Then
      tabTrace.Tabs.Item("C" & lProcessId).Caption = tabTrace.Tabs.Item("C" &
       lProcessId).Caption + " (Ended)"
      
      updateTrace cTrace
   End If
   '
End Sub

Private Sub lvwWindows_ColumnClick(Column As vbalListViewLib6.cColumn)
   If (Column.Key = "WINDOW") Then
      Column.SortType = eLVSortStringNoCase
   Else
      Column.SortType = eLVSortNumeric
   End If
   If (Column.SortOrder = eSortOrderAscending) Then
      Column.SortOrder = eSortOrderDescending
   Else
      Column.SortOrder = eSortOrderAscending
   End If
   lvwWindows.ListItems.SortItems
End Sub

Private Sub lvwWindows_ItemDblClick(Item As vbalListViewLib6.cListItem)
   If Not (Item Is Nothing) Then
      Dim lPid As Long
      lPid = Item.SubItems(1).Caption
      newTrace lPid
   End If
End Sub

Private Sub m_tmr_ThatTime()
   ' tag all listview items:
   Dim i As Long
   For i = 1 To lvwWindows.ListItems.Count
      lvwWindows.ListItems(i).Tag = "X"
   Next i
   ' enumerate windows:
   EnumerateWindows Me
   ' remove anything that's gone away:
   For i = lvwWindows.ListItems.Count To 1 Step -1
      If (lvwWindows.ListItems(i).Tag = "X") Then
         lvwWindows.ListItems.Remove i
      End If
   Next i
End Sub

Private Sub mnuFile_Click(Index As Integer)
   Select Case Index
   Case 1
      ' close trace
      closeTrace
   Case 3
      ' save trace
      saveTrace
   Case 4
      ' save all
      saveAllTraces
   Case 6
      ' exit
      Unload Me
   End Select
End Sub

Private Sub mnuFileTOP_Click()
   enableMenus
End Sub


Private Sub picTabInfo_Resize()
   On Error Resume Next
   Dim lHeight As Long
   lHeight = picTabInfo.ScaleHeight - lblMinMax.Height - 6 *
    Screen.TwipsPerPixelY
   picTrace.Move lblMinMax.Left, 2 * Screen.TwipsPerPixelY, _
      picTabInfo.ScaleWidth - lblMinMax.Left * 2, _
      lHeight
   lblMinMax.Move lblMinMax.Left, lHeight + 2 * Screen.TwipsPerPixelY, _
      picTabInfo.ScaleWidth - lblMinMax.Left * 2
End Sub

Private Sub picWindows_Resize()
   lvwWindows.Move 0, 0, picWindows.ScaleWidth, picWindows.ScaleHeight
End Sub

Private Sub tabTrace_TabClose(theTab As vbalDTab6.cTab, bCancel As Boolean)
Dim sKey As String
Dim cTrace As cGuiResTrace
   sKey = theTab.Key
   Set cTrace = m_cTraces.Item(sKey)
   m_cTraces.Remove sKey
   Set cTrace = Nothing
   If (m_cTraces.Count = 0) Then
      picTabInfo.Visible = False
   End If
End Sub

Private Sub tabTrace_TabSelected(theTab As vbalDTab6.cTab)
Dim sKey As String
Dim cTrace As cGuiResTrace
   
   sKey = theTab.Key
   Set cTrace = m_cTraces.Item(sKey)
   picTabInfo.Move _
      tabTrace.Left + tabTrace.ClientLeft * Screen.TwipsPerPixelX, _
      tabTrace.Top + tabTrace.ClientTop * Screen.TwipsPerPixelY, _
      tabTrace.ClientWidth * Screen.TwipsPerPixelX, _
      tabTrace.ClientHeight * Screen.TwipsPerPixelY
   picTabInfo.Visible = True
   updateTrace cTrace

End Sub

Private Sub tabWindows_Pinned()
   Form_Resize
End Sub

Private Sub tabWindows_UnPinned()
   Form_Resize
End Sub