图片拖动源代码

图片拖动源代码

解决方案 »

  1.   

    类名：CRect
    Option Explicit#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 ThenPrivate 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    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
            
            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
            
            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
            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
            
            NormalizeRect
        Else
            
            NormalizeRect
            ctl.Move m_Rect.Left, m_Rect.Top, Width, Height
        End If#Else    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
      

  2.   

    Form中实现代码：
    '定义
    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 TypePrivate 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 Boolean
      

  3.   

    '实现1
    Private Sub Form_Load()
        DragInit
    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 ===========================Private 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 ================================Private Sub DragInit()
        Dim i As Integer, xHandle As Single, yHandle As Single    xHandle = 5 * Screen.TwipsPerPixelX
        yHandle = 5 * Screen.TwipsPerPixelY    For i = 0 To 7
            If i <> 0 Then
                Load picHandle(i)
            End If
            picHandle(i).Width = xHandle
            picHandle(i).Height = yHandle
            picHandle(i).ZOrder
        Next i
        
        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    Set m_CurrCtl = Nothing
    End SubPrivate Sub DragBegin(ctl As Control)
        Dim rc As RECT    ShowHandles False
        Set m_CurrCtl = ctl
        GetCursorPos m_DragPoint
        
        m_DragRect.SetRectToCtrl m_CurrCtl
        m_DragRect.TwipsToScreen m_CurrCtl
        m_DragPoint.X = m_DragPoint.X - m_DragRect.Left
        m_DragPoint.Y = m_DragPoint.Y - m_DragRect.Top
        
        Refresh
        DrawDragRect
        m_DragState = StateDragging
        ReleaseCapture
        SetCapture hwnd
        
        GetWindowRect hwnd, rc
        ClipCursor rc
    End SubPrivate Sub DragEnd()
        Set m_CurrCtl = Nothing
        ShowHandles False
        m_DragState = StateNothing
    End SubPrivate 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
            For i = 0 To (Controls.Count - 1)
                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
            Set m_CurrCtl = Nothing
            ShowHandles False
        End If
    End SubPrivate 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
            nWidth = m_DragRect.Right - m_DragRect.Left
            nHeight = m_DragRect.Bottom - m_DragRect.Top
            
            GetCursorPos pt
            
            DrawDragRect
            
            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
            
            DrawDragRect
        ElseIf m_DragState = StateSizing Then
            
            GetCursorPos pt
            
            DrawDragRect
            
            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
            
            DrawDragRect
        End If
    End Sub
      

  4.   

    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
                DrawDragRect
                m_DragRect.ScreenToTwips m_CurrCtl
                m_DragRect.SetCtrlToRect m_CurrCtl
                
                ShowHandles True
                
                ClipCursor ByVal 0&
                
                ReleaseCapture
                
                m_DragState = StateNothing
            End If
        End If
    End SubPrivate 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    Debug.Assert (Not m_CurrCtl Is Nothing)    m_DragRect.SetRectToCtrl m_CurrCtl
        m_DragRect.TwipsToScreen m_CurrCtl    m_DragHandle = Index    ShowHandles False    Refresh
        
        m_DragState = StateSizing
        
        DrawDragRect
        
        SetCapture hwnd
        
        GetWindowRect hwnd, rc
        ClipCursor rc
    End SubPrivate 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
                nWidth = (picHandle(0).Width \ 2)
                nHeight = (picHandle(0).Height \ 2)
                xFudge = (0.5 * Screen.TwipsPerPixelX)
                yFudge = (0.5 * Screen.TwipsPerPixelY)            picHandle(0).Move (.Left - nWidth) + xFudge, (.Top - nHeight) + yFudge            picHandle(4).Move (.Left + .Width) - nWidth - xFudge, .Top + .Height - nHeight - yFudge            picHandle(1).Move .Left + (.Width / 2) - nWidth, .Top - nHeight + yFudge            picHandle(5).Move .Left + (.Width / 2) - nWidth, .Top + .Height - nHeight - yFudge            picHandle(2).Move .Left + .Width - nWidth - xFudge, .Top - nHeight + yFudge            picHandle(6).Move .Left - nWidth + xFudge, .Top + .Height - nHeight - yFudge            picHandle(3).Move .Left + .Width - nWidth - xFudge, .Top + (.Height / 2) - nHeight
                
                picHandle(7).Move .Left - nWidth + xFudge, .Top + (.Height / 2) - nHeight
            End With
        End If
        
        For i = 0 To 7
            picHandle(i).Visible = bShowHandles
        Next i
    End SubPrivate Sub DrawDragRect()
        Dim hPen As Long, hOldPen As Long
        Dim hBrush As Long, hOldBrush As Long
        Dim hScreenDC As Long, nDrawMode As Long    hScreenDC = GetDC(0)
        hPen = CreatePen(PS_SOLID, 2, 0)
        hOldPen = SelectObject(hScreenDC, hPen)
        hBrush = GetStockObject(NULL_BRUSH)
        hOldBrush = SelectObject(hScreenDC, hBrush)
        nDrawMode = SetROP2(hScreenDC, R2_NOT)    Rectangle hScreenDC, m_DragRect.Left, m_DragRect.Top, _
            m_DragRect.Right, m_DragRect.Bottom    SetROP2 hScreenDC, nDrawMode
        SelectObject hScreenDC, hOldBrush
        SelectObject hScreenDC, hOldPen
        ReleaseDC 0, hScreenDC    DeleteObject hPen
    End Sub
      

  5.   

    另：窗口中放置控件Image1图形框，Picture1图片框,picHandle(0)图片框数组将其底色设为黑色Visible设为False
    菜单项：一级菜单名为：mnuMode 下级菜单名为：mnuModeDesign用于控制图片是否可拖动
    所有代码均已调试通过