用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