Erreur définie par l'application ou par l'objet

Le 29/01/2025 à 11:33

Salut,

Sur la feuille "Accueil" de mon fichier, j'ai un UserForm dans lequel j'ai inséré une ListView1 dans laquelle je peux double cliquer pour charger des données dans les feuilles Archive_Page1 et Achive_page2.

Mon UserForm et sa ListView1 :

2025 01 29 11h16 14

Lorsque je double clique sur l'un des résultats de la ListView, j'ai ce code qui se lance (j'ai défini des niveaux d'accès aux feuilles Archive_Page1 et Archive_Page2 selon le mail de l'utilisateur du fichier) :

Private Sub ListView1_DblClick()
    On Error GoTo ErrHandler

    If ListView1.SelectedItem Is Nothing Then Exit Sub

    ' Récupération de l'ID uniquement
    Dim ID As Long
    ID = CLng(ListView1.SelectedItem.Text)

    Application.ScreenUpdating = False

    Me.Hide

    ' Appel de ChargerDonnees et ChargerDonnees2 avec uniquement l'ID
    ChargerDonnees ID 'pour charger Archive_Page1
    ChargerDonnees2 ID 'pour charger Archive_Page2

    ' Vérification de l'autorisation d'accès
    Dim outlookApp As Object
    Dim userEmail As String
    Dim niveau1Emails As Variant
    Dim niveau2Emails As Variant
    Dim isNiveau1 As Boolean
    Dim isNiveau2 As Boolean

    ' Définir les niveaux d'accès
    niveau1Emails = Array("mail1@essai.fr", "mail2@essai.fr", "mail3@essai.fr")
    niveau2Emails = Array("mail1@essai.fr", "mail2@essai.fr", "mail4@essai.fr", "mail6@essai.fr")

    ' Récupérer l'email de l'utilisateur
    On Error Resume Next
    Set outlookApp = CreateObject("Outlook.Application")
    If Not outlookApp Is Nothing Then
        userEmail = outlookApp.Session.currentUser.AddressEntry.GetExchangeUser.PrimarySmtpAddress
    End If
    Set outlookApp = Nothing
    On Error GoTo ErrHandler

    ' Vérifier les niveaux d'accès
    isNiveau1 = IsEmailInArray(userEmail, niveau1Emails)
    isNiveau2 = IsEmailInArray(userEmail, niveau2Emails)

    ' Références aux feuilles
    Dim wsArchive1 As Worksheet
    Dim wsArchive2 As Worksheet
    Set wsArchive1 = ThisWorkbook.Sheets("Archive_Page1")
    Set wsArchive2 = ThisWorkbook.Sheets("Archive_Page2")

    ' S'assurer que les feuilles sont déprotégées avant modification
    On Error Resume Next
    wsArchive1.Unprotect
    wsArchive2.Unprotect
    On Error GoTo ErrHandler

    ' Configuration selon le niveau d'accès
    If isNiveau2 Then
        wsArchive2.Visible = xlSheetVisible
        wsArchive1.Visible = xlSheetVisible
    ElseIf isNiveau1 Then
        wsArchive1.Visible = xlSheetVisible
        wsArchive2.Visible = xlSheetVeryHidden
    Else
        wsArchive1.Visible = xlSheetVisible
        wsArchive2.Visible = xlSheetVeryHidden
        wsArchive1.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, _
            UserInterfaceOnly:=True, AllowFormattingCells:=False
    End If

    ' Activer Archive_Page1
    wsArchive1.Activate

    Application.ScreenUpdating = True
    Exit Sub

ErrHandler:
    Application.ScreenUpdating = True
    If Err.Number <> 0 Then
        MsgBox "Une erreur s'est produite : " & Err.Description, vbExclamation
        Resume Next
    End If
End Sub

Dans un module à part, j'ai le code de la fonction utilisée ci-dessus, IsEmailInArray :

Public Function IsEmailInArray(email As String, arr As Variant) As Boolean
    Dim i As Long

    ' Si l'email est vide, retourner False
    If Len(Trim(email)) = 0 Then
        IsEmailInArray = False
        Exit Function
    End If

    ' Parcourir le tableau pour chercher l'email
    For i = LBound(arr) To UBound(arr)
        If LCase(Trim(email)) = LCase(Trim(arr(i))) Then
            IsEmailInArray = True
            Exit Function
        End If
    Next i

    ' Si l'email n'est pas trouvé, retourner False
    IsEmailInArray = False

End Function

Le code qui charge les données dans la feuille Archive_Page1 est celui-ci :

Sub ChargerDonnees(ID As Long)
    On Error GoTo GestionErreur

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("BDD1")
    Dim wsCharger As Worksheet
    Set wsCharger = ThisWorkbook.Sheets("Archive_Page1")

    ' Trouver la ligne correspondante dans BDD1
    Dim selectedRow As Long
    selectedRow = Application.Match(ID, ws.Range("A:A"), 0)

    If IsError(selectedRow) Then
        MsgBox "ID introuvable dans la feuille BDD1.", vbCritical
        Exit Sub
    End If

    ' Copier les données
wsCharger.Range("E3").Value = ws.Cells(selectedRow, GetColumnByHeader(ws, "Date")).Value
wsCharger.Range("K3").Value = ws.Cells(selectedRow, GetColumnByHeader(ws, "Heure")).Value
wsCharger.Range("K8").Value = ws.Cells(selectedRow, GetColumnByHeader(ws, "Nom")).Value
wsCharger.Range("K9").Value = ws.Cells(selectedRow, GetColumnByHeader(ws, "Prénom")).Value
wsCharger.Range("K11").Value = ws.Cells(selectedRow, GetColumnByHeader(ws, "Date de naissance")).Value
wsCharger.Range("K12").Value = ws.Cells(selectedRow, GetColumnByHeader(ws, "Adresse privée")).Value

            wsCharger.Activate

    Exit Sub

GestionErreur:
    MsgBox "Erreur lors du chargement des données : " & Err.Description, vbCritical
End Sub

Le code qui charge les données dans la feuille Archive_Page2 est celui-ci :

Sub ChargerDonnees2(ID As Long)
    On Error GoTo GestionErreur

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("BDD1")
    Dim wsCharger As Worksheet
    Set wsCharger = ThisWorkbook.Sheets("Archive_Page2")

    ' Déprotéger la feuille Archive_Page2
    wsCharger.Unprotect

    ' Trouver la ligne correspondante dans BDD1
    Dim selectedRow As Long
    selectedRow = Application.Match(ID, ws.Range("A:A"), 0)

    If IsError(selectedRow) Then
        Exit Sub
    End If

' Premier bloc
wsCharger.Range("E7").Value = ws.Cells(selectedRow, GetColumnByHeader(ws, "Appréciation1")).Value
wsCharger.Range("I8").Value = ws.Cells(selectedRow, GetColumnByHeader(ws, "Appréciation2")).Value
wsCharger.Range("I9").Value = ws.Cells(selectedRow, GetColumnByHeader(ws, "Appréciation3")).Value
wsCharger.Range("I10").Value = ws.Cells(selectedRow, GetColumnByHeader(ws, "Appréciation4")).Value

    ' Formatage des cellules
    With wsCharger.Range("E7")
        .Font.Name = "Calibri"
        .Font.Size = 11
    End With

' Déprotéger la feuille avant de modifier les protections
    wsCharger.Unprotect

' Verrouiller toutes les cellules
wsCharger.Cells.Locked = True

' Verrouiller tous les boutons et formes
Dim shp As Shape
For Each shp In wsCharger.Shapes
    On Error Resume Next
    shp.Locked = True
    On Error GoTo 0
Next shp

    ' Protéger la feuille avec toutes les restrictions, sans mot de passe
    wsCharger.Protect DrawingObjects:=True, _
        Contents:=True, _
        Scenarios:=True, _
        UserInterfaceOnly:=True, _
        AllowFormattingCells:=False, _
        AllowFormattingColumns:=False, _
        AllowFormattingRows:=False, _
        AllowInsertingColumns:=False, _
        AllowInsertingRows:=False, _
        AllowInsertingHyperlinks:=False, _
        AllowDeletingColumns:=False, _
        AllowDeletingRows:=False, _
        AllowSorting:=False, _
        AllowFiltering:=False, _
        AllowUsingPivotTables:=False

    ' Activer la feuille
    wsCharger.Activate

    Exit Sub

GestionErreur:
    MsgBox "Erreur lors du chargement des données : " & Err.Description, vbCritical
    ' Protéger la feuille même en cas d'erreur
    wsCharger.Protect UserInterfaceOnly:=True
End Sub

Je ne comprends pas pourquoi, lorsque je lance la macro Sub ListView1_DblClick j'ai le message suivant qui s'affiche : je précise que, une fois que j'ai cliqué sur OK il disparait et n'empêche pas le fichier d'être exploitable mais c'est curieux...je ne vois pas d'où ca peut venir. D'autant que ce message n'apparait qu'une seule fois, c'est à dire que si je reclique dans ma ListView1, les feuilles Archive_Page1 et Archive_Page2 s'affichent sans que ce message n'apparaisse au préalable...

2025 01 29 09h12 55

Auriez-vous une idée ? car je ne sais plus où chercher...

Le 29/01/2025 à 11:51

Bonjour,

Alors tout d'abord je tiens quand même a vous féliciter votre code est très propre et facile à relire.

A priori il est difficile de bien cerner le point qui lève l'erreur. Si vous pouviez joindre un fichier de démo, ce serait parfait.

Dans l'état, mon intuition me pousse à la conclusion suivante :

C'est probablement le lien avec Outlook qui pose problème. Je vous conseillerai, au niveau de la connexion à l'app, d'ajouter des DoEvents comme ceci, afin de laisser à l'app le temps de se lancer. Cela pourrait expliquer pourquoi la 1e fois ça met une erreur, et après non (l'app reste active en arrière-plan).

' Récupérer l'email de l'utilisateur
    On Error Resume Next
    Set outlookApp = CreateObject("Outlook.Application")
    DoEvents
    If Not outlookApp Is Nothing Then
        userEmail = outlookApp.Session.currentUser.AddressEntry.GetExchangeUser.PrimarySmtpAddress
    End If
    Set outlookApp = Nothing
    DoEvents
    On Error GoTo ErrHandler

Si ce n'est pas ça… Je pense qu'un fichier est nécessaire pour voir en exécution pas à pas.

Le 29/01/2025 à 13:11

1000 mercis! vous avez l'œil!

Il s'agissait effectivement d'un problème de connexion à Outllook... Un problème qui ne survenait pas sur mon PC perso (excel 2021) mais sur mon PC pro (excel 2013)

bonne journée

Le 29/01/2025 à 13:46

Merci pour votre retour, content d'aider.

Bonne journée également

Rechercher des sujets similaires à "erreur definie application objet"