استدعاء فورم عن طريق رقم سري

**محمد الورفلي1** · يناير 29, 2016

السكم عليكم

هل يمكن استدعاء فورم برقم سري بمعنى عند الظغط علي مفتاح فورم الموجود في الشيت لايظهر الفوم الا بعد وضع رقم سري

**رجب جاويش** · يناير 29, 2016

طبعا ممكن

اجعل كود استدعاء الفورم كالاتى

Sub النتائج()
Dim x As Variant
x = InputBox("أدخل كلمة المرور لفتح الفورم")
If x = "" Then Exit Sub
If x = "123" Then
UserForm1.Show
Else
MsgBox ("كلمة المرور غير صحيحة")
End If
End Sub

**محمد الورفلي1** · يناير 29, 2016

بارك الله فيك

تمام بس ا لرقم يكو ن *** نجوم

تم تعديل يناير 29, 2016 بواسطه محمد الخازمي

**مختار حسين محمود** · يناير 29, 2016

Sub ShowUF()
    Dim strPass As String
    Dim LCount As Integer

    For LCount = 1 To 3
        strPass = InputBox(Prompt:="الرجاء إدخال كلمة المرور", Title:="كلمة المرور")
        If strPass = vbNullString Then
            Exit Sub
        ElseIf strPass <> "123" Then
            MsgBox "كلمة المرور غير صحيحة", vbCritical, "التأكد من كلمة المرور"
        Else
            UserForm1.Show
            Exit For
        End If
    Next LCount
    
    If LCount = 4 Then Exit Sub
End Sub

تحياتى أخى رجب بارك الله فيكم

أخى محمد وجرب الكود السابق كمان

ياسر خليل أبو البراء · يناير 29, 2016

أخي الحبيب رجب جاويش وأخي الغالي مختار

بارك الله فيكما وجزاكما الله خيرأً

إليكم هذا الحل إثراءً للموضوع ..الحل معقد بعض الشيء لكنه يلبي الغرض من ناحية إظهار كلمة السر على شكل نجوم

أولاً يتم إدراج موديول من النوع Class باسم PwdInputBox

ويوضع فيه الكود التالي

Function PassInputBox(Prompt As String, Optional PasswordChar As String, Optional Title As String, Optional Default As String, Optional XPos As Long, Optional YPos As Long)
    Dim UF
    Dim VUF As Object
    Dim Lb  As Object
    Dim Tb  As Object
    Dim BOk  As Object
    Dim BCancel  As Object
    Dim VBAVisible As Boolean
    Dim I As Integer
    
    If Len(Title) = 0 Then Title = Application.Name
    
    VBAVisible = Application.VBE.MainWindow.Visible
    Application.VBE.MainWindow.Visible = False
    
    Set UF = ThisWorkbook.VBProject.VBComponents.Add(3)
    
    Set Tb = UF.Designer.Controls.Add("Forms.Textbox.1", "TextBox1")
    With Tb
        .PasswordChar = PasswordChar
        .Left = 4.5
        .Top = 69.75
        .Width = 254.25
        .Height = 15.75
        .Value = Default
    End With
    
    Set Lb = UF.Designer.Controls.Add("Forms.Label.1")
    With Lb
        .Caption = Prompt
        .WordWrap = True
        .Left = 6.75
        .Top = 6.75
        .Width = 198
        .Height = 54
    End With
    
    Set BOk = UF.Designer.Controls.Add("Forms.CommandButton.1", "BOk")
    With BOk
        .Caption = "OK"
        .Left = 209.25
        .Top = 4.5
        .Width = 49.5
        .Height = 18
        .Default = True
    End With
    
    Set BCancel = UF.Designer.Controls.Add("Forms.CommandButton.1", "BCancel")
    With BCancel
        .Caption = "Cancel"
        .Cancel = True
        .Left = 209.25
        .Top = 27
        .Width = 49.5
        .Height = 18
    End With
    
    With UF.CodeModule
        I = .CountOfLines
        .InsertLines I + 0, "Public MyText as Variant"
        .InsertLines I + 1, "Private Sub BCancel_Click()"
        .InsertLines I + 2, "   MyText = False: Me.Hide"
        .InsertLines I + 3, "End Sub"
        .InsertLines I + 4, "Private Sub BOk_Click()"
        .InsertLines I + 5, "   MyText = TextBox1.Value: Me.Hide"
        .InsertLines I + 6, "End Sub"
        .InsertLines I + 7, "Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)"
        .InsertLines I + 8, "   If CloseMode = 0 Then Cancel = True: MyText = False: Me.Hide"
        .InsertLines I + 9, "End Sub"
    End With

    With UF
        .Properties("Caption") = Title
        .Properties("Width") = 273
        .Properties("Height") = 108.75
        
        If XPos > 0 Or YPos > 0 Then
            .Properties("StartUpPosition") = 0
            .Properties("Left") = XPos
            .Properties("Top") = YPos
        Else
            .Properties("StartUpPosition") = 1
        End If
    End With
    
    Set VUF = VBA.UserForms.Add(UF.Name)
    VUF.Show
    PassInputBox = VUF.MyText
    
    ThisWorkbook.VBProject.VBComponents.Remove VBComponent:=UF
    
    Application.VBE.MainWindow.Visible = VBAVisible
End Function

ثم يتم إدراج الكود التالي في موديول عادي ..

Sub ShowForm()
    Dim ANS As Variant
    Dim App As PwdInputBox
    Set App = New PwdInputBox
    
    ANS = App.PassInputBox("Please Enter The Password", "*", "My Application")
    
    If ANS = False Or ANS = "" Then
        Exit Sub
    Else
        If ANS = "123" Then UserForm1.Show Else MsgBox "Incorrect Password", vbCritical
    End If
End Sub

وإليكم المرفق فيه تطبيق ما سبق

تقبلوا تحياتي

Show UserForm By Password Mask For InputBox YasserKhalil.rar

**محمد الورفلي1** · يناير 29, 2016

للفائدة

وجدت هذا الكود لااستاذ محمدصالح

وهذا الرابط

http://www.officena.net/ib/topic/46101-طلب-تعديل-كود-لإظهار-الرقم-السري-على-شكل-نجوم/

Option Explicit
'////////////////////////////////////////////////////////////////////
'Password masked inputbox
'Allows you to hide characters entered in a VBA Inputbox.
'
'Code written by Daniel Klann
'March 2003
'////////////////////////////////////////////////////////////////////
 
 
'API functions to be used
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _
                                                      ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
 
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
 
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _
                                          (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, _
                                          ByVal dwThreadId As Long) As Long
 
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
 
Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" _
                                            (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, _
                                            ByVal wParam As Long, ByVal lParam As Long) As Long
 
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, _
                                                                          ByVal lpClassName As String, _
                                                                          ByVal nMaxCount As Long) As Long
 
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
 
'Constants to be used in our API functions
Private Const EM_SETPASSWORDCHAR = &HCC
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5
Private Const HC_ACTION = 0
 
Private hHook As Long
 
Public Function NewProc(ByVal lngCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim RetVal
    Dim strClassName As String, lngBuffer As Long
 
    If lngCode < HC_ACTION Then
        NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam)
        Exit Function
    End If
 
    strClassName = String$(256, " ")
    lngBuffer = 255
 
    If lngCode = HCBT_ACTIVATE Then    'A window has been activated
 
        RetVal = GetClassName(wParam, strClassName, lngBuffer)
 
        If Left$(strClassName, RetVal) = "#32770" Then  'Class name of the Inputbox
 
            'This changes the edit control so that it display the password character *.
            'You can change the Asc("*") as you please.
            SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0
        End If
 
    End If
 
    'This line will ensure that any other hooks that may be in place are
    'called correctly.
    CallNextHookEx hHook, lngCode, wParam, lParam
 
End Function
 
Public Function InputBoxDK(Prompt, Optional Title, Optional Default, Optional XPos, _
                        Optional YPos, Optional HelpFile, Optional Context) As String
 
    Dim lngModHwnd As Long, lngThreadID As Long
 
    lngThreadID = GetCurrentThreadId
    lngModHwnd = GetModuleHandle(vbNullString)
 
    hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID)
 
    InputBoxDK = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context)
    UnhookWindowsHookEx hHook
 
End Function  'Hope someone can use it!

Sub TEST()
Dim strAdminPWord As String
strAdminPWord = InputBoxDK("Password required to proceed.", "Enter Licence Code")
If strAdminPWord = "password" Then
    MsgBox "cool Password Correct ", vbOKOnly, "success"
Else
    MsgBox ("You entered an invalid password")
   ' Exit Sub
End If
End Sub

**رجب جاويش** · يناير 29, 2016

وهذا كود آخر منقول من موقع أجنبى

Option Explicit
 
 '////////////////////////////////////////////////////////////////////
 'Password masked inputbox
 'Allows you to hide characters entered in a VBA Inputbox.
 '
 'Code written by Daniel Klann
 'http://www.danielklann.com/
 'March 2003
 
 '// Kindly permitted to be amended
 '// Amended by Ivan F Moala
 '// http://www.xcelfiles.com
 '// April 2003
 '// Works for Xl2000+ due the AddressOf Operator
 '////////////////////////////////////////////////////////////////////
 
 '********************   CALL FROM FORM *********************************
 '    Dim pwd As String
 '
 '    pwd = InputBoxDK("Please Enter Password Below!", "Database Administration Security Form.")
 '
 '    'If no password was entered.
 '    If pwd = "" Then
 '        MsgBox "You didn't enter a password!  You must enter password to 'enter the Administration Screen!" _
 '        , vbInformation, "Security Warning"
 '    End If
 '**************************************
 
 
 
 'API functions to be used
Private Declare Function CallNextHookEx _
Lib "user32" ( _
ByVal hHook As Long, _
ByVal ncode As Long, _
ByVal wParam As Long, _
lParam As Any) _
As Long
 
Private Declare Function GetModuleHandle _
Lib "kernel32" _
Alias "GetModuleHandleA" ( _
ByVal lpModuleName As String) _
As Long
 
Private Declare Function SetWindowsHookEx _
Lib "user32" _
Alias "SetWindowsHookExA" ( _
ByVal idHook As Long, _
ByVal lpfn As Long, _
ByVal hmod As Long, _
ByVal dwThreadId As Long) _
As Long
 
Private Declare Function UnhookWindowsHookEx _
Lib "user32" ( _
ByVal hHook As Long) _
As Long
 
Private Declare Function SendDlgItemMessage _
Lib "user32" Alias "SendDlgItemMessageA" ( _
ByVal hDlg As Long, _
ByVal nIDDlgItem As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) _
As Long
 
Private Declare Function GetClassName _
Lib "user32" _
Alias "GetClassNameA" ( _
ByVal hWnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) _
As Long
 
Private Declare Function GetCurrentThreadId _
Lib "kernel32" () _
As Long
 
 'Constants to be used in our API functions
Private Const EM_SETPASSWORDCHAR = &HCC
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5
Private Const HC_ACTION = 0
 
Private hHook As Long
 
Public Function NewProc(ByVal lngCode As Long, _
    ByVal wParam As Long, _
    ByVal lParam As Long) As Long
     
    Dim RetVal
    Dim strClassName As String, lngBuffer As Long
     
    If lngCode < HC_ACTION Then
        NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam)
        Exit Function
    End If
     
    strClassName = String$(256, " ")
    lngBuffer = 255
     
    If lngCode = HCBT_ACTIVATE Then 'A window has been activated
        RetVal = GetClassName(wParam, strClassName, lngBuffer)
        If Left$(strClassName, RetVal) = "#32770" Then 'Class name of the Inputbox
             'This changes the edit control so that it display the password character *.
             'You can change the Asc("*") as you please.
            SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0
        End If
    End If
     
     'This line will ensure that any other hooks that may be in place are
     'called correctly.
    CallNextHookEx hHook, lngCode, wParam, lParam
     
End Function
 
 '// Make it public = avail to ALL Modules
 '// Lets simulate the VBA Input Function
Public Function InputBoxDK(Prompt As String, Optional Title As String, _
    Optional Default As String, _
    Optional Xpos As Long, _
    Optional Ypos As Long, _
    Optional Helpfile As String, _
    Optional Context As Long) As String
     
    Dim lngModHwnd As Long, lngThreadID As Long
     
     '// Lets handle any Errors JIC! due to HookProc> App hang!
    On Error GoTo ExitProperly
    lngThreadID = GetCurrentThreadId
    lngModHwnd = GetModuleHandle(vbNullString)
     
    hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID)
    If Xpos Then
        InputBoxDK = InputBox(Prompt, Title, Default, Xpos, Ypos, Helpfile, Context)
    Else
        InputBoxDK = InputBox(Prompt, Title, Default, , , Helpfile, Context)
    End If
     
ExitProperly:
    UnhookWindowsHookEx hHook
     
End Function
 
Sub TestDKInputBox()
    Dim x
     
    x = InputBoxDK("أدخل كلمة المرور", "كلمة المرور")
    If x = "" Then End
    If x <> "123" Then
        MsgBox "كلمة المرور غير صحيحة"
        End
    End If
    UserForm1.Show
End Sub

فورم.rar

مهند الزيدي · يناير 29, 2016

شكرا اخي العزيز رجب جاويش..

شكرا للاخ محمد الخازمي ..

شكرا للاخ ياسر خليل ..

اخي ياسر عند تنفيذ الظغط على زر اظهار الفورم .. نظهر الرسالة الخطأ كما في الصور المرفقة

تسجيل الدخول

استدعاء فورم عن طريق رقم سري

الردود الموصى بها

محمد الورفلي1

رجب جاويش

محمد الورفلي1

مختار حسين محمود

ياسر خليل أبو البراء

محمد الورفلي1

رجب جاويش

مهند الزيدي

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information