运行时拖动控件及调整控件大小的方法

对于想用VB6开发IDE程序的人来说很实用的代码，存下备忘。

frmFormDesign.frm

Option ExplicitPrivate Type POINTAPI    X   As Long    Y   As LongEnd TypePrivate Type RECT    Left   As Long    Top   As Long    Right   As Long    Bottom   As LongEnd Type'Windows   declarationsPrivate Declare Function SetCapture Lib "user32 " (ByVal hwnd As Long) As LongPrivate Declare Function ClipCursor Lib "user32 " (lpRect As Any) As LongPrivate Declare Function ReleaseCapture Lib "user32 " () As LongPrivate Declare Function GetWindowRect _                Lib "user32 " (ByVal hwnd As Long, _                               lpRect As RECT) As LongPrivate Declare Function GetCursorPos Lib "user32 " (lpPoint As POINTAPI) As LongPrivate Declare Function GetDC Lib "user32 " (ByVal hwnd As Long) As LongPrivate Declare Function ReleaseDC _                Lib "user32 " (ByVal hwnd As Long, _                               ByVal hdc As Long) As LongPrivate Declare Function SelectObject _                Lib "gdi32 " (ByVal hdc As Long, _                              ByVal hObject As Long) As LongPrivate Declare Function DeleteObject Lib "gdi32 " (ByVal hObject As Long) As LongPrivate Declare Function GetStockObject Lib "gdi32 " (ByVal nIndex As Long) As LongPrivate Declare Function CreatePen _                Lib "gdi32 " (ByVal nPenStyle As Long, _                              ByVal nWidth As Long, _                              ByVal crColor As Long) As LongPrivate Declare Function SetROP2 _                Lib "gdi32 " (ByVal hdc As Long, _                              ByVal nDrawMode As Long) As LongPrivate 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 = 5Private Const PS_SOLID = 0Private Const R2_NOT = 6Enum ControlState    StateNothing = 0    StateDragging    StateSizingEnd EnumPrivate m_CurrCtl     As ControlPrivate m_DragState   As ControlStatePrivate m_DragHandle  As IntegerPrivate m_DragRect    As New CRectPrivate m_DragPoint   As POINTAPIPrivate m_bDesignMode As BooleanPrivate Sub Form_Load()    DragInit         'Initialize   drag   codeEnd SubPrivate Sub mnuMode_Click()    mnuModeDesign.Checked = m_bDesignModeEnd SubPrivate Sub mnuModeDesign_Click()    m_bDesignMode = Not m_bDesignMode    If Not m_bDesignMode Then        DragEnd    End IfEnd SubPrivate Sub mnuModeExit_Click()    Unload MeEnd 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 IfEnd 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 IfEnd 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 IfEnd 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 IfEnd 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 IfEnd Sub'==========================   Dragging   Code   ================================'Initialization   --   Do   not   call   more   than   oncePrivate 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 = NothingEnd Sub'Drags   the   specified   controlPrivate 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 rcEnd Sub'Clears   any   current   drag   mode   and   hides   sizing   handlesPrivate Sub DragEnd()    Set m_CurrCtl = Nothing    ShowHandles False    m_DragState = StateNothingEnd 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 IfEnd Sub'To   handle   all   mouse   message   anywhere   on   the   form,   we   set   the   mouse'capture   to   the   form.   Mouse   movement   is   processed   herePrivate 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 IfEnd Sub'To   handle   all   mouse   message   anywhere   on   the   form,   we   set   the   mouse'capture   to   the   form.   Mouse   up   is   processed   herePrivate 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 IfEnd Sub'Process   MouseDown   over   handlesPrivate 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 rcEnd Sub'Display   or   hide   the   sizing   handles   and   arrange   them   for   the   current   rectangldPrivate 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 iEnd 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   controlsPrivate 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 hPenEnd Sub

Crect.cls

Option Explicit'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 LongEnd TypePrivate Type RECT    Left   As Long    Top   As Long    Right   As Long    Bottom   As LongEnd TypePrivate Declare Function ClientToScreen Lib "user32 " (ByVal hwnd As Long, lpPoint As POINTAPI) As LongPrivate 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 = NewLeftEnd PropertyPublic Property Get Left() As Long    Left = m_Rect.LeftEnd PropertyPublic Property Let Top(NewTop As Long)    m_Rect.Top = NewTopEnd PropertyPublic Property Get Top() As Long    Top = m_Rect.TopEnd PropertyPublic Property Let Right(NewRight As Long)    m_Rect.Right = NewRightEnd PropertyPublic Property Get Right() As Long    Right = m_Rect.RightEnd PropertyPublic Property Let Bottom(NewBottom As Long)    m_Rect.Bottom = NewBottomEnd PropertyPublic Property Get Bottom() As Long    Bottom = m_Rect.BottomEnd PropertyPublic Property Let Width(NewWidth As Long)    m_Rect.Right = m_Rect.Left + NewWidthEnd PropertyPublic Property Get Width() As Long    Width = m_Rect.Right - m_Rect.LeftEnd PropertyPublic Property Let Height(NewHeight As Long)    m_Rect.Bottom = m_Rect.Top + NewHeightEnd PropertyPublic Property Get Height() As Long    Height = m_Rect.Bottom - m_Rect.TopEnd 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.TwipsPerPixelXEnd 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.YEnd 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 IfEnd 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 IfEnd Function