[Class Access]

Salut, j'ai fais une petite class qui fais sa, donc pour access, tu as juste
a fair ConnectACCESS(chemin) etc bon, enregistrement te retourne nu
enregistrement, et affiche permet d'afficher une requette sql dans n'importe
quelle type d'element.

quelleque explication, toute les fonction zz sont des enciennefonction que
j'ai renomer au fur et a mesure je les garde juste par sousi de
compatibiliter,
tu peut les virer, sa me permet quand je rouvre un ancien projet de
remplacer rapidement les ancienne fonction, toute le code es pas fini, je
n'avais ps ma derniere class sous la main :-). mas a partire de la tu fait
nue connecionSQL2000 et ainsi de suite, c ce que j'ai fais, si tu veux la
derniere class dit le moi je te l'enverai

l'aventage, si un jour tu migre en .net, tu remplace juste dans la class le
code et tu garde tes habitude (c peut etre pas ce qu'il y a de mieux ...
mais bon) et tu peut rapidement migrer tes projet, c ce que je fais,
j'encapsule tout dans des class, maintenans c peut etre pas la meilleur
solution, mais c celle qui me convient le mieux.

' a mettre dans une class
'---------------------------------------------------------------------------
------------------
Public BaseDonne As ADODB.Connection

Private ColErreur As Collection
Private hideDateInitialisation As String

Public Function sqlUpdate(ByVal pTable As String, ByVal pChampsMAJ As
String, ByVal pCondition As String)
Dim lSql As String

If pCondition = "" Then
lSql = "update " & pTable & " set " & pChampsMAJ
Else
lSql = "update " & pTable & " set " & pChampsMAJ & " where (" &
pCondition & ")"
End If

Me.Execute lSql

End Function

Public Function strUpdate(ByVal pNumeric As Boolean, ParamArray
pTableauValeur())

Dim i As Integer
Dim lSqlRetour As String


For i = LBound(pTableauValeur) To UBound(pTableauValeur) - 1 Step 2

If i = LBound(pTableauValeur) Then

If pNumeric = True Then

lSqlRetour = pTableauValeur(i) & " = " & RPoint(pTableauValeur(i +
1), True)

Else

lSqlRetour = pTableauValeur(i) & " = '" & RCote(pTableauValeur(i +
1)) & "'"

End If

Else

If pNumeric = True Then

lSqlRetour = lSqlRetour & " , " & pTableauValeur(i) & " = " &
RPoint(pTableauValeur(i + 1), True)

Else

lSqlRetour = lSqlRetour & " , " & pTableauValeur(i) & " = '" &
RCote(pTableauValeur(i + 1)) & "'"

End If

End If

Next

strUpdate = lSqlRetour

End Function

Public Function ConnectClose()

BaseDonne.Close

End Function

Private Function zzDate() As String

zzDate = Format(Date, "yyyymmdd") & Format(Time, "hhmmss")

End Function

Private Function AjouteErreur(ByVal pSql As String)

Dim lErreur(1 To 5) As String

Static lID As Double

lID = lID + 1

lErreur(1) = lID 'Id unique pour la ligne dans le lancement du logiciel
lErreur(2) = hideDateInitialisation 'date du lancement du logiciel
lErreur(3) = zzDate 'date de l'erreur
lErreur(4) = "SQL" 'property
lErreur(5) = pSql 'valeur property

ColErreur.Add lErreur

End Function

Public Function RPoint(ByVal pChaine As String, Optional ByVal pZero As
Boolean) As String
'Remplace les virgule pardes point pour les requette SQL et retourne un
string
Dim lRetour As String


lRetour = Replace(pChaine, ",", ".")

If pZero = True Then

If lRetour = "" Then lRetour = "0"

End If

RPoint = lRetour

End Function

Public Function RCote(ByVal pChaine As String) As String
'Double les cotes pour la requette SQL
RCote = Replace(pChaine, "'", "''")
End Function

Public Function RPointDbl(ByVal pChaine As String) As Double
'Retourne un double avec une chaine de caractere,
'et convertie automatiquement la virgule en point

RPointDbl = Val(RPoint(pChaine))

End Function

Public Function Execute(ByVal pCommandTexte As String)

On Error GoTo erreur:

Me.BaseDonne.Execute pCommandTexte

Exit Function

erreur:

If pBoucle = False Then 'permet de verifier si la foncitone exectue est
executer dans une boulce d'erreur

End If

End Function

Public Function sqlSupprimerLigne(ByVal pNomTable As String, Optional
pCritere As String = "")

If pCritere = "" Then

Me.Execute "DELETE FROM " & pNomTable

Else

Me.Execute "DELETE FROM " & pNomTable & " WHERE (" & pCritere & ")"

End If


End Function

Function ChercheMax(ByVal table As String, ByVal champ As String) As String

Dim EnregistrementLocal As ADODB.Recordset
Dim SQL As String

SQL = "Select max(" & champ & ") from " & table
' créer un jeu d'enregistrements à partir de la collection fournie
Set EnregistrementLocal = New Recordset
EnregistrementLocal.CursorLocation = adUseClient
EnregistrementLocal.Open SQL, BaseDonne, adOpenForwardOnly,
adLockReadOnly

If EnregistrementLocal.RecordCount = 0 Then

ChercheMax = 0

Else
If IsNull(EnregistrementLocal(0).Value) = True Then ChercheMax = 0
Else ChercheMax = EnregistrementLocal(0).Value


End If

Set EnregistrementLocal = Nothing

End Function

Function ConnectDSN(ByVal pConnect As String)

Dim sConnect As String

' définir les chaînes

sConnect = pConnect

' ouvrir la connexion
Set BaseDonne = New Connection

BaseDonne.Open sConnect

End Function

Function ConnectACCESS(ByVal CheminBaseDonne As String)

Dim sConnect As String

' définir les chaînes

sConnect = "Provider=Microsoft.Jet.OLEDB.4.0;Password='';" & _
"User ID=Admin;" & _
"Data Source=" & CheminBaseDonne & ";" & _
"Mode=Share Deny None;Extended Properties='';" & _
"Jet OLEDB:System database='';" & _
"Jet OLEDB:Registry Path='';" & _
"Jet OLEDB:Database Password='';" & _
"Jet OLEDB:Engine Type=4;" & _
"Jet OLEDB:Database Locking Mode=0;" & _
"Jet OLEDB:Global Partial Bulk Ops=2;" & _
"Jet OLEDB:Global Bulk Transactions=1;" & _
"Jet OLEDB:New Database Password='';" & _
"Jet OLEDB:Create System Database=False;" & _
"Jet OLEDB:Encrypt Database=False;" & _
"Jet OLEDB:Don't Copy Locale on Compact=False;" & _
"Jet OLEDB:Compact Without Replica Repair=False;" & _
"Jet OLEDB:SFP=False"

' ouvrir la connexion
Set BaseDonne = New Connection

BaseDonne.Open sConnect

End Function

Function Enregistrement(ByRef pEnregistrement As ADODB.Recordset, ByVal SQL
As String)

Dim EnregistrementLocal As ADODB.Recordset
' créer un jeu d'enregistrements à partir de la collection fournie

If pEnregistrement Is Nothing Then Set pEnregistrement = New
ADODB.Recordset

Set EnregistrementLocal = New Recordset

EnregistrementLocal.CursorLocation = adUseClient
EnregistrementLocal.Open SQL, BaseDonne, adOpenForwardOnly,
adLockReadOnly

Set pEnregistrement.DataSource = EnregistrementLocal
Set EnregistrementLocal = Nothing

End Function

Public Function Affiche(ByVal pSql As String, Optional ByRef pListe As
ListBox, Optional ByRef pCombo As ComboBox, Optional pListeVieew As
ListView, Optional pAfficherNumero As Boolean = False, Optional ByVal
pNomColonne As String, Optional ByVal pLargeurColonne As String)

Dim lEnr As ADODB.Recordset
Dim lTexte As String
Dim i As Long
Dim lIndex As Long
Dim lKey As String
Dim lTexteKey As String
Dim lLargeurColonneT As Variant
Dim lLargeurColonne As Double
Dim lNomColonneT As Variant
Dim lNomColonne As String

lNomColonneT = Split(pNomColonne, "|")
lLargeurColonneT = Split(pLargeurColonne, "|")

'Cette fonction affiche dans une liste, ue combo, une listeview, le contenu
de la requette SQL
'pour la combo et la liste, la premiere colonne de la requettesql sera prise
en compte
'pour la liste view elle bouclera sur les colonnes,
'il es possible de specifier des noms de colonne dans pNomColonne, le
separateur est '|'

Me.Enregistrement lEnr, pSql

If Not pListeVieew Is Nothing Then
pListeVieew.ListItems.Clear
pListeVieew.ColumnHeaders.Clear

For i = 0 To lEnr.Fields.Count - 1

If pNomColonne = "" Then

lNomColonne = lEnr.Fields(i).Name

Else

If i < LBound(lNomColonneT) Or i > UBound(lNomColonneT) Then
lNomColonne = lEnr.Fields(i).Name
Else
lNomColonne = lNomColonneT(i)
End If

End If

If pLargeurColonne = "" Then

lLargeurColonne = 1001

Else

If i < LBound(lLargeurColonneT) Or i > UBound(lLargeurColonneT)
Then
lLargeurColonne = 1002
Else
lLargeurColonne = Val(lLargeurColonneT(i))
End If

End If

pListeVieew.ColumnHeaders.Add , "col:" & i, lNomColonne,
lLargeurColonne

Next

End If

Do While Not lEnr.EOF

lIndex = lIndex + 1

If lEnr.Fields.Count > 1 Then

lTexteKey = lEnr(1).Value

End If

If pAfficherNumero = True Then
lTexte = lIndex & " : " & lEnr(0).Value
Else
lTexte = lEnr(0).Value
End If

If Not pListe Is Nothing Then
pListe.AddItem lTexte
End If

If Not pCombo Is Nothing Then
pCombo.AddItem lTexte
End If

If Not pListeVieew Is Nothing Then

lKey = "l:" & lIndex
pListeVieew.ListItems.Add , lKey, lTexte

For i = 1 To lEnr.Fields.Count - 1

pListeVieew.ListItems(lKey).ListSubItems.Add , lKey & ":c" & i,
Nz(lEnr(i).Value)

Next

End If

lEnr.MoveNext

Loop

End Function

Public Function Nz(ByVal pValue)

If IsNull(pValue) Then
Nz = ""
Else
Nz = pValue
End If

End Function

Private Sub Class_Initialize()

Set ColErreur = New Collection
hideDateInitialisation = zzDate

End Sub

Private Sub Class_Terminate()

Set ColErreur = Nothing
'ConnectClose

End Sub
'------------------------------------------

Public Function zzStringDouble(ByVal pString) As Double

zzStringDouble = Val(zzReplaceVirgVersPoint(pString))

End Function

Function zzReplaceApostrof(ByVal Chaine As String) As String

zzReplaceApostrof = RCote(Chaine)

End Function

Function zzReplaceVirgVersPoint(ByVal Chaine As String) As String

On Error GoTo erreur

zzReplaceVirgVersPoint = RPoint(Chaine)

Exit Function

erreur:

FunErreur Err, "", "zzReplaceVirgVersPoint"
'MsgBox "Erreur n°" & Err.Number & " : " & Err.Description

End Function

Public Function zzCoteDb(ByVal pChaine As String) As String

zzCoteDb = RCote(pChaine)

End Function

Function zzFunconnectionAccess(ByVal CheminBaseAccess As String)

ConnectACCESS CheminBaseAccess

End Function

Function zzFunEnregistrement(ByRef pEnregistrement As ADODB.Recordset, ByVal
SQL As String)

Enregistrement pEnregistrement, SQL

End Function

Function zzAjouterEnregistrementListe(ByRef Enregistrement As
ADODB.Recordset, ByVal SQL As String, ByRef Liste As ListBox, Optional Num
As Boolean)

Dim Compteur As Long
Dim EnregistrementLocal As ADODB.Recordset

Set Enregistrement = Nothing
Set Enregistrement = New ADODB.Recordset

' créer un jeu d'enregistrements à partir de la collection fournie
Set EnregistrementLocal = New Recordset

EnregistrementLocal.CursorLocation = adUseClient
EnregistrementLocal.Open SQL, BaseDonne, adOpenForwardOnly, adLockReadOnly
Compteur = 0

Do While Not EnregistrementLocal.EOF

Compteur = Compteur + 1

If Num = False Then

Liste.AddItem EnregistrementLocal(0).Value

Else

Liste.AddItem Compteur & " : " & EnregistrementLocal(0).Value

End If

EnregistrementLocal.MoveNext

Loop

Set Enregistrement.DataSource = EnregistrementLocal
Set EnregistrementLocal = Nothing

End Function


'---------------------------------------------------------------------------
------------------

--
a++
Sebastien
s.dieudonne@inosys.net ou inosys@hotmail.com
---------------------------------------------------------------------------
Un addin bien sympa qui facilite la prog objet (Génération automatique de
code) et la gestion d'erreur sous VB6.0 :-)
http://www.inosys.net/genclass/vb6/addingenclass.zip