Titre du sujet : Re: Mot de passe sur bouton
par JCGL le 25/04/2013 20:40:04
Bonjour à tous,
Avec un code de l'ami Didier
Option Explicit
'---------------------------------------------------------------------------------------
' Auteur : Didier FOURGEOT (myDearFriend!) - www.mdf-xlpages.com
' Date : 26/07/2007
' Sujet : Une InputBox façon "Mot de Passe" ?
'---------------------------------------------------------------------------------------
Public Rep As String
Function InputBoxPwd(rPrompt As String, Optional rTitle As String, Optional rDefault As String) As String
Dim Usf As Object
Dim T As String
Dim N As Byte
'Création d'un Userform "à la volée"
Set Usf = ThisWorkbook.VBProject.VBComponents.Add(3)
With Usf
For N = 1 To 4
'Propriétés du USF
If N < 4 Then
.Properties(Choose(N, "Caption", "Height", "Width")) = Choose(N, rTitle, 110, 280)
End If
'Création des 4 contrôles et du code associé aux boutons
With .Designer.Controls.Add("Forms." & Choose(N, "TextBox", "Label", "CommandButton", "CommandButton") & ".1")
.Move Choose(N, 6, 6, 228, 228), _
Choose(N, 64, 6, 6, 30), _
Choose(N, 264, 210, 42, 42), _
Choose(N, 16, 54, 18, 18)
Select Case N
Case 1
'Propriétés du TextBox
.Value = rDefault
.PasswordChar = "*"
Case Else
.Caption = Choose(N - 1, rPrompt, "OK", "Annuler")
'Création du code VBA associé aux boutons
If N > 2 Then
T = "Private Sub " & .Name & "_Click(): "
If N = 3 Then
.Default = True
T = T & "Rep = Me.TextBox1.Text: "
End If
T = T & "Unload Me: End Sub"
With Usf.CodeModule
.InsertLines .CountOfLines + 1, T
End With
End If
End Select
End With
Next N
'Afficher InputBox fictive
VBA.UserForms.Add(.Name).Show
'Retour réponse utilisateur
InputBoxPwd = Rep
End With
'Supprimer l'USF créé
ThisWorkbook.VBProject.VBComponents.Remove Usf
End Function
Et
Private Sub CommandButton4_Click()
Dim sPass As String
If MsgBox("Etes-vous le concepteur du programme ?", 4 + 32, "Demande du concepteur") = vbYes Then
Else
End
End If
Do
sPass = InputBoxPwd("Veuillez saisir le mot de passe")
If sPass = "mon mdp" Then
Exit Do
End If
Loop While 1 = 1
ActiveWindow.DisplayWorkbookTabs = True
End Sub
A+ à tous
|
Didier FOURGEOT