Public Function FillListViewFromAdoCnx(ByRef CnxAdo As ADODB.Connection, MyLv As ListView, ByVal sSql As String, Optional ByVal bHeader As Boolean = True, Optional ByVal lFirstRow As Long = 1, Optional ByVal lLastRow As Long = 0) As Boolean
'******************************************************************************
'* Fonction remplissage de colonnes (headers / nom des tables) et des *
'* champs avec "LIMIT" définissable dans ListView à partir *
'* d'une Connexion ADO active *
'* *
'* ----------------------- *
'* -Ajout Référence projet : Microsoft ActiveX Data Objects 2.5 Library *
'* -Ajout composant : Microsoft Windows Common controls 6.0 *
'* ----------------------- *
'* *
'* ------------ *
'* Utilisation : *
'* ------------ *
'* les 5 premiers : *
'* FillListViewFromAdoCnx CnxAdo, ListView1, Sql, , 1, 5 *
' *
'* les 5 seconds : *
'* FillListViewFromAdoCnx CnxAdo, ListView1, Sql, , 6, 10 *
' *
'* du 11è à la fin : *
'* FillListViewFromAdoCnx CnxAdo, ListView1, Sql, , 11, 0 *
' *
'* tous sans Header : *
'* ListView1.ColumnHeaders.Add , , "champs 1" *
'* ListView1.ColumnHeaders.Add , , "champs 2" *
'* FillListViewFromAdoCnx CnxAdo, ListView1, Sql, False *
' *
'******************************************************************************
' init
FillListViewFromAdoCnx = False
' cnx inexistante?
If CnxAdo Is Nothing Then
Exit Function
ElseIf Not (CnxAdo.State = adStateOpen) Then
Exit Function
End If
' sql vide?
sSql = Trim$(sSql)
If LenB(sSql) = 0 Then Exit Function
' logique rows
If lFirstRow < 0 Then
Exit Function
ElseIf lLastRow < 0 Then
Exit Function
ElseIf (lLastRow > 0) And (lLastRow < lFirstRow) Then
Exit Function
End If
' variables
Dim i As Long
Dim j As Long
Dim RstAdo As New ADODB.RecordSet
Dim Itmx As ListItem
' init Listview
If bHeader Then MyLv.ListItems.Clear: MyLv.ColumnHeaders.Clear
MyLv.Visible = False
On Error GoTo Lbl_Err
' Paramètres RecordSet et lancement de la requête
RstAdo.CursorLocation = adUseClient
RstAdo.Open sSql, CnxAdo, adOpenDynamic, adLockPessimistic
' Si il n'y a pas de champs on ne fait rien
If RstAdo.Fields.Count > 0 Then
' header
If bHeader Then
' on affiche forcément toutes les colonnes puisque c'est la requête qui prévoit le retour
For i = 0 To RstAdo.Fields.Count - 1
MyLv.ColumnHeaders.Add , , RstAdo.Fields(i).Name
Next i
End If
' champs. attention!! si pas de header, il faut évidemment que la listview ait été préparée avant!
If RstAdo.RecordCount > 0 Then
' 1er champ zéro = aucun champs
If lFirstRow > 0 Then
' dernier champ zéro = tous, trop grand => on réduit au dernier
If (lLastRow = 0) Or (lLastRow > RstAdo.RecordCount) Then lLastRow = RstAdo.RecordCount
' ajoute
RstAdo.Move lFirstRow - 1
For i = lFirstRow - 1 To lLastRow - 1
Set Itmx = MyLv.ListItems.Add(, , CStr(RstAdo.Fields(0).Value))
For j = 1 To RstAdo.Fields.Count - 1
Itmx.SubItems(j) = IIf(LenB(RstAdo.Fields(j).Value) > 0, RstAdo.Fields(j).Value, vbNullString)
Next j
' passe à l'enregistrement suivant
If Not RstAdo.EOF Then RstAdo.MoveNext
Next i
' pas d'erreur
FillListViewFromAdoCnx = True
Else
' pas de champs mais pas d'erreur pour autant
FillListViewFromAdoCnx = True
End If
Else
' pas d'erreur
FillListViewFromAdoCnx = True
End If
End If
' gestion d'erreur s'il y en a eu
Lbl_Err:
If Not (Err.Number = 0) Then
FillListViewFromAdoCnx = False
Err.Clear
End If
MyLv.Visible = True
' destruction objets
RstAdo.Cancel
If Not (RstAdo.State = adStateClosed) Then RstAdo.Close
Set RstAdo = Nothing
Set Itmx = Nothing
End Function