磁性窗体 VBWord文档下载推荐.docx

1、Private 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_aSubData（） As tSubDataPrivate sc_

2、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 （ByVal lpModuleName As String） As LongPrivate Decla

3、re Function GetProcAddress Lib （ByVal hModule As Long, ByVal lpProcName As String） As LongPrivate Declare Function GlobalAlloc Lib （ByVal wFlags As Long, ByVal dwBytes As Long） As LongPrivate Declare Function GlobalFree Lib （ByVal hmem As Long） As LongPrivate Declare Function SetWindowLongA Lib user

4、32 （ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long） As LongPrivate Declare Function VirtualProtect Lib （lpAddress As Any, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long） As LongPrivate Type POINTAPI x1 As Long Y1 As LongPrivate Type RECT2 x2 As Long Y2 As

5、 LongPrivate 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_EXITSIZEMOVE As Long = &H232Private Const WM_SYSCOMMAND As Long = &H112Private Const WM_COMMAND As Long = &H111P

6、rivate 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 Const WMSZ_BOTTOM As Long = 6Private Const WMSZ_BOTTOMLEFT As Long = 7Private Const WMSZ_BOTTOMRIGHT As Long =

7、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_NOACTIVATE As Long = &H10Private Declare Function SystemParametersInfo Lib Alias SystemParametersInfoA （ByVal uAction

8、As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long） As LongPrivate Declare Function IsWindow Lib （ByVal hwnd As Long） As LongPrivate Declare Function IsZoomed Lib Private Declare Function BeginDeferWindowPos Lib （ByVal nNumWindows As Long） As LongPrivate Declare Function DeferWin

9、dowPos Lib （ByVal hWinPosInfo As Long, 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 LongPrivate Declare Function EndDeferWindowPos Lib （ByVal hWinPosInfo As Long） As LongPrivate Declare Function GetC

10、ursorPos Lib （lpPoint As POINTAPI） As LongPrivate Declare Function GetWindowRect Lib （ByVal hwnd As Long, lpRect As RECT2） As LongPrivate Declare Function OffsetRect Lib （lpRect As RECT2, ByVal X As Long, ByVal Y As Long） As LongPrivate Declare Function UnionRect Lib （lpDestRect As RECT2, lpSrc1Rect

11、 As RECT2, lpSrc2Rect As RECT2） As LongPrivate Declare Sub CopyMemory Lib RtlMoveMemory （pDest As Any, pSrc As Any, ByVal ByteLen As Long）Private Type WND_INFO hWndParent As Long Glue As BooleanPrivate Const LB_RECT As Long = 16Private m_uWndInfo（） As WND_INFOPrivate m_lWndCount As LongPrivate m_rcW

12、nd（） As RECT2Private m_ptAnchor As POINTAPIPrivate m_ptOffset 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_T

13、erminate（） 停止Subclass If （m_lWndCount） Then Call Subclass_StopAll End IfPublic 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 Sele

14、ct Case uMsg Case WM_ENTERSIZEMOVE 开始移动或改变大小 Call 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_rc

15、Wnd（lc） 获取窗体矩形 If （m_uWndInfo（lc）.hwnd = 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 Next lc改变大小 Case WM_SIZING Call CopyMemory（rcWnd, ByVal lParam, LB_RECT） Call pvSi

16、zeRect（lng_hWnd, rcWnd, wParam） Call CopyMemory（ByVal lParam, rcWnd, LB_RECT） bHandled = True lReturn = 1移动 Case WM_MOVING Call pvMoveRect（lng_hWnd, rcWnd）改变或移动大小结束 Case WM_EXITSIZEMOVE Call pvCheckGlueing特殊情况 菜单调用 Case WM_SYSCOMMAND If （wParam = SC_MINIMIZE Or wParam = SC_RESTORE） Then特殊情况 控件调用 Cas

17、e WM_COMMAND End SelectPublic Function AddWindow（ByVal hwnd As Long, Optional ByVal hWndParent As Long = 0） As Boolean For lc = 1 To m_lWndCount If （hwnd = m_uWndInfo（lc）.hwnd） Then Exit Function If （IsWindow（hwnd） And （IsWindow（hWndParent） Or hWndParent = 0） Then 如果窗体有效 m_lWndCount = m_lWndCount +

18、1 增加数量 ReDim Preserve m_uWndInfo（0 To m_lWndCount） 调整数组大小 ReDim Preserve m_rcWnd（0 To m_lWndCount） With m_uWndInfo（m_lWndCount） 添加信息 .hwnd = hwnd .hWndParent = hWndParent End With Call pvCheckGlueing 粘合执行Subclass Call Subclass_Start（hwnd） Call Subclass_AddMsg（hwnd, WM_ENTERSIZEMOVE） Call Subclass_Ad

19、dMsg（hwnd, WM_SIZING, MSG_BEFORE） Call Subclass_AddMsg（hwnd, WM_MOVING, MSG_BEFORE） Call Subclass_AddMsg（hwnd, WM_EXITSIZEMOVE） Call Subclass_AddMsg（hwnd, WM_SYSCOMMAND） Call Subclass_AddMsg（hwnd, WM_COMMAND）执行成功 AddWindow = TrueEnd FunctionPublic Function RemoveWindow（ByVal hwnd As Long） As Boolean

20、 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 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

21、lc2 = 1 To m_lWndCount If （m_uWndInfo（lc2）.hWndParent = hwnd） Then m_uWndInfo（lc2）.hWndParent = 0 Call Subclass_Stop（hwnd） 停止Subclass检查粘合 RemoveWindow = True Exit For Next lc1Public Sub CheckGlueing（）检查窗体所有可能的粘合Public Property Get SnapWidth（） As Long SnapWidth = m_lSnapWidthEnd PropertyPublic Proper

22、ty Let SnapWidth（ByVal New_SnapWidth As Long） m_lSnapWidth = New_SnapWidthPrivate Sub pvSizeRect（ByVal hwnd As Long, rcWnd As RECT2, ByVal lfEdge As Long） Dim rcTmp As RECT2 Call CopyMemory（rcTmp, rcWnd, LB_RECT）检查所有的窗体 For lc = 0 To m_lWndCount With m_rcWnd（lc） If （m_uWndInfo（lc）.hwnd hwnd） Then 如果

23、不是当前窗体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） rcWnd.x1 = .x2 Case WMSZ_RIGHT, WMSZ_TOPRIGHT, WMSZ_BOTTOMRIGHT Case Abs（rcTmp.x2 - .x1

24、） rcWnd.x2 = .x1 Case Abs（rcTmp.x2 - .x2） rcWnd.x2 = .x2Y轴方向的粘合 If （rcWnd.x1 .x1 - m_lSnapWidth） Then Case WMSZ_TOP, WMSZ_TOPLEFT, WMSZ_TOPRIGHT Case Abs（rcTmp.Y1 - .Y1） rcWnd.Y1 = .Y1 Case Abs（rcTmp.Y1 - .Y2） rcWnd.Y1 = .Y2 Case WMSZ_BOTTOM, WMSZ_BOTTOMLEFT, WMSZ_BOTTOMRIGHT Case Abs（rcTmp.Y2 - .Y1

25、） rcWnd.Y2 = .Y1 Case Abs（rcTmp.Y2 - .Y2） rcWnd.Y2 = .Y2Private Sub pvMoveRect（ByVal hwnd As Long, rcWnd As RECT2） Dim lWId As Long 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 如果不是当前的窗体 If （m_uWndInfo（lc1）.Glue = False Or m_uWndInfo（lc1）.hWn