Option Explicit
Option Compare Text
#If VBA7 Then
Private Declare PtrSafe Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare PtrSafe Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function FindWindowEx Lib "user32.dll" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32.dll" (ByVal hwnd As LongPtr, ByRef lpdwProcessId As Long) As Long
Private Declare PtrSafe Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare PtrSafe Function PostMessage Lib "user32.dll" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare PtrSafe Function VirtualAllocEx Lib "kernel32.dll" (ByVal hProcess As Long, ByRef lpAddress As Any, ByRef dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare PtrSafe Function ReadProcessMemory Lib "kernel32.dll" (ByVal hProcess As Long, ByRef lpBaseAddress As Any, ByRef lpBuffer As Any, ByVal nSize As Long, ByRef lpNumberOfBytesWritten As Long) As Long
Private Declare PtrSafe Function VirtualFreeEx Lib "kernel32.dll" (ByVal hProcess As Long, ByRef lpAddress As Any, ByRef dwSize As Long, ByVal dwFreeType As Long) As Long
Private Declare PtrSafe Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare PtrSafe Function EnumWindows Lib "user32" (ByVal lpEnumFunc As LongPtr, lParam As Any) As Long
Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, _
ByVal lpString As String, _
ByVal cch As Long) As Long
Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function EnumChildWindows Lib "user32" (ByVal hWndParent _
As Long, ByVal lpEnumFunc As LongPtr, ByVal lParam As Long) As Long
Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, _
ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare PtrSafe Function SendMessageS Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, _
ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Private Declare PtrSafe Function FindWindowX Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, _
ByVal hWnd2 As LongPtr, ByVal lpsz1 As Long, ByVal lpsz2 As Long) As Long
Private Declare PtrSafe Function CreateFileMapping Lib "KERNEL32" Alias "CreateFileMappingA" (ByVal hFile As Long, ByVal lpFileMappigAttributes As Long, ByVal flProtect As Long, ByVal dwMaximumSizeHigh As Long, ByVal dwMaximumSizeLow As Long, ByVal lpName As String) As Long
Private Declare PtrSafe Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (ByVal lpDest As Long, ByVal lpSource As Long, ByVal cBytes As Long)
Private Declare PtrSafe Function MapViewOfFile Lib "KERNEL32" (ByVal hFileMappingObject As Long, ByVal dwDesiredAccess As Long, ByVal dwFileOffsetHigh As Long, ByVal dwFileOffsetLow As Long, ByVal dwNumberOfBytesToMap As Long) As Long
Private Declare PtrSafe Function GetVersionEx Lib "KERNEL32" Alias "GetVersionExA" (LpVersionInformation As OSVERSIONINFO) As Long
#Else
Private Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, lParam As Any) 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 GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function EnumChildWindows Lib "user32" (ByVal hWndParent _
As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
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 SendMessageS Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Private Declare Function FindWindowX Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, ByVal lpsz1 As Long, ByVal lpsz2 As Long) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function ReadProcessMemory Lib "KERNEL32" (ByVal hProcess As Long, ByVal lpBaseAddress As Long, ByVal lpBuffer As Long, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Private Declare Function OpenProcess Lib "KERNEL32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcId 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 CreateFileMapping Lib "KERNEL32" Alias "CreateFileMappingA" (ByVal hFile As Long, ByVal lpFileMappigAttributes As Long, ByVal flProtect As Long, ByVal dwMaximumSizeHigh As Long, ByVal dwMaximumSizeLow As Long, ByVal lpName As String) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (ByVal lpDest As Long, ByVal lpSource As Long, ByVal cBytes As Long)
Private Declare Function MapViewOfFile Lib "KERNEL32" (ByVal hFileMappingObject As Long, ByVal dwDesiredAccess As Long, ByVal dwFileOffsetHigh As Long, ByVal dwFileOffsetLow As Long, ByVal dwNumberOfBytesToMap As Long) As Long
Private Declare Function GetVersionEx Lib "KERNEL32" Alias "GetVersionExA" (LpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Any) As Long
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32.dll" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function VirtualFreeEx Lib "kernel32.dll" (ByVal hProcess As Long, ByRef lpAddress As Any, ByRef dwSize As Long, ByVal dwFreeType As Long) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
#End If
Public Const WM_GETTEXT = &HD
Const PROCESS_VM_OPERATION = &H8
Const PROCESS_VM_READ = &H10
Const PROCESS_VM_WRITE = &H20
Const MEM_RESERVE = &H2000&
Const MEM_COMMIT = &H1000&
Const PAGE_READWRITE = &H4
Const STANDARD_RIGHTS_REQUIRED = &HF0000
Const SECTION_QUERY = &H1
Const SECTION_MAP_WRITE = &H2
Const SECTION_MAP_READ = &H4
Const SECTION_MAP_EXECUTE = &H8
Const SECTION_EXTEND_SIZE = &H10
Const SECTION_ALL_ACCESS = STANDARD_RIGHTS_REQUIRED Or SECTION_QUERY Or SECTION_MAP_WRITE Or SECTION_MAP_READ Or SECTION_MAP_EXECUTE Or SECTION_EXTEND_SIZE
Const FILE_MAP_ALL_ACCESS = SECTION_ALL_ACCESS
Public Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Public WIN As OSVERSIONINFO
Global MyButton As TBButton, lResult As Long
Private Const WM_COMMAND As Long = &H111
Private Const WM_USER& = &H400
Public Const TB_COMMANDTOINDEX As Integer = (WM_USER + 25)
Public Const TB_GETBUTTONTEXTA As Integer = (WM_USER + 45)
Public Const TB_GETBUTTONTEXTW As Long = (WM_USER + 75)
Public Const TB_GETBUTTONINFO As Long = (WM_USER + 65)
Private PlatformKnown As Boolean ' have we identified the platform?
Private NTflag As Boolean ' if so, are we NT family (NT, 2K,XP) or non-NT (9x)?
Public myBTNCnt As Integer
Public myBTNtoPress As Integer
Private Const TBSTATE_HIDDEN As Long = &H8
Private Const TB_BUTTONCOUNT& = (WM_USER + 24)
Private Const TB_GETBUTTON& = (WM_USER + 23)
Private Const MEM_RELEASE& = &H8000
Private Const WM_LBUTTONDOWN& = &H201
Private Const WM_LBUTTONUP& = &H202
Private Const PROCESS_QUERY_INFORMATION& = (&H400)
Private Const PROCESS_ALL_ACCESS& = &H1F0FFF
Private Type TrayMore
SyshWnd As Long
SysIconId As Long
End Type
'Private Type TBButton
'iBitmap As Long
'idCommand As Long
'fsState As Byte
'fsStyle As Byte
'bReserved1 As Byte
'bReserved2 As Byte
'dwData As Long
'iString As Long
'End Type
Private Type TBButton
iBitmap As Long
idCommand As Long
fsState As Byte
fsStyle As Byte
#If Win64 Then
bReserved(0 To 5) As Byte
dwData As Long
dummy(0 To 3) As Byte
#Else
bReserved(0 To 1) As Byte
dwData As Long
#End If
iString As Long
End Type
Private Type TRAYDATA
hwnd As Long
#If Win64 Then
dummy(0 To 3) As Byte
uID As Long
uCallbackMessage As Long
Reserved(0 To 7) As Long
#Else
uID As Long
uCallbackMessage As Long
Reserved(0 To 7) As Long
#End If
hIcon As Long
End Type
Private fpHandle As Long ' the foreign-process instance handle. When we want
' memory on NT platforms, this is returned to us by
' OpenProcess, and we pass it in to VirtualAllocEx.
Private TitleToFind As String
Sub test_GetTBAppInTaskbarOn()
Dim Where$
TurnAppInTaskbar True, Where
MsgBox Where
End Sub
Sub test_GetTBAppInTaskbarOff()
Dim Where$
TurnAppInTaskbar False, Where
MsgBox Where
End Sub
Private Function TurnAppInTaskbar(Optional Byval TurnOnSysTray As Boolean = True, Optional Where$) As Boolean
Dim hTB&
hTB = FindWindow("NotifyIconOverflowWindow", vbNullString)
If hTB <> 0 Then
hTB = FindWindowEx(hTB, 0, "ToolbarWindow32", vbNullString)
If AppInSystemTray(hTB, TurnOnSysTray) Then
Where$ = "Toolbar": TurnAppInTaskbar = True: Exit Function
End If
End If
hTB = FindWindow("Shell_TrayWnd", vbNullString)
If hTB <> 0 Then
hTB = FindWindowEx(hTB, 0, "TrayNotifyWnd", vbNullString)
If hTB <> 0 Then
hTB = FindWindowEx(hTB, 0, "SysPager", vbNullString)
If hTB <> 0 Then
hTB = FindWindowEx(hTB, 0, "ToolbarWindow32", vbNullString)
If AppInSystemTray(hTB, TurnOnSysTray) Then
Where$ = "Taskbar": TurnAppInTaskbar = True
End If
End If
End If
End If
End Function
Private Function AppInSystemTray(ByVal hTB&, Optional Byval TurnOnSysTray As Boolean = True) As Boolean
Dim nCount&, k&, sTip$, tb As TBButton, tray As TRAYDATA, _
pid&, pMemory&, hProcess&, BytesRead&
If hTB = 0 Then GoTo Ends
GetWindowThreadProcessId hTB, pid
hProcess = OpenProcess(PROCESS_ALL_ACCESS, 0, pid)
If hProcess = 0 Then GoTo Ends
nCount = SendMessage(hTB, TB_BUTTONCOUNT, 0, 0)
pMemory = VirtualAllocEx(hProcess, ByVal 0, ByVal 1024, MEM_COMMIT, PAGE_READWRITE)
For k = 0 To nCount - 1
SendMessage hTB, TB_GETBUTTON, k, pMemory
ReadProcessMemory hProcess, ByVal pMemory, tb, LenB(tb), BytesRead
ReadProcessMemory hProcess, ByVal tb.dwData, tray, LenB(tray), BytesRead
sTip = String(256, Chr(0))
ReadProcessMemory hProcess, ByVal tb.iString, ByVal StrPtr(sTip), 256, BytesRead
sTip = Left(sTip, InStr(1, sTip, Chr(0)) - 1)
If (sTip = "Click to turn off Vietnamese mode" And Not TurnOnSysTray) Or _
(sTip = "Click to turn on Vietnamese mode" And TurnOnSysTray) Then
AppInSystemTray = True
PostMessage tray.hwnd, tray.uCallbackMessage, tray.uID, WM_LBUTTONDOWN
PostMessage tray.hwnd, tray.uCallbackMessage, tray.uID, WM_LBUTTONUP
End If
Next k
VirtualFreeEx hProcess, pMemory, 0, MEM_RELEASE
CloseHandle hProcess
Exit Function
Ends:
AppInSystemTray = False
End Function
Sub testTB()
Dim mytitle&
Dim hparent&
mytitle = "Unikey MainWnd"
myBTNCnt = 200 'Bao nhieu Nút tren Toolbar
myBTNtoPress = 201
MsgBox FindWindowByTitle(mytitle)
hparent = FindWindowByTitle(mytitle)
EnumChildWindow hparent, 0 ' one call directly to list parent
EnumChildWindows hparent, AddressOf EnumChildWindow, 0
End Sub
Function FindWindowByTitle&(winTitle&)
'returns the handle of the top window
'with the title "winTitle"
Dim t&
'set public titletofind to wintitle
TitleToFind = winTitle
EnumWindows AddressOf FindWindowByTitlePROC, t
'reset public titletofind
TitleToFind = ""
FindWindowByTitle = t
End Function
Function EnumChildWindow&(ByVal hChild&, ByVal lParam&)
Dim wClass&, wText&, j%, TBhWnd&, xpBuffer&, z1 As Variant, tbcount&
Dim i&, TBBUTT As TBButton, hProcess&, pMemory&
wClass = Space(64)
j = GetClassName(hChild, wClass, 63)
wClass = Left(wClass, j)
wText = Space(256)
j = SendMessageS(hChild, WM_GETTEXT, 255, wText)
wText = Left(wText, j)
Debug.Print "Enum " & hChild; ", "; wClass;
If Len(wText) Then Debug.Print ", """; wText; """";
Debug.Print
If wClass = "ToolbarWindow32" Then
tbcount = SendMessageS(hChild, TB_BUTTONCOUNT, 0, 0)
MsgBox "Button Count:" & tbcount
pMemory = VirtualAllocEx(hProcess, ByVal 0, ByVal 1024, MEM_COMMIT, PAGE_READWRITE)
If tbcount = myBTNCnt Then 'This will select the correct toolbar - Need to find buttoncount
For i = 0 To tbcount - 1
TBhWnd = hChild
MsgBox i
If i = myBTNtoPress Then
'*********************************************************************
'This is the part that I am failing on...
xpBuffer = drMemoryAlloc(hChild, 1024)
' lResult = SendMessage(TBhWnd, TB_GETBUTTON, i, xpBuffer)
lResult = SendMessage(TBhWnd, TB_GETBUTTONINFO, i, xpBuffer)
MsgBox "lResult =" & lResult
' drMemoryRead xpBuffer, VarPtr(i), Len(i)
'*********************************************************************
End If
Next
End If
End If
EnumChildWindow = 1 ' Continue enumeration
End Function
Function FindWindowByTitlePROC(ByVal hwnd&, lParam&) As Boolean
'this is the callback function procedure..do not change order
' or type of parameters in the procedure definition
If hwnd = 0 Then
lParam = 0
'stop enumerating
FindWindowByTitlePROC = False
End If
'see if the Hwnd is the one with the title
If UCase(GetCaption(hwnd)) Like UCase(TitleToFind) & "*" Then
'set return value
lParam = CLng(hwnd)
'stop enumerating
FindWindowByTitlePROC = False
Else
'continue enumerating (not found)
FindWindowByTitlePROC = True
End If
End Function
Function GetCaption&(ByVal hwnd&)
'returns the caption of the window with handle "hwnd"
Dim sTemp&, c%
sTemp = String$(255, 0)
c = GetWindowText(hwnd, sTemp, 256)
GetCaption = Left$(sTemp, c)
End Function
Public Function drMemoryAlloc&(ByVal xpWindow&, ByVal nBytes&)
'
' Returns pointer to a share-able buffer (size nBytes) in target process
' that owns xpWindow
'
Dim xpThread& ' target control's thread id
Dim xpID& ' process id
If WindowsNT Then
xpThread = GetWindowThreadProcessId(xpWindow, xpID)
drMemoryAlloc = VirtualAllocNT(xpID, nBytes)
Else
drMemoryAlloc = VirtualAlloc9X(nBytes)
End If
End Function
Public Sub drMemoryRead(ByVal xpBuffer&, ByVal myBuffer&, ByVal nBytes&)
If WindowsNT Then
ReadProcessMemory fpHandle, xpBuffer, myBuffer, nBytes, 0
Else
CopyMemory myBuffer, xpBuffer, nBytes
End If
End Sub
Sub test_WindowsNT()
MsgBox WindowsNT
End Sub
Public Function WindowsNT() As Boolean
' return TRUE if NT-like platform (NT, 2000, XP, etc)
If Not PlatformKnown Then GetWindowsVersion
WindowsNT = NTflag
End Function
Private Function VirtualAllocNT&(ByVal fpID&, ByVal memSize&)
fpHandle = OpenProcess(PROCESS_VM_OPERATION Or PROCESS_VM_READ Or PROCESS_VM_WRITE, False, fpID)
VirtualAllocNT = VirtualAllocEx(fpHandle, ByVal 0&, ByVal memSize, MEM_RESERVE Or MEM_COMMIT, PAGE_READWRITE)
End Function
Private Function VirtualAlloc9X&(ByVal memSize&)
fpHandle = CreateFileMapping(&HFFFFFFFF, 0, PAGE_READWRITE, 0, memSize, vbNullString)
VirtualAlloc9X = MapViewOfFile(fpHandle, FILE_MAP_ALL_ACCESS, 0, 0, 0)
End Function
Public Sub GetWindowsVersion()
WIN.dwOSVersionInfoSize = Len(WIN)
If (GetVersionEx(WIN)) = 0 Then Exit Sub ' in deep doo if this fails
NTflag = (WIN.dwPlatformId = 2)
PlatformKnown = True
End Sub
