vbAccelerator - Contents of code file: frmTestDrag.frm

VERSION 5.00
Object = "{396F7AC0-A0DD-11D3-93EC-00C0DFE7442A}#1.0#0"; "vbalIml6.ocx"
Begin VB.Form frmImageListDragDrop 
   Caption         =   "vbAccelerator Image List Drag Drop Demonstration"
   ClientHeight    =   3435
   ClientLeft      =   2940
   ClientTop       =   2865
   ClientWidth     =   6585
   BeginProperty Font 
      Name            =   "Tahoma"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "frmTestDrag.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   3435
   ScaleWidth      =   6585
   Begin vbalIml6.vbalImageList ilsCustom 
      Left            =   3360
      Top             =   2700
      _ExtentX        =   953
      _ExtentY        =   953
      IconSizeX       =   128
      IconSizeY       =   48
      ColourDepth     =   32
   End
   Begin vbalIml6.vbalImageList ilsIcons 
      Left            =   2700
      Top             =   2700
      _ExtentX        =   953
      _ExtentY        =   953
      IconSizeX       =   32
      IconSizeY       =   32
      ColourDepth     =   32
      Size            =   154420
      Images          =   "frmTestDrag.frx":1272
      Version         =   131072
      KeyCount        =   35
      Keys            =   $"frmTestDrag.frx":26DC6
   End
   Begin VB.TextBox txtDragDrop 
      Height          =   2175
      Left            =   2520
      MultiLine       =   -1  'True
      OLEDropMode     =   2  'Automatic
      ScrollBars      =   2  'Vertical
      TabIndex        =   1
      Text            =   "frmTestDrag.frx":26F4A
      Top             =   360
      Width           =   3615
   End
   Begin VB.PictureBox picDragDrop 
      AutoRedraw      =   -1  'True
      BackColor       =   &H80000005&
      Height          =   2415
      Left            =   60
      OLEDropMode     =   1  'Manual
      ScaleHeight     =   157
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   153
      TabIndex        =   0
      Top             =   60
      Width           =   2355
   End
   Begin VB.Label lblInfo 
      Caption         =   "Text:"
      Height          =   255
      Left            =   2520
      TabIndex        =   2
      Top             =   60
      Width           =   3615
   End
End
Attribute VB_Name = "frmImageListDragDrop"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private m_cDrag As cImageListDrag

Private Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long,
 lprcUpdate As RECT, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
Private Const RDW_UPDATENOW = &H100
Private Const RDW_INVALIDATE = &H1
Private Const RDW_ALLCHILDREN = &H80
Private Const RDW_ERASE = &H4

' Processing of the Image Picture Box:
Private Type RECT
   left As Long
   top As Long
   right As Long
   bottom As Long
End Type
Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal ptX As
 Long, ByVal ptY As Long) As Long
Private m_iDragOver As Long
Private m_iDragging As Long
Private m_tR() As RECT
Private m_iOrder() As Long
Private m_iCount As Long

' Creating a custom drag image:
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 SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal
 crColor As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal
 nBkMode As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal
 crColor As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Const TRANSPARENT = 1
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As
 Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal
 wFormat As Long) As Long
Private Const DT_CENTER = &H1
Private Const DT_TOP = &H0
Private Const DT_WORDBREAK = &H10
Private Const DT_WORD_ELLIPSIS = &H40000
Private m_iLastSelStart As Long
Private m_iLastSelLength As Long

Private Sub setDragState()
   On Error Resume Next
   Dim ctl As Control
   For Each ctl In Me.Controls
      If (ctl.OLEDropMode = 0) Then ' none
         ctl.OLEDropMode = 1 ' manual
      End If
   Next
   If Me.OLEDropMode = 0 Then
      Me.OLEDropMode = 1
   End If
End Sub

Private Sub Form_Load()
   
   setDragState
   
   Set m_cDrag = New cImageListDrag
   'm_cDrag.Owner = Me ' if you set the owner, then the image is only displayed
    within that object's window
   
   Dim i As Long
   m_iCount = ilsIcons.ImageCount
   ReDim m_iOrder(1 To m_iCount) As Long
   For i = 1 To m_iCount
      m_iOrder(i) = i
   Next i
   ReDim m_tR(1 To m_iCount) As RECT
   paintIcons
   
End Sub


Private Sub Form_OLEDragOver(Data As DataObject, Effect As Long, Button As
 Integer, Shift As Integer, X As Single, Y As Single, State As Integer)
   Effect = vbDropEffectNone
End Sub

Private Sub Form_Resize()
   On Error Resume Next
   picDragDrop.Height = Me.ScaleHeight - picDragDrop.top * 2
   txtDragDrop.Move _
      txtDragDrop.left, _
      txtDragDrop.top, _
      Me.ScaleWidth - txtDragDrop.left - 4 * Screen.TwipsPerPixelX, _
      Me.ScaleHeight - txtDragDrop.top - picDragDrop.top
End Sub

Private Sub picDragDrop_MouseDown(Button As Integer, Shift As Integer, X As
 Single, Y As Single)
Dim i As Long
   i = hitTest(X, Y)
   If (i > 0) Then
      m_iDragOver = i
      m_iDragging = i
      picDragDrop.OLEDrag
   End If
End Sub

Private Sub picDragDrop_MouseMove(Button As Integer, Shift As Integer, X As
 Single, Y As Single)
   '
End Sub

Private Sub picDragDrop_OLECompleteDrag(Effect As Long)
   '
   m_cDrag.CompleteDrag
   '
End Sub

Private Sub picDragDrop_OLEDragDrop(Data As DataObject, Effect As Long, Button
 As Integer, Shift As Integer, X As Single, Y As Single)
   '
   m_cDrag.CompleteDrag
   
   Dim i As Long
   Dim j As Long
   Dim iOrder As Long
   i = hitTest(X, Y)
   If (i > 0) Then
      If Not (i = m_iDragging) Then
         If (m_iDragging < i) Then
            iOrder = m_iOrder(m_iDragging)
            For j = m_iDragging To i - 1
               m_iOrder(j) = m_iOrder(j + 1)
            Next j
            m_iOrder(i) = iOrder
         Else
            iOrder = m_iOrder(m_iDragging)
            For j = m_iDragging To i + 1 Step -1
               m_iOrder(j) = m_iOrder(j - 1)
            Next j
            m_iOrder(i) = iOrder
         End If
         paintIcons
      End If
   End If
   '
End Sub

Private Sub picDragDrop_OLEDragOver(Data As DataObject, Effect As Long, Button
 As Integer, Shift As Integer, X As Single, Y As Single, State As Integer)
   '
   Dim b() As Byte
   On Error Resume Next
   b = Data.GetData(&HFFFFB045)
   Dim s As String
   On Error GoTo 0
   s = b
   If (InStr(s, "picDragDrop") > 0) Then
      Dim i As Long
      i = hitTest(X, Y)
      If Not (i = m_iDragOver) Then
         m_iDragOver = i
         paintIcons
      End If
   Else
      Effect = vbDropEffectNone
   End If
   '
End Sub

Private Sub picDragDrop_OLEGiveFeedback(Effect As Long, DefaultCursors As
 Boolean)
   '
   m_cDrag.DragDrop
   '
End Sub

Private Sub picDragDrop_OLESetData(Data As DataObject, DataFormat As Integer)
   '
   '
End Sub

Private Sub picDragDrop_OLEStartDrag(Data As DataObject, AllowedEffects As Long)
   '
   paintIcons
   Data.SetData ilsIcons.ItemKey(m_iDragOver), vbCFText
   Dim b() As Byte
   b = "picDragDrop"
   Data.SetData b, &HFFFFB045
   AllowedEffects = vbDropEffectCopy
   m_cDrag.hImagelist = ilsIcons.hIml
   m_cDrag.StartDrag m_iOrder(m_iDragOver) - 1, -8, -8
   '
End Sub

Private Sub picDragDrop_Resize()
   paintIcons
End Sub

Private Sub paintIcons()
   '
   Dim i As Long
   Dim X As Long
   Dim Y As Long
   picDragDrop.Cls
   X = 4
   Y = 4
   For i = 1 To m_iCount
      m_tR(i).left = X
      m_tR(i).top = Y
      m_tR(i).right = X + 32
      m_tR(i).bottom = Y + 32
      ilsIcons.DrawImage m_iOrder(i), picDragDrop.hdc, X, Y, (i = m_iDragOver)
      X = X + 32 + 8
      If (X + 32 > picDragDrop.ScaleWidth) Then
         X = 4
         Y = Y + 32 + 8
      End If
   Next i
   
   m_cDrag.HideDragImage True
   picDragDrop.Refresh
   m_cDrag.HideDragImage False
   '
End Sub

Private Function hitTest(ByVal X As Long, ByVal Y As Long) As Long
Dim i As Long
   For i = 1 To ilsIcons.ImageCount
      If Not (PtInRect(m_tR(i), X, Y) = 0) Then
         hitTest = i
         Exit For
      End If
   Next i
End Function

Private Function IsInRange( _
      ByVal lIndex As Long, _
      ByVal lStart As Long, _
      ByVal lLength As Long _
   )
   IsInRange = ((lIndex >= lStart) And (lIndex <= lStart + lLength))
End Function

Private Sub txtDragDrop_MouseDown(Button As Integer, Shift As Integer, X As
 Single, Y As Single)
   If IsInRange(txtDragDrop.SelStart, m_iLastSelStart, m_iLastSelLength) Then
      txtDragDrop.SelStart = m_iLastSelStart
      txtDragDrop.SelLength = m_iLastSelLength
      txtDragDrop.OLEDrag
   Else
      m_iLastSelStart = txtDragDrop.SelStart
      m_iLastSelLength = txtDragDrop.SelLength
   End If
End Sub

Private Sub txtDragDrop_MouseUp(Button As Integer, Shift As Integer, X As
 Single, Y As Single)
   m_iLastSelStart = txtDragDrop.SelStart
   m_iLastSelLength = txtDragDrop.SelLength
End Sub

Private Sub txtDragDrop_OLECompleteDrag(Effect As Long)
   m_cDrag.CompleteDrag
   
   Dim tR As RECT
   tR.right = Me.ScaleX(txtDragDrop.Width, Me.ScaleMode, vbPixels)
   tR.bottom = Me.ScaleY(txtDragDrop.Height, Me.ScaleMode, vbPixels)
   RedrawWindow txtDragDrop.hwnd, tR, 0&, RDW_UPDATENOW Or RDW_INVALIDATE Or
    RDW_ALLCHILDREN Or RDW_ERASE
   
   m_iLastSelStart = txtDragDrop.SelStart
   m_iLastSelLength = txtDragDrop.SelLength
   
End Sub


Private Sub txtDragDrop_OLEDragOver(Data As DataObject, Effect As Long, Button
 As Integer, Shift As Integer, X As Single, Y As Single, State As Integer)
   '
End Sub

Private Sub txtDragDrop_OLEGiveFeedback(Effect As Long, DefaultCursors As
 Boolean)
   m_cDrag.DragDrop
End Sub

Private Sub txtDragDrop_OLEStartDrag(Data As DataObject, AllowedEffects As Long)
   '
   ' Get the selected text:
   Dim sText As String
   sText = txtDragDrop.SelText
   
   ' Create a memory DC for adding to the ImageList:
   Dim cMemDC As New pcMemDC
   cMemDC.Width = 128
   cMemDC.Height = 48
   
   ' Draw the text into it:
   Dim hFontOld As Long
   Dim iFnt As IFont
   Dim tR As RECT
   tR.top = 2
   tR.bottom = 2
   tR.right = 126
   tR.bottom = 46
   Set iFnt = txtDragDrop.Font
   hFontOld = SelectObject(cMemDC.hdc, iFnt.hFont)
   SetBkColor cMemDC.hdc, GetSysColor(vbHighlight And &H1F&)
   SetTextColor cMemDC.hdc, GetSysColor(vbHighlightText And &H1F&)
   DrawText cMemDC.hdc, sText, -1, tR, DT_WORDBREAK Or DT_WORD_ELLIPSIS Or
    DT_TOP
   SelectObject cMemDC.hdc, hFontOld
      
   ' Get a clone of the image:
   Dim lhBmp As Long
   lhBmp = cMemDC.hBitmap
   
   ' Add to the custom image list:
   ilsCustom.Clear
   ilsCustom.IconSizeX = 128
   ilsCustom.IconSizeY = 48
   ilsCustom.ColourDepth = ILC_COLOR32
   ilsCustom.AddFromHandle lhBmp, IMAGE_BITMAP, "CUSTOM", &H0&
   DeleteObject lhBmp
   
   m_cDrag.hImagelist = ilsCustom.hIml
   m_cDrag.StartDrag 0, 64, 24
   
   Data.SetData sText, vbCFText
   AllowedEffects = vbDropEffectCopy
   '
End Sub