Dan Appleman's Visual Bas…s Guide to the Win32 API/Dan.Applmans.Visual.Basic.5.0.Programmers.Guide.To.The.Win32.API.1997.Ziff-Davis.Press.CD/VB5PG32.mdf/articles/vbdev/source/pindrag2.frm

Visual Basic Form | 1996-01-22 | 16.4 KB | 440 lines

VERSION 4.00
Begin VB.Form frmDrag
   Appearance      =   0  'Flat
   BackColor       =   &H00FFFFFF&
   Caption         =   "Dynamic Dragging Example"
   ClientHeight    =   5760
   ClientLeft      =   1095
   ClientTop       =   1485
   ClientWidth     =   7365
   BeginProperty Font
      name            =   "MS Sans Serif"
      charset         =   1
      weight          =   700
      size            =   8.25
      underline       =   0   'False
      italic          =   0   'False
      strikethrough   =   0   'False
   EndProperty
   ForeColor       =   &H80000008&
   Height          =   6165
   Left            =   1035
   LinkTopic       =   "Form1"
   ScaleHeight     =   5760
   ScaleWidth      =   7365
   Top             =   1140
   Width           =   7485
   Begin VB.CommandButton Command1
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      Caption         =   "Command1"
      Height          =   555
      Left            =   1380
      TabIndex        =   4
      Top             =   2400
      Width           =   1335
   End
   Begin VBX.ccWinHook WinHook1
      Left            =   360
      Messages        =   "PINDRAG2.frx":0000
      Monitor         =   1  'My Siblings
      Top             =   5040
   End
   Begin VB.TextBox Text1
      Appearance      =   0  'Flat
      Height          =   855
      Left            =   3240
      MultiLine       =   -1  'True
      TabIndex        =   3
      Text            =   "PINDRAG2.frx":0406
      Top             =   1380
      Width           =   3135
   End
   Begin VB.PictureBox picDrag
      Appearance      =   0  'Flat
      BackColor       =   &H00FFFFFF&
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   1695
      Left            =   2160
      ScaleHeight     =   1695
      ScaleWidth      =   2595
      TabIndex        =   0
      Top             =   3240
      Visible         =   0   'False
      Width           =   2595
   End
   Begin VB.CheckBox chkDrag
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      Caption         =   "Drag ""Design"" Mode On"
      ForeColor       =   &H80000008&
      Height          =   495
      Left            =   4320
      TabIndex        =   2
      Top             =   120
      Width           =   2835
   End
   Begin VB.PictureBox Picture2
      Appearance      =   0  'Flat
      BackColor       =   &H0000FF00&
      ForeColor       =   &H80000008&
      Height          =   1575
      Left            =   900
      ScaleHeight     =   1545
      ScaleWidth      =   1785
      TabIndex        =   1
      Top             =   540
      Width           =   1815
   End
Attribute VB_Name = "frmDrag"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
' Current drag state
' 0 - Drag mode is off
' 1 - Waiting on mouse down
' 2 - Sizing on CurrentHandle
' 3 - Moving
Dim DragState%
' 1 to 8 - indicates current handle for cursor and sizing
' 0 means cursor is not over a handle
' 1   8   7
' 2       6
' 3   4   5
Dim CurrentHandle%
Const HandleSize% = 5
' Smallest drag size (minimum size of control when sizing)
Const MinDragSizeX% = 10 ' pixels
Const MinDragSizeY% = 10 ' pixels
' Size of grab handles in twips
Dim HandleSizeTwipsX%
Dim HandleSizeTwipsY%
' Handle rectangles (twips coordinates)
Dim HandleRects(8) As Rect
' x and y reference point (previous position - pixel coordinates)
Dim Anchor(2) As Integer
Dim RefPoint(2) As Integer
' Current location of drag rectangle (pixel screen coordinates)
Dim DragRect As Rect
Dim ScreenDC%   ' Screen device context
Dim UsePen%     ' Grey pen used for dragging
' Control that we are dragging or sizing
Dim ControlToAdjust As Control
' Calculate the rectangles that describe the grab handles
Private Sub CalcHandles()
    Dim nleft%, ntop%
    Dim x%
    For x% = 1 To 8
        Select Case x%
                Case 1  ' Upper left
                        nleft% = 0
                        ntop% = 0
                Case 2, 6 ' Center left
                          ' Or center right
                        ntop% = picDrag.Height \ 2 - HandleSizeTwipsY \ 2
                Case 3  ' Bottom left
                        ntop% = picDrag.Height - HandleSizeTwipsY
                Case 4, 8   ' Bottom center
                            ' Top center
                        nleft% = picDrag.Width \ 2 - HandleSizeTwipsX \ 2
                Case 5  ' Bottom right
                        nleft% = picDrag.Width - HandleSizeTwipsX
                Case 7  ' Upper right
                        ntop% = 0
        End Select
        HandleRects(x%).top = ntop%
        HandleRects(x%).left = nleft%
        HandleRects(x%).right = nleft% + HandleSizeTwipsX
        HandleRects(x%).bottom = ntop% + HandleSizeTwipsY
    Next x%
End Sub
Private Sub chkDrag_Click()
    Dim style&
    Dim dl&
    If chkDrag.Value = 1 Then
        ' It's been clicked

        ' Place over control
        Set ControlToAdjust = picture2
        picDrag.Move -1, -1 ' Trick Windows into always moving control
        PlacePicDrag ControlToAdjust
        DragState = 1   ' Watch for mouse down
    Else
        picDrag.Visible = False
        DragState = 0
    End If
End Sub
Private Sub Command1_Click()
    ' Notice - no beep in design mode!
    Beep
End Sub
' mode  0 - Start the drag
'       1 - New position
'       2 - End the drag
Private Sub DragTheRect(ByVal mode%, ByVal x%, ByVal y%)
    Dim di%
    Static origpen%
    Static newpen%
    Select Case mode%
        Case 0
                ' Get a device context for the screen
                ScreenDC% = CreateDC("Display", 0, 0, 0)
                ' XOR line draw mode
                di% = SetROP2(ScreenDC%, R2_XORPEN)
                ' Create a grey pen and select it
                newpen% = CreatePen(PS_SOLID, 3, QBColor(8))
                origpen% = SelectObject(ScreenDC%, newpen)
                ' Don't fill the rectangle
                di% = SelectObject(ScreenDC%, GetStockObject(NULL_BRUSH))
                ' Draw the first rectangle
                Rectangle ScreenDC%, DragRect.left, DragRect.top, DragRect.right, DragRect.bottom
                ' Mark the anchor point
                Anchor(1) = x%
                Anchor(2) = y%
                ' Set the original reference to the same point
                RefPoint(1) = x%
                RefPoint(2) = y%
        Case 1  ' Called during movement
                ' Erase previous rectangle
                Rectangle ScreenDC%, DragRect.left, DragRect.top, DragRect.right, DragRect.bottom
                ' Now handle the new position
                If DragState = 3 Then
                    ' Move the rectangle
                    OffsetRect DragRect, x% - RefPoint(1), y% - RefPoint(2)
                Else ' DragState is 2 (sizing)
                    ' Adjust the size based on the grab handle in use
                    Select Case CurrentHandle
                        Case 1 To 3
                            DragRect.left = DragRect.left + x% - RefPoint(1)
                        Case 5 To 7
                            DragRect.right = DragRect.right + x% - RefPoint(1)
                    End Select
                    Select Case CurrentHandle
                        Case 3 To 5
                            DragRect.bottom = DragRect.bottom + y% - RefPoint(2)
                        Case 1, 7 To 8
                            DragRect.top = DragRect.top + y% - RefPoint(2)
                    End Select
                End If
                ' Draw the new rectangle
                Rectangle ScreenDC%, DragRect.left, DragRect.top, DragRect.right, DragRect.bottom
                RefPoint(1) = x%
                RefPoint(2) = y%
        Case 2  ' Clean up when done
                ' Erase previous rectangle
                Rectangle ScreenDC%, DragRect.left, DragRect.top, DragRect.right, DragRect.bottom
                ' Replace original pen
                di% = SelectObject(ScreenDC%, origpen)
                di% = DeleteObject(newpen)

                ' Destroy the device context
                di% = DeleteDC(ScreenDC%)
                ' Mark the final position.
                RefPoint(1) = x%
                RefPoint(2) = y%

    End Select
End Sub
' Draw the grab handles
Private Sub DrawHandles()
    Dim x%
    For x% = 1 To 8
        picDrag.Line (HandleRects(x%).left, HandleRects(x%).top)-Step(HandleSizeTwipsX, HandleSizeTwipsY), 0, BF
    Next x%
End Sub
Private Sub Form_Load()
    ' Set the size of the grab handles
    HandleSizeTwipsX% = HandleSize * Screen.TwipsPerPixelX
    HandleSizeTwipsY% = HandleSize * Screen.TwipsPerPixelY
End Sub
' Find out which (if any) grab handle is under the specified point
Private Function GetHandleForPoint%(ByVal x%, ByVal y%)
    Dim n%
    Dim pt&
    pt& = (CLng(y%) * &H10000) Or x%
    For n% = 1 To 8
        If PtInRect(HandleRects(n%), pt&) Then
            GetHandleForPoint = n
            Exit Function
        End If
    Next n
    ' It's not over a grab handle
    GetHandleForPoint = 0

End Function
' Clicked on picture
Private Sub picDrag_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim di%
    Select Case DragState%
        Case 1  ' Waiting for the click
                ' We are now entering move or drag mode
                ' Hide the drag window
                picDrag.Visible = False
                ' Clip the cursors
                SetCursorClipping
                ' Grab the capture
                di% = SetCapture(picDrag.hwnd)

                ' Position the initial drag rectangle
                GetClientRect picDrag.hwnd, DragRect
                ClientToScreen picDrag.hwnd, DragRect.left
                ClientToScreen picDrag.hwnd, DragRect.right

                If CurrentHandle% = 0 Then
                    ' It's a move
                    DragState = 3
                Else
                    ' It's a drag
                    DragState = 2
                End If
                ' Initialize the dragging
                DragTheRect 0, x \ Screen.TwipsPerPixelX, y \ Screen.TwipsPerPixelY
    End Select
End Sub
Private Sub picDrag_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim newhandle%
    Select Case DragState
        Case 1  ' Normal mouse movement - Adjust cursor
                newhandle% = GetHandleForPoint(x, y)
                ' No change
                If newhandle% = CurrentHandle% Then Exit Sub
                Select Case newhandle%
                    Case 0
                        picDrag.MousePointer = 0
                    Case 1, 5
                        picDrag.MousePointer = 8
                    Case 2, 6
                        picDrag.MousePointer = 9
                    Case 3, 7
                        picDrag.MousePointer = 6
                    Case 4, 8
                        picDrag.MousePointer = 7
                End Select
                CurrentHandle% = newhandle%

        Case 2, 3 ' Dragging or sizing
                DragTheRect 1, x \ Screen.TwipsPerPixelX, y \ Screen.TwipsPerPixelY
    End Select
End Sub
' Mouse was released
Private Sub picDrag_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim di%
    Select Case DragState%
        Case 2, 3   ' Released after move or size
                DragTheRect 2, x \ Screen.TwipsPerPixelX, y \ Screen.TwipsPerPixelY

                ' Dump cursor clipping
                ClipCursorClear 0
                ' Release the capture
                ReleaseCapture
                ' Now convert DragRect into container coordinates
                ScreenToClient ControlToAdjust.Parent.hwnd, DragRect.left
                ScreenToClient ControlToAdjust.Parent.hwnd, DragRect.right
                DragRect.left = DragRect.left * Screen.TwipsPerPixelX
                DragRect.top = DragRect.top * Screen.TwipsPerPixelY
                DragRect.right = DragRect.right * Screen.TwipsPerPixelX
                DragRect.bottom = DragRect.bottom * Screen.TwipsPerPixelY
                ' We now have the new control size/location in container
                ' coordinates.  Set the new control position
                ControlToAdjust.Move DragRect.left, DragRect.top, DragRect.right - DragRect.left, DragRect.bottom - DragRect.top
                ' And place the dragging window over this one
                PlacePicDrag ControlToAdjust
    End Select
End Sub
Private Sub picDrag_Paint()
    ' We earlier ate the WM_ERASEBKGND message
    ' Now draw the grab handles
    DrawHandles
End Sub
' Place the drag picture control over a control
Private Sub PlacePicDrag(ctl As Control)
    ' Place over control
    Dim style&
    Dim dl&
    Dim nleft&, ntop&, nwidth&, nheight&
    ' Position the drag control over the target control.
    ' Make it large enough so the grab handles fit.
    nleft& = ctl.left - HandleSizeTwipsX \ 2
    ntop& = ctl.top - HandleSizeTwipsY \ 2
    nwidth& = ctl.Width + HandleSizeTwipsX
    nheight& = ctl.Height + HandleSizeTwipsY
    ' Our drag picture control must be on top.
    picDrag.ZOrder 0
    ' Make it transparent
    style& = GetWindowLong(picDrag.hwnd, GWL_EXSTYLE)
    style& = style& Or WS_EX_TRANSPARENT
    dl& = SetWindowLong(picDrag.hwnd, GWL_EXSTYLE, style&)
    ' Note - be sure form ClipControls property is True
    picDrag.Visible = True
    picDrag.Move nleft&, ntop&, nwidth&, nheight&
    CalcHandles     ' Calcuate grab handle positions
    DragState = 1   ' Watch for mouse down
End Sub
' Set the cursor clipping based on the current handle setting
Private Sub SetCursorClipping()
    Dim rcscreen As Rect
    ' Start with a rectangle describing the form
    GetClientRect frmDrag.hwnd, rcscreen
    ' Now adjust per handle in use, Horizontal first
    Select Case CurrentHandle
        Case 0  ' Full screen, do nothing
        Case 1 To 3
            rcscreen.right = (picDrag.left + picDrag.Width) \ Screen.TwipsPerPixelX - MinDragSizeX
        Case 5 To 7
            rcscreen.left = picDrag.left \ Screen.TwipsPerPixelX + MinDragSizeX%
    End Select
    ' Now adjust the vertical dimension
    Select Case CurrentHandle
        Case 0  ' Full screen, do nothing
        Case 3 To 5
            rcscreen.top = picDrag.top \ Screen.TwipsPerPixelY + MinDragSizeX
        Case 1, 7 To 8
            rcscreen.bottom = (picDrag.top + picDrag.Height) \ Screen.TwipsPerPixelX - MinDragSizeX%
    End Select
    ' Now convert the rectangle to screen coordinates
    ClientToScreen frmDrag.hwnd, rcscreen.left
    ClientToScreen frmDrag.hwnd, rcscreen.right
    ' And set the clipping
    ClipCursorRect rcscreen
End Sub
' Set to drag the next control
Private Sub WinHook1_DelayedEvent(lvalue As Long)
    picDrag.Visible = False
    PlacePicDrag ControlToAdjust
End Sub
' Select the control to drag or size
Private Sub WinHook1_WndMessage(wnd As Integer, msg As Integer, wp As Integer, lp As Long, nodef As Integer)
    Dim ctl As Control
    Dim x%
    Dim FoundHwnd%
    Dim NotValid%
    ' We are only concerned with DragState 1
    If DragState% <> 1 Then Exit Sub
    ' Ignore mouse clicks in picDrag
    If wnd = picDrag.hwnd Then Exit Sub
    ' Also ignore clicks on the checkbox that lets us
    ' turn dragging off!
    If wnd = chkDrag.hwnd Then Exit Sub
    On Error GoTo HwndNotFound
    For x% = 0 To frmDrag.Controls.Count - 1
        FoundHwnd% = frmDrag.Controls(x%).hwnd
        If Not NotValid% And wnd = FoundHwnd% Then
            ' We are already handling this control
            If wnd = ControlToAdjust.hwnd Then Exit Sub
            WinHook1.PostEvent = 0
            Set ControlToAdjust = frmDrag.Controls(x%)
            nodef = True
            msg = 0
            Exit Sub
        End If
        NotValid% = False   ' Clear the flag
    Next x%
    ' Clear error correction
    On Error GoTo 0
    Exit Sub
HwndNotFound:
    NotValid% = True    ' Don't try to use this control
    Resume Next
End Sub