Option Explicit
Public Type RECT
Left As Long
Top
As Long
Right As Long
Bottom
As Long
End Type
Public Type POINTAPI
x
As Long
y
As Long
End Type
Public Const COLOR_ACTIVECAPTION
= 2
Public Const SM_CXDLGFRAME
= 7
Public Const SM_CYDLGFRAME
= 8
Public Declare Function GetWindowRect
Lib "user32" _
(ByVal hwnd
As Long, lpRect
As RECT
) As Long
Public Declare Function GetSysColor
Lib "user32" _
(ByVal nIndex
As Long) As Long
Public Declare Function GetSystemMetrics
Lib "user32" _
(ByVal nIndex
As Long) As Long
Public Declare Function DrawFocusRect
Lib "user32" _
(ByVal hdc
As Long, lpRect
As RECT
) As Long
Public Declare Function ClientToScreen
Lib "user32" _
(ByVal hwnd
As Long, lpPoint
As POINTAPI
) As Long
Public Declare Function GetDC
Lib "user32" _
(ByVal hwnd
As Long) As Long
Public Declare Function ReleaseDC
Lib "user32" _
(ByVal hwnd
As Long, ByVal hdc
As Long) As Long
在窗体中输入以下代码：
Option Explicit
Dim tpoint
As POINTAPI
Dim temp
As POINTAPI
Dim dpoint
As POINTAPI
Dim fbox
As RECT
Dim tbox
As RECT
Dim oldbox
As RECT
Dim TwipsPerPixelX
Dim TwipsPerPixelY
Private Sub BeginFRDrag
(x
As Single, y
As Single)
Dim tDc
As Long
Dim sDc
As Long
Dim d
As Long
MousePointer
= 5
'convert points to POINTAPI struct
dpoint
.x
= x
dpoint
.y
= y
'get screen area of toolbar
GetWindowRect hwnd
, fbox
'screen Rect of toolbar
TwipsPerPixelX
= Screen
.TwipsPerPixelX
TwipsPerPixelY
= Screen
.TwipsPerPixelY
'get point of mousedown in screen coordinates
temp
= dpoint
ClientToScreen hwnd
, temp
sDc
= GetDC
(ByVal 0)
DrawFocusRect sDc
, tbox
d
= ReleaseDC
(0, sDc
)
oldbox
= tbox
End Sub
Private Sub DoFRDrag
(x
As Single, y
As Single)
Dim tDc
As Long
Dim sDc
As Long
Dim d
As Long
tpoint
.x
= x
tpoint
.y
= y
ClientToScreen hwnd
, tpoint
tbox
.Left = (fbox
.Left + tpoint
.x
/ TwipsPerPixelX
) - temp
.x
/ TwipsPerPixelX
tbox
.Top
= (fbox
.Top
+ tpoint
.y
/ TwipsPerPixelY
) - temp
.y
/ TwipsPerPixelY
tbox
.Right = (fbox
.Right + tpoint
.x
/ TwipsPerPixelX
) - temp
.x
/ TwipsPerPixelX
tbox
.Bottom
= (fbox
.Bottom
+ tpoint
.y
/ TwipsPerPixelY
) - temp
.y
/ TwipsPerPixelY
sDc
= GetDC
(ByVal 0)
DrawFocusRect sDc
, oldbox
DrawFocusRect sDc
, tbox
d
= ReleaseDC
(0, sDc
)
oldbox
= tbox
End Sub
Private Sub EndFRDrag
(x
As Single, y
As Single)
Dim tDc
As Long
Dim sDc
As Long
Dim d
As Long
Dim newleft
As Single
Dim newtop
As Single
sDc
= GetDC
(ByVal 0)
DrawFocusRect sDc
, oldbox
d
= ReleaseDC
(0, sDc
)
newleft
= x
+ fbox
.Left * TwipsPerPixelX
- dpoint
.x
newtop
= y
+ fbox
.Top
* TwipsPerPixelY
- dpoint
.y
Move newleft
, newtop
MousePointer
= 0
End Sub
Private Sub Form_MouseDown
(Button
As Integer, Shift
As Integer, x
As Single, y
As Single)
If Button
= 2 Then BeginFRDrag x
, y
End Sub
Private Sub Form_MouseMove
(Button
As Integer, Shift
As Integer, x
As Single, y
As Single)
If Button
= 2 Then DoFRDrag x
, y
End Sub
Private Sub Form_MouseUp
(Button
As Integer, Shift
As Integer, x
As Single, y
As Single)
If Button
= 2 Then EndFRDrag x
, y
End Sub 这样只要你按下右键就可以移动窗体。这里面的一个关键就是使用ClientToScreen函数转换窗体坐标为屏幕坐标。
