TRANSFERT DONNÉES ACCESS

---

Commentaire sur cette source (0)
Ajouter un commentaire et/ou une note

Permet d'importer des données d'une table choisie pour tous les noms de champs qui correspondent. Evidement une adaptation au besoin est toujours nécessaire et j’attends de connaître toutes les subtilités ADO pour refaire cette source.

J'ai un souci avec les .zip, j'atterris sur une page d'erreur alors désolé mais pour le formulaire va falloir imaginer

Et surtout je dois préciser que j'attend juste de maîtriser un peu plus ADO pour modifier cette source.

Option Compare Database

Public tableAchercher


'*************************************************************************************************************************
'*********************FONCTIONS ET PROCEDURES CONCERNANT LE FORMULAIRE****************************************************
'*************************************************************************************************************************

Private Sub propriete_Click()
Call deleteTable("table2")
Call listeProriete([Form_transfert], "table2")
End Sub

Private Sub choixFichier_Click() ' bouton nommé choix fichier ras
On Error GoTo ErrorHandlerChoixFichier
Dim oDialog As Object
Dim NomFichier As String
Set oDialog = choisirAutreBase.object ' active X common dialog
With oDialog
.DialogTitle = "fichier à importer"
.Filter = "Fichiers (*.mdb)|*.mdb"
'.Filter = "Fichiers (*.*)|*.*"
.FilterIndex = 1
.ShowOpen
If Len(.FileName) > 0 Then
nomLivrable.Caption = .FileName ' nomLivrable c'est juste une etiquette pour recupérer un nom, plus stable qu'une variable
End If
End With
ErrorHandlerChoixFichier:
Call ajoutErreur(Err.Description, "echec choix fichier")
param.Caption = "fichier choisi" & vbCrLf & "choisissez vos option et cliquez" & vbCrLf & "sur le bouton transferer"
Err.Clear
End Sub

Private Sub Commande0_Click() ' je n'ai pas pris le temp de renommer ce bouton dsl c'est pas bien

param.Caption = "Calculs en cours" & vbCrLf & "veuillez patienter" & vbCrLf & "le temps d'attente est de quelques minutes maximum"
tableAchercher = table

Call transfereTable

Call exporter

'etiquette
param.Caption = "calcul terminé" & vbCrLf & "fichier excel livré" & vbCrLf & "vous pouvez choisir un autre fichier"


End Sub

Private Sub Étiquette41_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call recupForm([Form_transfert], "table1")
'Call recupForm("Me.Name", "table1")
End Sub

Private Sub Étiquette43_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call deleteTable("table1")
End Sub
Public Sub deleteTable(table)
Dim dbs
Set dbs = CurrentDb
On Error GoTo errorHandlerDeleteTable
dbs.Execute ("delete * from " & table)
errorHandlerDeleteTable:
Err.Clear
dbs.Close
Set dbs = Nothing

End Sub

'*************************************************************************************************************************
'******************PROPRITE DES CONTROLES ET AJOUT DE CHAMPS NON EXISTANTS************************************************

Public Sub nonErrorPropreties(rst, ctl, prp, formulaire, listeControle)
On Error GoTo errorHandlerProperties
'        rst(formulaire(formulaire(ctl).Name).Properties(prp).Name) = formulaire(formulaire(ctl).Name).Properties(prp).Name & " = " & formulaire(formulaire(ctl).Name).Properties(prp).Value
Dim a, b
a = formulaire(formulaire(ctl).Name).Properties(prp).Name
b = formulaire(formulaire(ctl).Name).Properties(prp).Value
                listeControle = listeControle & a & " = " & b & " , " & Chr(9)
                rst("propriete" & prp) = a & " = " & b
errorHandlerProperties:
Err.Clear
End Sub
Private Sub Form_Load()
ouvre_livrable = True 'c'est juste une "check box" ou case option apres le transfert on ouvre ou pas le fichier excel resumant la transaction
End Sub
'*************************************************************************************************************************
'*************************************************************************************************************************
Public Sub listeProriete(formulaire, table)
Dim listeControle
Call tableExistsForced(table)
Dim ctlValue, ctlName
Dim ctl As Integer
Dim prp As Integer
Dim dbs
Set dbs = CurrentDb


Dim rst As DAO.recordset
Set rst = dbs.OpenRecordset(table)
Dim nombreControles, nombreProprietes
nombreControles = formulaire.Controls.Count - 1
For ctl = 0 To nombreControles
    '------------------D ABORD FORCER L EXISTANCE DES CHAMPS-----------------------------------------
    Call champExistForced(rst, dbs, formulaire, ctl, prp, table, "nomControle")
    For prp = 0 To formulaire(formulaire(ctl).Name).Properties.Count - 1
    Call champExistForced(rst, dbs, formulaire, ctl, prp, table, "propriete" & prp)
    Next prp
        
    '----------------ensuite entrer les val-----------------------------------
rst.AddNew
        listeControle = formulaire(ctl).Name & " : " & Chr(9)
       Call transfertNameControl(formulaire, ctl, rst, table, "nomControle")
       nombreProprietes = formulaire(formulaire(ctl).Name).Properties.Count - 1
        For prp = 0 To nombreProprietes
'                listeControle = listeControle & formulaire(formulaire(ctl).Name).Properties.Name & " = " & formulaire(formulaire(ctl).Name).Properties.values
                Call nonErrorPropreties(rst, ctl, prp, formulaire, listeControle)
        Next prp
rst.Update
Call writeInFile("C:\proprietes.txt", listeControle)
listeControle = ""
Next ctl

End Sub
Public Sub champExistForced(rst, dbs, formulaire, ctl, prp, table, nouvChamp)
'If Not champExist(rst, formulaire(ctl).Name) Then
        rst.Close
        Set rst = Nothing
On Error GoTo ErrorHandlerchampExistForced
        dbs.Execute ("alter table " & table & " ADD " & nouvChamp & " Varchar(100) NULL")
ErrorHandlerchampExistForced:
        Set rst = dbs.OpenRecordset(table)
Err.Clear
'End If
End Sub
'*************************************************************************************************************************
'*********FONCTIONS ET PROCEDURES POUR LE TRANSFERT DE DONNEES DU FORMULAIRE VERS TABLE***********************************
'*************************************************************************************************************************
Public Sub recupForm(formulaire, table)
Dim dbs
Set dbs = CurrentDb
Dim rst As DAO.recordset
Set rst = dbs.OpenRecordset(table)
Dim ctl As Integer

rst.AddNew
For ctl = 0 To formulaire.Controls.Count - 1
Call tranfertControl(formulaire, ctl, rst, table)
Next ctl

'*************************************
rst("champ3") = "5"
rst("champ4") = "6"
rst(7) = "7"
rst(8) = "8"
rst.Update
'*************************************

End Sub
Public Sub transfertNameControl(formulaire, ctl, rst, table, champ)
Dim ctlValue, ctlName
On Error GoTo ici
If champExist(rst, champ) Then
ctlValue = formulaire(formulaire(ctl).Name).Value
ctlName = formulaire(ctl).Name
rst(champ) = ctlName & " = " & ctlValue
End If
ici:
Err.Clear

End Sub
Public Sub tranfertControl(formulaire, ctl, rst, table)
Dim ctlValue, ctlName
On Error GoTo labas
If champExist(rst, formulaire(ctl).Name) Then
ctlValue = formulaire(formulaire(ctl).Name).Value
ctlName = formulaire(ctl).Name
rst(ctlName) = ctlValue
End If
labas:
Err.Clear
End Sub

Public Function champExist(rst, champ)
'Set dbs = CurrentDb
'Set RstGlo = dbs.openrecordset("Global")

Dim existanceVerifie
existanceVerifie = False
On Error GoTo ErrorHandlerChampExist
If rst(champ).Name = rst(champ).Name Then existanceVerifie = True
'MsgBox RstGlo(champ).Name
ErrorHandlerChampExist:
Err.Clear
champExist = existanceVerifie
End Function

'*************************************************************************************************************************
'*************************TOUT POURRI CA MARCHE PAS**********************************************************************
'Public Function testExistanceTable(table)
'Dim caExiste, a
'caExiste = False
'Dim dbs
'Set dbs = CurrentDb
'Dim rst As DAO.recordset
'On Error GoTo ErrorInTestExistanceTable
'Set rst = dbs.OpenRecordset("Select * from sysobjects where name='" & table & "' and Xtype='U'")
'a = rst("name")
'If rst("name") = table Then caExiste = True
'rst.Close
'ErrorInTestExistanceTable:
'Err.Clear
'Set dbs = Nothing
'Set rst = Nothing
'testExistanceTable = caExiste
'End Function
'Public Function tableExists(table, rst, dbs)
'Dim caExiste
'caExiste = False
'On Error GoTo tabDontExist
'Set rst = dbs.OpenRecordset("Select * from sysobjects where name='" & table & "' and Xtype='U'")
'If rst("name") = table Then caExiste = True
'rst.Close
'tabDontExist:
'Err.Clear
'tableExists = caExiste
'End Function
'*************************************************************************************************************************
'*************************************************************************************************************************

Public Sub tableExistsForced(table)
Dim dbs
Dim rst As DAO.recordset
On Error GoTo tableExiste
Set dbs = CurrentDb
    dbs.Execute ("CREATE table " & table)
tableExiste:
Err.Clear
Set dbs = Nothing
Set rst = Nothing
End Sub

'*************************************************************************************************************************
'*********FONCTIONS ET PROCEDURES POUR LE TRANSFERT DE DONNEES************************************************************
'*************************************************************************************************************************

Public Function finFichier(objet)
Dim varBooleenne
varBooleenne = True
On Error GoTo ErrorHandlerfinfichier
varBooleenne = objet.EOF
ErrorHandlerfinfichier:
Call ajoutErreur(Err.Description, "il n'y pas pas données récoltées?")
Err.Clear
finFichier = varBooleenne
End Function


Public Sub nonErrorActionMoveFirst(rst)
On Error GoTo ErrorHandlerEnregistrement
RsQual.MoveFirst
ErrorHandlerEnregistrement:
Call ajoutErreur(Err.Description, "pas de données récupérées")
Err.Clear
End Sub

Public Sub ajoutErreur(textErreur, comentaireSuplementaire) 'listes des erreurs rencontrées dans une etiquette pour ne pas arreter le processus
If Len(journalErreurs.Caption) < 1000 Then
If InStr(1, journalErreurs.Caption, comentaireSuplementaire) < 1 Then
journalErreurs.Caption = journalErreurs.Caption & " ERROR:" & textErreur & " commentaire: " & comentaireSuplementaire
End If
End If
End Sub

Private Sub refreshErrorNew_Click()
journalErreurs.Caption = "journal des erreurs"
End Sub
Public Sub nonErrorTableToTable(rstGet, rstGive, i)
On Error GoTo ErrorHandlerChampAbsent
rstGet(rstGive(i).Name) = rstGive(i)
ErrorHandlerChampAbsent:
Err.Clear
End Sub
Public Sub recupPlusPossible(rstGet, rstGive)
Call nonErrorActionMoveFirst(rstGive)
Dim i
    While Not (finFichier(rstGive))
    rstGet.AddNew
        For i = 0 To rstGive.Fields.Count - 1
        Call nonErrorTableToTable(rstGet, rstGive, i)
        Next
    rstGive.MoveNext
    rstGet.Update
    Wend

End Sub
Public Sub transfereTable()
Dim dbsGet, dbsGive
Set dbsGet = CurrentDb()
Set dbsGive = DBEngine.Workspaces(0).OpenDatabase(nomLivrable.Caption)
    Dim rstGet, rstGive As DAO.recordset
    Set rstGet = dbsGet.OpenRecordset("table1")
    Set rstGive = dbsGive.OpenRecordset(tableAchercher, dbOpenDynaset, dbSeeChanges)

        Call recupPlusPossible(rstGet, rstGive)
        
        
      rstGive.Close
      rstGet.Close
      dbsGet.Close
      dbsGive.Close
      Set rstGive = Nothing
      Set rstGive = Nothing
      Set dbsGet = Nothing
      Set dbsGive = Nothing
End Sub




'*************************************************************************************************************************
'*****************FONCTIONS ET PROCEDURES DE MANIPULATION DE MACRO*******************************************************
'*************************************************************************************************************************
Public Sub nonErrorMacro(laMacro)
On Error GoTo ErrorHandlerMacro
DoCmd.RunMacro laMacro
ErrorHandlerMacro:
Call ajoutErreur(Err.Description, "le livrable est il deja ouvert?  une macro a t'elle été effacée")
Err.Clear
End Sub
Public Sub jexecute(path)
On Error GoTo errorExecution
Dim executeur
Set executeur = CreateObject("Wscript.shell")
executeur.Run (path)
errorExecution:
Set executeur = Nothing
Err.Clear
End Sub
Private Sub exportSimple_Click()
Call exporter
End Sub
Public Sub exporter() 'macro ACCESS exporte la table de cette bdd en fichier ACCESS
Dim livrable
livrable = "C:\livrable.xls"
Call nonErrorMacro("transfer")
If ouvre_livrable Then jexecute (livrable)
End Sub

'*************************************************************************************************************************
'**********************FONCTION D ECRITURE DANS FICHIER TXT ET XLS********************************************************

Public Sub writeFile(textfile, txt)
Dim fobject
Dim fw
Set fobject = CreateObject("Scripting.FileSystemObject")
Set fw = fobject.createTextFile(textfile, True)
fw.writeline (txt)
fw.Close
Set fw = Nothing
Set fobject = Nothing
End Sub
Public Function fileContent(textfile)
Dim contenu
contenu = ""
Dim fobject
Dim fr
Set fobject = CreateObject("Scripting.FileSystemObject")
If fobject.FileExists(textfile) Then
Set fr = fobject.openTextFile(textfile)
contenu = fr.readall
fr.Close
Set fr = Nothing
End If
Set fobject = Nothing
fileContent = contenu
End Function
Public Sub writeInFile(textfile, txt)
Dim contenu
contenu = fileContent(textfile)
Call writeFile(textfile, contenu & vbCrLf & txt)
End Sub

C'est surtout l'astuce

On Error GoTo ErrorHandlerChampAbsent
rstGet(rstGive(i).Name) = rstGive(i)
ErrorHandlerChampAbsent:
Err.Clear

que j'ai utilisé, le reste c'est la déco autour.

j'ai aussi ajouté des fonctions tel que champExistForced et idem pour les tables, j'utilise le system des etiquettes (gestions erreurs) pour creer la table ou le champ s'ils n'existent pas c'est trés pratique en synergie avec la connaissance des propriétés des controls pour recupérer les valeurs et les noms de tous les controls d'un certain type.

(pour le passage ADO j'ai des soucis de zip)...

27 mars 2008 10:20:53 :

juste une petite précision pour le choix DAO (même si il est super vieux) au lieu d'ADO. C'est temporaire.

24 avril 2008 11:09:45 :

transferts entre table et formulaire interressant

24 avril 2008 17:16:27 :

précision sur de nouvelles fonctions

• CONNEXION BASES DE DONNÉES
• TACHE PLANIFIÉES (PETITE BLAGUE)
• MES TEST ET MES RECHERCHES SUR WMI, PROCESSUS ET INTERNET
• RAPPEL POUR NE PAS OUBLIER D'ALER MANGER

• GESTION DE STOCK
• EXCEL <> AUTOCAD LT
• SHIFUMI EN FORMULAIRE ACCÈSS / CODE VBA
• CALCUL ENTHALPIQUE DE L'AIR HUMIDE
• ENCODER UNE URL EN UTF8 DEPUIS WORD

• DÉTECTEUR DE PROCÉDURES ET FONCTIONS INUTILISÉES
• CALCUL DE CRC16
• UN ACCESS MOIN COMPLET (IL MANQUE L'ÉDITEUR DE BASE DE DONNÉ)
• CRÉATION ASSISTÉE PAR CODE DAO D’UNE TABLE DANS MS ACCESS – NOMBRE ET TYPE DE CHAMPS SELON LES BESOINS.
• TRANSFERER UN DATAROW D'UN FENETRE À UNE AUTRE