我的源代码如下:
Private Sub Timer1_Timer()
Dim f As Long
Dim r As RECT
' handle = acadApp.LocaleID
'EnumWindows AddressOf EnumWindowsProc, 0&
handle = FindWindow("Notepad", vbNullString) '找到记事本
If handle Then
GetWindowRect handle, r '得到位置
' Debug.Print r.Left, r.Top, r.Right, r.Bottom
If r.Left < 0 And _
r.Top < 0 And _
r.Right < 0 And _
r.Bottom < 0 Then '记事本最小化
Me.WindowState = 1
Else
Me.WindowState = 0
End If
If r.Right < 1024 Then '假设记事本的右边缘小于某个数
SetWindowPos Me.hWnd, HWND_TOPMOST, r.Right, r.Top, r.Right, r.Bottom - r.Top, 0
'实现什么样的效果自己随便
End If
Else
End
End If
prevWndProc = GetWindowLong(handle, GWL_WNDPROC)
SetWindowLong handle, GWL_WNDPROC, AddressOf WndProc
End Sub
模块:
Option Explicit
Public Const WM_WINDOWPOSCHANGED = &H47
Public Const GWL_WNDPROC = -4
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 GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex 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 prevWndProc As Long
Function WndProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
On Error Resume Next
Select Case Msg
Case WM_WINDOWPOSCHANGED
MsgBox "窗体位置改变!", vbOKOnly
End Select
WndProc = CallWindowProc(prevWndProc, hWnd, Msg, wParam, lParam)
Private Sub SetOnTop(ByVal IsOnTop As Integer)
Dim rtn As Long
If IsOnTop = 1 Then
'将窗口置于最上面
rtn = SetWindowPos(CapturePassword.hwnd, -1, 0, 0, 0, 0, 3)
Else
rtn = SetWindowPos(CapturePassword.hwnd, -2, 0, 0, 0, 0, 3)
End If
End Sub
Private Sub Check1_Click()
SetOnTop (Check1.Value)
End Sub
Private Sub Command1_Click()
End
End Sub
Private Sub Command2_Click()
Dim strSavePath, strDateOfRec, strPassword, strCopyright As String
On Error Resume Next
strSavePath = App.Path
If Right(strSavePath, 1) <> "\" Then
strSavePath = strSavePath & "\"
End If
If Trim(PasswordText.Text) <> "" Then
strDateOfRec = CStr(Now())
strPassword = PasswordText.Text
strCopyright = "Copyright(c) 2002 by Johnny Lill"
Open strSavePath & "CapturePassword.Txt" For Append Access Write As #1
Print #1, "******************************************************************************"
Print #1, "* Date of Record : " & strDateOfRec & Space(55 - CInt(Len(strDateOfRec))) & " *"
Print #1, "* Password : " & strPassword & Space(55 - CInt(Len(strPassword))) & " *"
Print #1, "* Copyright : " & strCopyright & Space(55 - CInt(Len(strCopyright))) & " *"
Print #1, "******************************************************************************"
Close #1
End If
End Sub
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(CapturePassword.hwnd, point) = 0 Then Exit Sub
'获得鼠标所在的窗口句柄并显示在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.MouseIcon = Picture1.Picture
Screen.MousePointer = vbCustom
'将以后的鼠标输入消息都发送到本程序窗口
SetCapture (CapturePassword.hwnd)
End If