Ma liaison vers table access ne fonctionnent pas avec le runtime access

[chich]

Bonjour
j'ai un fichier excel qui me permet de gere mes contact
depuis un userform qui a pour base une table access
pour que mon userform recupere , ajoute , modifie , et supprime les informations dans
la table access et j'ai aussi la Function fMDP qui me permet de rendre visible des de mon classeur
hélas ces deux bouts de macro ne fonctionnent pas avec le runtime access
j'ai fais le test un pc qui a access et tout fonctonne tres bien
si vous avez une solution pour adapter avec le runtime access
Cordialement

 

[chich]

Je travavail avec un reseau informatique pro imposible instaler quoique se soit
voici les deux bout qui pose problrme

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

On Error Resume Next
Set ACapp = New Access.Application
Set db = DBEngine.OpenDatabase("C:\Users\pyrus2047\Documents\table.accdb", False, False, ";pwd=PAPA")
Sql = "select * from Tombins where [NOM PRENOM]='" & 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
ActiveWindow.DisplayWorkbookTabs = False
End Function

Option Explicit
Const c_t_contacts As String = "PARAMETREAGE"
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
If Not rcontacts.BOF Then
    Me.TextBox1.Text = rcontacts![NOM PRENOM]
    Me.TextBox2.Text = rcontacts!MAIL
    Me.TextBox3.Text = rcontacts!TELEPHONE
    Me.TextBox4.Text = rcontacts!ADRESSE
    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
If Not rcontacts.EOF Then
    Me.TextBox1.Text = rcontacts![NOM PRENOM]
    Me.TextBox2.Text = rcontacts!MAIL
    Me.TextBox3.Text = rcontacts!TELEPHONE
    Me.TextBox4.Text = rcontacts!ADRESSE
    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
rcontacts.FindFirst ("[NOM PRENOM]='" & Me.ComboBox1.Value & "'")
Me.TextBox1.Text = rcontacts![NOM PRENOM]
Me.TextBox2.Text = rcontacts!MAIL
Me.TextBox3.Text = rcontacts!TELEPHONE
Me.TextBox4.Text = rcontacts!ADRESSE
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\pyrus2047\Pictures\organe\" & photo & ".jpg")
Exit Sub

defaut:
Image1.Picture = LoadPicture("C:\Users\pyrus2047\Pictures\organe\Defaut.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\pyrus2047\Pictures\organe\" & photo & ".jpg")
Exit Sub

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

Private Sub UserForm_Initialize()

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

 

[Staple1600]

Bonsoir


Juste pour infos
D'habitude, on ne publie pas ce genre d'infos sur le forum, ou alors en anonymisant un chouia
Comme je viens de le faire ci-dessous
Set db = ACapp.DBEngine.OpenDatabase _
("C:\Users\*********\Documents\fiche contactes\contactes.accdb", False, False, ";pwd=*")

 

[chich]

Bonsoir
merci pour l"info
C'est un pseudo (pyrus2047)
Cordialemen

 

[Staple1600]

Re

Certes, mais le mot de passe était en clair...
Et c'était juste pour infos

D'ailleurs il est toujours lisible dans ton message

 

[chich]

re
Meris pour l'info

 

[chich]

Peut être en installation le moteur de Bdd =>https://www.microsoft.com/fr-FR/download/details.aspx?id=13255

Bonjour
J'ai cette connection qui fonctionne tres bien avec le runtime access mais je sais pas comment l'adapter
si vous avez une solution svp merci
Cordialement

Private Declare Function FindWindowA& Lib "user32" (ByVal lpClassName$, ByVal lpWindowName$)
Private Declare Function EnableWindow& Lib "user32" (ByVal hwnd&, ByVal bEnable&)
Private Declare Function GetWindowLongA& Lib "user32" (ByVal hwnd&, ByVal nIndex&)
Private Declare Function SetWindowLongA& Lib "user32" (ByVal hwnd&, ByVal nIndex&, ByVal dwNewLong&)
Option Compare Text
Option Explicit

Dim conn As Object      'pour connection base
Dim connstring              'pour connection base
Dim Rs As Object           'recordset
Dim Sql                         'chaine requete SQL
Dim TInfos                    'tableau recup requete SQL
Dim Flag_Nok As Boolean 'pas d'enregistrement
Dim NbRecord               'nombre d'enregistrement trouves

'connection base et recherche
Sub Connecte_base_Access()
    Dim Rs As Object
    Dim Nom_Base, Chemin_Base, Sql, PAPA, Admin, Uid, pwd, ExtendedAnsiSQL ', connstring
    
    Set conn = CreateObject("ADODB.Connection")
'    Nom_Base = "ListView table.accdb"
'    Chemin_Base = ThisWorkbook.Path & "\" & Nom_Base
    Chemin_Base = "C:\Users\mmmmmm\Documents\table.accdb"
    connstring = "DRIVER={Microsoft Access Driver (*.mdb, *.accdb)}; DBQ=" & Chemin_Base & ";Uid=Admin;Pwd=mmmmm;ExtendedAnsiSQL=1;"
    conn.Open connstring
End Sub

Sub Recherche_Infos_Affichage_LVW()
    Dim Rs As Object
    Dim DT1, DT2
    Dim PartTxt, Sql, SQL1, n, L, c, D, e, NbF
On Error Resume Next
    Set Rs = CreateObject("ADODB.recordset")
    PartTxt = TextBox1
    
    Sql = "select * from [parametreage] where [Nom et Prenom] like '%" & PartTxt & "%'"
    Rs.Open Sql, conn, 3, 3
    If Not Rs.EOF Then
        Rs.MoveFirst
        NbF = Rs.Fields.Count
        NbRecord = Rs.RecordCount
        n = 1
        Do While Not Rs.EOF
            With ListView1
                .ListItems.Add , , Rs.Fields(0)
                For L = 2 To NbF
                
                    .ListItems(n).ListSubItems.Add , , Rs.Fields(L - 1)
                Next L
                If .ListItems(n) = TextBox1 Then .ListItems(n).Bold = True
                If .ListItems(n).ListSubItems(8).Text = "MMMMMMMMM" Then
                    .ListItems(n).Bold = True
                    .ListItems(n).ForeColor = vbRed
                    For c = 1 To .ColumnHeaders.Count - 1
                        .ListItems(n).ListSubItems(c).Bold = True
                        .ListItems(n).ListSubItems(c).ForeColor = vbRed     'couleur colonne 8
                    Next c
                End If
            End With
            n = n + 1
            Rs.MoveNext
        Loop
        Label2.Caption = NbRecord & " enregistrement(s) !"
    Else
        MsgBox "Attention: pas d'enregistrement trouvé!!"
    End If
    Rs.Close
    Set Rs = Nothing
End Sub

 

[chich]

J'ai ce code qui fonctionne très bien => http://tatiak.canalblog.com/archives/2016/05/25/33865554.html

Re
Je suis debutant je ne sais pas comment l'adapter a mes deux cas
si vous avez une solution svp merci
Cordialement