磁性窗体 VB.docx

1、磁性窗体 VB/mag/Cls_Magnetic.clsVERSION 1.0 CLASSBEGIN MultiUse = -1 True Persistable = 0 NotPersistable DataBindingBehavior = 0 vbNone DataSourceBehavior = 0 vbNone MTSTransactionMode = 0 NotAnMTSObjectENDAttribute VB_Name = Cls_MagneticAttribute VB_GlobalNameSpace = FalseAttribute VB_Creatable = TrueA

2、ttribute VB_PredeclaredId = FalseAttribute VB_Exposed = FalseOption ExplicitPrivate Enum eMsgWhen MSG_AFTER = 1 MSG_BEFORE = 2 MSG_BEFORE_AND_AFTER = MSG_AFTER Or MSG_BEFOREEnd EnumPrivate Const ALL_MESSAGES As Long = -1Private Const CODE_LEN As Long = 197Private Const GWL_WNDPROC As Long = -4Privat

3、e Const PATCH_04 As Long = 88Private Const PATCH_05 As Long = 93Private Const PATCH_08 As Long = 132Private Const PATCH_09 As Long = 137Private Type tSubData hwnd As Long nAddrSub As Long nAddrOrig As Long nMsgCntA As Long nMsgCntB As Long aMsgTblA() As Long aMsgTblB() As LongEnd TypePrivate sc_aSub

4、Data() As tSubDataPrivate sc_aBuf(1 To CODE_LEN) As BytePrivate sc_pCWP As LongPrivate sc_pEbMode As LongPrivate sc_pSWL As LongPrivate Declare Sub RtlMoveMemory Lib kernel32 (Destination As Any, Source As Any, ByVal Length As Long)Private Declare Function GetModuleHandleA Lib kernel32 (ByVal lpModu

5、leName As String) As LongPrivate Declare Function GetProcAddress Lib kernel32 (ByVal hModule As Long, ByVal lpProcName As String) As LongPrivate Declare Function GlobalAlloc Lib kernel32 (ByVal wFlags As Long, ByVal dwBytes As Long) As LongPrivate Declare Function GlobalFree Lib kernel32 (ByVal hmem

6、 As Long) As LongPrivate Declare Function SetWindowLongA Lib user32 (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPrivate Declare Function VirtualProtect Lib kernel32 (lpAddress As Any, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As LongPriv

7、ate Type POINTAPI x1 As Long Y1 As LongEnd TypePrivate Type RECT2 x1 As Long Y1 As Long x2 As Long Y2 As LongEnd TypePrivate Const SPI_GETWORKAREA As Long = 48Private Const WM_SIZING As Long = &H214Private Const WM_MOVING As Long = &H216Private Const WM_ENTERSIZEMOVE As Long = &H231Private Const WM_

8、EXITSIZEMOVE As Long = &H232Private Const WM_SYSCOMMAND As Long = &H112Private Const WM_COMMAND As Long = &H111Private Const WMSZ_LEFT As Long = 1Private Const WMSZ_RIGHT As Long = 2Private Const WMSZ_TOP As Long = 3Private Const WMSZ_TOPLEFT As Long = 4Private Const WMSZ_TOPRIGHT As Long = 5Private

9、 Const WMSZ_BOTTOM As Long = 6Private Const WMSZ_BOTTOMLEFT As Long = 7Private Const WMSZ_BOTTOMRIGHT As Long = 8Private Const SC_MINIMIZE As Long = &HF020&Private Const SC_RESTORE As Long = &HF120&Private Const SWP_NOSIZE As Long = &H1Private Const SWP_NOZORDER As Long = &H4Private Const SWP_NOACTI

10、VATE As Long = &H10Private Declare Function SystemParametersInfo Lib user32 Alias SystemParametersInfoA (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As LongPrivate Declare Function IsWindow Lib user32 (ByVal hwnd As Long) As LongPrivate Declare Function IsZo

11、omed Lib user32 (ByVal hwnd As Long) As LongPrivate Declare Function BeginDeferWindowPos Lib user32 (ByVal nNumWindows As Long) As LongPrivate Declare Function DeferWindowPos Lib user32 (ByVal hWinPosInfo As Long, ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, B

12、yVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As LongPrivate Declare Function EndDeferWindowPos Lib user32 (ByVal hWinPosInfo As Long) As LongPrivate Declare Function GetCursorPos Lib user32 (lpPoint As POINTAPI) As LongPrivate Declare Function GetWindowRect Lib user32 (ByVal hwnd As Long

13、, lpRect As RECT2) As LongPrivate Declare Function OffsetRect Lib user32 (lpRect As RECT2, ByVal X As Long, ByVal Y As Long) As LongPrivate Declare Function UnionRect Lib user32 (lpDestRect As RECT2, lpSrc1Rect As RECT2, lpSrc2Rect As RECT2) As LongPrivate Declare Sub CopyMemory Lib kernel32 Alias R

14、tlMoveMemory (pDest As Any, pSrc As Any, ByVal ByteLen As Long)Private Type WND_INFO hwnd As Long hWndParent As Long Glue As BooleanEnd TypePrivate Const LB_RECT As Long = 16Private m_uWndInfo() As WND_INFOPrivate m_lWndCount As LongPrivate m_rcWnd() As RECT2Private m_ptAnchor As POINTAPIPrivate m_p

15、tOffset As POINTAPIPrivate m_ptCurr As POINTAPIPrivate m_ptLast As POINTAPIPrivate m_lSnapWidth As LongPrivate Sub Class_Initialize() m_lSnapWidth = 10 默认吸引的宽度 ReDim m_uWndInfo(0) As WND_INFO 初始化包含窗口句柄的数组 m_lWndCount = 0End SubPrivate Sub Class_Terminate() 停止Subclass If (m_lWndCount) Then Call Subcl

16、ass_StopAll End IfEnd SubPublic Sub zSubclass_Proc(ByVal bBefore As Boolean, ByRef bHandled As Boolean, ByRef lReturn As Long, ByRef lng_hWnd As Long, ByRef uMsg As Long, ByRef wParam As Long, ByRef lParam As Long) Dim rcWnd As RECT2 Dim lc As Long Select Case uMsg Case WM_ENTERSIZEMOVE 开始移动或改变大小 Ca

17、ll SystemParametersInfo(SPI_GETWORKAREA, 0, m_rcWnd(0), 0) 获得桌面区域 For lc = 1 To m_lWndCount 获得窗体句柄 If (IsZoomed(m_uWndInfo(lc).hwnd) Then 如果窗体最大化 Call CopyMemory(m_rcWnd(lc), m_rcWnd(0), LB_RECT) 获取工作区矩形 Else Call GetWindowRect(m_uWndInfo(lc).hwnd, m_rcWnd(lc) 获取窗体矩形 End If If (m_uWndInfo(lc).hwnd =

18、 lng_hWnd) Then 如果是当前的窗体 获取偏移量 Call GetCursorPos(m_ptAnchor) Call GetCursorPos(m_ptLast) m_ptOffset.x1 = m_rcWnd(lc).x1 - m_ptLast.x1 m_ptOffset.Y1 = m_rcWnd(lc).Y1 - m_ptLast.Y1 End If Next lc 改变大小 Case WM_SIZING Call CopyMemory(rcWnd, ByVal lParam, LB_RECT) Call pvSizeRect(lng_hWnd, rcWnd, wParam)

19、 Call CopyMemory(ByVal lParam, rcWnd, LB_RECT) bHandled = True lReturn = 1 移动 Case WM_MOVING Call CopyMemory(rcWnd, ByVal lParam, LB_RECT) Call pvMoveRect(lng_hWnd, rcWnd) Call CopyMemory(ByVal lParam, rcWnd, LB_RECT) bHandled = True lReturn = 1 改变或移动大小结束 Case WM_EXITSIZEMOVE Call pvCheckGlueing 特殊情

20、况 菜单调用 Case WM_SYSCOMMAND If (wParam = SC_MINIMIZE Or wParam = SC_RESTORE) Then Call pvCheckGlueing End If 特殊情况 控件调用 Case WM_COMMAND Call pvCheckGlueing End SelectEnd SubPublic Function AddWindow(ByVal hwnd As Long, Optional ByVal hWndParent As Long = 0) As Boolean Dim lc As Long For lc = 1 To m_lWn

21、dCount If (hwnd = m_uWndInfo(lc).hwnd) Then Exit Function Next lc If (IsWindow(hwnd) And (IsWindow(hWndParent) Or hWndParent = 0) Then 如果窗体有效 m_lWndCount = m_lWndCount + 1 增加数量 ReDim Preserve m_uWndInfo(0 To m_lWndCount) 调整数组大小 ReDim Preserve m_rcWnd(0 To m_lWndCount) With m_uWndInfo(m_lWndCount) 添加

22、信息 .hwnd = hwnd .hWndParent = hWndParent End With Call pvCheckGlueing 粘合 执行Subclass Call Subclass_Start(hwnd) Call Subclass_AddMsg(hwnd, WM_ENTERSIZEMOVE) Call Subclass_AddMsg(hwnd, WM_SIZING, MSG_BEFORE) Call Subclass_AddMsg(hwnd, WM_MOVING, MSG_BEFORE) Call Subclass_AddMsg(hwnd, WM_EXITSIZEMOVE) C

23、all Subclass_AddMsg(hwnd, WM_SYSCOMMAND) Call Subclass_AddMsg(hwnd, WM_COMMAND) 执行成功 AddWindow = True End IfEnd FunctionPublic Function RemoveWindow(ByVal hwnd As Long) As Boolean Dim lc1 As Long Dim lc2 As Long For lc1 = 1 To m_lWndCount If (hwnd = m_uWndInfo(lc1).hwnd) Then 移动到下面 For lc2 = lc1 To

24、m_lWndCount - 1 m_uWndInfo(lc2) = m_uWndInfo(lc2 + 1) Next lc2 m_lWndCount = m_lWndCount - 1 数量减一 ReDim Preserve m_uWndInfo(m_lWndCount) ReDim Preserve m_rcWnd(m_lWndCount) 移动父 For lc2 = 1 To m_lWndCount If (m_uWndInfo(lc2).hWndParent = hwnd) Then m_uWndInfo(lc2).hWndParent = 0 End If Next lc2 Call

25、Subclass_Stop(hwnd) 停止Subclass Call pvCheckGlueing 检查粘合 执行成功 RemoveWindow = True Exit For End If Next lc1End FunctionPublic Sub CheckGlueing() Call pvCheckGlueing 检查窗体所有可能的粘合End SubPublic Property Get SnapWidth() As Long SnapWidth = m_lSnapWidthEnd PropertyPublic Property Let SnapWidth(ByVal New_Sna

26、pWidth As Long) m_lSnapWidth = New_SnapWidthEnd PropertyPrivate Sub pvSizeRect(ByVal hwnd As Long, rcWnd As RECT2, ByVal lfEdge As Long) Dim rcTmp As RECT2 Dim lc As Long Call CopyMemory(rcTmp, rcWnd, LB_RECT) 检查所有的窗体 For lc = 0 To m_lWndCount With m_rcWnd(lc) If (m_uWndInfo(lc).hwnd hwnd) Then 如果不是

27、当前窗体 X轴方向的粘合 If (rcWnd.Y1 .Y1 - m_lSnapWidth) Then Select Case lfEdge Case WMSZ_LEFT, WMSZ_TOPLEFT, WMSZ_BOTTOMLEFT Select Case True Case Abs(rcTmp.x1 - .x1) m_lSnapWidth: rcWnd.x1 = .x1 Case Abs(rcTmp.x1 - .x2) m_lSnapWidth: rcWnd.x1 = .x2 End Select Case WMSZ_RIGHT, WMSZ_TOPRIGHT, WMSZ_BOTTOMRIGHT

28、 Select Case True Case Abs(rcTmp.x2 - .x1) m_lSnapWidth: rcWnd.x2 = .x1 Case Abs(rcTmp.x2 - .x2) m_lSnapWidth: rcWnd.x2 = .x2 End Select End Select End If Y轴方向的粘合 If (rcWnd.x1 .x1 - m_lSnapWidth) Then Select Case lfEdge Case WMSZ_TOP, WMSZ_TOPLEFT, WMSZ_TOPRIGHT Select Case True Case Abs(rcTmp.Y1 -

29、.Y1) m_lSnapWidth: rcWnd.Y1 = .Y1 Case Abs(rcTmp.Y1 - .Y2) m_lSnapWidth: rcWnd.Y1 = .Y2 End Select Case WMSZ_BOTTOM, WMSZ_BOTTOMLEFT, WMSZ_BOTTOMRIGHT Select Case True Case Abs(rcTmp.Y2 - .Y1) m_lSnapWidth: rcWnd.Y2 = .Y1 Case Abs(rcTmp.Y2 - .Y2) m_lSnapWidth: rcWnd.Y2 = .Y2 End Select End Select En

30、d If End If End With Next lcEnd SubPrivate Sub pvMoveRect(ByVal hwnd As Long, rcWnd As RECT2) Dim lc1 As Long Dim lc2 As Long Dim lWId As Long Dim rcTmp As RECT2 Dim lOffx As Long Dim lOffy As Long Dim hDWP As Long Call GetCursorPos(m_ptCurr) 获取当前鼠标位置 检查当前窗体的可粘合性 移动当前窗体 Call OffsetRect(rcWnd, (m_ptCurr.x1 - rcWnd.x1) + m_ptOffset.x1, 0) Call OffsetRect(rcWnd, 0, (m_ptCurr.Y1 - rcWnd.Y1) + m_ptOffset.Y1) For lc1 = 0 To m_lWndCount 检查所有的窗体 If (m_uWndInfo(lc1).hwnd hwnd) Then 如果不是当前的窗体 If (m_uWndInfo(lc1).Glue = False Or m_uWndInfo(lc1).hWn