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

Abdelaziz Osman · أبريل 10, 2022

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

image.jpeg.0a9f7b8df0be81dd74cde451e6488cab.jpeg

**ازهر عبد العزيز** · أبريل 10, 2022

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

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

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

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

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

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

Abdelaziz Osman · أبريل 11, 2022

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

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

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

**Moosak** · أبريل 11, 2022

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 · أبريل 11, 2022

@Moosak

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

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

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

**Moosak** · أبريل 11, 2022

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

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

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

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

image.png.25d8483aa14f21e354f99d11aebb74f2.png

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

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

Abdelaziz Osman · أبريل 11, 2022

@Moosak

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

فما هو الحل

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

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

**Moosak** · أبريل 11, 2022

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

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

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

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

**ازهر عبد العزيز** · أبريل 12, 2022

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 · أبريل 12, 2022

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

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

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

delete with password.mdb

Abdelaziz Osman · أبريل 12, 2022

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

اقتباس

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 · أبريل 12, 2022

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

تفضل أخي

delete with password.mdb

Abdelaziz Osman · أبريل 12, 2022

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

**Eng.Qassim** · أبريل 12, 2022

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

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

**Shivan Rekany** · أبريل 12, 2022

في 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 · أبريل 12, 2022

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

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

image.jpeg.2589440081590fe16a020ab48d2a4561.jpeg

**abouelhassan** · أبريل 12, 2022

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

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

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

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

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

Abdelaziz Osman · أبريل 12, 2022

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

**Eng.Qassim** · أبريل 12, 2022

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

DeleteWithPassword.accdb

**Eng.Qassim** · أبريل 12, 2022

منذ ساعه, abouelhassan said:

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

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

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

**Shivan Rekany** · أبريل 12, 2022

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** · أبريل 12, 2022

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

أبو ألين · أبريل 13, 2022

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

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

**عمر ضاحى** · أبريل 13, 2022

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

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

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

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

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

Private Declare PtrSafe Function

**ابو جودي** · أبريل 13, 2022

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

تسجيل الدخول

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

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

Abdelaziz Osman

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

Abdelaziz Osman

Moosak

Abdelaziz Osman

Moosak

Abdelaziz Osman

Moosak

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

Abdelaziz Osman

Abdelaziz Osman

عبدالقدوس48

Abdelaziz Osman

Eng.Qassim

Shivan Rekany

Abdelaziz Osman

abouelhassan

Abdelaziz Osman

Eng.Qassim

Eng.Qassim

Shivan Rekany

abouelhassan

أبو ألين

عمر ضاحى

ابو جودي

Join the conversation

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

تصفح الموقع

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

Support

Important Information