如何实现浮动没有标题的窗体

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函数转换窗体坐标为屏幕坐标。
阅读更多

没有更多推荐了,返回首页