وضع كلمة مرور كشرط فى حدث عند الحذف

[Abdelaziz Osman]

السلام عليكم   يرجى الافادة  عن كود وضع كلمة مرور كشرط فى حدث عند الحذف  ( المطلوب هو حذف سجل باكملة وليس حقل حقل ولكن اريد شرط كلمة مرور عند الحذف)  ولكم منى بالغ التحية

[ازهر عبد العزيز]

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

ضع حقل غير منظم في النموذج واعطة اسم كمثال  textpassword  

ثم ضع الكود التالي عند الحذف 

if me.textpassword = 9999 then
   DoCmd.RunCommand acCmdDeleteRecord
else
   msgbox "error password"
end if

 

ستكون كلمة السر 9999

وهناك طرق اخرى حسب احتياجك

[Abdelaziz Osman]

لك جزيل الشكر @ازهر عبد العزيز      ولكن كيف   اضع حقل غير منظم في النموذج

وهل ممكن طريقة اخرى لزيادة المعرفة فقط لك منى بالغ التحية

تم تعديل أبريل 11, 2022 بواسطه Abdelaziz Osman

[Moosak]

2 ساعات مضت, Abdelaziz Osman said:

ولكن كيف   اضع حقل غير منظم في النموذج

نيابة عن أخي أزهر .. يقصد لك أن تضع مربع نص جديد وتسميه textpassword لكي يتعرف عليه الكود 🙂

 

أما لو أردت الاستغناء عن مربع النص والاستعاضة عنه بصندوق إدخال فاكتب الكود هكذا :

Private Sub Form_Delete(Cancel As Integer)

Dim InBox As String
InBox = InputBox("أدخل كلمة المرور لتأكيد الحذف", "خاص بالادارة")

If InBox = 9999 Then
   DoCmd.RunCommand acCmdDeleteRecord
Else
   MsgBox "كلمة مرور خاطئة"
   Cancel = True
End If
End Sub

 

[Abdelaziz Osman]

@Moosak

السلام عليكم ورحمة الله

هل ممكن ان ترسل  نموذج توضيحى

لك بالغ التحية

[Moosak]

أخي عبدالعزيز ضع الكود التالي على زر الحذف :

Dim InBox As String
On Error Resume Next
InBox = InputBox("أدخل كلمة المرور لتأكيد الحذف", "خاص بالادارة")

If InBox = 9999 Then
   DoCmd.RunCommand acCmdDeleteRecord
Else
   MsgBox "كلمة مرور خاطئة"
End If

وعند الضغط على الزر ستظهر لك هذه الرسالة :

إذا تم إدخال كلمة المرور بشكل صحيح = 9999

فسيتم الحذف وإلا فلن يتم الحذف 🙂 

[Abdelaziz Osman]

@Moosak

صورة تاكيد الحذف لاتزال موجودة حتى بعد الحذف

فما هو الحل

Dim InBox As String
On Error Resume Next
InBox = InputBox("أدخل كلمة المرور لتأكيد الحذف", "خاص بالادارة")

If InBox = 9999 Then
   DoCmd.RunCommand acCmdDeleteRecord
Else
   MsgBox "كلمة مرور خاطئة"
End If

[Moosak]

2 ساعات مضت, Abdelaziz Osman said:

صورة تاكيد الحذف لاتزال موجودة حتى بعد الحذف

ماذا تقصد بالصورة  ؟ 

هل ممكن تضع مرفق للتعديل مباشرة عليه ..

[ازهر عبد العزيز]

20 ساعات مضت, Abdelaziz Osman said:

صورة تاكيد الحذف لاتزال موجودة حتى بعد الحذف

فما هو الحل

لالغاء رسالة تاكيد الحذف

Dim InBox As String
On Error Resume Next
InBox = InputBox("أدخل كلمة المرور لتأكيد الحذف", "خاص بالادارة")

If InBox = 9999 Then
   DoCmd.SetWarnings False
   DoCmd.RunCommand acCmdDeleteRecord
   DoCmd.SetWarnings Treu
Else
   MsgBox "كلمة مرور خاطئة"
End If

 

تم تعديل أبريل 12, 2022 بواسطه ازهر عبد العزيز

[Abdelaziz Osman]

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

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

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

delete with password.mdb

[Abdelaziz Osman]

صديق ارسل لى هذا الكود   ولكن يوجد مشكلة ايضا

اقتباس

On Error GoTo Err_Form_Delete_Click
'----------
Dim secret As String
 secret = InputBox("Enter Password")
 If secret = "9999" Then

    DoCmd.DoMenuItem acFormBar, acEditMenu, 8, , acMenuVer70
    DoCmd.DoMenuItem acFormBar, acEditMenu, 6, , acMenuVer70
    Else
    MsgBox "Password invalid"
    Exit Sub
    End If
 '-----------------
Exit_Form_Delete_Click:
    Exit Sub

Err_Form_Delete_Click:
    MsgBox Err.Description
    Resume Exit_Form_Delete_Click

ارجوا التكرم بالافادة والمساعدة

تم تعديل أبريل 12, 2022 بواسطه Abdelaziz Osman

[عبدالقدوس48]

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

تفضل أخي

delete with password.mdb

[Abdelaziz Osman]

مربع ادخال كلمة المرور يظل مفتوح بعد الضغط على زر الحذف الخاص باعدادات النموذج !!!

[Eng.Qassim]

استخدم كود استاذ ازهر

علما ان كل الاكواد ليس يها مشكلة

[Shivan Rekany]

في 10‏/4‏/2022 at 07:11, Abdelaziz Osman said:

يرجى الافادة  عن كود وضع كلمة مرور كشرط فى حدث عند الحذف  ( المطلوب هو حذف سجل باكملة وليس حقل حقل ولكن اريد شرط كلمة مرور عند الحذف)  ولكم منى بالغ التحية

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

Private Sub BtnDelete_Click()
    If Me.NewRecord = True Then Exit Sub
        Dim MyPass, MyId
            MyPass = InputBox("للحذف السجل اكتب رقم سري الخاص بالحذف السجلات", "تأكيد الحذف")
If MyPass = 9999 Then
    MyId = Me.ID
    DoCmd.SetWarnings False
        DoCmd.RunCommand acCmdSelectRecord
        DoCmd.RunCommand acCmdDeleteRecord
    DoCmd.SetWarnings True
    MsgBox "تم حذف السجل رقم " & " ( " & MyId & " ) " & "بنجاح"
ElseIf Len(MyPass & "") = 0 Then
   MsgBox "تم الغاء العملية الحذف"
Else
   MsgBox "خطأ في رقم سري الخاص لحذف السجلات"
End If

End Sub

واليك ملف تطبيقي
 

DeleteWithPassword.accdb

[Abdelaziz Osman]

شكرا  معلمنا @Shivan Rekany  لك بالغ التحية بالفعل الحل الخاص بك قد نجح مع انى كنت اريد استخدام الزر الخاص بالحذف الموجود بالفعل  باعدادات النموذج ولكن الحل الخاص بك مبهر بالفعل لك بالغ التحية   

والان اريد المساعدة فى  الغاء زر الحذف  الموجود بالفعل بالنموذج  حتى لا يتم استخدام  زرارين معا

[abouelhassan]

بعد اذنك اخى عبد العزيز عثمان

استاذنا الفاضل Shivan Rekany هل بالامكان ان تكون الباس ورد على شكل نجوم ليكتمل الموضوع 

زادك الله من فضله اخى

احترام وتقدير من اخيك

تم تعديل أبريل 12, 2022 بواسطه abouelhassan

[Abdelaziz Osman]

 @Shivan Rekany   اريد ايضا  رسالة تأكيد  للحذف قبل الضغط بالحذف

[Eng.Qassim]

اليك اخفاء شريط الادوات ورسالة التاكيد للحذف

 

DeleteWithPassword.accdb

[Eng.Qassim]

منذ ساعه, abouelhassan said:

هل بالامكان ان تكون الباس ورد على شكل نجوم

المستخدم لايحتاج ان يكون الباسوورد له على شكل نجوم

ونموذج اكسس الخاص بالادخال لا اعتقد بامكانية التحكم به ..الا اذا عملت نموذج خاص بك

[Shivan Rekany]

2 ساعات مضت, Abdelaziz Osman said:

والان اريد المساعدة فى  الغاء زر الحذف  الموجود بالفعل بالنموذج  حتى لا يتم استخدام  زرارين معا

والجواب 

40 دقائق مضت, Eng.Qassim said:

اخفاء شريط الادوات

 

1 ساعه مضت, Abdelaziz Osman said:

اريد ايضا  رسالة تأكيد  للحذف قبل الضغط بالحذف

حسنا سنضيف اليه مسج التاكيدية

 

1 ساعه مضت, abouelhassan said:

هل بالامكان ان تكون الباس ورد على شكل نجوم ليكتمل الموضوع 

نعم , بواسطة هذا موديول
 

'----------------------------------
'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

وفي خلف الزر الحذف سنكتب هكذا
 

Private Sub BtnDelete_Click()
    If Me.NewRecord = True Then Exit Sub
        Dim MyPass, MyId
            MyPass = InputBoxDK("للحذف السجل اكتب رقم سري الخاص بالحذف السجلات", "تأكيد الحذف")
If MyPass = 9999 Then
    MyId = Me.ID
    If MsgBox("هل انت متأكد من حذف السجل" & " ( " & MyId & " ) " & "؟ عند اختيار ( نعم ) لا يمكنك الرجوع عنه ", vbYesNo, "رسالة تأكيدية") = vbYes Then
        DoCmd.SetWarnings False
            DoCmd.RunCommand acCmdSelectRecord
            DoCmd.RunCommand acCmdDeleteRecord
        DoCmd.SetWarnings True
        MsgBox "تم حذف السجل رقم " & " ( " & MyId & " ) " & "بنجاح"
    Else
        MsgBox "تم الغاء العملية الحذف "
    End If
ElseIf Len(MyPass & "") = 0 Then
   MsgBox "تم الغاء العملية الحذف"
Else
   MsgBox "خطأ في رقم سري الخاص لحذف السجلات"
End If

End Sub

واليكم المرفق 

 

DeleteWithPassword.accdb

[abouelhassan]

شكر وتقدير وفائق الاحترام

[أبو ألين]

هل يمكن معالجة الكود استاذ Shivan Rekany ليعمل على نظام 64 بت

فقد ظهرت هذه المشكلة عند تجربة الحذف .. (مرفقة صورة توضيحية)

[عمر ضاحى]

4 ساعات مضت, uzer said:

هل يمكن معالجة الكود استاذ Shivan Rekany ليعمل على نظام 64 بت

فقد ظهرت هذه المشكلة عند تجربة الحذف .. (مرفقة صورة توضيحية)

عدل على الكود باضافة كلمة PtrSafe بين  Declare Function

حتي يصبح الكود بهذا الشكل 

 Private Declare PtrSafe Function

 

[ابو جودي]

5 ساعات مضت, uzer said:

هل يمكن معالجة الكود استاذ Shivan Rekany ليعمل على نظام 64 بت

اتفضل يا سيدى

غير الاكواد داخل الموديول بتلك الاكودا

التعديل يتوافق للعمل على كلتا النواتان 32 , 64

انا الان قمت بالتجربة على 64 برجاء التجربة على 32 وموافتنا بالنتيجة

 

#If VBA7 Or Win64 Then
Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal ncode As LongPtr, 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 LongPtr, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As LongPtr) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As LongPtr
Private Declare PtrSafe Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As LongPtr, ByVal wMsg As LongPtr, 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 LongPtr) As LongPtr
Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As LongPtr
#Else
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 LongPtr, ByVal lpfn As LongPtr, ByVal hmod As LongPtr,  ByVal dwThreadId As LongPtr) As LongPtr
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
#End If



'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
 
#If VBA7 Or Win64 Then
    Private hHook As LongPtr
#Else
    Private hHook As Long
#End If

Public Function NewProc(ByVal lngCode As LongPtr, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Dim RetVal
    Dim strClassName    As String
    Dim lngBuffer       As LongPtr
 
    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
        RetVal = GetClassName(wParam, strClassName, lngBuffer)
        If Left$(strClassName, RetVal) = "#32770" Then
            SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0
        End If
    End If
    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
On Error GoTo ExitProperly
    
    Dim lngModHwnd As LongPtr
    Dim lngThreadID As LongPtr
     
    lngThreadID = GetCurrentThreadId
    lngModHwnd = GetModuleHandle(vbNullString)
 
    hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID)
 
    InputBoxDK = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context)
    UnhookWindowsHookEx hHook
    
ExitProperly:
    UnhookWindowsHookEx hHook
End Function

--------------------------------------------------------

 

1 ساعه مضت, عمر ضاحى said:

عدل على الكود باضافة كلمة PtrSafe بين  Declare Function

حتي يصبح الكود بهذا الشكل 

 Private Declare PtrSafe Function

للاسف مش دايما بيكون ده التعديل وبس شوف الكود وانت تعرف الفرق 

وغير انت الملف القديم وجربه مش راح يشتغل 

 

وهذا مرفق التطبيق بعد التعديل

 

DeleteWithPassword.accdb