شخابيط ابو جودى : تصميم نموذج بديل InputBox وبامتيازات اكثر

[ابو جودي]

 نموذج مثلا باسم : frmPasswordPrompt
العناصر داخل النموذج كالتالى 
مربع نص باسم : txtPassword
زر امر للتأكيد باسم : btnOK
زر امر للالغاء والاحباط باسم : btnCancel
واستخدم الاكواد التالية فى هذا النموذج
 

Private Sub Form_Load()
    Me.KeyPreview = True
    Me.txtPassword.Value = ""
    Me.txtPassword.SetFocus
End Sub

Private Sub btnOK_Click()
    PasswordConfirm Nz(Me.txtPassword.Value, "")
    DoCmd.Close acForm, Me.Name
End Sub

Private Sub btnCancel_Click()
    PasswordCancel
    DoCmd.Close acForm, Me.Name
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyEscape Then
        KeyCode = 0
        btnCancel_Click
    End If
End Sub

قم بانشاء وحدة نمطية عامة اعطها مثلا اسم : basPasswordPrompt
الاكواد داخل الوحدة النمطية تكون كالتالى :

Option Compare Database
Option Explicit

Public Enum PasswordStatus
    psEmpty = 0
    psInvalid = 1
    psCancelled = 2
    psMaxAttemptsExceeded = 3
    psUnsupportedAction = 4
    psDangerousSQL = 5
End Enum

Public Enum ActionType
    atOpenForm = 0
    atOpenQuery = 1
    atOpenReport = 2
    atPrintReport = 3
    atDeleteAllRecords = 4
    atExecuteSQL = 5
    atRunGlobalFunction = 6
    atRunFormMethod = 7
End Enum

Private Const MAX_PASSWORD_ATTEMPTS As Long = 3

Private m_PasswordValue     As String
Private m_PasswordConfirmed As Boolean
Private m_PasswordCancelled As Boolean

Public Sub ExecuteAction( _
    ByVal actionToExecute As ActionType, _
    ByVal targetName As String, _
    Optional ByVal expectedPassword As String = "", _
    Optional ByVal callerForm As Access.Form = Nothing)

    On Error GoTo ErrorHandler

    If Len(Trim$(targetName)) = 0 Then Exit Sub

    Dim i As Long

    For i = 1 To MAX_PASSWORD_ATTEMPTS

        PromptPasswordForm

        If m_PasswordCancelled Then
            ShowMessage psCancelled
            Exit Sub
        End If

        If Len(m_PasswordValue) = 0 Then
            ShowMessage psEmpty
            GoTo NextTry
        End If

        If StrComp(m_PasswordValue, expectedPassword, vbBinaryCompare) <> 0 Then
            ShowMessage psInvalid
            GoTo NextTry
        End If

        ExecuteInternal actionToExecute, targetName, callerForm
        m_PasswordValue = ""
        Exit Sub

NextTry:
    Next i

    ShowMessage psMaxAttemptsExceeded
    Exit Sub

ErrorHandler:
    DoCmd.SetWarnings True
    m_PasswordValue = ""
    MsgBox Err.Number & " - " & Err.Description, vbCritical
    Debug.Print "ExecuteAction Error " & Err.Number & ": " & Err.Description

End Sub

Private Sub ExecuteInternal( _
    ByVal actionToExecute As ActionType, _
    ByVal targetName As String, _
    ByVal callerForm As Access.Form)

    On Error GoTo ErrorHandler

    Select Case actionToExecute

        Case atOpenForm
            DoCmd.OpenForm targetName

        Case atOpenQuery
            DoCmd.OpenQuery targetName

        Case atOpenReport
            DoCmd.OpenReport targetName, acViewNormal

        Case atPrintReport
            DoCmd.OpenReport targetName, acViewNormal

        Case atDeleteAllRecords
            If MsgBox("هل أنت متأكد من حذف جميع السجلات؟", _
                      vbYesNo + vbCritical + vbDefaultButton2) <> vbYes Then
                Exit Sub
            End If
            SafeRunSQL "DELETE FROM [" & targetName & "]"

        Case atExecuteSQL
            If IsDangerousSQL(targetName) Then
                ShowMessage psDangerousSQL
                Exit Sub
            End If
            SafeRunSQL targetName

        Case atRunGlobalFunction
            Application.Run targetName

        Case atRunFormMethod
            If callerForm Is Nothing Then Exit Sub
            On Error Resume Next
            CallByName callerForm, targetName, VbMethod
            If Err.Number <> 0 Then
                MsgBox "Method '" & targetName & "' not found in form.", vbCritical
                Debug.Print "CallByName Error: " & Err.Description
                Err.Clear
            End If
            On Error GoTo ErrorHandler

        Case Else
            ShowMessage psUnsupportedAction

    End Select

    Exit Sub

ErrorHandler:
    DoCmd.SetWarnings True
    MsgBox Err.Number & " - " & Err.Description, vbCritical
    Debug.Print "ExecuteInternal Error " & Err.Number & ": " & Err.Description

End Sub

Private Sub SafeRunSQL(ByVal sqlText As String)
    On Error GoTo ErrorHandler
    DoCmd.SetWarnings False
    DoCmd.RunSQL sqlText
    DoCmd.SetWarnings True
    Exit Sub

ErrorHandler:
    DoCmd.SetWarnings True
    MsgBox "SQL Error " & Err.Number & vbCrLf & Err.Description, vbCritical
    Debug.Print "SafeRunSQL Error " & Err.Number & ": " & Err.Description
End Sub

Private Function IsDangerousSQL(ByVal sqlText As String) As Boolean
    Dim t As String
    t = Trim$(LCase$(sqlText))

    If InStr(t, "drop ") > 0 Then IsDangerousSQL = True: Exit Function
    If InStr(t, "alter ") > 0 Then IsDangerousSQL = True: Exit Function
    If InStr(t, "create ") > 0 Then IsDangerousSQL = True: Exit Function
    If InStr(t, "truncate ") > 0 Then IsDangerousSQL = True: Exit Function
    If InStr(t, "--") > 0 Then IsDangerousSQL = True: Exit Function
    If InStr(t, "/*") > 0 Then IsDangerousSQL = True: Exit Function
    If InStr(t, "*/") > 0 Then IsDangerousSQL = True: Exit Function
    If InStr(t, ";") > 0 Then IsDangerousSQL = True: Exit Function

    If InStr(t, "delete ") > 0 And InStr(t, "where") = 0 Then
        IsDangerousSQL = True: Exit Function
    End If
    If InStr(t, "update ") > 0 And InStr(t, "where") = 0 Then
        IsDangerousSQL = True: Exit Function
    End If

    IsDangerousSQL = False
End Function


Public Sub PromptPasswordForm()
    m_PasswordValue = ""
    m_PasswordConfirmed = False
    m_PasswordCancelled = False
    DoCmd.OpenForm "frmPasswordPrompt", WindowMode:=acDialog
End Sub

Public Sub PasswordConfirm(ByVal passwordValue As String)
    m_PasswordValue = passwordValue
    m_PasswordConfirmed = True
    m_PasswordCancelled = False
End Sub

Public Sub PasswordCancel()
    m_PasswordValue = ""
    m_PasswordConfirmed = False
    m_PasswordCancelled = True
End Sub

Public Function GetLastPassword() As String
    GetLastPassword = m_PasswordValue
End Function

Public Function WasPasswordCancelled() As Boolean
    WasPasswordCancelled = m_PasswordCancelled
End Function

Public Sub ShowMessage(ByVal status As PasswordStatus)
    Dim sMsg  As String
    Dim nIcon As Long

    Select Case status
        Case psEmpty
            sMsg = "الرجاء إدخال كلمة السر للمتابعة"
            nIcon = vbExclamation
        Case psInvalid
            sMsg = "كلمة سر خاطئة. حاول مرة أخرى"
            nIcon = vbCritical
        Case psCancelled
            sMsg = "تم إلغاء الإجراء"
            nIcon = vbInformation
        Case psMaxAttemptsExceeded
            sMsg = "تم تجاوز عدد المحاولات المسموح بها"
            nIcon = vbCritical
        Case psUnsupportedAction
            sMsg = "إجراء غير مدعوم"
            nIcon = vbExclamation
        Case psDangerousSQL
            sMsg = "تم رفض تنفيذ SQL لأسباب أمنية"
            nIcon = vbCritical
    End Select

    MsgBox sMsg, nIcon + vbMsgBoxRight, "مطالبة كلمة السر"
End Sub

'========================================================
' امثلة الاستدعاء والاستخدام
'========================================================
' 1) فتح نموذج
'    ExecuteAction atOpenForm, "FormName", "1234"
'
' 2) فتح استعلام
'    ExecuteAction atOpenQuery, "QueryName", "1234"
'
' 3) فتح تقرير
'    ExecuteAction atOpenReport, "ReportName", "1234"
'
' 4) طباعة تقرير
'    ExecuteAction atPrintReport, "ReportName", "1234"
'
' 5) حذف سجلات
'    ExecuteAction atDeleteAllRecords, "TableName", "1234"
'
' 6) تنفيذ SQL
'    ExecuteAction atExecuteSQL, "UPDATE Table SET Field=1 WHERE ID=5", "1234"
'
' 7) استدعاء دالة عامة
'    ExecuteAction atRunGlobalFunction, "MyFunction", "1234"
'
' 8) استدعاء دالة من النموذج الحالي
'    ExecuteAction atRunFormMethod, "MyMethod", "1234", Me
'
' 9) فتح نموذج حسب كلمة المرور — في النموذج:
'    Private Sub Command0_Click()
'
'    Dim sPass As String
'    Dim i     As Long
'    Const MAX_TRIES As Long = 3
'
'    For i = 1 To MAX_TRIES
'
'        PromptPasswordForm
'        sPass = GetLastPassword()
'
'        If WasPasswordCancelled() Then
'            MsgBox "تم إلغاء الإجراء", vbInformation + vbMsgBoxRight, "مطالبة كلمة السر"
'            Exit Sub
'        End If
'
'        If Len(sPass) = 0 Then
'            MsgBox "الرجاء إدخال كلمة السر للمتابعة", vbExclamation + vbMsgBoxRight, "مطالبة كلمة السر"
'            GoTo NextTry
'        End If
'
'        Select Case sPass
'            Case "123": DoCmd.OpenForm "Form1": Exit Sub
'            Case "456": DoCmd.OpenForm "Form2": Exit Sub
'            Case "789": DoCmd.OpenForm "Form3": Exit Sub
'            Case Else
'                MsgBox "كلمة سر خاطئة. حاول مرة أخرى", vbCritical + vbMsgBoxRight, "مطالبة كلمة السر"
'        End Select
'
'NextTry:
'    Next i
'
'    MsgBox "تم تجاوز عدد المحاولات المسموح بها", vbCritical + vbMsgBoxRight, "مطالبة كلمة السر"
'End Sub

'========================================================

وتستطيع استخدام اى شئ بتمرير و بتطبيق كلمة مرور اولا من خلال احد الاستدعاءات التالية

' 1) فتح نموذج طبعا مع تغيير : FormName باسم النموذج الذى تريد فتحه

ExecuteAction atOpenForm, "FormName", "YourPassword"

' 2) فتح استعلام طبعا مع تغيير : QueryName باسم الاستعلام الذى تريد فتحه

ExecuteAction atOpenQuery, "QueryName", "YourPassword"

' 3) فتح تقرير طبعا مع تغيير : ReportName باسم التقرير الذى تريد فتحه

ExecuteAction atOpenReport, "ReportName", "YourPassword"

' 4) طباعة تقرير طبعا مع تغيير : ReportName باسم التقرير الذى تريد طباعته

ExecuteAction atPrintReport, "ReportName", "YourPassword"

' 5) حذف سجلات  طبعا مع تغيير : TableName باسم الجدول الذى تريد حذف سجلاته

ExecuteAction atDeleteAllRecords, "TableName", "YourPassword"

' 6) تنفيذ SQL اكتبالجملة حسب تصميمك

Dim SQLStatement As String
SQLStatement = "UPDATE tblSettings SET IsActive=1 WHERE ID=" & Me.txtID.Value

ExecuteAction atExecuteSQL, SQLStatement, "1234"

' 7) استدعاء دالة عامة من اى وحدة نمطية عامة

ExecuteAction atRunGlobalFunction, "FunctionName", "YourPassword"

' 8) استدعاء أى وظيفة أو إجراء داخل النموذج الحالى

ExecuteAction atRunFormMethod, "MethodName", "YourPassword", Me

طبعا تغير كلم : YourPassword بكلمة المرور التى تريدها وكلمة المرور ليست ثابتة تستطيع تغييرها دائما مع الاستدعاءات المختلفة
على سبيل المثال لو اردت فتح كل نموذج ولكل نموذج كلمة مرور خاصة به هو
 

ExecuteAction atOpenForm, "frmA", "000"
ExecuteAction atOpenForm, "frmB", "111"
ExecuteAction atOpenForm, "frmC", "222"

وأخيرا  لو اردت فتح احد النماذج المتعددة ولكن كل نموذج حسب تمرير كلمة مرور خاصة به
استخدم الكود التالى

Private Sub Command0_Click()

    Dim sPass As String
    Dim i     As Long
    Const MAX_TRIES As Long = 3

    For i = 1 To MAX_TRIES

        PromptPasswordForm
        sPass = GetLastPassword()

        If WasPasswordCancelled() Then
            MsgBox "تم إلغاء الإجراء", vbInformation + vbMsgBoxRight, "مطالبة كلمة السر"
            Exit Sub
        End If

        If Len(sPass) = 0 Then
            MsgBox "الرجاء إدخال كلمة السر للمتابعة", vbExclamation + vbMsgBoxRight, "مطالبة كلمة السر"
            GoTo NextTry
        End If

        Select Case sPass
            Case "123": DoCmd.OpenForm "Form1": Exit Sub
            Case "456": DoCmd.OpenForm "Form2": Exit Sub
            Case "789": DoCmd.OpenForm "Form3": Exit Sub
            Case Else
                MsgBox "كلمة سر خاطئة. حاول مرة أخرى", vbCritical + vbMsgBoxRight, "مطالبة كلمة السر"
        End Select

NextTry:
    Next i

    MsgBox "تم تجاوز عدد المحاولات المسموح بها", vbCritical + vbMsgBoxRight, "مطالبة كلمة السر"

End Sub

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

• لو تم استخدام كلمة المرور : 123 يتم فتح النموذج : Form1
• لو تم استخدام كلمة المرور : 456 يتم فتح النموذج : Form2
• لو تم استخدام كلمة المرور : 789 يتم فتح النموذج : Form3
  
   

بديل InputBox.accdb

[بلال بلال]

استاذ ممكن عمل نموذج بارك الله فيك

[ابو جودي]

6 دقائق مضت, بلال بلال said:

ممكن عمل نموذج بارك الله فيك

تم ارفاق قاعدة بيانات بسيطة للتجربة فى رأس الموضوع
على الرغم من الشرح باستفاضة لعمل القاعدة