Stephle
Messages postés10Date d'inscriptionlundi 17 mars 2003StatutMembreDernière intervention 3 août 2004
-
15 mai 2003 à 09:33
cs_Sator2
Messages postés137Date d'inscriptionsamedi 11 septembre 2004StatutMembreDernière intervention10 septembre 2006
-
12 avril 2005 à 20:03
Slt tt le monde
Quelqu'un pourrait-il me dire quelle erreur il y a dans le source suivant quant au rafraichissement du pointeur de table.
En effet, quand je veux changer de table pour récupérer champs et valeurs, j'ai une erreur du type '3709'.
Répondez moi le plus vite possible, c'est urgent
Voici mon source (inspiré de MonsterMax que je remercie par ailleurs, meme si son code est peu commenté ;-)) )
Merci d'avance...
=========================================
'fonction de traitement des champs d'une table ACCESS
Public Function trait_champs(la_table As String)
Dim requete, champs, valeurs, valeur, champ, type_champ, attribut_champ As Variant
Dim le_champ, le_type, l_attribut, la_taille As Variant
Dim SQL, order_by, tampon, tampon0 As String
Dim I, msg As Integer
Dim condition As Boolean
Dim obj As Variant
'*** creation d'une nouvelle table ***
Dim les_champs() As Variant
ReDim les_champs(0)
'recuperation des infos BDD source
SQL = "SELECT * FROM " & la_table
msg = MsgBox(SQL, vbOKOnly)
rs_table.Open SQL
'on liste les champs de la table source
If Not rs_table.EOF Then
For I = 0 To rs_table.Fields.Count - 1
ReDim Preserve les_champs(I)
Set les_champs(I) = rs_table.Fields(I)
Next
order_by = "ORDER BY " & rs_table.Fields(0).Name
Else
order_by = ""
End If
'creation de table
If Check5.Value = Checked Then
' 'listage des tables destination
' Set table_srce = cn_dest.OpenSchema(adSchemaTables)
' While Not table_srce.EOF
' If Left(table_srce("TABLE_NAME"), 3) <> "sys" Then
' If table_srce("TABLE_NAME") <> "dtproperties" Then
' tabsrce(I) = table_srce("TABLE_NAME")
' I = I + 1
' End If
' End If
' table_srce.MoveNext
' Wend
' table_srce.Close
' 'suppression d'une table si elle existe
' For I = 1 To 200
' If tabsrce(I) <> "" Then
' If tabsrce(I) = la_table Then
' SQL = "DROP TABLE " & la_table
' If Check4.Value <> Checked Then cn_dest.Execute SQL
' End If
' End If
' Next I
' SQL = "DROP TABLE " & la_table & " IF EXISTS" '(SELECT * FROM " & la_table & ")"
' If Check4.Value <> Checked Then cn_dest.Execute SQL
If UBound(les_champs) > 0 Then
For I = 0 To UBound(les_champs)
le_champ = Trim(les_champs(I).Name)
le_type = les_champs(I).Type
l_attribut = les_champs(I).Attributes
la_taille = les_champs(I).DefinedSize
If LCase(le_champ) "from" Then le_champ "de" If LCase(le_champ) "to" Then le_champ "pour"
tampon0 = le_champ If l_attribut 16 Then tampon0 tampon0 & " bigint" If l_attribut 116 And le_type <> 135 Then tampon0 tampon0 & " bigint" If l_attribut 116 And le_type 135 Then tampon0 = tampon0 & " datetime" If l_attribut 100 Then tampon0 tampon0 & " varchar(" & la_taille & ")" If l_attribut 230 Then tampon0 tampon0 & " text" If l_attribut 20 Then tampon0 tampon0 & " bigint" If l_attribut 16 Or I 0 Then tampon0 = tampon0 & " NOT NULL"
tampon = tampon & tampon0 & "," & vbCrLf
Next I
If les_champs(0).Attributes 16 Or les_champs(0).Attributes 116 Then tampon = tampon & "PRIMARY KEY (" & les_champs(0).Name & ")" & vbCrLf
tampon = tampon & ")" & vbCrLf
'Msg = MsgBox(tampon, vbOKOnly)
Debug.Print tampon
If Check4.Value <> Checked Then cn_dest.Execute tampon
Else
Exit Function
End If
End If
rs_table.Close
'*** effacement de la table de destination si coché ***
If Check6.Value = Checked Then
SQL = "DELETE FROM " & la_table
'Msg = MsgBox(SQL, vbOKOnly)
If Check4.Value <> Checked Then cn_dest.Execute SQL
End If
'*** insertion des données dans la table de destination ***
While Not rs_table.EOF
champs = ""
valeurs = ""
For Each le_champ In rs_table.Fields
valeur = le_champ.Value
champ = le_champ.Name
type_champ = le_champ.Type
attribut_champ = le_champ.Attributes
If Check5.Value = Checked Or attribut_champ <> 16 Then If LCase(champ) "from" Then champ "de" If LCase(champ) "to" Then champ "pour"
condition = True
If condition Then
If Not IsNull(valeur) Then
If champs <> "" Then champs = champs & ","
champs = champs & champ
valeur = Replace(valeur, "'", "''")
If type_champ <> 3 Then valeur = "'" & valeur & "'"
If type_champ = 11 Then
If valeur = "'Vrai'" Then
valeur = 1
Else
valeur = 0
End If
End If
If valeurs <> "" Then valeurs = valeurs & ","
valeurs = valeurs & valeur
End If
End If
End If
Next
If champs <> "" And valeurs <> "" Then
valeurs = Replace(valeurs, vbCrLf, "")
requete = "INSERT INTO " & la_table & " (" & champs & ") VALUES (" & valeurs & ")"
'Msg = MsgBox(requete, vbOKOnly)
Debug.Print requete
If Check4.Value <> Checked Then cn_dest.Execute requete
End If
rs_table.MoveNext
Wend
'suppression valeurs table source
If Check8.Value = Checked Then
SQL = "DELETE FROM " & la_table
If Check4.Value <> Checked Then cn_srce.Execute SQL
End If
Principale.Label16.Caption = Principale.Label16.Caption & ", Conversion BDD OK"
'fermeture des connexions
rs_table.Close
flag1_cnx = False
flag2_cnx = False
End Function
===================================================================
'fonction de traitement conversion SQL
Public Function trait_SQL()
Dim msg, I, J As Integer
Dim str, chemin As String
'chemin du fichier
If Text5.Text <> "" Then
chemin = Text5.Text & file_srce
Else
Principale.Label16.Caption = "Aucun fichier n'est chargé..."
End If
'test validité connexion SQL
'verification validité fichier source par son extension
If flag_copy = True Then
If testpresfile(chemin) <> True Then
Principale.Label16.Caption = "Fichier inexistant"
Else
If StrComp(chemin, str_avant) <> 0 Then
str_avant = chemin 'rechargement du chemin fichier source
Principale.Label16.Caption = "Le fichier a changé. Revalidez la configuration serveur..."
Else
str = Mid(chemin, Len(chemin) - 3)
str = StrConv(str, vbLowerCase) 'conversion en minuscule au cas où l'extension ne l'est pas
If str <> ".mdb" Then 'fichier ACCESS seulement
Principale.Label16.Caption = "Fichier base de données non valide..."
Else
'listage des tables
I = 1
Set rs_table = cn_srce.OpenSchema(adSchemaTables)
While Not rs_table.EOF
If Left(rs_table("TABLE_NAME"), 4) <> "MSys" Then
table(I) = rs_table("TABLE_NAME") 'recupere le nom des tables
'Msg = MsgBox("table: " & table(I), vbOKOnly)
I = I + 1
End If
rs_table.MoveNext
Wend
rs_table.Close
For J = 1 To I - 1
Call trait_champs(table(J))
Next J
'fermeture des connexions
cn_dest.Close
cn_srce.Close
End If
End If
End If
End If
End Function
====================================================================
'Fonction de connexion SQL
Public Function connect_SQL()
Dim msg, I As Integer
Dim str As String
'ouverture d'une connexion ADO
'text1.text: nom du serveur
'text2.text: nom de la base
'text3.text: login
'text4.text: password
'vidage tampon des labels
Label7.Caption = "Connexion..."
Label8.Caption = "Connexion..."
verif_ok = ""
str = ""
'fermeture des connexions si déjà ouverte
If flag1_cnx = True Then
cn_srce.Close
flag1_cnx = False
End If
If flag2_cnx = True Then
cn_dest.Close
flag2_cnx = False
End If
On Error GoTo erropen
'Authentification = Windows NT
If Option3.Value = True Then
'ouverture d'une connexion avec le provider
c_string = "Provider=Microsoft OLE DB Provider for SQL Server;" & "Integrated Security=SSPI;" & "Data Source=" & Text1.Text & ";" & "Initial Catalog=" & Text2.Text
cn_dest.ConnectionString = c_string
End If
'Authentification SQL sécurisée
If Option4.Value = True Then
'ouverture d'une connexion avec le provider
c_string = "Provider=Microsoft OLE DB Provider for SQL Server;" & "Data Source=" & Text1.Text & ";" & "Initial Catalog=" & Text2.Text & ";" & "User ID=" & Text3.Text & ";" & "Password=" & Text4.Text
cn_dest.ConnectionString = c_string
End If
cn_dest.ConnectionTimeout = 10
cn_dest.Open
flag2_cnx = True
'etat de la connexion
Label8.Caption = "OK"
'verification validité fichier source par son extension
If options.Text4.Text = "" Then
msg = MsgBox("Aucun fichier source n'est chargé dans la fenêtre MAJ automatique", vbExclamation, "Attention")
Else
str = Mid(options.Text4.Text, Len(options.Text4.Text) - 3)
str = StrConv(str, vbLowerCase) 'conversion en minuscule au cas où l'extension ne l'est pas
If str = ".mdb" Then 'fichier ACCESS seulement
c_string2 = "Driver={Microsoft Access Driver (*.mdb)};DBQ=" & options.Text4.Text
cn_srce.ConnectionString = c_string2
cn_srce.Open
flag1_cnx = True
Else
'etat de la connexion
Label7.Caption = "Erreur"
End If
End If
'etat de la connexion
Label7.Caption = "OK"
erropen:
I = 1
On Error Resume Next
Set errs1 = cn_dest.Errors
Set errs2 = cn_srce.Errors
For Each errloop In errs1
With errloop
msg = MsgBox("Erreur ADO #" & .Number & " Description: " & .Description & " Source: " & .Source, vbExclamation, "Attention!")
I = I + 1
'etat de la connexion
Label8.Caption = "Erreur"
End With
Next
cs_Sator2
Messages postés137Date d'inscriptionsamedi 11 septembre 2004StatutMembreDernière intervention10 septembre 2006 12 avril 2005 à 20:03
Salut j'ai aussi eu un prob de rafraichissement avec Ado.... mais c'était d'une forme à une autre via une table access.... et je me suis rendu compte au bout de deux heures de travail acharné qu'il fallait laissé à l'ordi le temps de réfléchir donc un timer... 3 seconde.... mais fait des essais.... et le tour était joué....
@+Sator
