ارجو مساعدتي في اخفاء كلمة المرور وجعلها تظهر على شكل نجوم

[asdewq]

اخواني السلام عليكم ورحمة الله وبركاته

ارجو  المساعده في اخفاء الباسوورد الذي يتضمنه الكود المرفق حيث ليس فيه ( تكست بوكس ) واظهار نجوم بدل الارقام  

Private Sub أمر242_Click()
Dim pwd As String
pwd = InputBox("ادخل كلمة المرور")
If pwd = "350" Then
DoCmd.OpenForm "امر حذف الملاحظات"
Else
MsgBox "كلمة مرور خطاء"
DoCmd.CancelEvent
End If
End Sub

[أواب]

أخي الكريم

جرب هذا الكود

 Dim str_Prompt
TimerId = SetTimer(0, 0, 1, AddressOf TimerProc)
 str_Title = "كلمــــــــة المـــــــــرور مطلــــوبة"
 str_Prompt = "أدخـــــــــــــــل كلمــــــــــــة المـــــــــــرور"
If InputBox(str_Prompt, str_Title) = "350" Then
  DoCmd.OpenForm "امرحذف الملاحظات"
' اكتب هنا الإجراءات إذا كانت الكلمة صحيحة
Else
MsgBox "Error Password", vbOKOnly, "خطأ فى الباسوورد"
DoCmd.Close
End If

 

[asdewq]

شكرا اخي او اب على الرد بس ممكن سوال 

اين اضع الكود الذي ارسلته امسح الاول ام اضيفه عليه

[أواب]

بدلا من الأول

وضع الكود الآتي في وحدة نمطية جديدة   أو أسفل الكود السابق

Option Compare Database
Private Declare Function apiShowWindow Lib "user32" _
Alias "ShowWindow" (ByVal hwnd As Long, _
ByVal nCmdShow As Long) As Long
'++++++++++++++++
Declare Function SetTimer Lib "user32" (ByVal hwnd _
 As Long, ByVal nIDEvent As Long, ByVal uElapse _
 As Long, ByVal lpTimerFunc As Long) As Long
Declare Function KillTimer Lib "user32" _
(ByVal hwnd As Long, ByVal nIDEvent As Long) _
As Long
Declare Function FindWindowEx Lib "user32" _
 Alias "FindWindowExA" (ByVal hWndParent As _
 Long, ByVal hWndChildAfter As Long, ByVal _
 lpClassName As String, ByVal lpWindowName _
 As String) As Long
Declare Function Sendmessagebynum _
 Lib "user32" Alias "SendMessageA" (ByVal _
 hwnd As Long, ByVal wMsg As Long, ByVal _
 wParam As Long, ByVal lParam As Long) _
 As Long

 Const EM_SETPASSWORDCHAR = &HCC
  Public str_Title$, TimerId&

Sub TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, _
 ByVal uElapse As Long, ByVal lpTimerFunc As Long)
 KillTimer 0, TimerId
 Dim lng_Hwnd&
 lng_Hwnd = FindWindowEx(0, 0, "#32770", _
  Trim(str_Title))
 lng_Hwnd = FindWindowEx(lng_Hwnd, 0, _
  "Edit", vbNullString)
 If lng_Hwnd Then
  Sendmessagebynum lng_Hwnd, EM_SETPASSWORDCHAR, 42, 0
 End If

End Sub

 

تم تعديل أبريل 13, 2019 بواسطه أواب

[SEMO.Pa3x]

السلام عليكم. طريقة اخرى عن طريق winAPI

 

'----------------------------------
'API CONSTANTS FOR PRIVATE 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

'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

'----------------------------------
'PRIVATE PASSWORDS FOR INPUTBOX
'----------------------------------

'////////////////////////////////////////////////////////////////////
'Password masked inputbox
'Allows you to hide characters entered in a VBA Inputbox.
'
'Code written by Daniel Klann
'March 2003
'////////////////////////////////////////////////////////////////////

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

Function InputBoxDK(Prompt, Title) 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)
    UnhookWindowsHookEx hHook

End Function










'Call: InputBoxDK("Enter your Password.", "Password Required")

 

حسنين

[ابو جودي]

اتفضل 

PasswordTest.accdb

[asdewq]

الف شكرا للجميع على التفاعل

لم تنجح معي 

ياخوان اناعندي زر امر يفتح نموذج ثاني وابي احط على زر الامر رقم سري ما سوية مربع نص لدخال كلمة المرور 

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

وهذا الكود الي سويته

Private Sub أمر242_Click()
Dim pwd As String
pwd = InputBox("ادخل كلمة المرور")
If pwd = "350" Then
DoCmd.OpenForm "امر حذف الملاحظات"
Else
MsgBox "كلمة مرور خطاء"
DoCmd.CancelEvent
End If
 End Sub

 

[SEMO.Pa3x]

55 دقائق مضت, asdewq said:

الف شكرا للجميع على التفاعل

لم تنجح معي 

ياخوان اناعندي زر امر يفتح نموذج ثاني وابي احط على زر الامر رقم سري ما سوية مربع نص لدخال كلمة المرور 

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

وهذا الكود الي سويته

Private Sub أمر242_Click()
Dim pwd As String
pwd = InputBox("ادخل كلمة المرور")
If pwd = "350" Then
DoCmd.OpenForm "امر حذف الملاحظات"
Else
MsgBox "كلمة مرور خطاء"
DoCmd.CancelEvent
End If
 End Sub

 

 

اخي الكريم اقرأ ردي في الاعلى ففهيه جوابك لسؤالك.

[ehabaf2]

On 4/13/2019 at 4:18 AM, أواب said:

أخي الكريم

بعد اذنك عندى كود ظهور رسالة تطلب الرقم المرور للانتقال الى شيت اخر داخل الاكسل

عاوز اعدل الكود لاخفاء كلمة المرور عند كتابتها الكود مكتوب اسفل منه

Private Sub Worksheet_Activate()

xx:

Dim x
x = InputBox("Password required" & Chr(13) & "ãÑÍÈÇ Èßã 000 ÞÓã ÇáÊÞæííã æ ÇáÇãÊÍÇäÇÊ -- ÇíåÇÈ ÇáÇÓæÇäì", "ãÍãì ÈæÇÓØÉ ãÓÆæá ÇáÊÞæíã æ ÇáÇãÊÍÇäÇÊ")
If IsNull(x) Or x = "" Then GoTo xx

If x = 45 Then
MsgBox "ãÑÍÈÇ Èßã 000 ÇÚãÇá ÊÑã Ãæá"
Else
MsgBox "áíÓ áÏíß ÕáÇÍíÉ ÇáÏÎæá" & Chr(13) & " ÇáÚæÏÉ ááÕÝÍÉ ÇáÑÆíÓíÉ", vbOKOnly
Sheets("sheet1").Activate
End If

End Sub

 

 Dim str_Prompt
TimerId = SetTimer(0, 0, 1, AddressOf TimerProc)
 str_Title = "كلمــــــــة المـــــــــرور مطلــــوبة"
 str_Prompt = "أدخـــــــــــــــل كلمــــــــــــة المـــــــــــرور"
If InputBox(str_Prompt, str_Title) = "350" Then
  DoCmd.OpenForm "امرحذف الملاحظات"
' اكتب هنا الإجراءات إذا كانت الكلمة صحيحة
Else
MsgBox "Error Password", vbOKOnly, "خطأ فى الباسوورد"
DoCmd.Close
End If