1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149
| #If Win16 Then
Declare Function SendMessage& Lib "User" (ByVal hWnd%, ByVal _
wMsg%, ByVal wParam%, lParam As Any)
#Else
Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Long) As Long
#End If
Function ListRowCalc(lstTemp As Control, ByVal Y As Single) As Integer
#If Win16 Then
Const WM_USER = &H400
Const LB_GETITEMHEIGHT = (WM_USER + 34)
#Else
Const LB_GETITEMHEIGHT = &H1A1
'Determines the height of each item in ListBox control in pixels
#End If
Dim ItemHeight As Integer
ItemHeight = SendMessage(lstTemp.hWnd, LB_GETITEMHEIGHT, 0, 0)
ListRowCalc = min(((Y / Screen.TwipsPerPixelY) \ ItemHeight) + _
lstTemp.TopIndex, lstTemp.ListCount - 1)
End Function
Function min(X As Integer, Y As Integer) As Integer
If X > Y Then min = Y Else min = X
End Function
Sub ListOrganiseItems(lstTemp As Control, ByVal OldRow As Integer, _
ByVal NewRow As Integer)
If OldRow = NewRow Then Exit Sub
On Error GoTo err
'la différence entre le NewRow et la fin de la liste pour pouvoir le localiser
'une fois qu'on supprime des éléments de la liste
Dim DifferenceFin As Integer
'la différence entre le NewRow et le début de la liste pour pouvoir le localiser
'une fois qu'on supprime des éléments de la liste
DifferenceFin = (lstTemp.ListCount - 1) - NewRow
'on stocke le nombre d'élément supprimer ayant un indexe inférieur et suppérieur à
'l'élément cible
Dim RemovedBeforeNewRow As Integer
Dim RemovedAfterNewRow As Integer
RemovedBeforeNewRow = 0
RemovedAfterNewRow = 0
'On enleve les elements selectionnés et on les stoque dans un tableau
Dim SelectedIndexes() As String
ReDim Preserve SelectedIndexes(0) As String
Dim ind As Integer
ind = 0
total = lstTemp.ListCount - 1
'IndiceReel contient l'indexe de l'item de la liste à l'origine avant qu'il soit supprimé
'comme si c'est un compteur de la liste mais sans tenir en compte des elements qu'on a supprimé
Dim IndiceReel As Integer
IndiceReel = 0
i = 0
While i <= total
If (lstTemp.Selected(i) = True) Then
SelectedIndexes(ind) = lstTemp.List(i)
'on supprime de la liste les elements selectionnés
lstTemp.RemoveItem (i)
If IndiceReel < NewRow Then
RemovedBeforeNewRow = RemovedBeforeNewRow + 1
Else
If IndiceReel > NewRow Then
RemovedAfterNewRow = RemovedAfterNewRow + 1
End If
End If
i = i - 1
total = total - 1
ReDim Preserve SelectedIndexes(ind + 1) As String
ind = ind + 1
End If
i = i + 1
IndiceReel = IndiceReel + 1
Wend
'fin stockage des elements selectionnés et leur suppressions des deux listes
'Maintenant il faut classer ces elements qu'on a enlever à leur place
Dim cpt As Integer
Dim NouvellePosition As Integer
DifferenceFin = DifferenceFin - RemovedAfterNewRow
If OldRow < NewRow Then
'On fait drag vers le bas cad descend dans la liste
For cpt = 0 To UBound(SelectedIndexes()) - 1
NouvellePosition = (lstTemp.ListCount - 1) - DifferenceFin + 1
programme.lstTemp.AddItem SelectedIndexes(cpt), NouvellePosition
Next cpt
Else ' ===> If OldRow > NewRow Then
For cpt = 0 To UBound(SelectedIndexes()) - 1
NouvellePosition = (lstTemp.ListCount - 1) - DifferenceFin
programme.lstTemp.AddItem SelectedIndexes(cpt), NouvellePosition
Next cpt
End If 'If OldRow < NewRow Then
Exit Sub
err:
MsgBox err.Description & " " & err.Number, vbCritical, "Erreur"
End Sub |
Partager