Comment liée un userform avec une table access [Résolu/Fermé]

Messages postés
125
Date d'inscription
lundi 3 juillet 2017
Statut
Membre
Dernière intervention
24 août 2019
- - Dernière réponse : pyrus2047
Messages postés
125
Date d'inscription
lundi 3 juillet 2017
Statut
Membre
Dernière intervention
24 août 2019
- 16 janv. 2019 à 11:08
Bonjour a tous
Dans l' userform 1 j' ai une listview qui colore sus condition les lignes et champ de recherche multicritère matérialiser par la textbox1
et des textbox qui récupéré la ligne sélectionner dans la listview aussi des bouton ajouter,modifier,suprimer
donc voici mon souci je souhait liée l' userform 1 avec une table access a fin de pouvoir traiter un grand volume de donner
si vous avez une solution je vous joint les deux fichier a liée merci d'avance
Cordialement
Fichier Excel
https://www.cjoint.com/c/HDxkYumAidQ
Fichier Access
https://www.cjoint.com/c/HDxkWQbXqxQ


Afficher la suite 

3 réponses

Messages postés
14717
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
17 septembre 2019
1173
0
Merci
Bonjour,

Vous etes de la meme famille avec BLBATHOR???
Je regarde la chose
f894009
Messages postés
14717
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
17 septembre 2019
1173 -
Bonjour,

Ok
f894009
Messages postés
14717
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
17 septembre 2019
1173 -
Bonjour,

fichier modifie pour deux tables avec boutons option, mais si plus de table voir a passer par une combobox avec liste
des tables de la base Access (recherche dans la base)

https://mon-partage.fr/f/YrlgwTp4/
pyrus2047
Messages postés
125
Date d'inscription
lundi 3 juillet 2017
Statut
Membre
Dernière intervention
24 août 2019
> f894009
Messages postés
14717
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
17 septembre 2019
-
Bonjour
ne fonctionne pas il n'arrive pas a se connecter au fichier access
f894009
Messages postés
14717
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
17 septembre 2019
1173 -
Bonjour,
Quelle erreur avez vous??
pyrus2047
Messages postés
125
Date d'inscription
lundi 3 juillet 2017
Statut
Membre
Dernière intervention
24 août 2019
> f894009
Messages postés
14717
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
17 septembre 2019
-
Re
j'ai bien regarder le nom de la base voici une capture du message d'erreur
https://www.cjoint.com/c/HEifwkDf7Lb
Messages postés
14717
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
17 septembre 2019
1173
0
Merci
Re,
Probleme de refereces, vous devez avoir ce qui est coche a la version prete

pyrus2047
Messages postés
125
Date d'inscription
lundi 3 juillet 2017
Statut
Membre
Dernière intervention
24 août 2019
-
Re
voici mes references ca ne fonctionne pas

https://www.cjoint.com/c/HEisQyRshfb
f894009
Messages postés
14717
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
17 septembre 2019
1173 -
Bonjour,

Oui, ce sont les meme que je n'ai pas changées depuis le debut...... et ca marche chez moi
pyrus2047
Messages postés
125
Date d'inscription
lundi 3 juillet 2017
Statut
Membre
Dernière intervention
24 août 2019
-
Bonjour
J'ai cette connection qui fonctionne en liaison excel avec access
mais pas sur les machines qui dispose uniqeument du runtime access
si vous avez une solution pour l' adapter cette fonction et ce bout de code a votre méthode connection qui elle fonction
bien avec le runtime access
Cordialement

Function fMDP(Utilisateur As String, MdP As String) As Boolean
Dim ACapp As Access.Application, db As DAO.DATABASE, rTrouve As DAO.Recordset, sql As String
Dim ws As Worksheet, fd As DAO.Field

Set ACapp = New Access.Application
Set db = DBEngine.OpenDatabase("C:\Users\pyrus2047\Documents\ebergeur.accdb", False, False, ";pwd=PAPA")
sql = "select * from parametrage where NOM='" & Utilisateur & "' and [Mot de Passe] ='" & MdP & "'"

Set rTrouve = db.OpenRecordset(sql)
If rTrouve.EOF Then
fMDP = False
Else
fMDP = True
For Each ws In ThisWorkbook.Sheets
For Each fd In rTrouve.Fields
If ws.Name = fd.Name Then
If fd.Value = "X" Then
ws.Visible = True
Else
ws.Visible = xlSheetVeryHidden
End If
Exit For
End If
Next fd
Next ws
End If
db.Close
End Function

Option Explicit
Const c_t_parm As String = "Tombins"
Dim ACapp As Access.Application, db As DAO.Database, rcontacts As DAO.Recordset

Private Sub CommandButton4_Click()
If Me.ComboBox1.Value = "" Then
MsgBox "veuillez sélectionner une donnée dans la liste déroulante"
Else
rcontacts.FindFirst ("[NOM PRENOM]='" & Me.ComboBox1.Value & "'")
rcontacts.Edit
rcontacts![NOM PRENOM] = Me.TextBox1.Value
rcontacts!MAIL = Me.TextBox2.Value
rcontacts!TELEPHONE = Me.TextBox3.Value
rcontacts!ADRESSE = Me.TextBox4.Value
If Me.CheckBox1 = True Then
rcontacts!PHOTOS = "oui"
Else
rcontacts!PHOTOS = "NON"
End If
rcontacts.Update
End If
Me.TextBox1 = ""
Me.TextBox2 = ""
Me.TextBox3 = ""
Me.TextBox4 = ""
Me.CheckBox1 = False
MsgBox "Votre enregistrement a ete modifier"
End Sub
Private Sub CommandButton1_Click()
If MsgBox("Validez vous ces données?", vbYesNo, "Validation") = vbYes Then
rcontacts.AddNew
rcontacts![NOM PRENOM] = Me.TextBox1.Value
rcontacts!MAIL = Me.TextBox2.Value
rcontacts!TELEPHONE = Me.TextBox3.Value
rcontacts!ADRESSE = Me.TextBox4.Value
If Me.CheckBox1 = True Then
rcontacts!PHOTOS = "oui"
Else
rcontacts!PHOTOS = "NON"
End If
rcontacts.Update
End If
Me.TextBox1 = ""
Me.TextBox2 = ""
Me.TextBox3 = ""
Me.TextBox4 = ""
Me.CheckBox1 = False
End Sub
Private Sub CommandButton5_Click()
rcontacts.FindFirst ("[NOM PRENOM]='" & Me.TextBox1.Value & "'")
rcontacts.MovePrevious
On Error Resume Next
If Not rcontacts.BOF Then
Me.TextBox1.Text = rcontacts![XXXXXXXXX]
Me.TextBox2.Text = rcontacts![XXXXXXXXX]
Me.TextBox3.Text = rcontacts![XXXXXXXXXt]
Me.TextBox4.Text = rcontacts!XXXXXXXXX
Me.TextBox5.Text = rcontacts!XXXXXXXXX
Me.TextBox6.Text = rcontacts!XXXXXXXXX
Me.TextBox7.Text = rcontacts!XXXXXXXXX
Me.TextBox8.Text = rcontacts![XXXXXXXXX]
Me.TextBox9.Text = rcontacts!XXXXXXXXX
Me.TextBox10.Text = rcontacts![XXXXXXXXX]
Me.TextBox11.Text = rcontacts![XXXXXXXXX]
Me.TextBox12.Text = rcontacts![XXXXXXXXX]
Me.TextBox13.Text = rcontacts![XXXXXXXXX]
Me.TextBox14.Text = rcontacts![XXXXXXXXX]
If rcontacts!PHOTOS = "oui" Then
Me.CheckBox1 = True
Else
Me.CheckBox1 = False
End If
Else
MsgBox "Vous êtes au premier enregistrement"
End If
End Sub

Private Sub CommandButton6_Click()
rcontacts.FindFirst ("[NOM PRENOM]='" & Me.TextBox1.Value & "'")
rcontacts.MoveNext
On Error Resume Next
If Not rcontacts.EOF Then
Me.TextBox1.Text = rcontacts![XXXXXXXXX]
Me.TextBox2.Text = rcontacts![XXXXXXXXX]
Me.TextBox3.Text = rcontacts![XXXXXXXXX]
Me.TextBox4.Text = rcontacts!XXXXXXXXX
Me.TextBox5.Text = rcontacts!XXXXXXXXX
Me.TextBox6.Text = rcontacts!XXXXXXXXX
Me.TextBox7.Text = rcontacts!XXXXXXXXX
Me.TextBox8.Text = rcontacts![XXXXXXXXX]
Me.TextBox9.Text = rcontacts!XXXXXXXXX
Me.TextBox10.Text = rcontacts![XXXXXXXXX]
Me.TextBox11.Text = rcontacts![XXXXXXXXX]
Me.TextBox12.Text = rcontacts![XXXXXXXXX]
Me.TextBox13.Text = rcontacts![XXXXXXXXX]
Me.TextBox14.Text = rcontacts![XXXXXXXXX]
If rcontacts!PHOTOS = "oui" Then
Me.CheckBox1 = True
Else
Me.CheckBox1 = False
End If
Else
MsgBox "Vous êtes au dernier enregistrement"
End If
End Sub
Private Sub ComboBox1_Change()
Dim photo As String
On Error Resume Next
rcontacts.FindFirst ("[NOM PRENOM]='" & Me.ComboBox1.Value & "'")
Me.TextBox1.Text = rcontacts![XXXXXXXXX]
Me.TextBox2.Text = rcontacts![XXXXXXXXX]
Me.TextBox3.Text = rcontacts![XXXXXXXXX]
Me.TextBox4.Text = rcontacts!XXXXXXXXX
Me.TextBox5.Text = rcontacts!XXXXXXXXX
Me.TextBox6.Text = rcontacts!XXXXXXXXX
Me.TextBox7.Text = rcontacts!XXXXXXXXX
Me.TextBox8.Text = rcontacts![XXXXXXXXX]
Me.TextBox9.Text = rcontacts!XXXXXXXXX
Me.TextBox10.Text = rcontacts![XXXXXXXXX]
Me.TextBox11.Text = rcontacts![XXXXXXXXX]
Me.TextBox12.Text = rcontacts![XXXXXXXXX]
Me.TextBox13.Text = rcontacts![XXXXXXXXX]
Me.TextBox14.Text = rcontacts![XXXXXXXXX]
If rcontacts!PHOTOS = "oui" Then
Me.CheckBox1 = True
Else
Me.CheckBox1 = False
End If
On Error GoTo defaut

photo = TextBox1.Value
Image1.Picture = LoadPicture("C:\Users\Pictures\" & photo & ".jpg")
Exit Sub

defaut:
Image1.Picture = LoadPicture("C:\Users\Pictures.jpg")
End Sub
Private Sub CommandButton2_Click()
Unload Me
End Sub

Private Sub Textbox1_Change()
Dim photo As String
On Error GoTo defaut

photo = TextBox1.Value
Image1.Picture = LoadPicture("C:\Users\Pictures\" & photo & ".jpg")
Exit Sub

defaut:
Image1.Picture = LoadPicture("C:\Users\Pictures.jpg")
End Sub

Private Sub UserForm_Initialize()
Set ACapp = New Access.Application
Set db = ACapp.DBEngine.OpenDatabase _
("C:\Users\Abdessamad\Documents\table.accdb", False, False, ";pwd=PAPA")
Set rcontacts = db.OpenRecordset(c_t_parm, dbOpenDynaset)
Do While Not rcontacts.EOF
ComboBox1.AddItem rcontacts![NOM PRENOM]
rcontacts.MoveNext
Loop
End Sub



Messages postés
2964
Date d'inscription
lundi 18 septembre 2006
Statut
Membre
Dernière intervention
31 août 2019
166
0
Merci
Bonjour
Voire forum programmation VBA
f894009
Messages postés
14717
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
17 septembre 2019
1173 -
Bonjours Castours, ca roule?
Certes, mais ce fichier marchait chez lui depuis le 24/04/2018 jusqu'a 07/05/2018 et apres verif de l'erreur, c'est bien un probleme soit de nom de base soit de chemin et pas de references
Par-contre, il aurait du etre dans la partie VBA
pyrus2047
Messages postés
125
Date d'inscription
lundi 3 juillet 2017
Statut
Membre
Dernière intervention
24 août 2019
-
Bonjour
je m'excuse je fais perdre du temps a tout le monde
le boulet a encore frapper c'est un espace a la fin du nom de la base qui a cause le bug
pour clore le sujet
que dois ton ajouter pour le cas ou la base et protéger par un mot de passe ex:PAPA