vbAccelerator - Contents of code file: cGuiResTrace.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "cGuiResTrace"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Type POINTAPI
   x As Long
   y As Long
End Type
Private Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long)
 As Long
' Pen functions:
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal
 nWidth As Long, ByVal crColor As Long) As Long
    Private Const PS_DASH = 1
    Private Const PS_DASHDOT = 3
    Private Const PS_DASHDOTDOT = 4
    Private Const PS_DOT = 2
    Private Const PS_SOLID = 0
    Private Const PS_NULL = 5
Private Declare Function GetSysColorBrush Lib "user32" (ByVal nIndex As Long)
 As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As
 Long, ByVal y As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As
 Long, ByVal y As Long, lpPoint As POINTAPI) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As
 RECT, ByVal hBrush As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal
 hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As
 Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect
 As RECT) As Long
Private Declare Function InflateRect Lib "user32" (lpRect As RECT, ByVal x As
 Long, ByVal y As Long) As Long


Public Enum ResourceTypes
   GR_GDIOBJECTS = 0           '/* Count of GDI objects */
   GR_USEROBJECTS = 1          '/* Count of USER objects */
End Enum

Private Declare Function GetGuiResources Lib "user32.dll" ( _
    ByVal hProcess As Long, _
    ByVal uiFlags As Long _
   ) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As
 Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As
 Long

Private Declare Function GetModuleFileNameExW Lib "psapi.dll" ( _
    ByVal hProcess As Long, _
    ByVal hModule As Long, _
    ByVal lpFilename As Long, _
    ByVal nSize As Long _
    ) As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory"
 (Destination As Any, Source As Any, ByVal Length As Long)

Private Const PROCESS_VM_READ = &H10&
Private Const PROCESS_QUERY_INFORMATION = &H400

Private Const MAX_PATH = 260

Private WithEvents m_timer As CTimer
Private m_lId As Long
Private m_sFileName As String
Private m_owner As ITraceEvent
Private m_dStart As Date

Private m_lBufSize As Long
Private m_lBufPos As Long
Private m_lBuffer() As Long
Private m_lSamples As Long
Private m_lMax(0 To 1) As Long
Private m_lMin(0 To 1) As Long
Private m_lCurrent(0 To 1) As Long

Private m_lOffset As Long
Private m_lMaxLast As Long

Private m_bValid As Boolean

Public Sub Save(ByVal sFIle As String)
   Dim doc As New DOMDocument
   Dim nodTop As IXMLDOMNode
   Set nodTop = doc.createElement("GuiResTrace")
   ' add the header:
   addHeader doc, nodTop
   ' add the trace information:
   addTrace doc, nodTop
   ' Add the info to the XML document
   doc.appendChild nodTop
   ' save
   doc.Save sFIle
End Sub

Private Sub addHeader(doc As DOMDocument, nodTop As IXMLDOMNode)
Dim nodHdr As IXMLDOMNode
Dim nod As IXMLDOMNode
Dim attr As IXMLDOMAttribute
   Set nodHdr = doc.createElement("Process")
   Set attr = doc.createAttribute("startDateTime")
   attr.Value = parseDateTime(m_dStart)
   nodHdr.Attributes.setNamedItem attr
   Set attr = doc.createAttribute("saveDateTime")
   attr.Value = parseDateTime(Now)
   nodHdr.Attributes.setNamedItem attr
   Set attr = doc.createAttribute("samplesRecorded")
   attr.Value = m_lSamples \ 2
   nodHdr.Attributes.setNamedItem attr
   Set nod = doc.createElement("ExeName")
   nod.Text = m_sFileName
   nodHdr.appendChild nod
   nodTop.appendChild nodHdr
End Sub

Private Sub addTrace(doc As DOMDocument, nodTop As IXMLDOMNode)
Dim nodTrace As IXMLDOMNode
Dim nod As IXMLDOMNode
Dim attr As IXMLDOMAttribute
Dim i As Long
Dim lPos As Long

   Set nodTrace = doc.createElement("GDITrace")
   Set attr = doc.createAttribute("max")
   attr.Value = m_lMax(GR_GDIOBJECTS)
   nodTrace.Attributes.setNamedItem attr
   Set attr = doc.createAttribute("min")
   attr.Value = m_lMin(GR_GDIOBJECTS)
   nodTrace.Attributes.setNamedItem attr
   
   lPos = m_lBufPos - 1
   Do While (i < m_lSamples \ 2)
      Set nod = doc.createElement("Sample")
      Set attr = doc.createAttribute("value")
      attr.Value = m_lBuffer(lPos)
      nod.Attributes.setNamedItem attr
      Set attr = doc.createAttribute("sample")
      attr.Value = i
      nod.Attributes.setNamedItem attr
      lPos = lPos - 2
      i = i + 1
      If (lPos < 0) Then
         lPos = m_lBufSize - 2
      End If
      nodTrace.appendChild nod
   Loop
   nodTop.appendChild nodTrace
   
   Set nodTrace = doc.createElement("UserTrace")
   Set attr = doc.createAttribute("max")
   attr.Value = m_lMax(GR_USEROBJECTS)
   nodTrace.Attributes.setNamedItem attr
   Set attr = doc.createAttribute("min")
   attr.Value = m_lMin(GR_USEROBJECTS)
   nodTrace.Attributes.setNamedItem attr
   
   lPos = m_lBufPos
   i = 0
   Do While (i < m_lSamples \ 2)
      Set nod = doc.createElement("Sample")
      Set attr = doc.createAttribute("value")
      attr.Value = m_lBuffer(lPos)
      nod.Attributes.setNamedItem attr
      Set attr = doc.createAttribute("sample")
      attr.Value = i
      nod.Attributes.setNamedItem attr
      lPos = lPos - 2
      i = i + 1
      If (lPos < 0) Then
         lPos = m_lBufSize - 1
      End If
      nodTrace.appendChild nod
   Loop
   nodTop.appendChild nodTrace
   
End Sub

Private Function parseDateTime(d As Date) As String
   parseDateTime = Format$(d, "yyyy-mm-dd\Thh:nn:ss")
End Function

Public Sub DrawTrace(ByVal lhDC As Long, _
      ByVal lLeft As Long, _
      ByVal lTop As Long, _
      ByVal lRight As Long, _
      ByVal lBottom As Long, _
      ByVal bUpdate As Boolean _
   )
Dim hPen As Long
Dim hPenOld As Long
Dim tR As RECT
Dim hBr As Long
Dim yIntUser As Long
Dim yIntGDI As Long
Dim yMax As Long
Dim x As Long
Dim y As Long
Dim tJunk As POINTAPI
Dim lTraceStart As Long
Dim lTraceEnd As Long
Dim lTracePos As Long
Dim yV As Single
   
   If (bUpdate) Then
      m_lOffset = m_lOffset + 1
      If (m_lOffset Mod 12) = 0 Then
         m_lOffset = 0
      End If
   End If
   
   ' Updating the display using ScrollDC is left as
   ' an exercise...
   bUpdate = False
   
   yIntUser = m_lMax(GR_USEROBJECTS) + 50
   yIntGDI = m_lMax(GR_GDIOBJECTS) + 50
   yMax = IIf(yIntUser > yIntGDI, yIntUser, yIntGDI)
   If (yMax = 0) Then yMax = 100
   If (yMax > m_lMaxLast) Then
      m_lMaxLast = yMax
      bUpdate = False
   End If
   
   If Not bUpdate Then
      tR.Left = lLeft
      tR.Top = lTop
      tR.Right = lRight
      tR.Bottom = lBottom
         
      ' Fill background
      hBr = CreateSolidBrush(&H0&)
      FillRect lhDC, tR, hBr
      DeleteObject hBr
      
      ' Draw the grid lines:
      hPen = CreatePen(PS_SOLID, 1, RGB(0, &H66, 0))
      hPenOld = SelectObject(lhDC, hPen)
      
      For x = lLeft - m_lOffset To lRight Step 12
         MoveToEx lhDC, x, lTop, tJunk
         LineTo lhDC, x, lBottom
      Next x
      For y = lBottom To lTop Step -12
         MoveToEx lhDC, lLeft, y, tJunk
         LineTo lhDC, lRight, y
      Next y
      
      SelectObject lhDC, hPenOld
      DeleteObject hPen
      
      ' Draw the trace:
      hPen = CreatePen(PS_SOLID, 1, RGB(0, &HCC, &H33))
      hPenOld = SelectObject(lhDC, hPen)
      
      ' Draw GDI Resources:
      lTraceStart = m_lBufPos
      If (m_lSamples \ 2 > lRight - lLeft) Then
         lTraceEnd = m_lBufPos + lRight - lLeft
      Else
         lTraceEnd = m_lBufPos + m_lSamples \ 2
      End If
      lTracePos = m_lBufPos
      x = lRight
      yV = lTop + ((lBottom - lTop) * (1 - (m_lBuffer(lTracePos - 1) / (yMax *
       1#))))
      MoveToEx lhDC, x, yV, tJunk
      Do
         lTracePos = lTracePos - 2
         lTraceStart = lTraceStart + 1
         If (lTracePos < 0) Then
            lTracePos = m_lBufSize - 2
         End If
         x = x - 1
            yV = lTop + ((lBottom - lTop) * (1 - (m_lBuffer(lTracePos - 1) /
             (yMax * 1#))))
         LineTo lhDC, x, yV
      Loop While (lTraceStart < lTraceEnd)
      
      SelectObject lhDC, hPenOld
      DeleteObject hPen
      
      
      hPen = CreatePen(PS_SOLID, 1, RGB(&HFF, &HFF, &HCC))
      hPenOld = SelectObject(lhDC, hPen)
      
      ' Draw User Resources:
      lTraceStart = m_lBufPos
      If (m_lSamples \ 2 > lRight - lLeft) Then
         lTraceEnd = m_lBufPos + lRight - lLeft
      Else
         lTraceEnd = m_lBufPos + m_lSamples \ 2
      End If
      lTracePos = m_lBufPos
      x = lRight
      yV = lTop + ((lBottom - lTop) * (1 - (m_lBuffer(lTracePos) / (yMax *
       1#))))
      MoveToEx lhDC, x, yV, tJunk
      Do
         lTracePos = lTracePos - 2
         lTraceStart = lTraceStart + 1
         If (lTracePos < 0) Then
            lTracePos = m_lBufSize - 1
         End If
         x = x - 1
            yV = lTop + ((lBottom - lTop) * (1 - (m_lBuffer(lTracePos) / (yMax
             * 1#))))
         LineTo lhDC, x, yV
      Loop While (lTraceStart < lTraceEnd)
      
      SelectObject lhDC, hPenOld
      DeleteObject hPen
      
   Else
            
      ' Not implemented
   
   End If
   
End Sub

Public Property Get Filename() As String
   Filename = m_sFileName
End Property
Public Property Get ExeName() As String
Dim i As Long
Dim iFound As Long
   For i = Len(m_sFileName) To 1 Step -1
      If (Mid(m_sFileName, i, 1) = "\") Then
         iFound = i
         Exit For
      End If
   Next i
   If (iFound > 0) Then
      ExeName = Mid(m_sFileName, iFound + 1)
   Else
      ExeName = m_sFileName
   End If
End Property
Public Property Get Max(ByVal eType As ResourceTypes) As Long
   Max = m_lMax(eType)
End Property
Public Property Get Min(ByVal eType As ResourceTypes) As Long
   Min = m_lMin(eType)
End Property
Public Property Get Current(ByVal eType As ResourceTypes) As Long
   Current = m_lCurrent(eType)
End Property

Friend Sub fInit( _
      ByVal lId As Long, _
      Owner As ITraceEvent, _
      Optional ByVal lBufSize As Long = 1024 _
   )
Dim hProcess As Long
   m_lId = lId
   hProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0,
    m_lId)
   If Not (hProcess = 0) Then
      m_sFileName = ExeNameForProcess(hProcess)
      CloseHandle hProcess
      m_bValid = True
      m_dStart = Now
      m_lBufSize = lBufSize * 2
      ReDim m_lBuffer(0 To m_lBufSize - 1) As Long
      m_lBufPos = 1
      Set m_timer = New CTimer
      m_timer.Interval = 250
      Set m_owner = Owner
   Else
      Err.Raise 9
   End If
End Sub

Public Function ExeNameForPid(ByVal lPid As Long) As String
Dim hProcess As Long
   hProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, lPid)
   If Not (hProcess = 0) Then
      m_sFileName = ExeNameForProcess(hProcess)
      ExeNameForPid = m_sFileName
      CloseHandle hProcess
   End If
End Function

Private Function ExeNameForProcess(ByVal hProcess As Long) As String

   ReDim b(0 To MAX_PATH) As Byte
   Dim lPtrFileName As Long
   lPtrFileName = VarPtr(b(0))
   Dim lR As Long
   lR = GetModuleFileNameExW(hProcess, 0, lPtrFileName, MAX_PATH)
   If (lR > 1) Then
      ReDim bR(0 To lR * 2 - 1) As Byte
      CopyMemory bR(0), b(0), lR * 2
      ExeNameForProcess = bR
   End If
   
End Function

Public Property Get ProcessId() As Long
   ProcessId = m_lId
End Property

Public Sub CheckGuiResources(ByVal eType As ResourceTypes)
Dim lR As Long
Dim hProcess As Long
   hProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0,
    m_lId)
   If Not (hProcess = 0) Then
      lR = GetGuiResources(hProcess, eType)
      CloseHandle hProcess
      m_lBufPos = m_lBufPos + 1
      If (m_lBufPos >= m_lBufSize) Then
         m_lBufPos = 0
      End If
      m_lBuffer(m_lBufPos) = lR
      If (lR > m_lMax(eType)) Then
         m_lMax(eType) = lR
      End If
      If (lR < m_lMin(eType)) Then
         m_lMin(eType) = lR
      End If
      m_lCurrent(eType) = lR
      m_lSamples = m_lSamples + 1
   End If
End Sub

Public Function IsValidProcessId() As Boolean
   If (m_bValid) Then
      Dim hProcess As Long
      hProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0,
       m_lId)
      If (hProcess = 0) Then
         m_bValid = False
      Else
         CloseHandle hProcess
      End If
   End If
   IsValidProcessId = m_bValid
End Function

Private Sub Class_Initialize()
   m_lMin(0) = &H7FFFFFFF
   m_lMin(1) = &H7FFFFFFF
End Sub

Private Sub Class_Terminate()
   If Not m_timer Is Nothing Then
      m_timer.Interval = 0
      Set m_timer = Nothing
   End If
End Sub

Private Sub m_timer_ThatTime()
   If (IsValidProcessId()) Then
      CheckGuiResources GR_GDIOBJECTS
      CheckGuiResources GR_USEROBJECTS
      m_owner.newTrace m_lId
   Else
      m_owner.ProcessExit m_lId
      m_timer.Interval = 0
      Set m_timer = Nothing
   End If
End Sub