So I need to use the SetTimer API in my Excel VB project, but after I execute the interval timer, the program crashes as soon as you attempt to run another macro. Even when simply clicking the macro button in Developer tab. The code:
Public Declare Function SetTimer Lib "user32" ( _
ByVal HWnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" ( _
ByVal HWnd As Long, _
ByVal nIDEvent As Long) As Long
Public timId As Long, lala As Long, i As Integer
Public Sub CallTm()
timId = SetTimer(0, 0, 100, AddressOf Test)
End Sub
Public Sub AnotherSub()
MsgBox "This is not gonna be shown"
End Sub
Public Sub Test()
Cells(1, 1).Value = i
i = i + 1
End Sub
It seems it's not a problem with KillTimer. Simply setting the interval with SetTimer is like a switch for making sure no more macros can be run (or it will simply crash if you attempt that). I remember seeing Error 50290 if that's any more help.
Why is it so and how can it be fixed?
By the way, I'm making a snake game in Excel for a school project.
It seems like after the Timer is set, nothing can happen since the timer takes up all the thread? or smth like that and it can't be "interrupted".
Really, how is this API supposed to be used? It seems like a fatal error which makes it completely useless...
You're corrupting the stack, because your Test procedure does not match the signature of TimerProc. You should read and understand the documentation for API calls before simply making a blind stab at using them.
You can find the documentation for SetTimer at MSDN as well, just like all other WinAPI documentation.
the prototype of timerPorc is this
VOID CALLBACK TimerProc(
_In_ HWND hwnd,
_In_ UINT uMsg,
_In_ UINT_PTR idEvent,
_In_ DWORD dwTime
);
that can be translated to vb as follow
sub Test(byval hWnd as long, byval uMsg as long,byval idIvent as long, byval dwTime as long)
'your code here
end sub
Related
(I am not a native English speaker, I use google translate, then modify. If something wrong, forgive my poor English.)
My goal is to make a Userform with scrollbar in MS Word, hoping to scroll with the mouse wheel.
But VBA doesn't offer MouseScroll Event Handler. After searching, I know it can be achieved with WinAPI Hook.
I refer to the examples in “Subclassing and Hooking with Visual Basic (O'Reilly, 2001)”. After modification, my code can be successfully executed with modal Userform.
But when I open Userform in Modeless mode, once the hook is executed, the entire Windows system will be stuck, clicking windows of other program didn't respond, and the CPU usage > 80%.
I used Debug.Print to output some text. When I looked at the VBE’s immediate window, the macro was still executing, but it fell into an infinite loop.
My code is below:
(I use Win10 64-bit and Office 365 Word 64-bit. 64-bit API declaration is according to the document on Microsoft's official website.)
MouseHook Module code：
Option Explicit
Type POINTAPI
X As Long
Y As Long
End Type
Type MOUSEHOOKSTRUCT
pt As POINTAPI
hwnd As LongPtr
wHitTestCode As Long
dwExtraInfo As LongPtr
End Type
'This structure is just the extension of MOUSEHOOKSTRUCT
Type MOUSEHOOKSTRUCTEX
structMouseHook As MOUSEHOOKSTRUCT
mousedata As Long
End Type
Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" ( _
ByVal idHook As Long, _
ByVal lpfn As LongPtr, _
ByVal hmod As LongPtr, _
ByVal dwThreadId As Long) As LongPtr
Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" ( _
ByVal hhk As LongPtr) As Long
Declare PtrSafe Function CallNextHookEx Lib "user32" ( _
ByVal hHook As LongPtr, _
ByVal nCode As Long, _
ByVal wParam As LongPtr, _
lParam As Any) As LongPtr
Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
Private Const WH_MOUSE As Long = 7
Private Const HC_ACTION As Long = 0
Public IsHooked As Boolean
Private mhook As LongPtr
Private i As Long
Public Sub SetMouseHook()
If IsHooked Then
MsgBox "Don't hook the MOUSE twice."
Else
'I perform thread-specific Hook
mhook = SetWindowsHookEx(WH_MOUSE, AddressOf MouseProc, 0, GetCurrentThreadId)
IsHooked = True
End If
End Sub
Public Sub RemoveMouseHook()
Call UnhookWindowsHookEx(mhook)
IsHooked = False
End Sub
Public Function MouseProc( _
ByVal uCode As Long, _
ByVal wParam As LongPtr, _
lParam As MOUSEHOOKSTRUCTEX) As LongPtr
If uCode = HC_ACTION Then
Debug.Print i & "HC_ACTION" & lParam.mousedata: i = i + 1
'To emphasize the keypoint, I omitted some irrelevant code.
'lParam.mousedata gives you the direction of the mousewheel scrolling.
'(by positive or negative)
End If
MouseProc = CallNextHookEx(mhook, uCode, wParam, lParam)
End Function
Userform code:
(The form has two command buttons, which perform sethook and unhook function.)
Option Explicit
Private Sub cmdHook_Click()
Call SetMouseHook
End Sub
Private Sub cmdUnHook_Click()
Call RemoveMouseHook
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Call RemoveMouseHook
End Sub
How to solve this problem?
If the Modeless Userform cannot use the WH_MOUSE hook, are there any alternatives, like WH_MOUSE_LL hook or VSTO?
Thank you all.
===== Update =====
In my final test, I find that ‘WH_MOUSE Hook’, ‘WH_MOUSE_LL Hook’, and ‘Instance Subclassing’ all can work in Modeless VBA Userform.
But you should close the VBE first, and then execute the macro from the Macros dialog box (ALT+F8). (I executed the macro with VBE opened before.)
my Subclassing code is below:
Subclassing Userform code:
Option Explicit
'the Userform name is "frmSubclass"
'it contains 2 cmdButtons and 1 Frame with vertical scrollbar
'click the "SetSubclass Button" to SetSubclass
'click the "UnSubclass Button" to unSubclass
Private Sub cmdSetSubclass_Click()
Call SetSubclass
End Sub
Private Sub cmdUnSubclass_Click()
Call unSubclass
End Sub
Private Sub UserForm_Initialize()
Me.Frame1.ScrollBars = fmScrollBarsVertical
Me.Frame1.ScrollHeight = 1000
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Call unSubclass
End Sub
Subclassing bas Module code：
Option Explicit
'WinAPI function
Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
Declare PtrSafe Function GetWindow Lib "user32" ( _
ByVal hwnd As LongPtr, _
ByVal wCmd As Long) As LongPtr
Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrA" ( _
ByVal hwnd As LongPtr, _
ByVal nIndex As Long, _
ByVal dwNewLong As LongPtr) As LongPtr
Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcA" ( _
ByVal lpPrevWndFunc As LongPtr, _
ByVal hwnd As LongPtr, _
ByVal Msg As Long, _
ByVal wParam As LongPtr, _
ByVal lParam As LongPtr) As LongPtr
'Windows constant
Private Const GW_CHILD As Long = 5
Private Const GWLP_WNDPROC As Long = -4
Private Const WM_MOUSEWHEEL As Long = &H20A
'module-level variables
Private m_OrigWndProc As LongPtr
Private m_hwnd As LongPtr
Public Function SetSubclass() As Boolean
'I want to Subclassing the frame window inside the Main Userform
'not the Main userform itself
'get hwnd of Main Userform window which classname is "ThunderDFrame" in VBA
m_hwnd = FindWindow("ThunderDFrame", vbNullString)
Debug.Print IIf(m_hwnd <> 0, "Find Window: " & Hex$(m_hwnd), "Window not Find")
'get hwnd of client window of Main Userform
m_hwnd = GetWindow(m_hwnd, GW_CHILD)
Debug.Print IIf(m_hwnd <> 0, "Find Window: " & Hex$(m_hwnd), "Window not Find")
'get hwnd of Frame window
m_hwnd = GetWindow(m_hwnd, GW_CHILD)
Debug.Print IIf(m_hwnd <> 0, "Find Window: " & Hex$(m_hwnd), "Window not Find")
'I use spy++ to watch all hwnd values, the 3 values of m_hwnd is correct
'set Subclass and store the Original Window Procedure
If m_OrigWndProc <> 0 Then
Debug.Print "Already subclassed" 'Do not allow to subclass a 2nd time
Else
m_OrigWndProc = SetWindowLongPtr(m_hwnd, GWLP_WNDPROC, AddressOf SubclassWndProc)
Debug.Print "Subclassing succeed."
End If
End Function
Public Function unSubclass() As Boolean
If m_OrigWndProc <> 0 Then
SetWindowLongPtr m_hwnd, GWLP_WNDPROC, m_OrigWndProc
m_OrigWndProc = 0
End If
End Function
Public Function SubclassWndProc( _
ByVal hwnd As LongPtr, _
ByVal uMsg As Long, _
ByVal wParam As LongPtr, _
ByVal lParam As LongPtr) As LongPtr
On Error Resume Next
If uMsg = WM_MOUSEWHEEL Then
'the Userform name is "frmSubclass"
frmSubclass.Caption = " wParam = " & wParam
'By observing the value of wParam, we can know
'4287102976 represents scrolling down,7864320 represents scrolling up
If wParam = 4287102976# Then
frmSubclass.Frame1.ScrollTop = frmSubclass.Frame1.ScrollTop + 15
ElseIf wParam = 7864320 Then
frmSubclass.Frame1.ScrollTop = frmSubclass.Frame1.ScrollTop - 15
End If
End If
'Pass message to the default window procedure
SubclassWndProc = CallWindowProc(m_OrigWndProc, hwnd, uMsg, wParam, lParam)
End Function
starting point bas Module code：
Option Explicit
Sub testSubclass()
frmSubclass.Show vbModeless 'the Userform name is "frmSubclass"
End Sub
The book you mentioned is called "Subclassing and Hooking". You tried "Hooking" when in fact your problem is more suited to "Subclassing" instead.
You should subclass your Userform where you want to process the "WM_MOUSEWHEEL" message. Look into "SetWindowLong" and "CallWindowProc" functions to achieve this goal.
I am using the same AlphaBlend function as declared like this:
Public Declare Function AlphaBlend Lib "MSIMG32.dll" (ByVal hDCDest As Long, ByVal nXOriginDest As Long, ByVal nYOriginDest As Long, ByVal nWidthDest As Long, ByVal nHeightDest As Long, ByVal hDCSrc As Long, ByVal nXOriginSrc As Long, ByVal nYOriginSrc As Long, ByVal nWidthSrc As Long, ByVal nHeightSrc As Long, ByVal lBlendFunction As Long) As Long
There are some machines where my code works perfectly fine and does exactely what it should.
On one machine, the very same code works fine in application A, but the same code in application B makes AlphaBlend fail.
Imagine the following:
You have 2 identical twins both eating an apple. Both apples are perfectly the same.
One twin swallows it successfully, the other twin dies trying to do so.
GetLastError returns 0.
How could I investigate what goes wrong?
One some machines, all is fine.
On the one machine in question however, I have compiled the very same code running in two applications: Application A and application B.
In application A, AlphaBlend fails, and in application B, AlphaBlend succeeds.
And it's ALWAYS that it fails in application A.
I have even doubted VB6's sanity and checked if "Len" actually returns the correct length.
I use VB6 since 20 years, but I have never experienced something that crazy.
Does anybody have any idea why the same code might fail in that one application?
Option Explicit
Private Declare Function GetLastError Lib "kernel32" () As Long
Private Declare Function AlphaBlend Lib "MSIMG32.dll" (ByVal hDCDest As Long, ByVal nXOriginDest As Long, ByVal nYOriginDest As Long, ByVal nWidthDest As Long, ByVal nHeightDest As Long, ByVal hDCSrc As Long, ByVal nXOriginSrc As Long, ByVal nYOriginSrc As Long, ByVal nWidthSrc As Long, ByVal nHeightSrc As Long, ByVal lBlendFunction As Long) As Long
Private Declare Function FindWindow Lib "USER32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Sub MoveMemory Lib "Kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetClientRect Lib "USER32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function GetDC Lib "USER32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "User32.dll" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Private Type BLENDFUNCTION
BlendOp As Byte
BlendFlags As Byte
SourceConstantAlpha As Byte
AlphaFormat As Byte
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Const AC_SRC_OVER = &H0
Private Sub Timer1_Timer()
Dim lHwnd&
lHwnd = FindWindow(vbNullString, "twsseetechcamwin")
If lHwnd = 0 Then
Me.Caption = "is null!"
Exit Sub
End If
Me.Caption = "ok"
Dim LBF As Long
Dim bf As BLENDFUNCTION
With bf
.BlendOp = AC_SRC_OVER
.SourceConstantAlpha = 255
End With
Dim lLen&
lLen = Len(bf) 'just check for sanity... I wanted to make sure that it's 4, and it indeed is
Call MoveMemory(LBF, bf, Len(bf)) 'Copy struct into a Long var
Dim rOtherWin As RECT
GetClientRect lHwnd, rOtherWin
Dim lOtherDC&
lOtherDC = GetDC(lHwnd)
Dim r As RECT
GetClientRect Me.hWnd, r
Dim lret&
lret = AlphaBlend(Me.hdc, 0, 0, (r.Right - r.Left), (r.Bottom - r.Top), lOtherDC, 0, 0, (rOtherWin.Right - rOtherWin.Left), (rOtherWin.Bottom - rOtherWin.Top), LBF)
Dim lWinErr&
lWinErr = GetLastError()
Me.Caption = Time & " ret: " & lret & ", err: " & lWinErr&
ReleaseDC lHwnd, lOtherDC
End Sub
The problem occurs when the OS is set to high DPI settings (like display everything in 150%) AND if the application has a manifest that states dpiaware=true.
There are 2 possible solutions:
Remove dpiaware from the manifest
Add a manifest to the other process as well and declare dpiaware=true in that manifest, too. This way there is no discrepancy between the 2 processes. This of course only works if it's your product / process, and you have the possibility to compile it with a manifest.
Since this is machine-specific (assuming that is accurate) there is a possibility that the two programs A and B are not loading the same copy of MSIMG32.dll.
I would check: are there multiple copies of that DLL on the PC? Especially if there is a copy in the program folder for A or B?
Also you can run Process Monitor and observe the running program to see exactly what DLLs are being loaded. That could at least confirm they are both running the same DLL and eliminate that as a potential cause.
Other than that, personally I would throw in some debug logging and really verify that the inputs to the failing function are the same.
I'm trying to pull up the on-screen keyboard.
Here are my attempts so far:
' Only needed for Test3
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Sub Test1()
' Run-time error'53':
' File Not found
Dim RetVal As Variant
RetVal = Shell("C:\WINDOWS\system32\osk.exe", 1)
End Sub
Sub Test2()
' Run-time error '432':
' File name or class name not found during Automation operation
ActiveWorkbook.FollowHyperlink Address:="C:\Windows\System32\osk.exe"
End Sub
Sub Test3()
' No error. Nothing happens at all
ShellExecute 0, vbNullString, "osk.exe", vbNullString, "C:\", 1
End Sub
Test2 from this forum.
Test3 from this forum.
I checked the path to osk.exe is correct.
I have a Surface laptop/tablet, so it has a touch screen and a "touch" keyboard (different from the osk). Is that what's causing the issue or possibly it's a Windows 10 thing?
On a 64-Bit OS try this
Option Explicit
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Function Wow64EnableWow64FsRedirection Lib "kernel32.dll" (ByVal Enable As Boolean) As Boolean
Private Sub RunOsk_on64Bit()
Const SW_SHOWNORMAL = 1
On Error Resume Next
Wow64EnableWow64FsRedirection False
ShellExecute 0, "open", "osk.exe", "", "C:\windows\system32\osk.exe", SW_SHOWNORMAL
Wow64EnableWow64FsRedirection True
End Sub
Found here, this might the explanation, quote from the link
This is an issue with 64-bit OS, it affects any 64-bit version of Windows.
Basically you are calling osk.exe, but your program you are calling it
from is a 32-bit app. Windows won't allow you to call a 64-bit OSK.exe
from your program. The comments appear to miss your point here, anyone
can start osk.exe from Run, but call it from within a 32-bit
application won't work in 64-bit Windows.
I am developing software that uses the on-screen keyboard, the only
work around is Wow64DisableWow64FsRedirection.
Update: A "nicer" version might look like that
Option Explicit
Type SHELLEXECUTEINFO
cbSize As Long
fMask As Long
hwnd As Long
lpVerb As String
lpFile As String
lpParameters As String
lpDirectory As String
nShow As Long
hInstApp As Long
lpIDList As Long
lpClass As String
hkeyClass As Long
dwHotKey As Long
hIcon As Long
hProcess As Long
End Type
Public Declare Function ShellExecuteEx Lib "shell32.dll" _
(lpExecInfo As SHELLEXECUTEINFO) As Long
Declare Function Wow64DisableWow64FsRedirection Lib "kernel32.dll" (ByRef ptr As Long) As Boolean
Declare Function Wow64RevertWow64FsRedirection Lib "kernel32.dll" (ByRef ptr As Long) As Boolean
Public Function KeyboardOpen()
Dim shInfo As SHELLEXECUTEINFO
Dim lngPtr As Long
With shInfo
.cbSize = Len(shInfo)
.lpFile = "C:\Windows\Sysnative\cmd.exe" 'best to use Known folders here
.lpParameters = "/c start osk.exe"
.lpDirectory = "C:\windows\system32" 'best to use Known folders here
.lpVerb = "open"
.nShow = 0
End With
Call Wow64DisableWow64FsRedirection(lngPtr)
Call ShellExecuteEx(shInfo)
Call Wow64RevertWow64FsRedirection(lngPtr)
End Function
Based on the information in MSDN it might be more reliable to use Wow64DisableWow64FsRedirection and Wow64RevertWow64FsRedirection functions instead.
I am trying to make a macro that records what a user clicked, which then records the mouse coordinates and the delay between the clicks. This will then repeat after some other SendKey changes. How can I detect when I click the mouse when the macro is running? I already know how to get the coordinates and record the delay, but what is the best course of action for detecting the mouse click and also what would be the best way to save all this information? A text file? Here is a snippet of the mouse click events that I use:
Public Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Type POINTAPI
x As Long
y As Long
End Type
Public pos As POINTAPI ' Declare variable
Public Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Public Const MOUSEEVENTF_LEFTDOWN = &H2
Public Const MOUSEEVENTF_LEFTUP = &H4
Public Const MOUSEEVENTF_RIGHTDOWN As Long = &H8
Public Const MOUSEEVENTF_RIGHTUP As Long = &H10
Public Sub SingleClick()
Dim xval, yval
xval = GetSetting("Will's Program Sheet", "DPS Calibration", "PROGRAM X")
yval = GetSetting("Will's Program Sheet", "DPS Calibration", "PROGRAM Y")
Select Case xval
Case Is = "" 'Runs calibrate if it can't find an xval
Call CALIBRATE
End
End Select
SetCursorPos xval, yval 'x and y position
mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
End Sub
There is another macro that calls SingleClick where it moves to a constant x and y, clicks, does some magic, and returns to the position before the macro started. So to reiterate, is there a simple or easy to understand method to record multiple clicks and delays between clicks and replay them through Excel VBA?
This is theoretically possible to do, but you'd have to set a hook for WH_MOUSE_LL messages. The problem is that I seriously doubt that VBA can keep up with the volume of messages that are going to be coming through that pipe. It would be like trying drinking from a fire hose in VBA. If you really want to give it a shot, you can see if this works.
But first:
DISCLAIMER
In all likelihood, Excel will stop responding if you set up this Workbook and open it. It will certainlly stop responding if you open the VBE. Do not put this in a spreadsheet that you can't afford to delete. Be fully prepared to have to open it with the shift key down to make edits to the code. You have been warned. I take no responsibility for what you do with this. I know better than to have tried it with any code in the event handler. You will likely crash Excel. You will certainly crash the VBE. You may crash anything or everything else.
That should cover it. So...
In a class called HookHolder:
Option Explicit
Private hook As Long
Public Sub SetHook()
hook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf ClickHook, _
0, GetCurrentThreadId)
End Sub
Public Sub UnsetHook()
'IMPORTANT: You need to release the hook when you're done with it.
UnhookWindowsHookEx hook
End Sub
In ThisWorkbook:
Option Explicit
Private danger As HookHolder
Private Sub Workbook_Open()
Set danger = New HookHolder
danger.SetHook
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
danger.UnsetHook
End Sub
In a Module:
Option Explicit
Public Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Public Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _
(ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long
Public Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Public Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _
ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const HC_ACTION As Long = 0
Public Const WH_MOUSE_LL As Long = &H2
Public Const WM_LBUTTONDOWN As Long = &H201
Public Const WM_LBUTTONUP As Long = &H202
Public Const WM_LBUTTONDBLCLK As Long = &H203
'Your callback function.
Public Function ClickHook(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If nCode = HC_ACTION Then
'Anything in particular you're interest in?
Select Case wParam
Case WM_LBUTTONDOWN
'Do your thing.
Case WM_LBUTTONUP
'Do your thing.
Case WM_LBUTTONDBLCLK
'Do your thing.
End Select
End If
CallNextHookEx 0, nCode, wParam, ByVal lParam
End Function
I am implementing an application in C#.net that is passing a message to an VB6 application.
For testing I created 2 applications both in C#.NET:- One sends message and 2nd receives the message.
The receiving application (C#.NET) makes use of the following function to catch the message:-
Protected Override void WndProc(ref Message m)
I now need to implement this receiver app in VB6.. How do we implement Protected Override void WndProc(ref Message m) in VB6? Or is there any other alternative?
Overriding the default windows procedure is possible in VB6 and is called Subclassing.
In a module:
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const GWL_WNDPROC As Long = (-4)
Private originalWindowProcAddr As Long
Public Sub subclassForm(hwnd As Long)
'// replace existing windows procedure save its address
originalWindowProcAddr = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf NewWindowProc)
End Sub
Public Function NewWindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Debug.Print "received message for:", hwnd, "message:", uMsg
'// forward message to default
NewWindowProc = CallWindowProc(originalWindowProcAddr, hwnd, uMsg, wParam, lParam)
End Function
Public Sub unSubclassForm(hwnd As Long)
'// must tidy up by restoring the original window proc
SetWindowLong hwnd, GWL_WNDPROC, originalWindowProcAddr
End Sub
In the form
Private Sub Form_Load()
subclassForm Me.hwnd
End Sub
Private Sub form_Unload(Cancel As Integer)
unSubclassForm Me.hwnd
End Sub
Failing to call unSubclassForm will crash the VB IDE, as will breaking into debug mode.
I have followed this method:-
http://support.microsoft.com/kb/176058/en-us
Alternate link: https://web.archive.org/web/20150118054920/http://support.microsoft.com:80/kb/176058
How To Pass String Data Between Applications Using SendMessage
SUMMARY
There are many ways to achieve inter-process communication using Visual Basic. Unless you establish an OLE Automation client server relationship, string data is difficult to handle cleanly. The main reason is that 32-bit applications run in a separate address space, so the address of a string in one application is not meaningful to another application in a different address space. Using the SendMessage() API function to pass a WM_COPYDATA message avoids this problem.
This article demonstrates how to pass string data from one application to another by using the SendMessage API function with the WM_COPYDATA message.
WARNING: One or more of the following functions are discussed in this article; VarPtr, VarPtrArray, VarPtrStringArray, StrPtr, ObjPtr. These functions are not supported by Microsoft Technical Support. They are not documented in the Visual Basic documentation and are provided in this Knowledge Base article "as is." Microsoft does not guarantee that they will be available in future releases of Visual Basic.
Visual Basic does not support pointers and castings in the manner of Visual C++. In order to pass string data from one Visual Basic application to another, the Unicode string must be converted to ASCII prior to passing it to the other application. The other application must then convert the ASCII string back to Unicode.
The following summarizes how to pass string data from one application to another.
Step-by-Step Example
Convert the string to a byte array using the CopyMemory() API.
Obtain the address of the byte array using the VarPtr() intrinsic function and copy the address and length of the byte array into a COPYDATASTRUCT structure.
Pass the COPYDATASTRUCT to another application using the WM_COPYDATA message, setting up the other application to receive the message.
Unpack the structure on the target system using CopyMemory(), and convert the byte array back to a string using the StrConv() intrinsic function.
The next section shows you how to create a sample program that demonstrates passing string data from one application to another.
Steps to Create the Sample
To create this sample, you create two separate projects; a sending project and a target project.
Create the target application:
Start a new Standard EXE project in Visual Basic. Form1 is created by default. This project will be your target application.
Add a Label control to Form1.
Copy the following code to the Code window of Form1:
Private Sub Form_Load()
gHW = Me.hWnd
Hook
Me.Caption = "Target"
Me.Show
Label1.Caption = Hex$(gHW)
End Sub
Private Sub Form_Unload(Cancel As Integer)
Unhook
End Sub
Add a module to the project and paste the following code in the Module1 code window:
Type COPYDATASTRUCT
dwData As Long
cbData As Long
lpData As Long
End Type
Public Const GWL_WNDPROC = (-4)
Public Const WM_COPYDATA = &H4A
Global lpPrevWndProc As Long
Global gHW As Long
'Copies a block of memory from one location to another.
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Declare Function CallWindowProc Lib "user32" Alias _
"CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As _
Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As _
Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As _
Long) As Long
Public Sub Hook()
lpPrevWndProc = SetWindowLong(gHW, GWL_WNDPROC, _
AddressOf WindowProc)
Debug.Print lpPrevWndProc
End Sub
Public Sub Unhook()
Dim temp As Long
temp = SetWindowLong(gHW, GWL_WNDPROC, lpPrevWndProc)
End Sub
Function WindowProc(ByVal hw As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
If uMsg = WM_COPYDATA Then
Call mySub(lParam)
End If
WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, _
lParam)
End Function
Sub mySub(lParam As Long)
Dim cds As COPYDATASTRUCT
Dim buf(1 To 255) As Byte
Call CopyMemory(cds, ByVal lParam, Len(cds))
Select Case cds.dwData
Case 1
Debug.Print "got a 1"
Case 2
Debug.Print "got a 2"
Case 3
Call CopyMemory(buf(1), ByVal cds.lpData, cds.cbData)
a$ = StrConv(buf, vbUnicode)
a$ = Left$(a$, InStr(1, a$, Chr$(0)) - 1)
Form1.Print a$
End Select
End Sub
Save the project and minimize the Visual Basic IDE.
Create the Sending Application
Start a second instance of the Visual Basic IDE and create a new Standard EXE project in Visual Basic. Form1 is created by default.
Add a CommandButton to Form1.
Copy the following code to the Code window of Form1:
Private Type COPYDATASTRUCT
dwData As Long
cbData As Long
lpData As Long
End Type
Private Const WM_COPYDATA = &H4A
Private Declare Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName _
As String) As Long
Private Declare Function SendMessage Lib "user32" Alias _
"SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal _
wParam As Long, lParam As Any) As Long
'Copies a block of memory from one location to another.
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Sub Command1_Click()
Dim cds As COPYDATASTRUCT
Dim ThWnd As Long
Dim buf(1 To 255) As Byte
' Get the hWnd of the target application
ThWnd = FindWindow(vbNullString, "Target")
a$ = "It Works!"
' Copy the string into a byte array, converting it to ASCII
Call CopyMemory(buf(1), ByVal a$, Len(a$))
cds.dwData = 3
cds.cbData = Len(a$) + 1
cds.lpData = VarPtr(buf(1))
i = SendMessage(ThWnd, WM_COPYDATA, Me.hwnd, cds)
End Sub
Private Sub Form_Load()
' This gives you visibility that the target app is running
' and you are pointing to the correct hWnd
Me.Caption = Hex$(FindWindow(vbNullString, "Target"))
End Sub
Save the project.
Running the Sample
Restore the target application and press the F5 key to run the project. Note that the value of the hWnd displayed in the label.
Restore the sending application and press the F5 key to run the project. Verify that the hWnd in the form caption matches the hWnd in the label on the target application. Click the CommandButton and the text message should be displayed on the form of the target application.