磁性窗体 VB.docx
《磁性窗体 VB.docx》由会员分享，可在线阅读，更多相关《磁性窗体 VB.docx（25页珍藏版）》请在冰豆网上搜索。
磁性窗体VB
///mag/Cls_Magnetic.cls
VERSION1.0CLASS
BEGIN
MultiUse=-1'True
Persistable=0'NotPersistable
DataBindingBehavior=0'vbNone
DataSourceBehavior=0'vbNone
MTSTransactionMode=0'NotAnMTSObject
END
AttributeVB_Name="Cls_Magnetic"
AttributeVB_GlobalNameSpace=False
AttributeVB_Creatable=True
AttributeVB_PredeclaredId=False
AttributeVB_Exposed=False
OptionExplicit
PrivateEnumeMsgWhen
[MSG_AFTER]=1
[MSG_BEFORE]=2
[MSG_BEFORE_AND_AFTER]=MSG_AFTEROrMSG_BEFORE
EndEnum
PrivateConstALL_MESSAGESAsLong=-1
PrivateConstCODE_LENAsLong=197
PrivateConstGWL_WNDPROCAsLong=-4
PrivateConstPATCH_04AsLong=88
PrivateConstPATCH_05AsLong=93
PrivateConstPATCH_08AsLong=132
PrivateConstPATCH_09AsLong=137
PrivateTypetSubData
hwndAsLong
nAddrSubAsLong
nAddrOrigAsLong
nMsgCntAAsLong
nMsgCntBAsLong
aMsgTblA（）AsLong
aMsgTblB（）AsLong
EndType
Privatesc_aSubData（）AstSubData
Privatesc_aBuf（1ToCODE_LEN）AsByte
Privatesc_pCWPAsLong
Privatesc_pEbModeAsLong
Privatesc_pSWLAsLong
PrivateDeclareSubRtlMoveMemoryLib"kernel32"（DestinationAsAny,SourceAsAny,ByValLengthAsLong）
PrivateDeclareFunctionGetModuleHandleALib"kernel32"（ByVallpModuleNameAsString）AsLong
PrivateDeclareFunctionGetProcAddressLib"kernel32"（ByValhModuleAsLong,ByVallpProcNameAsString）AsLong
PrivateDeclareFunctionGlobalAllocLib"kernel32"（ByValwFlagsAsLong,ByValdwBytesAsLong）AsLong
PrivateDeclareFunctionGlobalFreeLib"kernel32"（ByValhmemAsLong）AsLong
PrivateDeclareFunctionSetWindowLongALib"user32"（ByValhwndAsLong,ByValnIndexAsLong,ByValdwNewLongAsLong）AsLong
PrivateDeclareFunctionVirtualProtectLib"kernel32"（lpAddressAsAny,ByValdwSizeAsLong,ByValflNewProtectAsLong,lpflOldProtectAsLong）AsLong
PrivateTypePOINTAPI
x1AsLong
Y1AsLong
EndType
PrivateTypeRECT2
x1AsLong
Y1AsLong
x2AsLong
Y2AsLong
EndType
PrivateConstSPI_GETWORKAREAAsLong=48
PrivateConstWM_SIZINGAsLong=&H214
PrivateConstWM_MOVINGAsLong=&H216
PrivateConstWM_ENTERSIZEMOVEAsLong=&H231
PrivateConstWM_EXITSIZEMOVEAsLong=&H232
PrivateConstWM_SYSCOMMANDAsLong=&H112
PrivateConstWM_COMMANDAsLong=&H111
PrivateConstWMSZ_LEFTAsLong=1
PrivateConstWMSZ_RIGHTAsLong=2
PrivateConstWMSZ_TOPAsLong=3
PrivateConstWMSZ_TOPLEFTAsLong=4
PrivateConstWMSZ_TOPRIGHTAsLong=5
PrivateConstWMSZ_BOTTOMAsLong=6
PrivateConstWMSZ_BOTTOMLEFTAsLong=7
PrivateConstWMSZ_BOTTOMRIGHTAsLong=8
PrivateConstSC_MINIMIZEAsLong=&HF020&
PrivateConstSC_RESTOREAsLong=&HF120&
PrivateConstSWP_NOSIZEAsLong=&H1
PrivateConstSWP_NOZORDERAsLong=&H4
PrivateConstSWP_NOACTIVATEAsLong=&H10
PrivateDeclareFunctionSystemParametersInfoLib"user32"Alias"SystemParametersInfoA"（ByValuActionAsLong,ByValuParamAsLong,lpvParamAsAny,ByValfuWinIniAsLong）AsLong
PrivateDeclareFunctionIsWindowLib"user32"（ByValhwndAsLong）AsLong
PrivateDeclareFunctionIsZoomedLib"user32"（ByValhwndAsLong）AsLong
PrivateDeclareFunctionBeginDeferWindowPosLib"user32"（ByValnNumWindowsAsLong）AsLong
PrivateDeclareFunctionDeferWindowPosLib"user32"（ByValhWinPosInfoAsLong,ByValhwndAsLong,ByValhWndInsertAfterAsLong,ByValXAsLong,ByValYAsLong,ByValcxAsLong,ByValcyAsLong,ByValwFlagsAsLong）AsLong
PrivateDeclareFunctionEndDeferWindowPosLib"user32"（ByValhWinPosInfoAsLong）AsLong
PrivateDeclareFunctionGetCursorPosLib"user32"（lpPointAsPOINTAPI）AsLong
PrivateDeclareFunctionGetWindowRectLib"user32"（ByValhwndAsLong,lpRectAsRECT2）AsLong
PrivateDeclareFunctionOffsetRectLib"user32"（lpRectAsRECT2,ByValXAsLong,ByValYAsLong）AsLong
PrivateDeclareFunctionUnionRectLib"user32"（lpDestRectAsRECT2,lpSrc1RectAsRECT2,lpSrc2RectAsRECT2）AsLong
PrivateDeclareSubCopyMemoryLib"kernel32"Alias"RtlMoveMemory"（pDestAsAny,pSrcAsAny,ByValByteLenAsLong）
PrivateTypeWND_INFO
hwndAsLong
hWndParentAsLong
GlueAsBoolean
EndType
PrivateConstLB_RECTAsLong=16
Privatem_uWndInfo（）AsWND_INFO
Privatem_lWndCountAsLong
Privatem_rcWnd（）AsRECT2
Privatem_ptAnchorAsPOINTAPI
Privatem_ptOffsetAsPOINTAPI
Privatem_ptCurrAsPOINTAPI
Privatem_ptLastAsPOINTAPI
Privatem_lSnapWidthAsLong
PrivateSubClass_Initialize（）
m_lSnapWidth=10'默认吸引的宽度
ReDimm_uWndInfo（0）AsWND_INFO'初始化包含窗口句柄的数组
m_lWndCount=0
EndSub
PrivateSubClass_Terminate（）
'停止Subclass
If（m_lWndCount）Then
CallSubclass_StopAll
EndIf
EndSub
PublicSubzSubclass_Proc（ByValbBeforeAsBoolean,ByRefbHandledAsBoolean,ByReflReturnAsLong,ByReflng_hWndAsLong,ByRefuMsgAsLong,ByRefwParamAsLong,ByReflParamAsLong）
DimrcWndAsRECT2
DimlcAsLong
SelectCaseuMsg
CaseWM_ENTERSIZEMOVE'开始移动或改变大小
CallSystemParametersInfo（SPI_GETWORKAREA,0,m_rcWnd（0）,0）'获得桌面区域
Forlc=1Tom_lWndCount'获得窗体句柄
If（IsZoomed（m_uWndInfo（lc）.hwnd））Then'如果窗体最大化
CallCopyMemory（m_rcWnd（lc）,m_rcWnd（0）,LB_RECT）'获取工作区矩形
Else
CallGetWindowRect（m_uWndInfo（lc）.hwnd,m_rcWnd（lc））'获取窗体矩形
EndIf
If（m_uWndInfo（lc）.hwnd=lng_hWnd）Then'如果是当前的窗体
'获取偏移量
CallGetCursorPos（m_ptAnchor）
CallGetCursorPos（m_ptLast）
m_ptOffset.x1=m_rcWnd（lc）.x1-m_ptLast.x1
m_ptOffset.Y1=m_rcWnd（lc）.Y1-m_ptLast.Y1
EndIf
Nextlc
'改变大小
CaseWM_SIZING
CallCopyMemory（rcWnd,ByVallParam,LB_RECT）
CallpvSizeRect（lng_hWnd,rcWnd,wParam）
CallCopyMemory（ByVallParam,rcWnd,LB_RECT）
bHandled=True
lReturn=1
'移动
CaseWM_MOVING
CallCopyMemory（rcWnd,ByVallParam,LB_RECT）
CallpvMoveRect（lng_hWnd,rcWnd）
CallCopyMemory（ByVallParam,rcWnd,LB_RECT）
bHandled=True
lReturn=1
'改变或移动大小结束
CaseWM_EXITSIZEMOVE
CallpvCheckGlueing
'特殊情况菜单调用
CaseWM_SYSCOMMAND
If（wParam=SC_MINIMIZEOrwParam=SC_RESTORE）Then
CallpvCheckGlueing
EndIf
'特殊情况控件调用
CaseWM_COMMAND
CallpvCheckGlueing
EndSelect
EndSub
PublicFunctionAddWindow（ByValhwndAsLong,OptionalByValhWndParentAsLong=0）AsBoolean
DimlcAsLong
Forlc=1Tom_lWndCount
If（hwnd=m_uWndInfo（lc）.hwnd）ThenExitFunction
Nextlc
If（IsWindow（hwnd）And（IsWindow（hWndParent）OrhWndParent=0））Then'如果窗体有效
m_lWndCount=m_lWndCount+1'增加数量
ReDimPreservem_uWndInfo（0Tom_lWndCount）'调整数组大小
ReDimPreservem_rcWnd（0Tom_lWndCount）
Withm_uWndInfo（m_lWndCount）'添加信息
.hwnd=hwnd
.hWndParent=hWndParent
EndWith
CallpvCheckGlueing'粘合
'执行Subclass
CallSubclass_Start（hwnd）
CallSubclass_AddMsg（hwnd,WM_ENTERSIZEMOVE）
CallSubclass_AddMsg（hwnd,WM_SIZING,[MSG_BEFORE]）
CallSubclass_AddMsg（hwnd,WM_MOVING,[MSG_BEFORE]）
CallSubclass_AddMsg（hwnd,WM_EXITSIZEMOVE）
CallSubclass_AddMsg（hwnd,WM_SYSCOMMAND）
CallSubclass_AddMsg（hwnd,WM_COMMAND）
'执行成功
AddWindow=True
EndIf
EndFunction
PublicFunctionRemoveWindow（ByValhwndAsLong）AsBoolean
Dimlc1AsLong
Dimlc2AsLong
Forlc1=1Tom_lWndCount
If（hwnd=m_uWndInfo（lc1）.hwnd）Then
'移动到下面
Forlc2=lc1Tom_lWndCount-1
m_uWndInfo（lc2）=m_uWndInfo（lc2+1）
Nextlc2
m_lWndCount=m_lWndCount-1'数量减一
ReDimPreservem_uWndInfo（m_lWndCount）
ReDimPreservem_rcWnd（m_lWndCount）
'移动父
Forlc2=1Tom_lWndCount
If（m_uWndInfo（lc2）.hWndParent=hwnd）Then
m_uWndInfo（lc2）.hWndParent=0
EndIf
Nextlc2
CallSubclass_Stop（hwnd）'停止Subclass
CallpvCheckGlueing'检查粘合
'执行成功
RemoveWindow=True
ExitFor
EndIf
Nextlc1
EndFunction
PublicSubCheckGlueing（）
CallpvCheckGlueing'检查窗体所有可能的粘合
EndSub
PublicPropertyGetSnapWidth（）AsLong
SnapWidth=m_lSnapWidth
EndProperty
PublicPropertyLetSnapWidth（ByValNew_SnapWidthAsLong）
m_lSnapWidth=New_SnapWidth
EndProperty
PrivateSubpvSizeRect（ByValhwndAsLong,rcWndAsRECT2,ByVallfEdgeAsLong）
DimrcTmpAsRECT2
DimlcAsLong
CallCopyMemory（rcTmp,rcWnd,LB_RECT）
'检查所有的窗体
Forlc=0Tom_lWndCount
Withm_rcWnd（lc）
If（m_uWndInfo（lc）.hwnd<>hwnd）Then'如果不是当前窗体
'X轴方向的粘合
If（rcWnd.Y1<.Y2+m_lSnapWidthAndrcWnd.Y2>.Y1-m_lSnapWidth）Then
SelectCaselfEdge
CaseWMSZ_LEFT,WMSZ_TOPLEFT,WMSZ_BOTTOMLEFT
SelectCaseTrue
CaseAbs（rcTmp.x1-.x1）rcWnd.x1=.x1
CaseAbs（rcTmp.x1-.x2）rcWnd.x1=.x2
EndSelect
CaseWMSZ_RIGHT,WMSZ_TOPRIGHT,WMSZ_BOTTOMRIGHT
SelectCaseTrue
CaseAbs（rcTmp.x2-.x1）rcWnd.x2=.x1
CaseAbs（rcTmp.x2-.x2）rcWnd.x2=.x2
EndSelect
EndSelect
EndIf
'Y轴方向的粘合
If（rcWnd.x1<.x2+m_lSnapWidthAndrcWnd.x2>.x1-m_lSnapWidth）Then
SelectCaselfEdge
CaseWMSZ_TOP,WMSZ_TOPLEFT,WMSZ_TOPRIGHT
SelectCaseTrue
CaseAbs（rcTmp.Y1-.Y1）rcWnd.Y1=.Y1
CaseAbs（rcTmp.Y1-.Y2）rcWnd.Y1=.Y2
EndSelect
CaseWMSZ_BOTTOM,WMSZ_BOTTOMLEFT,WMSZ_BOTTOMRIGHT
SelectCaseTrue
CaseAbs（rcTmp.Y2-.Y1）rcWnd.Y2=.Y1
CaseAbs（rcTmp.Y2-.Y2）rcWnd.Y2=.Y2
EndSelect
EndSelect
EndIf
EndIf
EndWith
Nextlc
EndSub
PrivateSubpvMoveRect（ByValhwndAsLong,rcWndAsRECT2）
Dimlc1AsLong
Dimlc2AsLong
DimlWIdAsLong
DimrcTmpAsRECT2
DimlOffxAsLong
DimlOffyAsLong
DimhDWPAsLong
CallGetCursorPos（m_ptCurr）'获取当前鼠标位置
'检查当前窗体的可粘合性
'移动当前窗体
CallOffsetRect（rcWnd,（m_ptCurr.x1-rcWnd.x1）+m_ptOffset.x1,0）
CallOffsetRect（rcWnd,0,（m_ptCurr.Y1-rcWnd.Y1）+m_ptOffset.Y1）
Forlc1=0Tom_lWndCount'检查所有的窗体
If（m_uWndInfo（lc1）.hwnd<>hwnd）Then'如果不是当前的窗体
If（m_uWndInfo（lc1）.Glue=FalseOrm_uWndInfo（lc1）.hWn
升级会员 