home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / CODE_UPLOAD92278232000.psc / clsDragList.cls next >
Encoding:
Visual Basic class definition  |  2000-08-23  |  12.3 KB  |  313 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4. END
  5. Attribute VB_Name = "clsDragList"
  6. Attribute VB_GlobalNameSpace = False
  7. Attribute VB_Creatable = True
  8. Attribute VB_PredeclaredId = False
  9. Attribute VB_Exposed = False
  10. Attribute VB_Description = "Klasse zur Erstellung von DragListBoxen"
  11. Option Explicit
  12. '#############################################################
  13. '# Class: clsDragList                                        #
  14. '# Author: Jonas Wolz (jwolzvb@yahoo.de)                     #
  15. '# Description: Creates a DragListBox (using ComCtl32.dll),  #
  16. '#     and processes the windows messages sent.              #
  17. '#     It will raise events allowing you to process them     #
  18. '#     easily or it will do everything automatically.        #
  19. '# --------------------------------------------------------- #
  20. '#    Needs SSubTmr.dll from vbAccelerator                   #
  21. '#    (www.vbAccelerator.com) to implement subclassing !     #
  22. '#############################################################
  23.  
  24. 'Subclassing:
  25. Implements ISubclass
  26.  
  27. 'API-Declarations:
  28. Private Type POINTAPI
  29.     X As Long
  30.     Y As Long
  31. End Type
  32.  
  33. 'Translated from C-Header files:
  34. Private Type DRAGLISTINFO
  35.     uNotification As Long
  36.     hWndLB As Long
  37.     ptCursor As POINTAPI
  38. End Type
  39.  
  40. Private Declare Function MakeDragList Lib "Comctl32.dll" (ByVal hWndLB As Long) As Long
  41. Private Declare Function LBItemFromPt Lib "Comctl32.dll" (ByVal hWndLB As Long, ByVal X As Long, ByVal Y As Long, ByVal bAutoScroll As Long) As Long
  42. Private Declare Sub DrawInsert Lib "Comctl32.dll" (ByVal hWndLBParent As Long, ByVal hWndLB As Long, ByVal nItem As Long)
  43. Private Const DL_BEGINDRAG = 1157
  44. Private Const DL_CANCELDRAG = 1160
  45. Private Const DL_DRAGGING = 1158
  46. Private Const DL_DROPPED = 1159
  47. Private Const DRAGLISTMSGSTRING = "commctrl_DragListMsg"
  48.  
  49. 'From API-Viewer:
  50. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dst As Any, Src As Any, ByVal cBytes As Long)
  51. Private Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
  52. Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
  53. Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
  54. Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
  55. Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
  56. Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
  57.  
  58. 'For Auto Mode:
  59. Private Const LB_INSERTSTRING = &H181
  60. Private Const LB_DELETESTRING = &H182
  61. Private Const LB_ERR = (-1)
  62. Private Const LB_GETITEMDATA = &H199
  63. Private Const LB_GETTEXT = &H189
  64. Private Const LB_GETTEXTLEN = &H18A
  65. Private Const LB_SETITEMDATA = &H19A
  66. Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
  67.  
  68.  
  69. 'Private variables:
  70. Private m_hWndLB As Long, m_hWndLBParent As Long
  71. Private m_DragListMsg As Long
  72. Private m_LastIdx As Long
  73. Private m_OldMousePointer As Long, m_OldMouseIcon As IPictureDisp
  74.  
  75. 'Properties:
  76. Public DrawInsertIcon As Boolean
  77. Attribute DrawInsertIcon.VB_VarDescription = "Gibt an, ob das Icon, das den Einfⁿgepunkt markiert, gezeichnet werden soll."
  78. Public AutoScroll As Boolean
  79. Attribute AutoScroll.VB_VarDescription = "Legt fest, ob die ListBox beim  ""Draggen"" automatisch scrollen soll."
  80. 'Sets the cursor to MouseIcon (or to vbArrow if is Nothing)
  81. ' if the Mouse is over the ListBox, and to vbNoDrop otherwise
  82. Public AutoCursor As Boolean
  83. 'Exchanges the items and the ItemData automatically when finished
  84. Public AutoItems As Boolean
  85.  
  86. 'Events:
  87.  
  88. 'Cancel can be set to True to cancel the Drag&Drop
  89. Event BeginDrag(ByVal nItemIndex As Long, ByRef Cancel As Boolean)
  90. Attribute BeginDrag.VB_Description = "Wird ausgel÷st, wenn der Benutzer Drag&Drop beginnt."
  91.  
  92. 'Change the MousePointer, if needed + draw a user defined insert icon in this event
  93. ' This event is raised very often during Drag&Drop, even if the list item hasn't changed,
  94. '  so change the Cursor only if needed, not every time when the event is raised
  95. Event Dragging(ByVal nItemDragging As Long, ByVal nTargetItem As Long, ByRef ChangeCursor As dlChangeCursor, ByVal PixelX As Long, ByVal PixelY As Long)
  96. Attribute Dragging.VB_Description = "Wird wΣhrend des Drag&Drop in regelmΣ▀igen AbstΣnden ausgel÷st."
  97.  
  98. Event CancelDrag()
  99. Attribute CancelDrag.VB_Description = "Wird ausgel÷st wenn das Drag&Drop abgebrochen wird."
  100.  
  101. 'IMPORTANT: You'll have to put code to exchange the list items
  102. '    into this event if AutoItems = False !
  103. Event Dropped(ByVal nOldIdx As Long, ByVal nTargetIdx As Long)
  104. Attribute Dropped.VB_Description = "Wird ausgel÷st, wenn das Drag&Drop erfolgreich beendet wird."
  105.  
  106. 'Constants for the cursor:
  107. Enum dlChangeCursor
  108.     NoChange = 0
  109.     DL_MOVECURSOR = 3
  110.     DL_COPYCURSOR = 2
  111.     DL_STOPCURSOR = 1
  112. End Enum
  113.  
  114. Public Sub ClearInsertIcon()
  115. Attribute ClearInsertIcon.VB_Description = """L÷scht"" das Icon, das den Einfⁿgepunkt markiert."
  116.     If m_hWndLBParent <> 0 And m_hWndLB <> 0 Then
  117.         'Clear icon:
  118.         DrawInsert m_hWndLBParent, m_hWndLB, -1
  119.     End If
  120. End Sub
  121.  
  122.  
  123. Public Property Get hWndListBox() As Long
  124. Attribute hWndListBox.VB_Description = "Legt das Handle der ListBox fest, die in eine DragListBox umgewandelt werden soll, fest.\r\nKann nur einmal gesetzt werden !"
  125.     hWndListBox = m_hWndLB
  126. End Property
  127. Public Property Let hWndListBox(ByVal NewVal As Long)
  128.     Static NotFirstTime As Boolean
  129.     'Can only be set once, because MakeDragListBox()
  130.     ' cannot be "undone". So you could encounter
  131.     ' problems with the messages if you did allow
  132.     ' setting this property multiple times
  133.     If NotFirstTime Then
  134.         Err.Raise vbObjectError + 100, "DragList", "hWndListBox can only be set one time !"
  135.     End If
  136.     If IsWindow(NewVal) Then 'Valid window ?
  137.         m_hWndLB = NewVal
  138.         If Not pCreate Then Err.Raise vbObjectError + 101, "DragList", "ListBox couldn't be changed into a DragListBox !"
  139.         NotFirstTime = True
  140.     Else
  141.         Err.Raise 380
  142.     End If
  143. End Property
  144. Public Property Get LastDraggedItemIndex() As Long
  145. Attribute LastDraggedItemIndex.VB_Description = "Gibt den ListIndex des zuletzt gezogenen Listenpunkts zurⁿck."
  146.     LastDraggedItemIndex = m_LastIdx
  147. End Property
  148.  
  149. Public Property Get MouseIcon() As IPictureDisp
  150.     Set MouseIcon = m_OldMouseIcon
  151. End Property
  152.  
  153. Public Property Set MouseIcon(NewMI As IPictureDisp)
  154.     If Not (m_OldMouseIcon Is NewMI) Then
  155.         Set m_OldMouseIcon = NewMI
  156.         Set Screen.MouseIcon = NewMI
  157.     End If
  158. End Property
  159.  
  160. Private Function pCreate() As Boolean
  161.     pCreate = False
  162.     'Create DragList
  163.     If (MakeDragList(m_hWndLB) = 0) Then Exit Function
  164.     'Register DragList-Message and trap it
  165.     m_DragListMsg = RegisterWindowMessage(DRAGLISTMSGSTRING)
  166.     m_hWndLBParent = GetParent(m_hWndLB)
  167.     AttachMessage Me, m_hWndLBParent, m_DragListMsg
  168.     pCreate = True
  169. End Function
  170.  
  171.  
  172. Private Sub pDetach()
  173.     'End subclassing:
  174.     DetachMessage Me, m_hWndLBParent, m_DragListMsg
  175.     'Remove property:
  176.     RemoveProp m_hWndLB, "clsDL_WPResponse"
  177. End Sub
  178.  
  179. Public Property Let MousePointer(ByVal NewMP As VBRUN.MousePointerConstants)
  180.     If m_OldMousePointer <> NewMP Then
  181.         m_OldMousePointer = NewMP
  182.         Screen.MousePointer = NewMP
  183.     End If
  184. End Property
  185.  
  186. Public Property Get MousePointer() As VBRUN.MousePointerConstants
  187.     MousePointer = m_OldMousePointer
  188. End Property
  189. Private Sub pDoAutoItems(ByVal nOldIdx As Long, ByVal nTargetIdx As Long)
  190.     Dim strOld As String, lOldData As Long
  191.     Dim lNewIdx As Long
  192.     If Not AutoItems Then Exit Sub
  193.     If nTargetIdx < 0 Then Exit Sub
  194.     If nTargetIdx = nOldIdx Then Exit Sub
  195.     
  196.     If nOldIdx > nTargetIdx Then
  197.         lNewIdx = nTargetIdx
  198.     Else
  199.         'If you remove a item, the indexes will change:
  200.         lNewIdx = nTargetIdx - 1
  201.     End If
  202.     'Allocate Buffer:
  203.     strOld = Space$(SendMessage(m_hWndLB, LB_GETTEXTLEN, nOldIdx, ByVal 0&) + 1)
  204.     'Get the Text:
  205.     SendMessage m_hWndLB, LB_GETTEXT, nOldIdx, ByVal strOld
  206.     'Get the old ItemData:
  207.     lOldData = SendMessage(m_hWndLB, LB_GETITEMDATA, nOldIdx, ByVal 0&)
  208.     'Remove the old item:
  209.     SendMessage m_hWndLB, LB_DELETESTRING, nOldIdx, ByVal 0&
  210.     'Insert the item at the new position:
  211.     SendMessage m_hWndLB, LB_INSERTSTRING, lNewIdx, ByVal strOld
  212.     'Set the ItemData:
  213.     SendMessage m_hWndLB, LB_SETITEMDATA, lNewIdx, ByVal lOldData
  214. End Sub
  215.  
  216. Private Sub Class_Initialize()
  217.     DrawInsertIcon = True
  218.     AutoScroll = True
  219.     AutoCursor = True
  220.     AutoItems = True
  221.     m_OldMousePointer = vbDefault
  222. End Sub
  223.  
  224.  
  225. Private Sub Class_Terminate()
  226.     pDetach
  227.     Set m_OldMouseIcon = Nothing
  228. End Sub
  229.  
  230.  
  231. Private Property Let ISubclass_MsgResponse(ByVal RHS As SSubTimer.EMsgResponse)
  232.     'Not used
  233. End Property
  234.  
  235. Private Property Get ISubclass_MsgResponse() As SSubTimer.EMsgResponse
  236.     ISubclass_MsgResponse = emrConsume
  237. End Property
  238.  
  239.  
  240. Private Function ISubclass_WindowProc(ByVal hwnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  241.     If iMsg = m_DragListMsg Then
  242.         Dim DLI As DRAGLISTINFO
  243.         Dim MyCancel As Boolean, lngLI As Long
  244.         Dim Cursor As dlChangeCursor
  245.         'Copy the struct pointed to by lParam into a local one to read its data
  246.         CopyMemory DLI, ByVal lParam, Len(DLI)
  247.         If DLI.hWndLB = m_hWndLB Then 'Is it our ListBox ?
  248.             Select Case DLI.uNotification
  249.             Case DL_BEGINDRAG 'Drag&Drop started
  250.                 MyCancel = False
  251.                 'Get the Index:
  252.                 lngLI = LBItemFromPt(DLI.hWndLB, DLI.ptCursor.X, DLI.ptCursor.Y, 0)
  253.                 RaiseEvent BeginDrag(lngLI, MyCancel)
  254.                 If MyCancel Then 'The class's user has selected to cancel Drag&Drop
  255.                     ISubclass_WindowProc = 0&
  256.                 Else
  257.                     m_LastIdx = lngLI
  258.                     ISubclass_WindowProc = 1&
  259.                 End If
  260.                 If AutoCursor Then
  261.                     If m_OldMouseIcon Is Nothing Then
  262.                         MousePointer = vbArrow
  263.                     Else
  264.                         MousePointer = vbCustom
  265.                     End If
  266.                 End If
  267.             Case DL_DRAGGING 'Drag&Drop is in progress
  268.                 lngLI = LBItemFromPt(m_hWndLB, DLI.ptCursor.X, DLI.ptCursor.Y, CLng(AutoScroll))
  269.                 Cursor = NoChange
  270.                 RaiseEvent Dragging(m_LastIdx, lngLI, Cursor, DLI.ptCursor.X, DLI.ptCursor.Y)
  271.                 ISubclass_WindowProc = Cursor
  272.                 If DrawInsertIcon Then 'Draw icon if wanted
  273.                     DrawInsert m_hWndLBParent, m_hWndLB, lngLI
  274.                 End If
  275.                 If AutoCursor Then
  276.                     If lngLI < 0 Then
  277.                         MousePointer = vbNoDrop
  278.                     Else
  279.                         If m_OldMouseIcon Is Nothing Then
  280.                             MousePointer = vbArrow
  281.                         Else
  282.                             MousePointer = vbCustom
  283.                         End If
  284.                     End If
  285.                 End If
  286.             Case DL_CANCELDRAG 'Drag&Drop cancelled
  287.                 RaiseEvent CancelDrag
  288.                 'Clear icon
  289.                 DrawInsert m_hWndLBParent, m_hWndLB, -1
  290.                 If AutoCursor Then
  291.                     MousePointer = vbDefault
  292.                 End If
  293.             Case DL_DROPPED 'Drag&Drop ended successfully
  294.                 lngLI = LBItemFromPt(m_hWndLB, DLI.ptCursor.X, DLI.ptCursor.Y, 0&)
  295.                 RaiseEvent Dropped(m_LastIdx, lngLI)
  296.                 'Clear icon
  297.                 DrawInsert m_hWndLBParent, m_hWndLB, -1
  298.                 If AutoCursor Then
  299.                     MousePointer = vbDefault
  300.                 End If
  301.                 If AutoItems Then pDoAutoItems m_LastIdx, lngLI
  302.             End Select
  303.             'For several classes:
  304.             SetProp hwnd, "clsDL_WPResponse", ISubclass_WindowProc
  305.         Else
  306.             'For several classes:
  307.             ISubclass_WindowProc = GetProp(hwnd, "clsDL_WPResponse")
  308.         End If
  309.     End If
  310. End Function
  311.  
  312.  
  313.