Login | Register   
LinkedIn
Google+
Twitter
RSS Feed
Download our iPhone app
TODAY'S HEADLINES  |   ARTICLE ARCHIVE  |   FORUMS  |   TIP BANK
Browse DevX
Sign up for e-mail newsletters from DevX


Tip of the Day
Language: VB4/32,VB5,VB6
Expertise: Advanced
Aug 19, 2000

DragControl - Drag any control using the mouse

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Type RECT
    Left    As Long
    Top     As Long
    Right   As Long
    Bottom  As Long
End Type

Private Declare Function ClipCursor Lib "user32" (lpRect As RECT) As Long
Private Declare Function ClipCursorByNum Lib "user32" Alias "ClipCursor" (ByVal _
    lpRect As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As _
    Integer
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, _
    lpRect As RECT) As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, _
    lpPoint As POINTAPI) As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, _
    lpRect As RECT, ByVal bErase As Long) As Long
Private Declare Function InvalidateRectByNum Lib "user32" Alias _
    "InvalidateRect" (ByVal hwnd As Long, ByVal lpRect As Long, _
    ByVal bErase As Long) As Long

' Drag a control until the user releases all mouse buttons
'
' You should call this routine from the MouseDown event procedures
' of the controls that you want to make draggable, after
' you determine that the user has initiated a drag operation.
' For example, if you want to let the user drag controls
' using the Ctrl+Right button combination, add this code
' to their MouseDown procedure:
'
' Private Sub Command1_MouseDown(...)
'    If Button = vbRightButton And Shift = vbCtrlMask Then
'        DragControl Command1
'    End If
' End Sub
'
' From that point on, this procedure takes the control and
' exits only when the user releases all mouse buttons

Sub DragControl(ctrl As Control)
    Dim startButton As Integer
    Dim startPoint As POINTAPI
    Dim currPoint As POINTAPI
    Dim contRect As RECT
    Dim contScaleMode As Integer
    
    ' get mouse position and buttons pressed
    GetCursorPos startPoint
    If GetAsyncKeyState(vbLeftButton) Then startButton = vbLeftButton
    If GetAsyncKeyState(vbRightButton) Then startButton = startButton Or _
        vbRightButton
    If GetAsyncKeyState(vbMiddleButton) Then startButton = startButton Or _
        vbMiddleButton
        
    ' get container upper-left corner position
    ' in screen coordinates (currPoint is Zero)
    ClientToScreen ctrl.Container.hwnd, currPoint
    ' get container size
    GetClientRect ctrl.Container.hwnd, contRect
    ' convert to screen coordintes
    contRect.Left = currPoint.X
    contRect.Top = currPoint.Y
    contRect.Right = contRect.Right + currPoint.X
    contRect.Bottom = contRect.Bottom + currPoint.Y
    ' limit the cursor within the parent control
    ClipCursor contRect
    
    ' get the ScaleMode that is active for the control
    ' this is the ScaleMode of its container, or it
    ' is vbTwips if its container does not support
    ' the ScaleMode property
    On Error Resume Next
    contScaleMode = vbTwips
    ' ignore next assignement if the container
    ' dows not support ScaleMode property
    contScaleMode = ctrl.Container.ScaleMode
    
    Do
        ' exit if all mouse buttons are released
        If (startButton And vbLeftButton) = 0 Or GetAsyncKeyState(vbLeftButton) _
            = 0 Then
            If (startButton And vbRightButton) = 0 Or GetAsyncKeyState _
                (vbRightButton) = 0 Then
                If (startButton And vbMiddleButton) = 0 Or GetAsyncKeyState _
                    (vbMiddleButton) = 0 Then
                    Exit Do
                End If
            End If
        End If
        
        ' get current mouse position
        GetCursorPos currPoint
        
        ' move the control if they are different
        If currPoint.X <> startPoint.X Or currPoint.Y <> startPoint.Y Then
            ' move the control
            With ctrl.Parent
                ctrl.Move ctrl.Left + .ScaleX(currPoint.X - startPoint.X, _
                    vbPixels, contScaleMode), ctrl.Top + .ScaleY(currPoint.Y - _
                    startPoint.Y, vbPixels, contScaleMode)
                ' refresh container
                InvalidateRectByNum .hwnd, 0, False
                .Refresh
            End With
            LSet startPoint = currPoint
        End If
        
        ' allow background processing
        DoEvents
    Loop
    
    ' restore full mouse movement
    ClipCursorByNum 0
End Sub
Francesco Balena
 
Comment and Contribute

 

 

 

 

 


(Maximum characters: 1200). You have 1200 characters left.

 

 

Sitemap
Thanks for your registration, follow us on our social networks to keep up-to-date