vbAccelerator - Contents of code file: frmInternalDrag.frm

VERSION 5.00
Object = "{A3A35BDB-3B6A-46F3-B662-08B8F72ECD03}#11.1#0"; "vbalTreeView.ocx"
Begin VB.Form frmInternalDrag 
   Caption         =   "vbAccelerator TreeView: Dragging in one control"
   ClientHeight    =   8340
   ClientLeft      =   4410
   ClientTop       =   1815
   ClientWidth     =   6015
   BeginProperty Font 
      Name            =   "Tahoma"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "frmInternalDrag.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   8340
   ScaleWidth      =   6015
   Begin vbalTreeViewLib.vbalTreeView tvwDrag 
      Height          =   7635
      Left            =   60
      TabIndex        =   0
      Top             =   540
      Width           =   5835
      _ExtentX        =   10292
      _ExtentY        =   13467
      OLEDropMode     =   1
      DragAutoExpand  =   -1
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin VB.Label lblInfo 
      Caption         =   $"frmInternalDrag.frx":45A2
      Height          =   435
      Left            =   60
      TabIndex        =   1
      Top             =   60
      Width           =   5865
   End
End
Attribute VB_Name = "frmInternalDrag"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private m_cIml As New cVBALSysImageList
Private m_lID As Long
Private m_shl As New Shell

Private Function validateDragLocation(nodDrag As cTreeViewNode, nodInsert As
 cTreeViewNode) As Boolean
   ' only ok if nodDrag's path is not a wholly
   ' contained child of nodInsert
   Dim sPathDrag As String
   Dim sPathInsert As String
   Dim iPos As Long
   Dim bOk As Boolean
   
   sPathDrag = nodDrag.Key
   iPos = InStr(sPathDrag, ":")
   sPathDrag = Mid(sPathDrag, iPos + 1)
   sPathInsert = nodInsert.Key
   iPos = InStr(sPathInsert, ":")
   sPathInsert = Mid(sPathInsert, iPos + 1)
   
   bOk = Not (InStr(sPathInsert, sPathDrag) = 1)
   validateDragLocation = bOk

End Function

Private Sub Form_Load()
   ' Create a System Image List:
   Set m_cIml = New cVBALSysImageList
   m_cIml.IconSizeX = 16
   m_cIml.IconSizeY = 16
   m_cIml.Create
   tvwDrag.ImageList = m_cIml.hIml
   
   tvwDrag.DragStyle = etvwDropHighlight

   ' Enumerate the shell's desktop folder for files
   Dim drives As Folder
   Set drives = m_shl.NameSpace(ssfDRIVES)
   Dim driveItem As FolderItem
   Dim nod As cTreeViewNode
   Dim count As Long
   Dim sKey As String
   For Each driveItem In drives.items
      If (driveItem.IsFolder) And (driveItem.IsFileSystem) Then
         m_lID = m_lID + 1
         sKey = m_lID & ":" & driveItem.Path
         Set nod = tvwDrag.Nodes.Add(, , sKey, driveItem.Name, _
         m_cIml.ItemIndex(driveItem.Path, True))
         nod.ItemData = 0
         m_lID = m_lID + 1
         nod.Children.Add , , "TODO:" & m_lID, "Unexpanded"
      End If
   Next

End Sub

Private Sub Form_Resize()
   '
   On Error Resume Next
   Dim lWidth As Long
   lWidth = Me.ScaleWidth - tvwDrag.left * 2
   lblInfo.Width = lWidth
   tvwDrag.Move tvwDrag.left, tvwDrag.tOp, lWidth, Me.ScaleHeight - tvwDrag.tOp
    - lblInfo.tOp
   '
End Sub

Private Sub tvwDrag_BeforeExpand(node As vbalTreeViewLib.cTreeViewNode, cancel
 As Boolean)
   '
   If InStr(node.FirstChild.Key, "TODO:") = 1 Then
      
      Screen.MousePointer = vbHourglass
      
      node.Children.Remove 1
      node.ChildSortMode = etvwAlphabetic

      Dim items As Folder
      Dim itm As FolderItem
      Dim nod As cTreeViewNode
      Dim sKey As String
      Dim iPos As Long
      sKey = node.Key
      iPos = InStr(sKey, ":")
      sKey = Mid(sKey, iPos + 1)
      Set items = m_shl.NameSpace(sKey)
      If Not items Is Nothing Then
         For Each itm In items.items
            If (itm.IsFolder) And (itm.IsFileSystem) Then
               m_lID = m_lID + 1
               sKey = m_lID & ":" & itm.Path
               Set nod = node.Children.Add(, , sKey, itm.Name, _
               m_cIml.ItemIndex(itm.Path, True))
               nod.ItemData = 0
               m_lID = m_lID + 1
               nod.Children.Add , , "TODO:" & m_lID, "Unexpanded"
            End If
         Next
      End If
      Screen.MousePointer = vbDefault
      
   End If
   '
End Sub

Private Sub tvwDrag_DragDropRequest(Data As DataObject, nodeOver As
 vbalTreeViewLib.cTreeViewNode, ByVal bAbove As Boolean, ByVal hitTest As Long)
   '
   ' Check if we're attempting to make something a child of
   ' itself:
   Dim nodDrag As cTreeViewNode
   Dim nodParent As cTreeViewNode
   
   Set nodDrag = tvwDrag.NodeFromDragData(Data)
   If Not (nodDrag Is Nothing) Then ' not a treeview node
      If validateDragLocation(nodDrag, nodeOver) Then
         
         Dim sPathFrom As String
         Dim sPathTo As String
         Dim iPos As Long
         Dim sText As String
         Dim sNewKey As String
         Dim sOldKey As String
         Dim sOldPath As String
         
         sPathFrom = nodDrag.Key
         iPos = InStr(sPathFrom, ":")
         sPathFrom = Mid(sPathFrom, iPos + 1)
         sPathTo = nodeOver.Key
         iPos = InStr(sPathTo, ":")
         sPathTo = Mid(sPathTo, iPos + 1)
         If (Right(sPathTo, 1) <> "\") Then sPathTo = sPathTo & "\"
         sPathTo = sPathTo & nodDrag.Text
         Dim sQuestion As String
         sQuestion = "Are you sure you want to move the folder " & vbCrLf _
            & nodDrag.Text & " (" & sPathFrom & ") " & vbCrLf & _
            " to " & vbCrLf & _
            nodeOver.Text & " (" & sPathTo & ") ?" & vbCrLf & vbCrLf & _
            "Note: In this demo, NO changes to your folders on disk will be
             made"
         
         If (vbYes = MsgBox(sQuestion, vbQuestion Or vbYesNo)) Then
                        
            sText = nodDrag.Text
            sOldKey = nodDrag.Key
            sOldPath = sOldKey
            iPos = InStr(sOldPath, ":")
            sOldPath = Mid(sOldPath, iPos + 1)
            
            ' Delete the source drag node:
            nodDrag.Delete
            
            m_lID = m_lID + 1
            sNewKey = m_lID & ":" & sPathTo
                                    
            ' Move nodDrag to the right location:
            
            ' Put it in the new place:
            nodeOver.Children.Add , , sOldKey, sText, _
               m_cIml.ItemIndex(sOldPath, True), m_cIml.ItemIndex(sOldPath,
                True)
               ' note we use the old key because we haven't
               ' actually physically moved the directory.
            
         End If
         
      End If
   End If
   
   '
End Sub

Private Sub tvwDrag_OLEDragOver(Data As DataObject, Effect As Long, Button As
 Integer, Shift As Integer, x As Single, y As Single, State As Integer)
   
   ' Check if we're attempting to make something a child of
   ' itself:
   Dim nodDrag As cTreeViewNode
   Dim bOk As Boolean
   
   bOk = False
   
   ' Get drag node:
   Set nodDrag = tvwDrag.NodeFromDragData(Data)
   If Not (nodDrag Is Nothing) Then ' It isn't a treeview node
   
      ' Get drag insert point
      Dim nodInsert As cTreeViewNode
      Set nodInsert = tvwDrag.DragInsertNode()
      If Not (nodInsert Is Nothing) Then ' there is no current insert point
      
         bOk = validateDragLocation(nodDrag, nodInsert)
         
      End If
      
   End If
   
   Effect = IIf(bOk, vbDropEffectMove, vbDropEffectNone)
   
End Sub

Private Sub tvwDrag_OLEStartDrag(Data As DataObject, AllowedEffects As Long)
   '
   ' Check if this is a root node:
   Dim nodDrag As cTreeViewNode
   Set nodDrag = tvwDrag.NodeFromDragData(Data)
   If (nodDrag.Parent Is Nothing) Then
      ' Cannot drag parent items
      AllowedEffects = vbDropEffectNone
   Else
      AllowedEffects = vbDropEffectMove
   End If
   '
End Sub