اظهار كلمة المرور على شكل نجوم

[أيمن عبادي]

السلام عليكم اخواني

كنت قد وضعت سؤال عن كيفية وضع كلمة السر لنموذج عند فتح، وقد تم الحل عن طريق أحد الخبراء جزاك الله خيرا على هذا الرابط

ولكن كلمة المرور تظهر عند كتابها في الصندوق اريد ان تكون على شكل نجوم

بوركتم

password.rar

تم تعديل نوفمبر 9, 2018 بواسطه أيمن عبادي

[kanory]

تفضل أخي الكريم .....

 

password.accdb

[أيمن عبادي]

الشكر الجزيل لك أخي

ولكن أخي يعطيني رسالة بأن هناك خطأ حسب الصورة المرفقة

 

هل من حل لها ؟

تم تعديل نوفمبر 17, 2018 بواسطه أيمن عبادي

[kanory]

البرنامج شغال لدي .... جربه على جهاز اخر

 

[jjafferr]

السلام عليكم

 

وانا كذلك ، البرنامج عندي شغال 🙂

 

واليك طريقة اخرى ، مشابهة لطريقة اخي kanory 🙂

 

في النموذج ، وعلى حدث "فتح النموذج" اكتب هذا الكود:

Private Sub Form_Open(Cancel As Integer)

str_Title = "الرقم السري مطلوب"
str_Prompt = "ادخل الرقم السري"

If InputBoxDK(str_Prompt, str_Title) = DLookup("[Pass]", "Pass", "[Pass]") Then
        MsgBox "الرقم السري صحيح", , "تفضل بالدخول"
        'DoCmd.Close
        DoCmd.OpenForm "employees_F", acNormal
   Else
        MsgBox "الرقم السري خاطىء", , "لا يمكنك الدخول"
        DoCmd.CancelEvent

        End If
End Sub

.

والذي ينادي الوحدة النمطية:

Option Compare Database
Option Explicit

'--------------------------------------------------------------------
'
' Copyright 1996-2013 J Street Technology, Inc.
' www.JStreetTech.com
'
' This code may be used and distributed as part of your application
' provided that all comments remain intact.
'
' J Street Technology offers this code "as is" and does not assume
' any liability for bugs or problems with any of the code.  In
' addition, we do not provide free technical support for this code.
'
' Code for Password-masked InputBox was originally written by
' Daniel Klann in March 2003 and has been adapted & updaed for 64-bit
' compatiblity
'--------------------------------------------------------------------

'Revised Type Declare for compatability with NT
'Re-revised for 64-bit compatibility
#If VBA7 Then
    Type tagOPENFILENAME
        lStructSize         As Long
        hwndOwner           As LongPtr
        hInstance           As LongPtr
        lpstrFilter         As String
        lpstrCustomFilter   As Long
        nMaxCustFilter      As Long
        nFilterIndex        As Long
        lpstrFile           As String
        nMaxFile            As Long
        lpstrFileTitle      As String
        nMaxFileTitle       As Long
        lpstrInitialDir     As String
        lpstrTitle          As String
        Flags               As Long
        nFileOffset         As Integer
        nFileExtension      As Integer
        lpstrDefExt         As String
        lCustData           As LongPtr
        lpfnHook            As LongPtr
        lpTemplateName      As Long
    End Type
    
    
    Private Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" _
        Alias "GetOpenFileNameA" (OPENFILENAME As tagOPENFILENAME) As Boolean

'APIs for Password-masked Inputbox
    Private Declare PtrSafe Function CallNextHookEx Lib "user32" ( _
        ByVal hHook As LongPtr, _
        ByVal ncode As Long, _
        ByVal wParam As LongPtr, _
        lParam As Any _
    ) As LongPtr
    
    Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" ( _
        ByVal lpModuleName As String _
    ) As LongPtr

    Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" ( _
        ByVal idHook As Long, _
        ByVal lpfn As LongPtr, _
        ByVal hmod As LongPtr, _
        ByVal dwThreadID As Long _
    ) As LongPtr
    
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" ( _
        ByVal hHook As LongPtr _
    ) As Long

    Private Declare PtrSafe Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" ( _
        ByVal hDlg As LongPtr, _
        ByVal nIDDlgItem As Long, _
        ByVal wMsg As Long, _
        ByVal wParam As LongPtr, _
        ByVal lParam As LongPtr _
    ) As LongPtr
    
    Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" ( _
        ByVal hwnd As LongPtr, _
        ByVal lpClassName As String, _
        ByVal nMaxCount As Long _
    ) As Long

    Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
    
    Private hHook As LongPtr
#Else
    Type tagOPENFILENAME
        lStructSize         As Long
        hwndOwner           As Long
        hInstance           As Long
        lpstrFilter         As String
        lpstrCustomFilter   As Long
        nMaxCustFilter      As Long
        nFilterIndex        As Long
        lpstrFile           As String
        nMaxFile            As Long
        lpstrFileTitle      As String
        nMaxFileTitle       As Long
        lpstrInitialDir     As String
        lpstrTitle          As String
        Flags               As Long
        nFileOffset         As Integer
        nFileExtension      As Integer
        lpstrDefExt         As String
        lCustData           As Long
        lpfnHook            As Long
        lpTemplateName      As Long
    End Type
    
    Private Declare Function GetOpenFileName Lib "comdlg32.dll" _
        Alias "GetOpenFileNameA" (OPENFILENAME As tagOPENFILENAME) As Long
        
'APIs for Password-masked Inputbox
    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
    
    Private hHook As Long
#End If

'Constants used by Password-masked Inputbox
Private Const EM_SETPASSWORDCHAR As Long = &HCC
Private Const WH_CBT As Long = 5
Private Const HCBT_ACTIVATE As Long = 5
Private Const HC_ACTION As Long = 0

#If VBA7 Then
Private Function InputBoxPasswordMaskProc( _
    ByVal lngCode As Long, _
    ByVal wParam As LongPtr, _
    ByVal lParam As LongPtr _
) As LongPtr
#Else
Private Function InputBoxPasswordMaskProc( _
    ByVal lngCode As Long, _
    ByVal wParam As Long, _
    ByVal lParam As Long _
) As Long
#End If
    'DO NOT PUT IN VBA ERROR HANDLING
    'This is a Windows procedure called by Message loop.
    On Error Resume Next
    
    'Originally written by Daniel Klann
    'Updated for 64-bit compatibility
    
    Dim RetVal
    Dim strClassName As String
    Dim lngBuffer As Long
 
    If lngCode < HC_ACTION Then
        InputBoxPasswordMaskProc = 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
 
'Private Function InputBoxDK( _

Function InputBoxDK( _
    Prompt, _
    Optional Title, _
    Optional Default, _
    Optional XPos, _
    Optional YPos, _
    Optional HelpFile, _
    Optional Context _
) As String
    'Originally written by Daniel Klann
    'Updated for 64-bit compatibility
    
    'Replicate the functionality of Inputbox function
    'while providing password masking.
#If VBA7 Then
    Dim lngModHwnd As LongPtr
#Else
    Dim lngModHwnd As Long
#End If
    Dim lngThreadID As Long
 
    On Error GoTo ErrHandler

    lngThreadID = GetCurrentThreadId
    lngModHwnd = GetModuleHandle(vbNullString)
 
    hHook = SetWindowsHookEx(WH_CBT, AddressOf InputBoxPasswordMaskProc, lngModHwnd, lngThreadID)
 
    InputBoxDK = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context)
    UnhookWindowsHookEx hHook

ExitProc:
    On Error Resume Next
    Exit Function
ErrHandler:
    Select Case Err.Number
        Case Else
            VBA.MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
    End Select
    Resume ExitProc
    Resume 'for Debugging
End Function  'Hope someone can use it!

.

جعفر

983.password.accdb.zip

[Shivan Rekany]

7 ساعات مضت, أيمن عبادي said:

ولكن أخي يعطيني رسالة بأن هناك خطأ حسب الصورة المرفقة

سؤال : هل نسخت وحدة النمطية حتى عطيتك ذلك الرسالة ؟

لان لدي ما في مشكلة ولكن بعد حذف الوحدة النمطية بيعطيني نفس الرسالة

[أيمن عبادي]

لكم اخواني جزيل الشكر والعرفان

الحمد لله اشتغل بشكل صحيح ... تقبلوا تحياتي

[Shivan Rekany]

16 دقائق مضت, أيمن عبادي said:

لكم اخواني جزيل الشكر والعرفان

الحمد لله اشتغل بشكل صحيح

شو عملت حتى اشتغلت بشكل صحيح عندك ؟ لكي يستفيد الجميع