modual 模块的:
Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Declare Function GetLastError Lib "kernel32" () As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Declare Function ReleaseCapture Lib "user32" () As Long
Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Public Const WM_GETTEXT = &HD
Type POINTAPI
x As Long
y As Long
End Type
form 模块的:
Private Sub Form_Load()
Check1.Value = 1
SetOnTop (Check1.Value)
IsDragging = False
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
If IsDragging = True Then
Dim rtn As Long, curwnd As Long
Dim tempstr As String
Dim strlong As Long
Dim point As POINTAPI
point.x = x
point.y = y
'将客户坐标转化为屏幕坐标并显示在PointText文本框中
If ClientToScreen(frmMain.hwnd, point) = 0 Then Exit Sub
PointText.Text = Str(point.x) + "," + Str(point.y)
'获得鼠标所在的窗口句柄并显示在hWndText文本框中
curwnd = WindowFromPoint(point.x, point.y)
hWndText.Text = Str(curwnd)
'获得该窗口的类型并显示在WndClassText文本框中
tempstr = Space(255)
strlong = Len(tempstr)
rtn = GetClassName(curwnd, tempstr, strlong)
If rtn = 0 Then Exit Sub
tempstr = Trim(tempstr)
WndClassText.Text = tempstr
'向该窗口发送一个WM_GETTEXT消息,以获得该窗口的文本,并显示在PasswordText文本框中
tempstr = Space(255)
strlong = Len(tempstr)
rtn = SendMessage(curwnd, WM_GETTEXT, strlong, tempstr)
tempstr = Trim(tempstr)
PasswordText.Text = tempstr
End If
End Sub
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
If IsDragging = True Then
Screen.MousePointer = vbDefault
IsDragging = False
'释放鼠标消息抓取
ReleaseCapture
End If
End Sub
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If IsDragging = False Then
IsDragging = True
Screen.MouseIcon = LoadPicture(App.Path + "\pass.ico")
Screen.MousePointer = vbCustom
'将以后的鼠标输入消息都发送到本程序窗口
SetCapture (frmMain.hwnd)
End If
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 Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private m_OldWindowProc As Long
Public Function SetMyWindowProc(bOn As Boolean, hWnd As Long)
If bOn Then
m_OldWindowProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf NewWindowProc)
Else
Call SetWindowLong(hWnd, GWL_WNDPROC, m_OldWindowProc)
End If
End Function
Private Function NewWindowProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
On Error GoTo psErr
Dim MyData As COPYDATASTRUCT
Dim strMsg As String
Dim bytMsg() As Byte
Select Case Msg
Case WM_COPYDATA
Call CopyMemory(MyData, ByVal lParam, LenB(MyData))
Select Case MyData.dwData
Case APP_COMMAND
ReDim bytMsg(0 To MyData.cbData - 1)
Call CopyMemory(bytMsg(0), ByVal MyData.lpData, MyData.cbData)
strMsg = StrConv(bytMsg, vbUnicode)
Call g_frmMain.ShowMessage(strMsg)
g_frmMain.Show
End Select
End Select
NewWindowProc = CallWindowProc(m_OldWindowProc, hWnd, Msg, wParam, lParam)
Exit Function
psErr:
MsgBox "错误:NewWindowProc" & Err.Description
End Function
bas:
Option Explicit
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, ByRef lParam As Any) As Long
Public Const WM_USER = &H400
Public Const WM_COPYDATA = &H4A
Public Const GWL_WNDPROC = (-4)
Public Const APP_COMMAND As Long = 1
Public Const APP_MSG_LENGTH As Long = 256
Public Type COPYDATASTRUCT
dwData As Long
cbData As Long
lpData As Long
End Type
Public Const APP_TITLE As String = "MY EXE" '窗口标题'
Global g_frmMain As Form1
Public Function CheckIsRuning(hWnd As Long)
If App.PrevInstance Then
Dim strMsg As String, nLenMsg As Integer
strMsg = Command
nLenMsg = LenB(strMsg)
If nLenMsg < APP_MSG_LENGTH And nLenMsg > 0 Then
Call SendOpenMessage(strMsg, hWnd)
End If
End
End If
End Function
Private Function SendOpenMessage(ByVal strMsg As String, hWnd As Long)
On Error GoTo ToExit '打开错误陷阱
'------------------------------------------------
Dim lngHWnd As Long
Dim MyData As COPYDATASTRUCT
Dim bytMsg() As Byte
lngHWnd = FindWindow(vbNullString, APP_TITLE)
If lngHWnd <> 0 Then
bytMsg = StrConv(strMsg, vbFromUnicode)
MyData.dwData = APP_COMMAND
MyData.cbData = UBound(bytMsg) + 1
MyData.lpData = VarPtr(bytMsg(0))
Call SendMessage(lngHWnd, WM_COPYDATA, hWnd, ByVal VarPtr(MyData))
End If
'------------------------------------------------
Exit Function
'----------------
ToExit:
MsgBox "[ERROR](SendOpenMessage)" & Err.Description
End Function
Sub main()
Set g_frmMain = New Form1
Load g_frmMain
g_frmMain.Show
End Sub
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, ByRef lParam As Any) As Long
Public Const WM_USER = &H400
Public Const WM_COPYDATA = &H4A
Public Const GWL_WNDPROC = (-4)
Public Const APP_COMMAND As Long = 1
Public Const APP_MSG_LENGTH As Long = 256
Public Type COPYDATASTRUCT
dwData As Long
cbData As Long
lpData As Long
End Type
Public Function CheckIsRuning(hWnd As Long)
If App.PrevInstance Then
Dim strMsg As String, nLenMsg As Integer
strMsg = Command
nLenMsg = LenB(strMsg)
If nLenMsg < APP_MSG_LENGTH And nLenMsg > 0 Then
Call SendOpenMessage(strMsg, hWnd)
End If
End
End If
End Function
Private Function SendOpenMessage(ByVal strMsg As String, hWnd As Long)
On Error GoTo ToExit '打开错误陷阱
'------------------------------------------------
Dim lngHWnd As Long
Dim MyData As COPYDATASTRUCT
Dim bytMsg() As Byte
lngHWnd = FindWindow(vbNullString, APP_TITLE)
If lngHWnd <> 0 Then
bytMsg = StrConv(strMsg, vbFromUnicode)
MyData.dwData = APP_COMMAND
MyData.cbData = UBound(bytMsg) + 1
MyData.lpData = VarPtr(bytMsg(0))
Call SendMessage(lngHWnd, WM_COPYDATA, hWnd, ByVal VarPtr(MyData))
End If
'------------------------------------------------
Exit Function
'----------------
ToExit:
MsgBox "[ERROR](SendOpenMessage)" & Err.Description
End Function
Option Explicit
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 Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private m_OldWindowProc As Long
Public Function SetMyWindowProc(bOn As Boolean, hWnd As Long)
If bOn Then
m_OldWindowProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf NewWindowProc)
Else
Call SetWindowLong(hWnd, GWL_WNDPROC, m_OldWindowProc)
End If
End Function
Private Function NewWindowProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
On Error GoTo psErr
Dim MyData As COPYDATASTRUCT
Dim strMsg As String
Dim bytMsg() As Byte
Select Case Msg
Case WM_COPYDATA
Call CopyMemory(MyData, ByVal lParam, LenB(MyData))
Select Case MyData.dwData
Case APP_COMMAND
ReDim bytMsg(0 To MyData.cbData - 1)
Call CopyMemory(bytMsg(0), ByVal MyData.lpData, MyData.cbData)
strMsg = StrConv(bytMsg, vbUnicode)
Call g_frmMain.ShowMessage(strMsg)
g_frmMain.Show
End Select
End Select
NewWindowProc = CallWindowProc(m_OldWindowProc, hWnd, Msg, wParam, lParam)
Exit Function
psErr:
MsgBox "错误:NewWindowProc" & Err.Description
End Function
Option Explicit
Public Const APP_TITLE As String = "MY EXE" '窗口标题'
Global g_frmMain As Form1
Sub main()
Set g_frmMain = New Form1
Load g_frmMain
g_frmMain.Show
End Sub