Sujet Précédent Sujet Suivant

Macro excel ne fonctionnent pas avec le runtime access

Résolu/Fermé
pyrus2047 Messages postés 153 Date d'inscription lundi 3 juillet 2017 Statut Membre Dernière intervention 22 mai 2023 - 1 avril 2019 à 14:49
pyrus2047 Messages postés 153 Date d'inscription lundi 3 juillet 2017 Statut Membre Dernière intervention 22 mai 2023 - 2 avril 2019 à 12:46
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 feuilles 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 
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("e;e;C:Users GortexDocumentstable.accdb"e;else, False, "e;e;;pwd=PAPA"e;e;)
Sql = "e;e;select * from Tombins where [NOM PRENOM]='"e;e; & Utilisateur & "e;e;' and [Mot de Passe] ='"e;e; & MdP & "e;e;'"e;e;
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 = "e;e;X"e;e; 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 = "e;e;PARAMETREAGE"e;e;
Dim ACapp As Access.Application, db As DAO.Database, rcontacts As DAO.Recordset

Private Sub CommandButton4_Click()
If Me.ComboBox1.Value = "e;e;"e;e; Then
MsgBox "e;e;veuillez sélectionner une donnée dans la liste déroulante"e;e;
Else
rcontacts.FindFirst ("e;e;[NOM PRENOM]='"e;e; & Me.ComboBox1.Value & "e;e;'"e;e;)
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 = "e;e;oui"e;e;
Else
rcontacts!PHOTOS = "e;e;NON"e;e;
End If
rcontacts.Update
End If
Me.TextBox1 = "e;e;"e;e;
Me.TextBox2 = "e;e;"e;e;
Me.TextBox3 = "e;e;"e;e;
Me.TextBox4 = "e;e;"e;e;
Me.CheckBox1 = False
MsgBox "e;e;Votre enregistrement a ete modifier"e;e;
End Sub
Private Sub CommandButton1_Click()
If MsgBox("e;e;Validez vous ces données?"e;e;, vbYesNo, "e;e;Validation"e;e;) = 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 = "e;e;oui"e;e;
Else
rcontacts!PHOTOS = "e;e;NON"e;e;
End If
rcontacts.Update
End If
Me.TextBox1 = "e;e;"e;e;
Me.TextBox2 = "e;e;"e;e;
Me.TextBox3 = "e;e;"e;e;
Me.TextBox4 = "e;e;"e;e;
Me.CheckBox1 = False
End Sub
Private Sub CommandButton5_Click()
rcontacts.FindFirst ("e;e;[NOM PRENOM]='"e;e; & Me.TextBox1.Value & "e;e;'"e;e;)
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 = "e;e;oui"e;e; Then
Me.CheckBox1 = True
Else
Me.CheckBox1 = False
End If
Else
MsgBox "e;e;Vous êtes au premier enregistrement"e;e;
End If
End Sub

Private Sub CommandButton6_Click()
rcontacts.FindFirst ("e;e;[NOM PRENOM]='"e;e; & Me.TextBox1.Value & "e;e;'"e;e;)
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 = "e;e;oui"e;e; Then
Me.CheckBox1 = True
Else
Me.CheckBox1 = False
End If
Else
MsgBox "e;e;Vous êtes au dernier enregistrement"e;e;
End If
End Sub
Private Sub ComboBox1_Change()
Dim photo As String
rcontacts.FindFirst ("e;e;[NOM PRENOM]='"e;e; & Me.ComboBox1.Value & "e;e;'"e;e;)
Me.TextBox1.Text = rcontacts![NOM PRENOM]
Me.TextBox2.Text = rcontacts!MAIL
Me.TextBox3.Text = rcontacts!TELEPHONE
Me.TextBox4.Text = rcontacts!ADRESSE
If rcontacts!PHOTOS = "e;e;oui"e;e; Then
Me.CheckBox1 = True
Else
Me.CheckBox1 = False
End If
On Error GoTo defaut

photo = TextBox1.Value
Image1.Picture = LoadPicture("e;e;C:Users GortexPicturesorgane"e;e; & photo & "e;e;.jpg"e;e;)
Exit Sub

defaut:
Image1.Picture = LoadPicture("e;e;C:Users GortexPicturesorganeDefaut.jpg"e;e
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("e;e;C:Users GortexPicturesorgane"e;e; & photo & "e;e;.jpg"e;e;)
Exit Sub

defaut:
Image1.Picture = LoadPicture("e;e;C:Users GortexPicturesorganeDefaut.jpg"e;e
End Sub

Private Sub UserForm_Initialize()

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


Configuration: Windows / Chrome 73.0.3683.86
A voir également:

1 réponse

Réponse 1 / 1
f894009 Messages postés 17206 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 22 novembre 2024 1 710
1 avril 2019 à 17:48
Bonjour,

Y a plein de "e;e; normal ou pas
0
pyrus2047 Messages postés 153 Date d'inscription lundi 3 juillet 2017 Statut Membre Dernière intervention 22 mai 2023
1 avril 2019 à 18:19
Re
Non c'est pas normal faut pas en tenir compte je supprime
0
pyrus2047 Messages postés 153 Date d'inscription lundi 3 juillet 2017 Statut Membre Dernière intervention 22 mai 2023
Modifié le 2 avril 2019 à 12:47
Bonjour

J'ai cette connection qui fonctionne tres bien dans tout les cas mais je ne sais pas comment l'adapter
aux macros qui pose probleme avec le runtime access
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
0