Cacher un mot de passe par des étoiles

Question

Pourriez-vous me dire comment cacher par des étoiles mon mot de passe? Sub Efface() Dim Mdp As String Mdp = Application.InputBox("Si vous voulez réellement supprimer la base de données,N'OUBLIEZ PAS DE FAIRE UNE SAUVEGARDE AVANT, introduisez votre mot de passe") If Mdp &lt;&gt; "1234 Then MsgBox "Accès refusé !": Exit Sub 'le reste du code si Mdp est ok Dim Supp Supp = MsgBox("Voulez-vous éffacer les données du tableau", vbYesNo + vbQuestion + _ vbDefaultButton2, "Confirmation de suppression") If Supp = vbYes Then Application.ScreenUpdating = False Sheets("Feuil1").Range("c18:e20").ClearContents Sheets("Feuil1").Range("g18:i20").ClearContents Sheets("Feuil1").Range("b4:e4").ClearContents Sheets("Feuil1").Range("d5:e5").ClearContents Sheets("Feuil1").Range("c6:e6").ClearContents Sheets("Feuil1").Range("g24:i26").ClearContents Sheets("Feuil1").Range("c24:e26").ClearContents Sheets("Feuil1").Range("c30:e32").ClearContents Sheets("Feuil1").Range("c36:e38").ClearContents Sheets("Feuil1").Range("c42:e44").ClearContents Sheets("Feuil1").Range("g42:i44").ClearContents Sheets("Feuil1").Range("c48:e50").ClearContents Sheets("Feuil1").Range("c54:e56").ClearContents Sheets("Feuil1").Range("g54:i56").ClearContents Sheets("Feuil1").Range("g30:i32").ClearContents Sheets("Feuil1").Range("g36:i38").ClearContents Sheets("Feuil1").Range("g48:i50").ClearContents Sheets("Feuil1").Range("f5:i7").ClearContents MsgBox "Toutes les informations sont éffacés." End If End Sub Merci beaucoup...

JExceL2fr · Answer

Il faut utiliser un USF et un Textbox pour ça, sinon ce n'est pas possible ou à grand renfort d'API A+...

Alex020181 · Answer

Même en utilisant un userform le MDP saisi en brut dans le code restera visible en le cherchant dans le code des modules ou dans le code du userform. Tu as quand même 2 solutions indirectes : - tu peux verrouiller l'affichage de ton code (le code complet donc c'est tout ou rien) avec un MDP par clic droit sur "vbaproject" / "propriétés de vba project" puis onglet "Protection". Pour afficher le code il faudra d'abord saisir ce mdp (tu peux choisir le même mdp que celui de ton code ou un autre). A savoir quand même que sur Internet on trouve tout un tas de logiciel pouvant passer outre cette sécurité... - tu peux ne pas utiliser un nom de variable parlant (tel que "mdp", "mot_de_passe", ...) mais un nom clairement "non parlant" et "non subjectif" qui ne laisse pas deviner ce qu'elle contient et ne pas faire apparaitre clairement ton mot de passe comme une simple chaine. C'est de la bidouille mais au moins pour une personne qui ne sait pas lire du code ce sera moins facile que "mdp = 1234". Mais soyons clair, il s'agit uniquement ici de noyer le poisson débutant tombant par inadvertance sur le code . Un développeur pourra facilement reconstituer le bousin. Option Explicit Sub test() Dim reputil As String Dim varcont As String varcont = Sqr(4 ^ 2) & " | " & Chr(25 * 2 + 1) & " ¤ " & 2 * Chr(7 ^ 2) / (Chr(7 ^ 2) * 1 + CInt(Chr(7 ^ 2))) + 1 & Chr(7 ^ 2) reputil = Application.InputBox("Si vous voulez réellement supprimer la base de données,N'OUBLIEZ PAS DE FAIRE UNE SAUVEGARDE AVANT, introduisez votre mot de passe") If reputil &lt;&gt; StrReverse(Replace(Replace(varcont, " ¤ ", ""), " | ", "")) Then MsgBox "Accès refusé !": Exit Sub 'reste code si ok MsgBox "ok" End Sub Avec : - x ^ y pour x puissance y. - sqr() pour racine carrée - cint() pour convertir en entier - chr() pour définir la lecture d'un code ASCII - Strreverse() pour lire la chaine à l'envers - replace() pour remplacer dans une chaine un ou des caractères consécutifs par d'autres Teste et dis nous...

cousinhub · Answer

Comme te l'a dit JExcel2fr, un InputBox ne permet pas de masquer les caractères saisis. Il faut utiliser un Userform, avec un TextBox, dont la propriété "PasswordChar" a été définie. Regarde le fichier joint (le mdp à saisir est "djodjo", mais tu peux essayer autre chose...) Bonne fin d'apm...

Alex020181 · Answer

Pardon. J'avais compris que tu voulais cacher ton MDP dans le code lors de son contrôle pour ne pas qu'un petit malin le voie ici. Pas lors de sa saisie.

Je suis sur smartphone alors je ne peux pas regarder le fichier Excel de la réponse précédente mais vu sa réponse tu as ta réponse.

Invité · Answer

Bonjour,
regarde la méthode Sub Tester_Complete()

' Module: CredUI_Complete
' Version complète pour récupérer les credentials Windows
Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function CredUIPromptForWindowsCredentials Lib "credui.dll" Alias "CredUIPromptForWindowsCredentialsW" ( _
        ByRef pUiInfo As CREDUI_INFO, _
        ByVal dwAuthError As Long, _
        ByRef pulAuthPackage As Long, _
        ByVal pvInAuthBuffer As LongPtr, _
        ByVal ulInAuthBufferSize As Long, _
        ByRef ppvOutAuthBuffer As LongPtr, _
        ByRef pulOutAuthBufferSize As Long, _
        ByRef pfSave As Long, _
        ByVal dwFlags As Long) As Long

    Private Declare PtrSafe Function CredUnPackAuthenticationBuffer Lib "credui.dll" Alias "CredUnPackAuthenticationBufferW" ( _
        ByVal dwFlags As Long, _
        ByVal pAuthBuffer As LongPtr, _
        ByVal cbAuthBuffer As Long, _
        ByVal pszUserName As LongPtr, _
        ByRef pcchMaxUserName As Long, _
        ByVal pszDomainName As LongPtr, _
        ByRef pcchMaxDomainame As Long, _
        ByVal pszPassword As LongPtr, _
        ByRef pcchMaxPassword As Long) As Long

    Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As LongPtr)
    Private Declare PtrSafe Function GetLastError Lib "kernel32" () As Long
#Else
    Private Declare Function CredUIPromptForWindowsCredentials Lib "credui.dll" Alias "CredUIPromptForWindowsCredentialsW" ( _
        ByRef pUiInfo As CREDUI_INFO, _
        ByVal dwAuthError As Long, _
        ByRef pulAuthPackage As Long, _
        ByVal pvInAuthBuffer As Long, _
        ByVal ulInAuthBufferSize As Long, _
        ByRef ppvOutAuthBuffer As Long, _
        ByRef pulOutAuthBufferSize As Long, _
        ByRef pfSave As Long, _
        ByVal dwFlags As Long) As Long

    Private Declare Function CredUnPackAuthenticationBuffer Lib "credui.dll" Alias "CredUnPackAuthenticationBufferW" ( _
        ByVal dwFlags As Long, _
        ByVal pAuthBuffer As Long, _
        ByVal cbAuthBuffer As Long, _
        ByVal pszUserName As Long, _
        ByRef pcchMaxUserName As Long, _
        ByVal pszDomainName As Long, _
        ByRef pcchMaxDomainame As Long, _
        ByVal pszPassword As Long, _
        ByRef pcchMaxPassword As Long) As Long

    Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
    Private Declare Function GetLastError Lib "kernel32" () As Long
#End If

Private Type CREDUI_INFO
    cbSize As Long
    hwndParent As LongPtr
    pszMessageText As LongPtr
    pszCaptionText As LongPtr
    hbmBanner As LongPtr
End Type

' Structure pour retourner toutes les informations
Public Type CredentialInfo
    username As String
    domain As String
    password As String
    Success As Boolean
End Type

' Constantes
Private Const CREDUIWIN_GENERIC As Long = &H1
Private Const CREDUIWIN_CHECKBOX As Long = &H2
Private Const ERROR_CANCELLED As Long = 1223
Private Const ERROR_NO_SUCH_LOGON_SESSION As Long = 1312
Private Const ERROR_NOT_FOUND As Long = 1168

' =============================================================================
' FONCTION PRINCIPALE - Récupère toutes les informations
' =============================================================================
Public Function PromptCredentials(Optional ByVal caption As String = "Saisir les credentials", _
                                 Optional ByVal message As String = "Entrez vos credentials :", _
                                 Optional ByVal enableDebug As Boolean = False) As CredentialInfo

    Dim ui As CREDUI_INFO
    Dim authPkg As Long
    Dim outBuf As LongPtr
    Dim outBufSize As Long
    Dim saveCred As Long
    Dim ret As Long
    Dim result As CredentialInfo
    Dim lastErr As Long

    ' Initialiser le résultat
    result.Success = False
    result.username = ""
    result.domain = ""
    result.password = ""

    ' Initialiser la structure
    ui.cbSize = Len(ui)
    ui.hwndParent = 0
    ui.pszCaptionText = StrPtr(caption)
    ui.pszMessageText = StrPtr(message)
    ui.hbmBanner = 0

    ' Initialiser les variables
    outBuf = 0
    outBufSize = 0
    saveCred = 0
    authPkg = 0

    If enableDebug Then Debug.Print "=== DEBUT PROMPT CREDENTIALS ==="

    ret = CredUIPromptForWindowsCredentials(ui, 0, authPkg, 0, 0, outBuf, outBufSize, saveCred, CREDUIWIN_GENERIC)
    lastErr = GetLastError()

    If enableDebug Then
        Debug.Print "Retour CredUIPromptForWindowsCredentials: " & ret
        Debug.Print "GetLastError: " & lastErr
        Debug.Print "outBuf: " & CLng(outBuf) & ", outBufSize: " & outBufSize
    End If

    ' Vérifier les codes d'erreur
    Select Case ret
        Case 0
            If enableDebug Then Debug.Print "SUCCESS - Credentials saisis"
        Case ERROR_CANCELLED
            If enableDebug Then Debug.Print "CANCELLED - Utilisateur a annulé"
            PromptCredentials = result
            Exit Function
        Case ERROR_NO_SUCH_LOGON_SESSION
            If enableDebug Then Debug.Print "ERROR - Pas de session de logon"
            PromptCredentials = result
            Exit Function
        Case ERROR_NOT_FOUND
            If enableDebug Then Debug.Print "ERROR - Ressource non trouvée"
            PromptCredentials = result
            Exit Function
        Case Else
            If enableDebug Then Debug.Print "ERROR - Code inconnu: " & ret
            PromptCredentials = result
            Exit Function
    End Select

    ' Vérifier que nous avons un buffer valide
    If outBuf = 0 Or outBufSize = 0 Then
        If enableDebug Then Debug.Print "ERROR - Buffer invalide"
        PromptCredentials = result
        Exit Function
    End If

    ' Préparer les buffers pour l'extraction
    Dim maxUser As Long: maxUser = 256
    Dim maxDomain As Long: maxDomain = 256
    Dim maxPass As Long: maxPass = 256

    Dim userS As String: userS = String$(maxUser, vbNullChar)
    Dim domainS As String: domainS = String$(maxDomain, vbNullChar)
    Dim passS As String: passS = String$(maxPass, vbNullChar)

    Dim lenUser As Long: lenUser = maxUser
    Dim lenDomain As Long: lenDomain = maxDomain
    Dim lenPass As Long: lenPass = maxPass

    If enableDebug Then Debug.Print "Appel CredUnPackAuthenticationBuffer..."

    ret = CredUnPackAuthenticationBuffer(0, outBuf, outBufSize, _
                                        StrPtr(userS), lenUser, _
                                        StrPtr(domainS), lenDomain, _
                                        StrPtr(passS), lenPass)

    ' Libération du buffer (CRITIQUE)
    If outBuf <> 0 Then
        CoTaskMemFree outBuf
        If enableDebug Then Debug.Print "Buffer libéré"
    End If

    If enableDebug Then
        Debug.Print "Retour CredUnPackAuthenticationBuffer: " & ret
        Debug.Print "Longueurs retournées - User: " & lenUser & ", Domain: " & lenDomain & ", Pass: " & lenPass
    End If

    If ret <> 0 Then
        ' Extraire les chaînes
        If lenUser > 0 And lenUser <= Len(userS) Then
            result.username = Left$(userS, lenUser)
        End If

        If lenDomain > 0 And lenDomain <= Len(domainS) Then
            result.domain = Left$(domainS, lenDomain)
        End If

        If lenPass > 0 And lenPass <= Len(passS) Then
            result.password = Left$(passS, lenPass)
        End If

        result.Success = True

        If enableDebug Then
            Debug.Print "=== RESULTATS ==="
            Debug.Print "Username: [" & result.username & "]"
            Debug.Print "Domain: [" & result.domain & "]"
            Debug.Print "Password: [***] (longueur: " & Len(result.password) & ")"
            Debug.Print "=== FIN ==="
        End If
    Else
        If enableDebug Then Debug.Print "ERREUR - CredUnPackAuthenticationBuffer a échoué"
    End If

    PromptCredentials = result
End Function

' =============================================================================
' FONCTIONS UTILITAIRES - Récupèrent un seul élément
' =============================================================================

' Fonction qui retourne seulement le username
Public Function GetUsername(Optional ByVal caption As String = "Saisir le nom d'utilisateur", _
                           Optional ByVal message As String = "Entrez vos credentials :") As String
    Dim creds As CredentialInfo
    creds = PromptCredentials(caption, message, False)
    GetUsername = creds.username
End Function

' Fonction qui retourne seulement le domain
Public Function GetDomain(Optional ByVal caption As String = "Saisir le domaine", _
                          Optional ByVal message As String = "Entrez vos credentials :") As String
    Dim creds As CredentialInfo
    creds = PromptCredentials(caption, message, False)
    GetDomain = creds.domain
End Function

' Fonction qui retourne seulement le password
Public Function GetPassword(Optional ByVal caption As String = "Saisir le mot de passe", _
                           Optional ByVal message As String = "Entrez vos credentials :") As String
    Dim creds As CredentialInfo
    creds = PromptCredentials(caption, message, False)
    GetPassword = creds.password
End Function

' =============================================================================
' FONCTIONS DE TEST
' =============================================================================

' Test complet avec affichage détaillé
Sub Tester_Complete()
    Dim creds As CredentialInfo
    Debug.Print "=== TEST COMPLET ==="

    creds = PromptCredentials("Test Complet", "Saisissez vos credentials :", True)

    If creds.Success Then
        MsgBox "Username: " & Left(creds.username, Len(creds.username) - 1) & "Password: " & Left(creds.password, Len(creds.password) - 1)
    Else
        MsgBox "Échec de récupération des credentials. Voir la fenêtre Debug pour détails."
    End If
End Sub

' Test du username uniquement
Sub Tester_Username()
    Dim username As String
    username = GetUsername("Test Username", "Entrez vos credentials :")
    If username <> "" Then
        MsgBox "Username récupéré: " & username
    Else
        MsgBox "Aucun username récupéré"
    End If
End Sub

' Test du domain uniquement
Sub Tester_Domain()
    Dim domain As String
    domain = GetDomain("Test Domain", "Entrez vos credentials :")
    If domain <> "" Then
        MsgBox "Domain récupéré: " & domain
    Else
        MsgBox "Aucun domain récupéré (normal si utilisateur local)"
    End If
End Sub

' Test du password uniquement
Sub Tester_Password()
    Dim password As String
    password = GetPassword("Test Password", "Entrez vos credentials :")
    If password <> "" Then
        MsgBox "Password récupéré (longueur: " & Len(password) & ")"
    Else
        MsgBox "Aucun password récupéré"
    End If
End Sub

' Test rapide sans debug
Sub Tester_Rapide()
    Dim creds As CredentialInfo
    creds = PromptCredentials("Test Rapide", "Credentials :")

    If creds.Success Then
        Debug.Print "OK - User: " & creds.username & ", Domain: " & creds.domain & ", Pass: " & Len(creds.password) & " chars"
    Else
        Debug.Print "ECHEC"
    End If
End Sub

' =============================================================================
' EXEMPLE D'UTILISATION PRATIQUE
' =============================================================================

' Exemple : Connexion à une base de données
Sub ExempleConnexionBDD()
    Dim creds As CredentialInfo
    creds = PromptCredentials("Connexion Base de Données", "Entrez vos identifiants de connexion :")

    If creds.Success Then
        ' Construire la chaîne de connexion
        Dim connectionString As String
        connectionString = "Server=monserveur;Database=mabase;" & _
                          "User Id=" & creds.username & ";" & _
                          "Password=" & creds.password & ";"

        Debug.Print "Chaîne de connexion créée (password masqué)"
        ' Ici vous pourriez utiliser connectionString pour vous connecter

        ' Nettoyer les variables sensibles
        creds.password = ""
        connectionString = ""
    Else
        MsgBox "Connexion annulée par l'utilisateur"
    End If
End Sub

' Exemple : Authentification avec domaine
Sub ExempleAuthDomaine()
    Dim creds As CredentialInfo
    creds = PromptCredentials("Authentification Réseau", "Connectez-vous au domaine :")

    If creds.Success Then
        Dim fullUsername As String
        If creds.domain <> "" Then
            fullUsername = creds.domain & "\" & creds.username
        Else
            fullUsername = creds.username
        End If

        MsgBox "Authentification pour: " & fullUsername
        ' Ici vous pourriez utiliser les credentials pour l'authentification réseau

        ' Nettoyer
        creds.password = ""
    End If
End Sub

Alex020181 · Answer

J'ai repris le fichier de cousin de Cousinhub (merci Cousinhub) et ajouté un module contenant ton code. Ce module sera appelé si le MDP saisi est correct. Djodjo tu n'as plus qu'à compléter le module "ton_code_ici" que j'ai ajouté. Dysortographie ta réponse est très complète mais je ne suis pas sûr que ce soit la demande. Remarque moi aussi je me suis planté dans la compréhension de la question lors de ma première réponse. Teste et dis nous...

Alex020181 · Answer

...