Таскаемые строки в ListBox

[arthur2]

Подскажите пожалуйста, как сделать, чтобы строки в ListBox можно было мышкой перетащить выше или ниже?

Понимаю, что нужно копать в сторону OLEDragMod, но что дальше?

[Хакер]

arthur2
Никак. Используй ListView.

[arthur2]

Да нет, совместными усилиями (помогли на другом форуме) набросался доволно простой код:

Код: Выделить всё

Option Explicit

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const LB_ITEMFROMPOINT = &H1A9&
Dim SourceIndex As Long, hLst As Long

Private Sub Form_Load()
  list1.OLEDropMode = vbOLEDropManual
  list1.OLEDragMode = vbOLEDragAutomatic
  With lblK
  .AutoSize = True
  .Caption = "> "
  .Visible = False
  .Move list1.Left - .Width
  End With
 
  Dim i As Integer
  For i = 0 To 100
    list1.AddItem "kkkkkkk " & i
  Next
End Sub

Private Sub List1_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)

Dim s As String, DestIndex As Long
If Data.GetFormat(vbCFText) Then
   s = Data.GetData(vbCFText)
    DestIndex = SendMessage(list1.hWnd, LB_ITEMFROMPOINT, 0, 65536 * (Y \ Screen.TwipsPerPixelY) + (X \ Screen.TwipsPerPixelX))
    If (SourceIndex <> DestIndex) And ((DestIndex And &HFFFF0000) = 0) Then
        If SourceIndex > DestIndex Then
            list1.AddItem list1.List(SourceIndex), DestIndex
            SourceIndex = SourceIndex + 1
        Else
            list1.AddItem list1.List(SourceIndex), DestIndex + 1
        End If
        list1.RemoveItem SourceIndex
        SourceIndex = DestIndex
        list1.ListIndex = DestIndex
    End If
End If
lblK.Visible = False

End Sub

Private Sub List1_OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer)
  If Data.GetFormat(vbCFText) Then
    If Y Then lblK.Top = Y + list1.Top
    Select Case Y
    Case 0
   
    Case Is <= 100
      If list1.TopIndex Then list1.TopIndex = list1.TopIndex - 1
    Case Is >= list1.Height - 100 - lblK.Height
       list1.TopIndex = list1.TopIndex + 1
    End Select
   
  Else
    Effect = vbDropEffectNone
  End If
End Sub

Private Sub list1_OLEStartDrag(Data As DataObject, AllowedEffects As Long)
   lblK.Visible = True
   AllowedEffects = vbDropEffectMove
   SourceIndex = list1.ListIndex
End Sub


В связи с чем появился ещё один вопрос: как узнать высоту одной строки? А то подставил 100 от балды. Вроде, работает, но вдруг при каких-нибудь условиях это окажется больше высоты строки?

Ещё надо бы как-то проверить, что перетаскивается не что-то вообще, а именно строка из этого же самого списка.

И ещё вопрос: что за константа 65536?

[Хакер]

1. Этот код - не перетаскивание строк, а эмуляция перетаскивания. Неужели она устанавливает тебя?

2. TextHeight
3. Значением очень многих констант является 65536. Это 2 в 16 степени, если хочешь.

[Lumen]

Код: Выделить всё

ItemHeight = SendMessage(List1.hwnd, LB_GETITEMHEIGHT, 0, 0)

И тут ещё глянь

[arthur2]

Хакер

1. Да, эмуляция меня вполне устраивает. А чем она хуже настоящего перетаскивания? В моём случае это значительно проще, чем таскать за собой листвьюер.

2. Этого свойства у листбокса нет. Я сделал, уравняв шрифты листа и лейбла-метки, а потом взяв высоту лейбла. Но способ Lumen-a ещё проще: ItemHeight = SendMessage(List1.hwnd, LB_GETITEMHEIGHT, 0, 0)

3. Спасибо, понял - здесь это, чтобы разделить лонг на верхнее и нижнее слово.

Ещё надо бы как-то проверить, что перетаскивается не что-то вообще, а именно строка из этого же самого списка.

решил это, устанавливая в SourceIndex заведомо невозможное для листиндекса значение. Если равно -2, значит притащили снаружи.

Код: Выделить всё

Option Explicit
'Эмуляция таскания мишью пунктов листбокса

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const LB_ITEMFROMPOINT = &H1A9&
Dim SourceIndex As Long, hLst As Long

Private Sub Form_Click() 'просто чтобы заполнить список сильнее - чтобы появилась прокрутка
Form_Load
End Sub

Private Sub Form_Load()
  list1.OLEDropMode = vbOLEDropManual
  list1.OLEDragMode = vbOLEDragAutomatic
  Set lblK.Font = list1.Font
  With lblK
  .AutoSize = True
  .Caption = ">"
  .Visible = False
  .Move list1.Left - .Width
   hLst = .Height \ 2 ' вполне хватает и половины высоты списка
  End With
 
  Dim i As Integer
  For i = 0 To 5 ' заполняю лист, чтобы было что таскать
    list1.AddItem "kkkkkkk " & i
  Next
SourceIndex = -2
End Sub

Private Sub list1_OLECompleteDrag(Effect As Long)
lblK.Visible = False
SourceIndex = -2 ' выставляю заведомо невозможное для листинлекса значение

End Sub

Private Sub List1_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim s As String, DestIndex As Long

If Y < 0 Then Exit Sub

If SourceIndex = -2 Then
' здесь можно написать код того случая,
' когда что-то в список притащено не из самого списка, а снаружи
'If Data.GetFormat(vbCFText) Then
'   s = Data.GetData(vbCFText)
'End If
   Exit Sub
End If
    DestIndex = SendMessage(list1.hWnd, LB_ITEMFROMPOINT, 0, 65536 * (Y \ Screen.TwipsPerPixelY) + (X \ Screen.TwipsPerPixelX))

   If (DestIndex And &HFFFF0000) Then DestIndex = list1.ListCount - 1 ' это произходит,
'   если пункт утащен ниже последней строки, поэтому и берём последнюю строку
   
    If (SourceIndex <> DestIndex) And ((DestIndex And &HFFFF0000) = 0) Then
        If SourceIndex > DestIndex Then
            list1.AddItem list1.List(SourceIndex), DestIndex
            SourceIndex = SourceIndex + 1
        Else
            list1.AddItem list1.List(SourceIndex), DestIndex + 1
        End If
       
        list1.RemoveItem SourceIndex
        SourceIndex = DestIndex
        list1.ListIndex = DestIndex
'вообще-то, здесь нужно уравнять ещё и свойства "перемещённой" строки:
'.ItemData() ,а если стиль установлен с чекбоксами, то и  .Selected()

    End If

End Sub

Private Sub List1_OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer)
'  If Data.GetFormat(vbCFText) Then
If SourceIndex > -2 Then
    If Y Then lblK.Top = Y + list1.Top
    Select Case Y
    Case 0
   
    Case Is < hLst
      If list1.TopIndex Then list1.TopIndex = list1.TopIndex - 1
    Case Is > list1.Height - hLst - lblK.Height
       list1.TopIndex = list1.TopIndex + 1
    End Select
   
  Else
    Effect = vbDropEffectNone
'  но  можно и разрешить - если нужна возможность добавлять в список что-то снаружи
  End If
End Sub

Private Sub list1_OLEStartDrag(Data As DataObject, AllowedEffects As Long)
'это событие произойдёт, если тащим именно строку самого списка
   lblK.Visible = True
   AllowedEffects = vbDropEffectMove '
   SourceIndex = list1.ListIndex
'если же тащим что-то снаружи,AllowedEffects останется vbDropEffectCopy,
'а  SourceIndex останется -2 , то есть в событии _OLEDragDrop можно будет узнать,
'снаружи данные, или из самого списка
End Sub


[Хакер]

1. Что значит таскать?
2. Это метод любого контейнера.
3. В таком случае, это битовая маска.

[Atoman]

Вот ещё такой вариантик с DragDrop.

[arthur2]

Хакер
1. Таскать - значит подключать .ocx Это простой вариант. Он мне не подходит - органически не перевариваю лишние файлы (ты, мне кажется, тоже?).

Можно пойти сложным путём: сделать листвьюер через апи и субклассить его. Возможно, мне бы и пришлось идти этим путём, если бы мне нужны были все расчудесные дополнительные возможности листвьюера. Но мне они не нужны, так что эмуляция перетаскивания в обычном листбоксе меня вполне устраивает. Чем она плоха - никак не пойму. Зачем идти сложным (и, кстати, положа руку на сердце, малопонятным для меня) путём, грозящим в моём исполнении регулярными крахами, если есть простой и безопасный путь?

Если есть ещё какой вариант с листвюером - подскажи, думаю, пригодится. Но опять же, не для этого случая: повторю, это решение с листбоксом меня уже вполне устраивает.

Странно было бы, например, использовать ричэдит, если вполне хватает текстбокса. Зачем в булочную ездить на такси?

2. Контейнер не обязан иметь тот же шрифт, что и контрол, а значит шрифты уровнять всё равно надо (раз), у фреймов тоже нет этого свойства (два). В любом случае, не факт, что высота одного итема обязательно равна высоте строки - а вдруг при разных настройках системы между итемами разные расстояния. Так что правильный способ всё-таки ItemHeight = SendMessage(List1.hwnd, LB_GETITEMHEIGHT, 0, 0). Но, поять же в данном конкретном случае это совершенно не важно - достаточно оказалось половины от высоты строки, чтобы спискок нормально прокручивался при перетаскивании.

3. Я не понял, о чём это. Про число я спрашивал в связи со строкой в коде: 65536 * (Y \ Screen.TwipsPerPixelY) + (X \ Screen.TwipsPerPixelX)). Сначала я не понял, как это работает. После твоей ремарки про степень двух понял - так Υ и Χ упаковываются в одну переменную лонг - игрек в старшее слово, икс в младшее. Я неправильно понял или неправильно сформулировал?

4. Чем тебе всё-таки не нравится ЭТО решение?

Atoman
Спасибо. Но в этом коде не показывается положение, в которое происходит перетаскивание, и список при перетаскивании за пределы видемых строк не прокручивается. Если всё это дописать, получится почти то же самое, что и у меня.

Но OLEDrag всё же лучше, чем просто Drag.