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
| Sub ShowUsers(strDBfullName As String)
Dim oCn As ADODB.Connection, r As ADODB.Recordset
Dim arrCnx(), strTxt As String, strThisComputer
Dim blnIgnore As Boolean
Dim p As Integer, row As Integer, col As Integer
Set oCn = New ADODB.Connection
oCn.ConnectionString = "PROVIDER=Microsoft.Jet.OLEDB.4.0;" & _
"DATA SOURCE=" & strDBfullName
oCn.Mode = adModeRead
On Error GoTo ERRH
oCn.Open
Set r = oCn.OpenSchema(adSchemaProviderSpecific, , "{947bb102-5d43-11d1-bdbf-00c04fb92675}")
' Copie le recordset dans un tableau
' 1ere colonne (indice 0) : Ordinateur
' 2eme colonne (indice 1) : Utilisateur Access
arrCnx = r.GetRows()
r.Close
Set r = Nothing
oCn.Close
Set oCn = Nothing
' Nettoye le tableau
For row = LBound(arrCnx, 2) To UBound(arrCnx, 2)
For col = LBound(arrCnx, 1) To UBound(arrCnx, 1)
strTxt = CStr(Nz(arrCnx(col, row)))
p = InStr(1, strTxt, vbNullChar)
If p > 1 Then strTxt = Left(strTxt, p - 1)
arrCnx(col, row) = strTxt
Next
Next
' Vide la table tblConnectes
DoCmd.SetWarnings False
DoCmd.RunSQL "DELETE FROM tblConnectes"
DoCmd.SetWarnings True
' Récupère le nom de l'Ordinateur
strThisComputer = Environ("COMPUTERNAME")
If strThisComputer = "" Then
strThisComputer = NomOrdinateur()
End If
blnIgnore = True
' Ajoute les connexions dans la table à l'exception de la
' première connexion trouvée ayant le même nom d'Ordinateur
' et d'utilisateur que celui qui exécute ce code
For row = LBound(arrCnx, 2) To UBound(arrCnx, 2)
If arrCnx(0, row) = strThisComputer And _
arrCnx(1, row) = Application.CurrentUser() _
And blnIgnore Then
blnIgnore = False
Else
DoCmd.SetWarnings False
DoCmd.RunSQL "INSERT INTO tblConnectes(Ordinateur, Utilisateur) " & _
"VALUES('" & arrCnx(0, row) & "', '" & arrCnx(1, row) & "')"
DoCmd.SetWarnings True
End If
Next
' Raffraichie la liste lstConnectes
Me.lstConnectes.Requery
' Met la date et l'heure de version de la liste dans la
' zone de texte txtLstConnectesDateHeure
Me.txtLstConnectesDateHeure = Now()
Exit Sub
ERRH:
If Not r Is Nothing Then
If r.State <> adStateClosed Then r.Close
Set r = Nothing
End If
If Not oCn Is Nothing Then
If oCn.State <> adStateClosed Then oCn.Close
Set oCn = Nothing
End If
MsgBox "Erreur " & CStr(Err.Number) & " : " & Err.Description
End Sub |
Partager