请教一个在运行状态下调整、移动控件的算法

CRect.cls:
'FormDsgn - Run-Time Form Design Demo Program
'Copyright (c) 1997 SoftCircuits Programming (R)
'Redistributed by Permission.
'
'Unfortunately, a fair amount of additional logic
'is required only for line controls
#Const ADD_LINE_LOGIC = TruePrivate Type POINTAPI
    X As Long
    Y As Long
End TypePrivate Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End TypePrivate Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As LongPrivate m_Rect As RECT#If ADD_LINE_LOGIC Then'
Private Const SWAP_NONE = &H0
Private Const SWAP_X = &H1
Private Const SWAP_Y = &H2
Private m_fRectSwap As Integer#End IfPublic Property Let Left(NewLeft As Long)
    m_Rect.Left = NewLeft
End PropertyPublic Property Get Left() As Long
    Left = m_Rect.Left
End PropertyPublic Property Let Top(NewTop As Long)
    m_Rect.Top = NewTop
End PropertyPublic Property Get Top() As Long
    Top = m_Rect.Top
End PropertyPublic Property Let Right(NewRight As Long)
    m_Rect.Right = NewRight
End PropertyPublic Property Get Right() As Long
    Right = m_Rect.Right
End PropertyPublic Property Let Bottom(NewBottom As Long)
    m_Rect.Bottom = NewBottom
End PropertyPublic Property Get Bottom() As Long
    Bottom = m_Rect.Bottom
End PropertyPublic Property Let Width(NewWidth As Long)
    m_Rect.Right = m_Rect.Left + NewWidth
End PropertyPublic Property Get Width() As Long
    Width = m_Rect.Right - m_Rect.Left
End PropertyPublic Property Let Height(NewHeight As Long)
    m_Rect.Bottom = m_Rect.Top + NewHeight
End PropertyPublic Property Get Height() As Long
    Height = m_Rect.Bottom - m_Rect.Top
End PropertyPublic Sub SetRectToCtrl(ctl As Control)#If ADD_LINE_LOGIC Then    'Reset swap flags
    m_fRectSwap = SWAP_NONE
    If TypeOf ctl Is Line Then
        m_Rect.Left = ctl.X1
        m_Rect.Top = ctl.Y1
        m_Rect.Right = ctl.X2
        m_Rect.Bottom = ctl.Y2
        'Need valid rect for hit testing but
        'must swap back in SetCtrlToRect
        If m_Rect.Left > m_Rect.Right Then
            m_fRectSwap = m_fRectSwap Or SWAP_X
        End If
        If m_Rect.Top > m_Rect.Bottom Then
            m_fRectSwap = m_fRectSwap Or SWAP_Y
        End If
        'Normalize if needed
        If m_fRectSwap <> SWAP_NONE Then
            NormalizeRect
        End If
    Else
        m_Rect.Left = ctl.Left
        m_Rect.Top = ctl.Top
        m_Rect.Right = ctl.Left + ctl.Width
        m_Rect.Bottom = ctl.Top + ctl.Height
    End If#Else    m_Rect.Left = ctl.Left
    m_Rect.Top = ctl.Top
    m_Rect.Right = ctl.Left + ctl.Width
    m_Rect.Bottom = ctl.Top + ctl.Height#End IfEnd SubPublic Sub SetCtrlToRect(ctl As Control)#If ADD_LINE_LOGIC Then    If TypeOf ctl Is Line Then
        'Restore normalized rectangle if needed
        If m_fRectSwap And SWAP_X Then
            ctl.X1 = m_Rect.Right
            ctl.X2 = m_Rect.Left
        Else
            ctl.X1 = m_Rect.Left
            ctl.X2 = m_Rect.Right
        End If
        If m_fRectSwap And SWAP_Y Then
            ctl.Y1 = m_Rect.Bottom
            ctl.Y2 = m_Rect.Top
        Else
            ctl.Y1 = m_Rect.Top
            ctl.Y2 = m_Rect.Bottom
        End If
        'Force to valid rectangle
        NormalizeRect
    Else
        'Force to valid rectangle
        NormalizeRect
        ctl.Move m_Rect.Left, m_Rect.Top, Width, Height
    End If#Else    'Force to valid rectangle
    NormalizeRect
    ctl.Move m_Rect.Left, m_Rect.Top, Width, Height#End IfEnd SubPublic Sub ScreenToTwips(ctl As Object)
    Dim pt As POINTAPI    pt.X = m_Rect.Left
    pt.Y = m_Rect.Top
    ScreenToClient ctl.Parent.hwnd, pt
    m_Rect.Left = pt.X * Screen.TwipsPerPixelX
    m_Rect.Top = pt.Y * Screen.TwipsPerPixelX
    pt.X = m_Rect.Right
    pt.Y = m_Rect.Bottom
    ScreenToClient ctl.Parent.hwnd, pt
    m_Rect.Right = pt.X * Screen.TwipsPerPixelX
    m_Rect.Bottom = pt.Y * Screen.TwipsPerPixelX
End SubPublic Sub TwipsToScreen(ctl As Object)
    Dim pt As POINTAPI    pt.X = m_Rect.Left / Screen.TwipsPerPixelX
    pt.Y = m_Rect.Top / Screen.TwipsPerPixelX
    ClientToScreen ctl.Parent.hwnd, pt
    m_Rect.Left = pt.X
    m_Rect.Top = pt.Y
    pt.X = m_Rect.Right / Screen.TwipsPerPixelX
    pt.Y = m_Rect.Bottom / Screen.TwipsPerPixelX
    ClientToScreen ctl.Parent.hwnd, pt
    m_Rect.Right = pt.X
    m_Rect.Bottom = pt.Y
End SubPublic Sub NormalizeRect()
    Dim nTemp As Long    If m_Rect.Left > m_Rect.Right Then
        nTemp = m_Rect.Right
        m_Rect.Right = m_Rect.Left
        m_Rect.Left = nTemp
    End If
    If m_Rect.Top > m_Rect.Bottom Then
        nTemp = m_Rect.Bottom
        m_Rect.Bottom = m_Rect.Top
        m_Rect.Top = nTemp
    End If
End SubPublic Function PtInRect(X As Single, Y As Single) As Integer
    If X >= m_Rect.Left And X < m_Rect.Right And _
        Y >= m_Rect.Top And Y < m_Rect.Bottom Then
        PtInRect = True
    Else
        PtInRect = False
    End If
End Function

MainForm:(part 1)Option ExplicitPrivate Type POINTAPI
    X As Long
    Y As Long
End TypePrivate Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type'Windows declarations
Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ClipCursor Lib "user32" (lpRect As Any) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
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 ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc 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 GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function SetROP2 Lib "gdi32" (ByVal hdc As Long, ByVal nDrawMode 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 LongPrivate Const NULL_BRUSH = 5
Private Const PS_SOLID = 0
Private Const R2_NOT = 6Enum ControlState
    StateNothing = 0
    StateDragging
    StateSizing
End EnumPrivate m_CurrCtl As Control
Private m_DragState As ControlState
Private m_DragHandle As Integer
Private m_DragRect As New CRect
Private m_DragPoint As POINTAPIPrivate m_bDesignMode As BooleanPrivate Sub Form_Load()
    DragInit    'Initialize drag code
End SubPrivate Sub mnuMode_Click()
    mnuModeDesign.Checked = m_bDesignMode
End SubPrivate Sub mnuModeDesign_Click()
    m_bDesignMode = Not m_bDesignMode
    If Not m_bDesignMode Then
        DragEnd
    End If
End SubPrivate Sub mnuModeExit_Click()
    Unload Me
End Sub'=========================== Sample controls ===========================
'To drag a control, simply call the DragBegin function with
'the control to be dragged
'=======================================================================Private Sub Label1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbLeftButton And m_bDesignMode Then
        DragBegin Label1
    End If
End SubPrivate Sub Text1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbLeftButton And m_bDesignMode Then
        DragBegin Text1
    End If
End SubPrivate Sub List1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbLeftButton And m_bDesignMode Then
        DragBegin List1
    End If
End SubPrivate Sub Image1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbLeftButton And m_bDesignMode Then
        DragBegin Image1
    End If
End SubPrivate Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbLeftButton And m_bDesignMode Then
        DragBegin Picture1
    End If
End Sub'========================== Dragging Code ================================'Initialization -- Do not call more than once
Private Sub DragInit()
    Dim i As Integer, xHandle As Single, yHandle As Single    'Use black Picture box controls for 8 sizing handles
    'Calculate size of each handle
    xHandle = 5 * Screen.TwipsPerPixelX
    yHandle = 5 * Screen.TwipsPerPixelY
    'Load array of handles until we have 8
    For i = 0 To 7
        If i <> 0 Then
            Load picHandle(i)
        End If
        picHandle(i).Width = xHandle
        picHandle(i).Height = yHandle
        'Must be in front of other controls
        picHandle(i).ZOrder
    Next i
    'Set mousepointers for each sizing handle
    picHandle(0).MousePointer = vbSizeNWSE
    picHandle(1).MousePointer = vbSizeNS
    picHandle(2).MousePointer = vbSizeNESW
    picHandle(3).MousePointer = vbSizeWE
    picHandle(4).MousePointer = vbSizeNWSE
    picHandle(5).MousePointer = vbSizeNS
    picHandle(6).MousePointer = vbSizeNESW
    picHandle(7).MousePointer = vbSizeWE
    'Initialize current control
    Set m_CurrCtl = Nothing
End Sub'Drags the specified control
Private Sub DragBegin(ctl As Control)
    Dim rc As RECT    'Hide any visible handles
    ShowHandles False
    'Save reference to control being dragged
    Set m_CurrCtl = ctl
    'Store initial mouse position
    GetCursorPos m_DragPoint
    'Save control position (in screen coordinates)
    'Note: control might not have a window handle
    m_DragRect.SetRectToCtrl m_CurrCtl
    m_DragRect.TwipsToScreen m_CurrCtl
    'Make initial mouse position relative to control
    m_DragPoint.X = m_DragPoint.X - m_DragRect.Left
    m_DragPoint.Y = m_DragPoint.Y - m_DragRect.Top
    'Force redraw of form without sizing handles
    'before drawing dragging rectangle
    Refresh
    'Show dragging rectangle
    DrawDragRect
    'Indicate dragging under way
    m_DragState = StateDragging
    'In order to detect mouse movement over any part of the form,
    'we set the mouse capture to the form and will process mouse
    'movement from the applicable form events
    ReleaseCapture  'This appears needed before calling SetCapture
    SetCapture hwnd
    'Limit cursor movement within form
    GetWindowRect hwnd, rc
    ClipCursor rc
End Sub'Clears any current drag mode and hides sizing handles
Private Sub DragEnd()
    Set m_CurrCtl = Nothing
    ShowHandles False
    m_DragState = StateNothing
End Sub'Because some lightweight controls do not have a MouseDown event,
'when we get a MouseDown event on a form, we do a scan of the
'Controls collection to see if any lightweight controls are under
'the mouse. Note that this code does not work for controls within
'containers. Also, if no control is under the mouse, then we
'remove the sizing handles and clear the current control.
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim i As Integer    If Button = vbLeftButton And m_bDesignMode Then
        'Hit test over light-weight (non-windowed) controls
        For i = 0 To (Controls.Count - 1)
            'Check for visible, non-menu controls
            '[Note 1]
            'If any of the sizing handle controls are under the mouse
            'pointer, then they must not be visible or else they would
            'have already intercepted the MouseDown event.
            '[Note 2]
            'This code will fail if you have a control such as the
            'Timer control which has no Visible property. You will
            'either need to make sure your form has no such controls
            'or add code to handle them.
            If Not TypeOf Controls(i) Is Menu And Controls(i).Visible Then
                m_DragRect.SetRectToCtrl Controls(i)
                If m_DragRect.PtInRect(X, Y) Then
                    DragBegin Controls(i)
                    Exit Sub
                End If
            End If
        Next i
        'No control is active
        Set m_CurrCtl = Nothing
        'Hide sizing handles
        ShowHandles False
    End If
End Sub

MainForm:(part 2)
'To handle all mouse message anywhere on the form, we set the mouse
'capture to the form. Mouse movement is processed here
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim nWidth As Single, nHeight As Single
    Dim pt As POINTAPI    If m_DragState = StateDragging Then
        'Save dimensions before modifying rectangle
        nWidth = m_DragRect.Right - m_DragRect.Left
        nHeight = m_DragRect.Bottom - m_DragRect.Top
        'Get current mouse position in screen coordinates
        GetCursorPos pt
        'Hide existing rectangle
        DrawDragRect
        'Update drag rectangle coordinates
        m_DragRect.Left = pt.X - m_DragPoint.X
        m_DragRect.Top = pt.Y - m_DragPoint.Y
        m_DragRect.Right = m_DragRect.Left + nWidth
        m_DragRect.Bottom = m_DragRect.Top + nHeight
        'Draw new rectangle
        DrawDragRect
    ElseIf m_DragState = StateSizing Then
        'Get current mouse position in screen coordinates
        GetCursorPos pt
        'Hide existing rectangle
        DrawDragRect
        'Action depends on handle being dragged
        Select Case m_DragHandle
            Case 0
                m_DragRect.Left = pt.X
                m_DragRect.Top = pt.Y
            Case 1
                m_DragRect.Top = pt.Y
            Case 2
                m_DragRect.Right = pt.X
                m_DragRect.Top = pt.Y
            Case 3
                m_DragRect.Right = pt.X
            Case 4
                m_DragRect.Right = pt.X
                m_DragRect.Bottom = pt.Y
            Case 5
                m_DragRect.Bottom = pt.Y
            Case 6
                m_DragRect.Left = pt.X
                m_DragRect.Bottom = pt.Y
            Case 7
                m_DragRect.Left = pt.X
        End Select
        'Draw new rectangle
        DrawDragRect
    End If
End Sub'To handle all mouse message anywhere on the form, we set the mouse
'capture to the form. Mouse up is processed here
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbLeftButton Then
        If m_DragState = StateDragging Or m_DragState = StateSizing Then
            'Hide drag rectangle
            DrawDragRect
            'Move control to new location
            m_DragRect.ScreenToTwips m_CurrCtl
            m_DragRect.SetCtrlToRect m_CurrCtl
            'Restore sizing handles
            ShowHandles True
            'Free mouse movement
            ClipCursor ByVal 0&
            'Release mouse capture
            ReleaseCapture
            'Reset drag state
            m_DragState = StateNothing
        End If
    End If
End Sub'Process MouseDown over handles
Private Sub picHandle_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim i As Integer
    Dim rc As RECT    'Handles should only be visible when a control is selected
    Debug.Assert (Not m_CurrCtl Is Nothing)
    'NOTE: m_DragPoint not used for sizing
    'Save control position in screen coordinates
    m_DragRect.SetRectToCtrl m_CurrCtl
    m_DragRect.TwipsToScreen m_CurrCtl
    'Track index handle
    m_DragHandle = Index
    'Hide sizing handles
    ShowHandles False
    'We need to force handles to hide themselves before drawing drag rectangle
    Refresh
    'Indicate sizing is under way
    m_DragState = StateSizing
    'Show sizing rectangle
    DrawDragRect
    'In order to detect mouse movement over any part of the form,
    'we set the mouse capture to the form and will process mouse
    'movement from the applicable form events
    SetCapture hwnd
    'Limit cursor movement within form
    GetWindowRect hwnd, rc
    ClipCursor rc
End Sub'Display or hide the sizing handles and arrange them for the current rectangld
Private Sub ShowHandles(Optional bShowHandles As Boolean = True)
    Dim i As Integer
    Dim xFudge As Long, yFudge As Long
    Dim nWidth As Long, nHeight As Long    If bShowHandles And Not m_CurrCtl Is Nothing Then
        With m_DragRect
            'Save some calculations in variables for speed
            nWidth = (picHandle(0).Width \ 2)
            nHeight = (picHandle(0).Height \ 2)
            xFudge = (0.5 * Screen.TwipsPerPixelX)
            yFudge = (0.5 * Screen.TwipsPerPixelY)
            'Top Left
            picHandle(0).Move (.Left - nWidth) + xFudge, (.Top - nHeight) + yFudge
            'Bottom right
            picHandle(4).Move (.Left + .Width) - nWidth - xFudge, .Top + .Height - nHeight - yFudge
            'Top center
            picHandle(1).Move .Left + (.Width / 2) - nWidth, .Top - nHeight + yFudge
            'Bottom center
            picHandle(5).Move .Left + (.Width / 2) - nWidth, .Top + .Height - nHeight - yFudge
            'Top right
            picHandle(2).Move .Left + .Width - nWidth - xFudge, .Top - nHeight + yFudge
            'Bottom left
            picHandle(6).Move .Left - nWidth + xFudge, .Top + .Height - nHeight - yFudge
            'Center right
            picHandle(3).Move .Left + .Width - nWidth - xFudge, .Top + (.Height / 2) - nHeight
            'Center left
            picHandle(7).Move .Left - nWidth + xFudge, .Top + (.Height / 2) - nHeight
        End With
    End If
    'Show or hide each handle
    For i = 0 To 7
        picHandle(i).Visible = bShowHandles
    Next i
End Sub'Draw drag rectangle. The API is used for efficiency and also
'because drag rectangle must be drawn on the screen DC in
'order to appear on top of all controls
Private Sub DrawDragRect()
    Dim hPen As Long, hOldPen As Long
    Dim hBrush As Long, hOldBrush As Long
    Dim hScreenDC As Long, nDrawMode As Long    'Get DC of entire screen in order to
    'draw on top of all controls
    hScreenDC = GetDC(0)
    'Select GDI object
    hPen = CreatePen(PS_SOLID, 2, 0)
    hOldPen = SelectObject(hScreenDC, hPen)
    hBrush = GetStockObject(NULL_BRUSH)
    hOldBrush = SelectObject(hScreenDC, hBrush)
    nDrawMode = SetROP2(hScreenDC, R2_NOT)
    'Draw rectangle
    Rectangle hScreenDC, m_DragRect.Left, m_DragRect.Top, _
        m_DragRect.Right, m_DragRect.Bottom
    'Restore DC
    SetROP2 hScreenDC, nDrawMode
    SelectObject hScreenDC, hOldBrush
    SelectObject hScreenDC, hOldPen
    ReleaseDC 0, hScreenDC
    'Delete GDI objects
    DeleteObject hPen
End Sub

其中， mnuModeDesign 是表示开启/关闭设计模式的菜单项目。然后你就可以添加自己的控件，在自己的控件的mousedown事件里写：Private Sub 你的控件_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbLeftButton And m_bDesignMode Then
        DragBegin 你的控件
    End If
End Sub

刚才的mainform是主窗体的代码，写不开了，你把他们复制到一起

调试易

请教一个在运行状态下调整、移动控件的算法

解决方案 »