shubiao.bas

该软件实现键盘锁定功能

Attribute VB_Name = "shubiao"
'限制鼠标活动区域
Option Explicit
Private Type RECT
left As Long
top As Long
right As Long
bottom As Long
End Type
Private Declare Function SetCursorPos Lib "user32" _
(ByVal x As Long, ByVal y As Long) As Long
Private Declare Function ClipCursor Lib "user32" _
(lpRect As Any) As Long
Private Declare Function GetWindowRect Lib "user32" _
(ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetSystemMetrics Lib "user32" _
(ByVal nIndex As Long) As Long
Private Const SM_CYCAPTION = 4
Private Const SM_CXFRAME = 32
Private Const SM_CYFRAME = 33

Public Sub Release()
Call ClipCursor(ByVal vbNullString)
End Sub

Public Sub RestrictToControl(cntl As Control)
Dim r As RECT
On Error Resume Next
Call GetWindowRect((cntl.hwnd), r)
If Err.Number = 0 Then
Call RestrictToRect(r)
End If
End Sub

Public Sub CenterOnControl(cntl As Control)
Dim r As RECT
On Error Resume Next
Call GetWindowRect((cntl.hwnd), r)
If Err.Number = 0 Then
CenterOnRect r
End If
End Sub

Public Sub RestrictToForm(frm As Form)
Dim r As RECT
Call GetClientScrnRect(frm, r)
Call RestrictToRect(r)
End Sub

Public Sub CenterOnForm(frm As Form)
Dim r As RECT
Call GetClientScrnRect(frm, r)
Call CenterOnRect(r)
End Sub

Private Sub RestrictToRect(lpRect As RECT)
Call ClipCursor(lpRect)
End Sub

Private Sub CenterOnRect(lpRect As RECT)
Call SetCursorPos(lpRect.left + (lpRect.right - lpRect.left) \ 2, _
lpRect.top + (lpRect.bottom - lpRect.top) \ 2)
End Sub

Private Sub GetClientScrnRect(frm As Form, rC As RECT)
Dim x As Integer
Dim y As Integer
Call GetWindowRect((frm.hwnd), rC)
x = GetSystemMetrics(SM_CXFRAME)
y = GetSystemMetrics(SM_CYFRAME)
rC.left = rC.left + x
rC.right = rC.right - x
rC.top = rC.top + y + GetSystemMetrics(SM_CYCAPTION)
rC.bottom = rC.bottom - y
End Sub