Solved: Get Visual Basic 6.0 'Form' object from a known HWnd value...

Is this hWnd from your app or an external app?

JR2003

Have you tried using the controls collection on the form?

If its the same app, then simply looping through the Forms collection should suffice, but I'm not aware of any relationship of window handle and form object if that handle is coming from an external app. However, there are many API functions that work on a window based on its handle. What exactly do you need to do once you locate this form you want to work with?

JR2003

Have you tried using the Spy software that comes in the tools options with Visual Studio?

WarpNine

ASKER

I'm familiar with looping through the Forms collection internally, I'm looking for an 'external' reference of a running (VB6) application. I already have most of what I need, but I can't seem to marry each control with it's hwnd handle...

Here's where I am now...

Method #1:
I'm enumerating using 'EnumWinProc()' and 'EnumChildProc()' which gives me class names from 'GetClassName()' and the controls' text from 'GetWindowText()'. I have the hwnd of my controls here, but I do not have the actual '.Name' of the control...

Method #2:
Now, if I pass the form's hwnd into the 'GetWindowThreadProcessId()' and hop through heap-addresses using 'ReadProcessMemory()' I can get the class name, caption text, and the actaul '.Name' values of the controls! Needless to say I was pleased! But I don't have an hwnd for the controls with this method!

The only remaining issue (for 500 points) is associating the two so that I can have the 'name' of the control AND the 'hwnd' as well. I can't find a way to directly associate the information in method #1 with the information in method #2.

I'm almost there!

Warp

Ark

>>Method #2:
Now, if I pass the form's hwnd into the 'GetWindowThreadProcessId()' and hop through heap-addresses using 'ReadProcessMemory()' I can get the class name, caption text, and the actaul '.Name' values of the controls!<<

It's strange! Actually, controls "Name" property is using in high level languages just to simplify programming. When compiled, control name go out - compiler just place each control code to predefined offsets. Try to disassembly vb executable - you won't find control's names there (not sure, probably compiling using P-code still keep names?)

JR2003

I think that the internal name from for the control is not available outside the application.
This would be a very poor security feature of vb if it did allow you to see the name of the controls in the form.

WarpNine

ASKER

All,

I was trying not to bore everyone with a long post. But since I'm being told that what I'm doing is not possible, I feel the need to prove myself. I may not be an 'expert', but I'm no liar and I'm not retarded either.

Following is the VB6 code and output for 'Method#1' and 'Method#2'. I pointed at a small (seperate AND external) compiled VB6 application I threw together to test this code. As far as 'poor-security' goes, what can I say? I didn't write the Win32 API library! To repeat myself, the following output was generated from a seperately compiled executing 'EXE'. There's more code to my application. I tried to include only lines pertaining to this issue...

========== Method #1 ============================================================

lRet = EnumChildWindows(p_oFormInfo(iIndex).hwnd, AddressOf EnumChildProc, lParam) ' <<< hWnd of the ref'd form >>>
.
.
.
Function EnumChildProc(ByVal lhWnd As Long, ByVal lParam As Long) As Long
Dim RetVal As Long, iIndex As Integer
Dim WinClassBuf As String * 255, WinTitleBuf As String * 255
Dim WinClass As String, WinTitle As String
Dim lID As Long, lpRect As RECT

RetVal = GetClassName(lhWnd, WinClassBuf, 255)
WinClass = StripNulls(WinClassBuf) ' remove extra Nulls & spaces
RetVal = GetWindowText(lhWnd, WinTitleBuf, 255)
WinTitle = StripNulls(WinTitleBuf)

If GetWindowLong(lhWnd, GWW_ID) Then
GetWindowRect lhWnd, lpRect
lID = GetWindowLong(lhWnd, GWW_ID)

iIndex = UBound(p_oControlInfo)
ReDim Preserve p_oControlInfo(iIndex + 1)
p_oControlInfo(iIndex).hwnd = lhWnd
p_oControlInfo(iIndex).XLoc = lpRect.Left
p_oControlInfo(iIndex).YLoc = lpRect.Top
p_oControlInfo(iIndex).ID = lID
p_oControlInfo(iIndex).Class = WinClass
p_oControlInfo(iIndex).Title = WinTitle

PPrint "Hwnd = " & p_oControlInfo(iIndex).hwnd & " Class = " & p_oControlInfo(iIndex).Class & " Title = '" & p_oControlInfo(iIndex).Title & "' X-Loc = " & p_oControlInfo(iIndex).XLoc & " Y-Loc = " & p_oControlInfo(iIndex).YLoc
End If
EnumChildProc = True
End Function
--------------------------------------------------------------------------------------------------------------------------------------

Hwnd = 3606330 Class = ThunderRT6Data Title = 'DataNavigation' X-Loc = 1251 Y-Loc = 482
Hwnd = 8259434 Class = ThunderRT6DriveListBox Title = '' X-Loc = 1251 Y-Loc = 610
Hwnd = 7604014 Class = ThunderRT6OptionButton Title = 'Bottom Option' X-Loc = 1251 Y-Loc = 738
Hwnd = 7014444 Class = ThunderRT6OptionButton Title = 'Top Option' X-Loc = 1251 Y-Loc = 714
Hwnd = 8587598 Class = ThunderRT6ListBox Title = '' X-Loc = 1387 Y-Loc = 682
Hwnd = 5376138 Class = ThunderRT6ComboBox Title = '' X-Loc = 1243 Y-Loc = 682
Hwnd = 13633778 Class = Edit Title = '' X-Loc = 1246 Y-Loc = 685
Hwnd = 1706164 Class = ThunderRT6CheckBox Title = 'Right Check' X-Loc = 1371 Y-Loc = 650
Hwnd = 10357056 Class = ThunderRT6CheckBox Title = 'Left Check' X-Loc = 1267 Y-Loc = 650
Hwnd = 5441768 Class = ThunderRT6Frame Title = 'Frame1' X-Loc = 1251 Y-Loc = 514
Hwnd = 4982842 Class = ThunderRT6CommandButton Title = 'Frame Button' X-Loc = 1395 Y-Loc = 562
Hwnd = 4917264 Class = ThunderRT6TextBox Title = 'In the frame' X-Loc = 1275 Y-Loc = 562
Hwnd = 3934264 Class = ThunderRT6OptionButton Title = 'Option In Frame' X-Loc = 1275 Y-Loc = 538
Hwnd = 3803230 Class = ThunderRT6CommandButton Title = 'Open' X-Loc = 1387 Y-Loc = 762
Hwnd = 9111828 Class = ThunderRT6CommandButton Title = 'Exit' X-Loc = 1243 Y-Loc = 762
Hwnd = 5572808 Class = ThunderRT6TextBox Title = 'Johnson' X-Loc = 1299 Y-Loc = 434
Hwnd = 6031502 Class = ThunderRT6TextBox Title = 'Van' X-Loc = 1299 Y-Loc = 402
Hwnd = 6883630 Class = ThunderRT6TextBox Title = 'Daryl' X-Loc = 1299 Y-Loc = 370

===============================================================================

========== Method #2 ============================================================

lRet = GetWindowThreadProcessId(lhWnd, PID) ' <<<< This is how I got the process ID I used... >>>>
.
.
.
Sub GetVBProcessControls(oForm As clsForm, PID As Long)
Dim hSnapshot As Long
Dim lRes As Long
Dim lRes2 As Long
Dim tHL As HEAPLIST32
Dim tHE As HEAPENTRY32
Dim sProgID As String
Dim sObjName As String
Dim sCaption As String

hSnapshot = CreateToolhelp32Snapshot(TH32CS_SNAPHEAPLIST, PID)
tHL.dwSize = Len(tHL)
lRes = Heap32ListFirst(hSnapshot, tHL)
With tHE
Do While lRes = 1
.dwSize = Len(tHE)
lRes2 = Heap32First(tHE, tHL.th32ProcessID, tHL.th32HeapID)
Do While lRes2 = 1
If IsValidControl(tHE.dwBlockSize) Then
sProgID = GetControlProgID(.th32ProcessID, .dwAddress)
If IsValidClass(sProgID) Then
sObjName = GetControlName(tHL.th32ProcessID, .dwAddress)
sCaption = GetControlCaption(tHL.th32ProcessID, .dwAddress)
PPrint " " & sProgID & ": " & sObjName & ".Caption = '" & sCaption & "' [ " & .dwBlockSize & " ]"
If tHE.dwBlockSize = BSIZE_VB_Form Then
oForm.FormName = sObjName
oForm.Caption = sCaption
End If
End If
End If
If oForm.FormNameOnly = True And sProgID = "VB.Form" Then Exit Do
lRes2 = Heap32Next(tHE)
Loop
If oForm.FormNameOnly = True And sProgID = "VB.Form" Then Exit Do
lRes = Heap32ListNext(hSnapshot, tHL)
Loop
End With
CloseToolhelp32Snapshot hSnapshot
End Sub

Function GetControlCaption(ByVal PID As Long, ByVal BaseAddress As Long) As String
Dim lStrPtr As Long, lInfoPtr As Long
Toolhelp32ReadProcessMemory PID, BaseAddress + 136, lStrPtr, 4, 0
GetControlCaption = String$(260, 0)
If lStrPtr <> 0 Then
Toolhelp32ReadProcessMemory PID, lStrPtr, ByVal GetControlCaption, 260, 4
End If
GetControlCaption = Left$(GetControlCaption, InStr(GetControlCaption, vbNullChar) - 1)
End Function

Function GetControlName(ByVal PID As Long, ByVal BaseAddress As Long) As String
Dim lStrPtr As Long, lInfoPtr As Long
Toolhelp32ReadProcessMemory PID, BaseAddress + 60, lInfoPtr, 4, 0
Toolhelp32ReadProcessMemory PID, lInfoPtr + 4, lStrPtr, 4, 0
GetControlName = String$(260, 0)
If lStrPtr <> 0 Then
Toolhelp32ReadProcessMemory PID, lStrPtr, ByVal GetControlName, 260, 0
End If
GetControlName = Left$(GetControlName, InStr(GetControlName, vbNullChar) - 1)
End Function
--------------------------------------------------------------------------------------------------------------------------------------

VB.Form: frmCaptureFrom.Caption = 'Capture From' [ 408 ]
VB.Data: dbDataNav.Caption = 'DataNavigation' [ 304 ]
VB.DriveListBox: drvMyList.Caption = '' [ 240 ]
VB.OptionButton: Option2.Caption = 'Bottom Option' [ 232 ]
VB.OptionButton: Option1.Caption = 'Top Option' [ 232 ]
VB.ListBox: lstMyList.Caption = '' [ 248 ]
VB.ComboBox: cboDropDown.Caption = 'Combo1' [ 280 ]
VB.CheckBox: chkRight.Caption = 'Right Check' [ 232 ]
VB.CheckBox: chkLeft.Caption = 'Left Check' [ 232 ]
VB.Frame: fraFrameContainer.Caption = 'Frame1' [ 224 ]
VB.CommandButton: cmdFrameButton.Caption = 'Frame Button' [ 232 ]
VB.TextBox: txtTextInFrame.Caption = 'In the frame' [ 256 ]
VB.OptionButton: optInFrame.Caption = 'Option In Frame' [ 232 ]
VB.CommandButton: Command1.Caption = 'Open' [ 232 ]
VB.CommandButton: cmdExit.Caption = 'Exit' [ 232 ]
VB.TextBox: txtLast.Caption = 'Johnson' [ 256 ]
VB.TextBox: txtMiddle.Caption = 'Van' [ 256 ]
VB.TextBox: txtFirst.Caption = 'Daryl' [ 256 ]
VB.Label: lblLast.Caption = 'Last:' [ 232 ]
VB.Label: lblMiddle.Caption = 'Middle:' [ 232 ]
VB.Label: lblFirst.Caption = 'First:' [ 232 ]
===============================================================================

I welcome 'helpful' and 'constructive' comments to this issue...

Thanks!

Warp

WarpNine

ASKER

Hey Ark,

If you are a guy... YOU ARE DA MAN!!! If you are a chick... YOU GO GIRL!!!

That one freakin' line of code is EXACTLY what needed! Works beautifully! That was the last piece to this puzzle I’ve been pulling my hair out over! As you probably noticed from my last post, I was starting to get a little frustrated. People have been telling me for a week that what YOU just did could NOT be done.

I can’t thank you enough!!! Too bad I can’t give you more than ‘500xA’ points!!

You totally ROCK!!!

Thanks!

Warp

(P.S.: If you could point me where you found this information, it would be greatly appreciated!)

Ark

Hello
To tell the truth, when I read your question, I also didn't belive this is possible. But after you show your code I realized that only one person can play with VB objects such a way - I just googled for Toolhelp32ReadProcessMemory+morcillo and found source code at http://groups.google.ru/group/microsoft.public.vb.winapi/browse_thread/thread/fa4fa7425c830b7f/3d0a387af069aed6
The rest was trivial - main code is

If sObjName = "Label1" Then
For i = 0 To 232 Step 4
Toolhelp32ReadProcessMemory pid, tHE.dwAddress + i, lVal, 4, 0
Debug.Print i, lVal, Hex(lVal)
Next i
End If

Digging around structure I found following properties (Note: offsets snown are for Labels only. Seems first 208 offsets are equal for all controls while offsets greater then 208 may differ for other controls)
0-43 - Unknown (some pointers - probably, events handlers addresses?)
44 - Class Info (pointer to Interface)
60 - Object Info
64 - hWnd
68,72 - seems to be a pointers to prev/next controls in form's controls collection
92 - Left (twips)
96 - Top (twips)
100 - Width (twips)
104 - Height (twips)
108 - Left (pixels)
112 - Top (pixels)
116 - Back color
120 - Fore color
128 - Unknown
132 - Tag (LPWSTR)
136 - Caption (LPSTR)
140 - DataField (LPSTR)
144 - DataMember (LPSTR)
148 - DataSource (LPSTR)
152 - DataFormat - Pointer to StdFormatObject
156,160 - Unknown
164 - WhatThisHelpID
168 - ToolTipText (LPSTR)
172 - DragIcon (hIcon)
176 - MouseIcon (hIcon)
180 - Pointer to DDE Link Object
184-192 - unknown
196 - TabIndex
200 - Unknown
204 - MousePointer (HiWord)
208 - Index (LoWord)
'==========For Label Only======
212 - Flags (Alignment, AutoSize etc) - See code below for flag values
216 - hFont (for form - 224)
228 - Seems to be more Flags (Appearance,Enabled, Visible) - not tested yet
Here is my sample (2 modules + 1 Form):

'============ mEnumWindows.bas========
'Purpose - Enumerate ThunderRT6... windows
Option Explicit

Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function EnumWindows& Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long)
Dim lb As ListBox

Function EnumWinProc(ByVal hWnd As Long, ByVal lParam As Long) As Long
If Left(GetWndClass(hWnd), 10) = "ThunderRT6" Then
lb.AddItem GetWndText(hWnd)
lb.ItemData(lb.NewIndex) = hWnd
End If
EnumWinProc = 1
End Function

Public Sub EnumVBWindows(lbWindows As ListBox)
Set lb = lbWindows
lb.Clear
EnumWindows AddressOf EnumWinProc, 0
Set lb = Nothing
End Sub

Private Function GetWndClass(hWnd As Long) As String
Dim k As Long, sName As String
sName = Space$(128)
k = GetClassName(hWnd, sName, 128)
If k > 0 Then sName = Left$(sName, k) Else sName = "No class"
GetWndClass = sName
End Function

Private Function GetWndText(hWnd As Long) As String
Dim k As Long, sName As String
sName = Space$(128)
k = GetWindowText(hWnd, sName, 128)
If k > 0 Then sName = Left$(sName, k) Else sName = "No name"
GetWndText = sName
End Function

'===============mEnumControls.bas=========
'Purpose - Enumerate controls and read their properties
Option Explicit

Const LF_FACESIZE = 32 'Font Dialog
Private Type LOGFONT 'Font Dialog
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type

Const TH32CS_SNAPHEAPLIST = &H1

Type HEAPLIST32
dwSize As Long
th32ProcessID As Long ' owning process
th32HeapID As Long ' heap (in owning process's context!)
dwFlags As Long
End Type

Type HEAPENTRY32
dwSize As Long
hHandle As Long ' Handle of this heap block
dwAddress As Long ' Linear address of start of block
dwBlockSize As Long ' Size of block in bytes
dwFlags As Long
dwLockCount As Long
dwResvd As Long
th32ProcessID As Long ' owning process
th32HeapID As Long ' heap block is in
End Type

Declare Function CreateToolhelp32Snapshot Lib "kernel32" (ByVal Flags As Long, ByVal pid As Long) As Long
Declare Function CloseToolhelp32Snapshot Lib "kernel32" Alias "CloseHandle" (ByVal Handle As Long) As Long
Declare Function Heap32ListFirst Lib "kernel32" (ByVal hSnapshot As Long, lphl As HEAPLIST32) As Long
Declare Function Heap32ListNext Lib "kernel32" (ByVal hSnapshot As Long, lphl As HEAPLIST32) As Long
Declare Function Heap32First Lib "kernel32" (lphe As HEAPENTRY32, ByVal th32ProcessID As Long, ByVal th32HeapID As Long) As Long
Declare Function Heap32Next Lib "kernel32" (lphe As HEAPENTRY32) As Long
Declare Function Toolhelp32ReadProcessMemory Lib "kernel32" (ByVal th32ProcessID As Long, ByVal lpBaseAddress As Long, lpBuffer As Any, ByVal cbRead As Long, lpNumberOfBytesRead As Long) As Long
Declare Function GetWindowThreadProcessId Lib "user32.dll" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
Private Declare Function GetObj Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal cBytes As Long)

Dim cb As ComboBox

Public Function EnumVBControls(ByVal hForm As Long, cbControls As ComboBox)
Dim hSnapshot As Long
Dim lRes As Long, lRes2 As Long, idx As Long
Dim pid As Long, tid As Long
Dim tHL As HEAPLIST32
Dim tHE As HEAPENTRY32
Dim lf As LOGFONT

Dim sProgid As String, sObjName As String, sShortProgID As String, s As String

Dim i As Long, lVal As Long, lVal1 As Long
Dim sCaption As String
Dim bDone As Boolean
tid = GetWindowThreadProcessId(hForm, pid) ' Get ProcessID
If pid = 0 Then Exit Function
Set cb = cbControls
cb.Clear
cb.Tag = pid
' cb.Sorted = True

' Create a snapshot of the process
hSnapshot = CreateToolhelp32Snapshot(TH32CS_SNAPHEAPLIST, pid)
tHL.dwSize = Len(tHL)
' Find first heap
lRes = Heap32ListFirst(hSnapshot, tHL)
Do While lRes = 1
tHE.dwSize = Len(tHE)
' Find first heap
lRes2 = Heap32First(tHE, tHL.th32ProcessID, tHL.th32HeapID)
Do While lRes2 = 1
If ValidateSize(tHE.dwBlockSize) Then
sProgid = GetControlProgID(tHE.th32ProcessID, tHE.dwAddress)
sShortProgID = ShortProgID(sProgid)
If sShortProgID <> "" Then
sObjName = GetControlName(tHL.th32ProcessID, tHE.dwAddress)
idx = GetIndex(pid, tHE.dwAddress)
If idx > -1 Then
sObjName = sObjName & "(" & idx & ")"
End If
cb.AddItem sObjName & " [" & sShortProgID & "]"
cb.ItemData(cb.NewIndex) = tHE.dwAddress
'================ For testings========================================
If sObjName = "Label1" Then
For i = 0 To 232 Step 4
Toolhelp32ReadProcessMemory pid, tHE.dwAddress + i, lVal, 4, 0
Debug.Print i, lVal, Hex(lVal)
Next i
End If
'=====================================================================
End If
End If
lRes2 = Heap32Next(tHE)
Loop
' Find next heap
lRes = Heap32ListNext(hSnapshot, tHL)
Loop
' Close the snapshot
CloseToolhelp32Snapshot hSnapshot
Set cb = Nothing
End Function

Function GetControlProgID(ByVal pid As Long, ByVal BaseAddress As Long) As String
Dim lInfoPtr As Long
Dim lStrPtr As Long

' Get pointer to class info
Toolhelp32ReadProcessMemory pid, BaseAddress + 44, lInfoPtr, 4, 0
' Get pointer to sProgID string
Toolhelp32ReadProcessMemory pid, lInfoPtr + 36, lStrPtr, 4, 0
' Get control ProgID
GetControlProgID = String$(260, 0)
If lStrPtr <> 0 Then
Toolhelp32ReadProcessMemory pid, lStrPtr, ByVal GetControlProgID, 260, 0
End If
GetControlProgID = TrimNULL(GetControlProgID)
End Function

Function GetControlName(ByVal pid As Long, ByVal BaseAddress As Long) As String
Dim lStrPtr As Long
Dim lInfoPtr As Long
' Get pointer to object info
Toolhelp32ReadProcessMemory pid, BaseAddress + 60, lInfoPtr, 4, 0
' Get pointer to object name
Toolhelp32ReadProcessMemory pid, lInfoPtr + 4, lStrPtr, 4, 0
' Get object name
GetControlName = String$(260, 0)
If lStrPtr <> 0 Then
Toolhelp32ReadProcessMemory pid, lStrPtr, ByVal GetControlName, 260, 0
End If
GetControlName = TrimNULL(GetControlName)
End Function

Public Function GetControlProperty(ByVal pid As Long, ByVal BaseAddress As Long, _
ByVal Offset As Long, ByVal sType As String, _
Optional ByVal bitNum As String, _
Optional ByVal bitNames As String) As Variant
Dim lVal As Long, lVal1 As Long, i As Long
Dim s As String
Dim lf As LOGFONT
Dim varBitNums As Variant
Dim varBitNames As Variant
Dim abData() As Byte, abTemp() As Byte
Dim intData As Integer

If UCase(sType) = "NAME" Then
GetControlProperty = GetControlName(pid, BaseAddress)
Exit Function
End If
GetControlProperty = ""
Toolhelp32ReadProcessMemory pid, BaseAddress + Offset, lVal, 4, 0
Select Case UCase(sType)
Case "DWORD": GetControlProperty = lVal
Case "HEX": GetControlProperty = "&H" & Right("00000000" & Hex(lVal), 8)
Case "LOWORD": GetControlProperty = LoWord(lVal)
Case "HIWORD": GetControlProperty = HiWord(lVal)
Case "LPSTR", "LPWSTR"
If lVal = 0 Then Exit Function
s = String$(260, 0)
Toolhelp32ReadProcessMemory pid, lVal, ByVal s, 260, 0
If bitNum <> "" Then s = Mid(s, CLng(bitNum))
If sType = "LPWSTR" Then s = StrConv(s, vbFromUnicode)
GetControlProperty = TrimNULL(s)
Case "FONT"
If lVal = 0 Then Exit Function
If UCase(GetControlProgID(pid, BaseAddress)) = "VB.FORM" Then
Toolhelp32ReadProcessMemory pid, BaseAddress + Offset + 8, lVal, 4, 0
End If
GetObj lVal, Len(lf), lf
GetControlProperty = TrimNULL(StrConv(lf.lfFaceName, vbUnicode))
Case "LINKOBJECT"
If lVal = 0 Then Exit Function
ReDim abData(259)
Toolhelp32ReadProcessMemory pid, lVal, abData(0), 260, 0
lVal = 0
Select Case UCase(bitNum)
Case "ITEM"
ReDim abTemp(259)
CopyMemory abTemp(0), abData(28), 200
s = StrConv(abTemp, vbUnicode)
lVal = InStr(1, s, Chr(0))
If lVal > 0 Then s = Mid(s, lVal + 10)
Case "MODE"
Case "SOURCE"
Case "TIMEOUT"
CopyMemory lVal, abData(14), 2
s = lVal
Case "TOPIC"
ReDim abTemp(259)
CopyMemory abTemp(0), abData(28), 200
s = StrConv(abTemp, vbUnicode)
End Select
GetControlProperty = TrimNULL(s)
Case "DATAFORMAT"
If lVal = 0 Then Exit Function
Toolhelp32ReadProcessMemory pid, lVal + 8, lVal, 4, 0
Toolhelp32ReadProcessMemory pid, lVal + 80, lVal1, 4, 0
Select Case lVal1
Case 0: s = "General"
Case 1
Toolhelp32ReadProcessMemory pid, lVal + 92, lVal1, 4, 0
Select Case lVal1
Case 1: s = "Number"
Case 2: s = "Percentage"
Case 7: s = "Time"
Case 9: s = "Scientific"
Case 10: s = "Time"
Case 12: s = "Currency"
Case Else: s = "Custom"
End Select
Case 2: s = "Picture"
Case 3: s = "Object"
Case 4: s = "Checbox"
Case 5: s = "Boolean"
Case 6: s = "Bytes"
Case Else: s = "Unknown"
End Select
GetControlProperty = s
Case "ICON"
If lVal = 0 Then GetControlProperty = "(None)" Else GetControlProperty = "(Icon)"
Case "FLAG"
If bitNum = "" Then Exit Function
varBitNums = Split(bitNum, ",")
varBitNames = Split(bitNames, ",")
For i = 0 To UBound(varBitNums)
If (lVal And varBitNums(i)) Then
s = varBitNames(i)
Exit For
End If
Next i
If s = "" Then s = varBitNames(UBound(varBitNames))
GetControlProperty = s
Case Else
End Select
End Function

Private Function ValidateSize(ByVal iSize As Long) As Boolean
ValidateSize = True
Select Case iSize
Case 224 'Frame
Case 232 'label,command button, checkbox, option button
Case 248 'array of controls (including menu and list box)
Case 256 'textbox
Case 280 'combobox
Case 328 'picturebox
Case 376 'WebBrowser, Common controls, DataList/Combo
Case 408 'Form
Case Else
ValidateSize = False
End Select
End Function

Private Function ShortProgID(ByVal sProgid As String) As String
Dim nPos As Long
nPos = InStr(1, sProgid, ".")
If nPos = 0 Then Exit Function
Select Case sProgid
Case "VB.Menu", "VB.Printer", "VB.Clipboard"
Case Else: ShortProgID = Mid(sProgid, nPos + 1)
End Select
End Function

Private Function GetIndex(ByVal pid As Long, ByVal BaseAddress As Long) As Long
Dim lVal As Long, idx As Long
Toolhelp32ReadProcessMemory pid, BaseAddress + 208, lVal, 4, 0
GetIndex = LoWord(lVal)
End Function

Public Function TrimNULL(ByVal str As String) As String
If InStr(str, Chr$(0)) > 0& Then
TrimNULL = Left$(str, InStr(str, Chr$(0)) - 1&)
Else
TrimNULL = str
End If
End Function

Public Function LoWord(ByVal dw As Long) As Integer
If dw And &H8000& Then
LoWord = dw Or &HFFFF0000
Else
LoWord = dw And &HFFFF&
End If
End Function

Public Function HiWord(ByVal dw As Long) As Integer
HiWord = (dw And &HFFFF0000) \ 65536
End Function

'===========Form code=======
'Add Listbox (Name=lbWindows), ComboBox (cbControls) and ListView(lvPropertis) on form - any size, any position
'Copy/Paste following code:
Option Explicit

Private Sub cbControls_Click()
EnumProperties
End Sub

Private Sub Form_Load()
Caption = "VB controls demo"
Width = 8700
With lvProperties
.View = lvwReport
.ColumnHeaders.Clear
.ColumnHeaders.Add , , "Property", 2000
.ColumnHeaders.Add , , "Value", 1900
.Appearance = ccFlat
.FullRowSelect = True
.GridLines = True
.LabelEdit = lvwManual
End With
FillPropertiesNames
EnumVBWindows lbWindows
Show
' If lbWindows.ListCount Then lbWindows.ListIndex = 0
End Sub

Private Sub Form_Resize()
lbWindows.Move 60, 60, ScaleWidth / 2 - 120, ScaleHeight - 120
cbControls.Move ScaleWidth / 2, 60, ScaleWidth / 2 - 60
lvProperties.Move cbControls.Left, cbControls.Top + cbControls.Height + 60, cbControls.Width
lvProperties.Height = ScaleHeight - lvProperties.Top - 60
End Sub

Private Sub lbWindows_Click()
MousePointer = vbHourglass
DoEvents
EnumVBControls lbWindows.ItemData(lbWindows.ListIndex), cbControls
If cbControls.ListCount Then cbControls.ListIndex = 0
MousePointer = vbDefault
End Sub

Private Sub FillPropertiesNames()
lvProperties.ListItems.Clear
AddProperty "(Name)", "60", "NAME"
AddProperty "Alignment", "212", "FLAG", "4,2", "2 - Center,1 - Right Justify,0 - Left Justify"
AddProperty "Appearance", "212", "FLAG"
AddProperty "AutoSize", "212", "FLAG", "1", "True,False"
AddProperty "BackColor", "116", "HEX"
AddProperty "BackStyle", "212", "FLAG", "16", "1 - Opaque,0 - Transparent"
AddProperty "BorderStyle", "212", "FLAG", "32", "1 - Fixed Single,0 - None"
AddProperty "Caption", "136", "LPSTR"
AddProperty "DataField", "140", "LPSTR"
AddProperty "DataFormat", "152", "DATAFORMAT"
AddProperty "DataMember", "144", "LPSTR"
AddProperty "DataSource", "148", "LPSTR"
AddProperty "DragIcon", "172", "ICON"
AddProperty "DragMode", "0", "UNKNOWN"
AddProperty "Enabled", "212", "FLAG"
AddProperty "Font", "216", "FONT"
AddProperty "ForeColor", "120", "HEX"
AddProperty "Height", "104", "DWORD"
AddProperty "Index", "208", "LOWORD"
AddProperty "Left", "92", "DWORD"
AddProperty "LinkItem", "180", "LINKOBJECT", "ITEM"
AddProperty "LinkMode", "0", "UNKNOWN"
AddProperty "LinkTimeout", "180", "LINKOBJECT", "TIMEOUT"
AddProperty "LinkTopic", "180", "LINKOBJECT", "TOPIC"
AddProperty "MouseIcon", "176", "ICON"
AddProperty "MousePointer", "204", "HIWORD"
AddProperty "OLEDropMode", "0", "UNKNOWN"
AddProperty "RightToLeft", "212", "FLAG"
AddProperty "TabIndex", "196", "DWORD"
AddProperty "Tag", "132", "LPWSTR"
AddProperty "ToolTipText", "168", "LPSTR"
AddProperty "Top", "96", "DWORD"
AddProperty "UseMnemonic", "212", "FLAG", "64", "True,False"
AddProperty "Visible", "0", "UNKNOWN"
AddProperty "WhatsThisHelpID", "164", "DWORD"
AddProperty "Width", "100", "DWORD"
AddProperty "WordWrap", "212", "FLAG", "8", "True,False"
End Sub

Private Sub AddProperty(ByVal sName As String, ByVal sOffset As String, _
ByVal sType As String, _
Optional bitNum As String, _
Optional bitName As String)
sType = sOffset & "_" & sType
If bitNum <> "" Then sType = sType & "_" & bitNum
If bitName <> "" Then sType = sType & "_" & bitName
lvProperties.ListItems.Add(, , sName).Tag = sType
End Sub

Private Sub EnumProperties()
Dim li As Object
Dim varData As Variant
Dim iOffset As Long, bitNum As Long
Dim sType As String, s As String
For Each li In lvProperties.ListItems
varData = Split(li.Tag, "_")
Select Case UBound(varData)
Case 1
s = GetControlProperty(cbControls.Tag, cbControls.ItemData(cbControls.ListIndex), varData(0), varData(1))
Case 2
s = GetControlProperty(cbControls.Tag, cbControls.ItemData(cbControls.ListIndex), varData(0), varData(1), varData(2))
Case 3
s = GetControlProperty(cbControls.Tag, cbControls.ItemData(cbControls.ListIndex), varData(0), varData(1), varData(2), varData(3))
Case Else: s = "Invalid Type"
End Select
If (li.Text = "Index") And (s = "-1") Then s = ""
li.SubItems(1) = s
Next
End Sub

Regards
Ark

Ark

PS
>>If you are a guy<< Yes :)

WarpNine

ASKER

Like I said before... YOU TOTALLY ROCK!!! DUDE!!!

I'm going to be picking off of this code for weeks. You're making me appear to be VERY smart!

Thanks again!

Warp

Ark

More amazing - you can change another process properties on the fly!
Add following declarations to mEnumControls.bas:

Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function VirtualAllocEx Lib "kernel32" (ByVal hProcess As Long, ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function VirtualFreeEx Lib "kernel32" (ByVal hProcess As Long, lpAddress As Any, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Private Declare Function WriteProcessMemory Lib "kernel32" (ByVal hProcess As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Private Declare Function ReadProcessMemory Lib "kernel32" (ByVal hProcess As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long

Const MEM_COMMIT = &H1000
Const MEM_RESERVE = &H2000
Const MEM_RELEASE = &H8000

Const PAGE_READWRITE = &H4&
Const PAGE_EXECUTE_READWRITE = &H40&
Const PROCESS_ALL_ACCESS = &H1F0FFF
Public hFont As Long, hDragIcon As Long, hMouseIcon As Long

'Add Follofing functions also:

Public Function SetControlProperty(ByVal pid As Long, ByVal BaseAddress As Long, _
ByVal Offset As Long, ByVal sType As String, _
ByVal varValue As Variant) As Boolean
Dim hProcess As Long, lVal As Long, ret As Long, addr As Long, oldProtect As Long
Dim intVal As Integer
Dim s As String
hProcess = OpenProcess(PROCESS_ALL_ACCESS, False, pid)
Select Case sType
Case "DWORD"
lVal = CLng(varValue)
WriteProcessMemory hProcess, ByVal BaseAddress + Offset, lVal, 4, ret
Case "HEX"
lVal = CLng(Val(varValue))
WriteProcessMemory hProcess, ByVal BaseAddress + Offset, lVal, 4, ret
Case "LOWORD"
intVal = CInt(varValue)
WriteProcessMemory hProcess, ByVal BaseAddress + Offset, intVal, 2, ret
Case "HIWORD"
intVal = CInt(varValue)
WriteProcessMemory hProcess, ByVal BaseAddress + Offset + 2, intVal, 2, ret
Case "LPSTR", "LPWSTR"
s = CStr(varValue)
If sType = "LPWSTR" Then s = StrConv(s, vbUnicode)
addr = VirtualAllocEx(hProcess, 0, Len(s), MEM_RESERVE Or MEM_COMMIT, PAGE_READWRITE)
If addr Then
WriteProcessMemory hProcess, ByVal addr, ByVal s, Len(s), ret
WriteProcessMemory hProcess, ByVal BaseAddress + Offset, addr, 4, ret
End If
Case "FONT"
lVal = CLng(varValue)
WriteProcessMemory hProcess, ByVal BaseAddress + Offset, lVal, 4, ret
Case "LINKOBJECT"
Case "DATAFORMAT"
Case "ICON"
lVal = CLng(varValue)
WriteProcessMemory hProcess, ByVal BaseAddress + Offset, lVal, 2, ret
Case "FLAG"
lVal = CLng(varValue)
WriteProcessMemory hProcess, ByVal BaseAddress + Offset, lVal, 4, ret
Case Else
End Select
CloseHandle hProcess
SetControlProperty = CBool(ret)
End Function

Public Function ShowFontDialog(cdlg As CommonDialog) As Long
Dim lf As LOGFONT
Dim tmpArr() As Byte
Dim i As Integer, lArr As Long
GetObj hFont, Len(lf), lf
With cdlg
.Flags = cdlCFBoth
.FontBold = (lf.lfWeight > 400)
.FontItalic = lf.lfItalic
.FontName = StrConv(lf.lfFaceName, vbUnicode)
.FontSize = -MulMul(lf.lfHeight, GetDeviceCaps(GetDC(0), 90&), 72)
.FontStrikethru = lf.lfStrikeOut
.FontUnderline = lf.lfUnderline
.CancelError = True
On Error Resume Next
If Err Then Exit Function
.ShowFont
lf.lfHeight = -MulDiv(.FontSize, GetDeviceCaps(GetDC(0), 90&), 72)
lf.lfItalic = Abs(.FontItalic)
lf.lfStrikeOut = Abs(.FontStrikethru)
lf.lfUnderline = Abs(.FontUnderline)
lf.lfWeight = IIf(.FontBold, 700, 400)
tmpArr = StrConv(.FontName & Chr$(0), vbFromUnicode)
lArr = UBound(tmpArr)
For i = 0 To lArr
lf.lfFaceName(i) = tmpArr(i)
Next i
hFont = CreateFontIndirect(lf)
End With
ShowFontDialog = hFont
End Function

Private Function MulMul(arg1 As Long, arg2 As Long, arg3 As Long) As Integer
Dim tmp As Single
tmp = arg2 / arg3
tmp = arg1 / tmp
MulMul = CInt(tmp)
End Function

'Add common dialog control on form.
'And finally add following event handler on form:

Private Sub lvProperties_ItemClick(ByVal Item As MSComctlLib.ListItem)
Dim varData As Variant, varValue As String, sType As String
Dim pid As Long, BaseAddress As Long, iOffset As Long
Dim sFont As StdFont
pid = cbControls.Tag
BaseAddress = cbControls.ItemData(cbControls.ListIndex)
varData = Split(Item.Tag, "_")
iOffset = varData(0)
sType = varData(1)
Select Case UCase(sType)
Case "FONT"
varValue = ShowFontDialog(CommonDialog1)
SetControlProperty pid, BaseAddress, iOffset, sType, varValue
Case Else
varValue = InputBox("EnterNewValue for " & Item.Text, "Change property", Item.SubItems(1))
SetControlProperty pid, BaseAddress, iOffset, sType, varValue
End Select
cbControls_Click
End Sub

'Now, you can change any property. For example, to change BackColor for label, just click on appropriate property and type &HFF in inputbox, press OK - you'll get red back color. To cahge font - click on font property and change font values in common dialog. I didn't apply code for Icons, Flags etc, but its not too difficult. It's even possible to make same property windows like in VB IDE for remote process!

stickleprojects

All
If you use heapwalk instead of heap32next it is much much quicker (seconds instead of minutes)
I'll drop the code on here, if that's ok?

Private Declare Function GetProcessHeaps Lib "kernel32" ( _
    ByVal NumberOfHeaps As Long, ProcessHeaps As Long) As Long
 
 
Private Declare Function HeapWalk Lib "kernel32" ( _
    ByVal hHeap As Long, lpEntry As PROCESS_HEAP_ENTRY) As Long
 
 
Private Type PROCESS_HEAP_ENTRY
  lpData As Long
  cbData As Long
  cbOverhead As Byte
  iRegionIndex As Byte
  wFlags As Integer
  dwCommittedSize As Long
  dwUnCommittedSize As Long
  lpFirstBlock As Long
  lpLastBlock As Long
End Type
 
 
Private Const PROCESS_HEAP_REGION As Integer = &H1
Private Const PROCESS_HEAP_UNCOMMITTED_RANGE As Integer = &H2
Private Const PROCESS_HEAP_ENTRY_BUSY As Integer = &H4
Private Const PROCESS_HEAP_ENTRY_MOVEABLE As Integer = &H10
Private Const PROCESS_HEAP_ENTRY_DDESHARE As Integer = &H20
 
Public Sub DoHeapWalk(thHeapID As Long)
    Dim tHeap As PROCESS_HEAP_ENTRY
    tHeap.lpData = 0
    
    
    Do While HeapWalk(thHeapID, tHeap)
         If ValidateSize(tHeap.cbData + tHeap.cbOverhead) Then
            ......
         End If
    Loop
    
End Sub

Open in new window

Akash Bollenwar

Hello,

I would like to get the offset address of the property 'Controls' of controls like Form, UserControl etc. Do anyone know how to get the offset address of the 'Controls' property.