clipcurs.bas

测绘仪器的模拟器

Attribute VB_Name = "Cursor"
Option Explicit
'
' Win32 API Declarations, Type Definitions,
' and Constants
'
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()
   '
   ' Clear clipping by passing NULL pointer
   '
   Call ClipCursor(ByVal vbNullString)
End Sub

Public Sub RestrictToControl(cntl As Control)
   Dim r As RECT
   '
   ' This routine only accepts controls which
   ' support the hWnd property.
   ' Handle errors by ignoring them.
   '
   On Error Resume Next
   Call GetWindowRect((cntl.hwnd), r)
   If Err.Number = 0 Then
      Call Cursor.RestrictToRect(r)
   End If
End Sub

Public Sub CenterOnControl(cntl As Control)
   Dim r As RECT
   '
   ' This routine only accepts controls which
   ' support the hWnd property.
   ' Handle errors by ignoring them.
   '
   On Error Resume Next
   Call GetWindowRect((cntl.hwnd), r)
   If Err.Number = 0 Then
      Cursor.CenterOnRect r
   End If
End Sub

Public Sub RestrictToForm(frm As Form)
   Dim r As RECT
   '
   ' Clip just to client area of form, to
   ' prevent resizing or closing.
   '
   Call GetClientScrnRect(frm, r)
   Call Cursor.RestrictToRect(r)
End Sub

Public Sub CenterOnForm(frm As Form)
   Dim r As RECT
   '
   ' Center to client area.
   '
   Call GetClientScrnRect(frm, r)
   Call Cursor.CenterOnRect(r)
End Sub

Private Sub RestrictToRect(lpRect As RECT)
   '
   ' Use API to restrict cursor to a rectangle.
   '
   Call ClipCursor(lpRect)
End Sub

Private Sub CenterOnRect(lpRect As RECT)
   '
   ' Use API to place cursor at center of rectangle.
   '
   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
   '
   ' Retrieve position info from API.
   ' Assume worst-case: sizable border.
   '
   Call GetWindowRect((frm.hwnd), rC)
   x = GetSystemMetrics(SM_CXFRAME)
   y = GetSystemMetrics(SM_CYFRAME)
   '
   ' Calculate screen coordinates of client area.
   '
   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