Binaryworld - DragControl - Drag any control using the mouse ... [ VB -> Forms & Controls ]

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