用Mouse移动没有TitleBar的Form

来源:cww 小吴

如果我们的Form.BorderStyle = 0而没有TitleBar，此时想用Mouse来移动Form似乎
很困难，虽说原本这种类型的Form就是不让别人来动它，但我们若真的想移动它时，
只好自己动手。这个程式在Form上按Mouse左键後可始拖曳，此时见一个方形的框随之
移动，放掉Mouse时，Form会移至正确的位址。

里面使用的GetWindowRect, GetCursorPos这些API事实上可以不用，而纯粹用vb来做
，但是这样做座标的转换会令我头大，所以就用现成的API来做。这里面比较复杂的是
如何画出方框後再将之消除，我使用的方式是使用XOR的方式来图，第一次画时，见得到
方形，等Mouse Move到新的地方後，要将先前画的方形涂掉，那就再以XOR的方式於原图
处再画一次，那就OK了。


'Need set Form.BorderStyle = 0, and with a Command Button
Option Explicit
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, _
        ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, _
        ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SetROP2 Lib "gdi32" (ByVal hdc As Long, ByVal nDrawMode As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long

Const R2_NOTXORPEN = 10
Const NULL_BRUSH = 5
Private Type POINTAPI
        X As Long
        Y As Long
End Type
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
Private hbrush As Long, hdc5 As Long
Private OldRect As RECT
Private StPoint As POINTAPI, PrevPoint As POINTAPI
Dim EndPoint As POINTAPI
Private ii As Long

Private Sub Command1_Click()
Unload Me
End Sub

'这个DblClick很奇怪，似乎不用这一段，的确，不过当Double Click Form时
'会产生MouseDown, MouseUp, Click, DblClick, MouseUp这个顺序的Events
'请注意，MouseUp两次，但MouseDown只一次，造成Rectangle没有成对出现，使得
'Form外面会有一个方框，所以在DblClick上多加一次Rectangle来解决之
Private Sub Form_DblClick()
Dim dx As Long, dy As Long
Call GetCursorPos(EndPoint)
dx = EndPoint.X - StPoint.X
dy = EndPoint.Y - StPoint.Y
Call Rectangle(hdc5, OldRect.Left, OldRect.Top, _
     OldRect.Right, OldRect.Bottom) '画方形
End Sub

Private Sub Form_Load()
   hdc5 = GetDC(0) '取得萤幕的hDc
   hbrush = GetStockObject(NULL_BRUSH)
   '设定画方形时内部为透明(因是Null Brush)
   Call SelectObject(hdc5, hbrush)
   Call SetROP2(hdc5, R2_NOTXORPEN) '以XOR的方式来画方形
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then '按了左Mouse
   Call GetCursorPos(StPoint) '取得Mouse目前对应萤的座标
   PrevPoint = StPoint        '记录Mouse Down时原先Mouse的位置
   Call GetWindowRect(Me.hwnd, OldRect) '取得目前Window对应萤幕的位置
   Call Rectangle(hdc5, OldRect.Left, OldRect.Top, _
        OldRect.Right, OldRect.Bottom) '画一方形
End If
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim dx As Long, dy As Long
If Button <> 1 Then
   Exit Sub
End If
Call GetCursorPos(EndPoint)
dx = EndPoint.X - StPoint.X
dy = EndPoint.Y - StPoint.Y
StPoint = EndPoint
Call Rectangle(hdc5, OldRect.Left, OldRect.Top, _
     OldRect.Right, OldRect.Bottom) '将原先画的方形涂掉(因是XOR的方式，画两次等於涂掉)
OldRect.Left = OldRect.Left + dx
OldRect.Top = OldRect.Top + dy
OldRect.Bottom = OldRect.Bottom + dy
OldRect.Right = OldRect.Right + dx
Call Rectangle(hdc5, OldRect.Left, OldRect.Top, _
     OldRect.Right, OldRect.Bottom) '重新画方形於新的位置

End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim dx As Long, dy As Long
If Button = 1 Then
   Call GetCursorPos(EndPoint)
   dx = EndPoint.X - StPoint.X
   dy = EndPoint.Y - StPoint.Y
   Call Rectangle(hdc5, OldRect.Left, OldRect.Top, _
        OldRect.Right, OldRect.Bottom) '方形涂掉
   Call GetCursorPos(EndPoint)
   dx = EndPoint.X - PrevPoint.X '计算Form新的位置
   dy = EndPoint.Y - PrevPoint.Y
   Me.Move Me.Left + dx * Screen.TwipsPerPixelX, Me.Top + dy * Screen.TwipsPerPixelY
End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
   Call ReleaseDC(0, hdc5)
   Call DeleteObject(hbrush)
End Sub

Option Explicit
Private Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Sub ReleaseCapture Lib "User32" ()
Const WM_NCLBUTTONDOWN = &HA1
Const HTCAPTION = 2

Private Sub Command1_Click()
Unload Me
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _
             X As Single, Y As Single)
  Dim lngReturnValue As Long
  If Button = 1 Then
    ReleaseCapture
    lngReturnValue = SendMessage(hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
  End If
End Sub