关于vb如何做磁性窗体(像千千静听一样的吸附窗体)[代码]

我花了一个晚上的时间研究
通过简单的五个Api函数调用实现其它窗体吸附到你的主窗体上
也就是你需要设定一个作为主要的窗体,其他窗口与之产生磁性
绝对非Timer控件判断
转载请注明作者Fly 谢谢!

虽然不能像千千静听那样窗体可以依附于任意已吸附的窗体上
既是Form1作为主要的拖动窗体,其他 Form2,Form3是要吸附的窗体
在千千静听里面只要Form2吸附到了Form1上面,Form3就可以吸附到Form1或者Form2上面了
而在下才疏学浅,不能实现该功能,只能实现全部吸附到Form1上面
另外我这里说的子窗体不是MIDChild窗体,只是形象一点称呼,就是一般的窗体
可以任意边框地方吸附

首先要解决窗体移动产生事件的问题
再次解决Form1移动到Form2边上时不吸附而是要Form2移动到Form1边上时才能吸附
最后就是判断是如何吸附的方式,以便主窗体移动时跟着一起移动

我的QQ是:164233576
Msn/E-mail:Geohfly@Hotmail.com
由于我对Vb也不是很精通,以下代码可能很繁琐
希望高手来修改/指正

先在主窗体和你希望吸附的子窗体的
Form_load事件中加

prevWndProc = GetWindowLong(Me.hwnd, GWL_WNDPROC)
SetWindowLong Me.hwnd, GWL_WNDPROC, AddressOf WndProc

另外建立模板文件
代码如下

  1 Option Explicit
  2  Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
  3  Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  4 '↑Windows消息函数,功能很多,但是我不是很了解
  5 Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
  6 '↑移动指定句柄窗体,我曾使用SetWindowsPos函数移动好像无效,望高手指点
  7 Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
  8 '↑获得指定句柄窗口位置/大小
  9 Private Type RECT 
 10      Left As Long
 11      Top As Long
 12      Right As Long
 13      Bottom As Long
 14 End Type
 15 
 16 Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
 17 '↑一系列的Windows消息函数
 18 '↓GetWindowLong SetWindowLong常量
 19 Public Const GWL_WNDPROC = (-4)
 20 Public Const WM_MOVE = &H3
 21 Public Const WM_SIZE = &H5
 22 
 23 Public prevWndProc As Long        '默认窗口程序地址
 24 
 25 Dim IsAdsorption() As Integer, FormAdsorption() As Long, AdsorptionNum& '定义所吸附的窗体的句柄和方式
 26 Dim Disparity() As Long '如果窗体左右边吸附,记录与主窗体的Top差距;上下吸附,记录与主窗体的Left差距
 27 Dim MainFormName As Form '定义你的主吸附窗体
 28 '子窗体吸附参数
 29 Public Function WndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
 30 On Error GoTo ShowErr
 31 '处理窗体移动的消息
 32 
 33        
 34 If hwnd = 0 Then Exit Function
 35 Dim i&, CrrentAdsorption% '当前吸附窗体所在数组的Id
 36 
 37 Set MainFormName = Form1 '定义Form1为主窗体,其他窗体都吸附在它上面
 38 
 39 CrrentAdsorption = 0: i = 0
 40 If Msg = WM_MOVE Or Msg = WM_SIZE Then
 41     If hwnd = MainFormName.hwnd Then '主窗体移动
 42     
 43      For i = 1 To UBound(FormAdsorption) '通过检测所有吸附的窗体来移动
 44       If CLng(FormAdsorption(i)) <> 0 Then
 45         If IsAdsorption(i) Then MoveOtherForm CLng(FormAdsorption(i)), i
 46       End If
 47      Next i
 48 
 49    ElseIf hwnd <> 0 Then '其他窗体移动
 50    
 51      For i = 1 To UBound(FormAdsorption) '判断是否是重复窗体
 52          If hwnd = CLng(FormAdsorption(i)) Then GoTo skip3 '发现相同就跳过不然就重新建立数组
 53      Next i
 54        AdsorptionNum = AdsorptionNum + 1
 55       ReDim Preserve FormAdsorption(0 To AdsorptionNum) As Long
 56       ReDim Preserve IsAdsorption(0 To AdsorptionNum) As Integer
 57       ReDim Preserve Disparity(0 To AdsorptionNum) As Long
 58       FormAdsorption(AdsorptionNum) = hwnd
 59       IsAdsorption(AdsorptionNum) = 0
 60       Disparity(AdsorptionNum) = 0
 61 skip3:
 62       
 63         For i = 1 To UBound(FormAdsorption)
 64            If CLng(FormAdsorption(i)) = hwnd Then CrrentAdsorption = i: Exit For
 65         Next i
 66       If CrrentAdsorption = 0 Then Exit Function
 67       MoveOtherForm hwnd, CrrentAdsorption, True
 68 
 69    End If
 70 End If
 71 '呼叫Windows参数
 72     WndProc = CallWindowProc(prevWndProc, hwnd, Msg, wParam, lParam)
 73 Set MainFormName = Nothing
 74 ShowErr:
 75    ' 唯一的错误就是在没有定义数组前取下标Ubound错误
 76    If Err.Number > 0 Then
 77     ReDim Preserve FormAdsorption(0 To AdsorptionNum) As Long
 78     ReDim Preserve IsAdsorption(0 To AdsorptionNum) As Integer
 79     ReDim Preserve Disparity(0 To AdsorptionNum) As Long
 80     Err.Clear
 81   End If
 82 End Function
 83 
 84 '本过程参数
 85 ' hwnd是要移动或被移动窗体的句柄
 86 ' id 该句柄在内部的数组中的id
 87 ' Judgment 判断是否是移动主窗体/判断被移动的子窗体
 88 ' 主要代码就是 判断与主窗体的边界相差多少象素来吸附 ＆移动其他窗体代码
 89 Private Sub MoveOtherForm(ByVal hwnd&, ByVal Id%, Optional ByVal Judgment As Boolean = False)
 90 If hwnd = 0 Then Exit Sub
 91 Const MinDisparityPixel As Integer = 10 '最小吸附象素
 92 
 93 Dim FormWhere As RECT, FormLeft&, FormTop&, FormRight&, FormBottom&, FormWidth&, FormHeight&
 94 GetWindowRect hwnd, FormWhere
 95 FormLeft = FormWhere.Left: FormTop = FormWhere.Top: FormRight = FormWhere.Right: FormBottom = FormWhere.Bottom
 96 FormWidth = FormWhere.Right - FormWhere.Left: FormHeight = FormWhere.Bottom - FormWhere.Top
 97 
 98 If Judgment Then
 99   IsAdsorption(Id) = 0
100   If Abs(FormRight - MainFormName.Left / Screen.TwipsPerPixelX) <= MinDisparityPixel Then
101         '左边吸附
102           If FormTop <= (MainFormName.Top + MainFormName.Height) / Screen.TwipsPerPixelY And FormBottom >= MainFormName.Top / Screen.TwipsPerPixelY Then
103             MoveWindow hwnd, MainFormName.Left / Screen.TwipsPerPixelX - FormWidth, FormTop, FormWidth, FormHeight, True
104             IsAdsorption(Id) = 1: Disparity(Id) = FormTop - MainFormName.Top / Screen.TwipsPerPixelY
105           End If
106   ElseIf Abs(FormLeft - (MainFormName.Left + MainFormName.Width) / Screen.TwipsPerPixelX) <= MinDisparityPixel Then
107         '右边吸附
108           If FormTop <= (MainFormName.Top + MainFormName.Height) / Screen.TwipsPerPixelY And FormBottom >= MainFormName.Top / Screen.TwipsPerPixelY Then
109             MoveWindow hwnd, (MainFormName.Left + MainFormName.Width) / Screen.TwipsPerPixelX, FormTop, FormWidth, FormHeight, True
110             IsAdsorption(Id) = 2: Disparity(Id) = FormTop - MainFormName.Top / Screen.TwipsPerPixelY
111           End If
112   ElseIf Abs(FormBottom - MainFormName.Top / Screen.TwipsPerPixelY) <= MinDisparityPixel Then
113         '上边吸附
114           If FormLeft <= (MainFormName.Left + MainFormName.Width) / Screen.TwipsPerPixelX And FormRight >= MainFormName.Left / Screen.TwipsPerPixelX Then
115             MoveWindow hwnd, FormLeft, MainFormName.Top / Screen.TwipsPerPixelY - FormHeight, FormWidth, FormHeight, True
116             IsAdsorption(Id) = 3: Disparity(Id) = FormLeft - MainFormName.Left / Screen.TwipsPerPixelX
117           End If
118   ElseIf Abs(FormTop - (MainFormName.Top + MainFormName.Height) / Screen.TwipsPerPixelY) <= MinDisparityPixel Then
119         '下边吸附
120         If FormLeft <= (MainFormName.Left + MainFormName.Width) / Screen.TwipsPerPixelX And FormRight >= MainFormName.Left / Screen.TwipsPerPixelX Then
121             MoveWindow hwnd, FormLeft, (MainFormName.Top + MainFormName.Height) / Screen.TwipsPerPixelY, FormWidth, FormHeight, True
122             IsAdsorption(Id) = 4: Disparity(Id) = FormLeft - MainFormName.Left / Screen.TwipsPerPixelX
123           End If
124   End If
125 Else
126   Select Case IsAdsorption(Id)
127    Case 1
128      MoveWindow hwnd, MainFormName.Left / Screen.TwipsPerPixelX - FormWidth, MainFormName.Top / Screen.TwipsPerPixelY + Disparity(Id), FormWidth, FormHeight, True
129    Case 2
130      MoveWindow hwnd, (MainFormName.Left + MainFormName.Width) / Screen.TwipsPerPixelX, MainFormName.Top / Screen.TwipsPerPixelY + Disparity(Id), FormWidth, FormHeight, True
131    Case 3
132      MoveWindow hwnd, MainFormName.Left / Screen.TwipsPerPixelX + Disparity(Id), MainFormName.Top / Screen.TwipsPerPixelY - FormHeight, FormWidth, FormHeight, True
133    Case 4
134      MoveWindow hwnd, MainFormName.Left / Screen.TwipsPerPixelX + Disparity(Id), (MainFormName.Top + MainFormName.Height) / Screen.TwipsPerPixelY, FormWidth, FormHeight, True
135 End Select
136 End If
137 
138 End Sub
139

Ok,代码就是这些了,我试验时没有问题的WinxpSp2+Vb6调试成功

posted on 2010-12-18 14:25 rooly 阅读(2022) 评论(0) 收藏举报