اخفاء شاشة الاكسس والتعامل مع النماذج

**2saad** · بالامس في 19:56

إخواني الأعزاء بعد سلام الله عليكم ورحمة الله وبركاته

في الملف المرفق محتاج أخفي شاشة الاكسس والتعامل مع النماذج

SaadPermissionsLast-1.rarSaadPermissionsLast-1.rar

**Foksh** · منذ 19 ساعات

استخدم خاصية البحث ، وستجد الكثير من المواضيع التي تحدثت عن نفس الموضوع . والتالي احدثها

Debug Ace · منذ 17 ساعات

انشئ وحدة نمطية عامة جديدة باسم : modWindowManager
قم باضافة الكود التالى الى الوحدة النمطية العامة

Option Private Module
Option Compare Database
Option Explicit

' -----------------------------------------------------------------------
' Windows API declarations — conditional for 32-bit / 64-bit compatibility
' -----------------------------------------------------------------------
#If VBA7 Then
    Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal nCmdShow As Long) As Long
    Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
    Private Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
#Else
    Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
    Private Declare Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex    As Long, ByVal dwNewLong As Long) As Long
#End If

' -----------------------------------------------------------------------
' Window-style constants
' -----------------------------------------------------------------------
Private Const GWL_EXSTYLE     As Long = -20
Private Const WS_EX_APPWINDOW As Long = &H40000

' ShowWindow state constants (Public so callers may use them directly)
Public Const SW_HIDE          As Long = 0
Public Const SW_SHOWNORMAL    As Long = 1
Public Const SW_SHOWMINIMIZED As Long = 2
Public Const SW_SHOWMAXIMIZED As Long = 3
Public Const SW_SHOW          As Long = 5

' Tracks current visibility state
Private m_bAppWindowHidden    As Boolean

Public Function HideAppWindow(Optional ByVal frm As Access.Form = Nothing) As Boolean

    On Error GoTo ErrHandler

    ' -- Resolve the target form -----------------------------------------------
    Dim frmTarget As Access.Form
    Set frmTarget = IIf(frm Is Nothing, ActiveFormOrNothing(), frm)
    
    If frmTarget Is Nothing And Forms.Count > 0 Then
        ' Screen.ActiveForm غير جاهز بعد — نأخذ أول نموذج مفتوح
        Set frmTarget = Forms(0)
    End If
    
    If frmTarget Is Nothing Then
        LogError "HideAppWindow", "No open form found to promote to the taskbar."
        HideAppWindow = False
        Exit Function
    End If

    ' -- Obtain the form window handle -----------------------------------------
#If VBA7 Then
    Dim hForm As LongPtr
#Else
    Dim hForm As Long
#End If
    hForm = frmTarget.hWnd

    If hForm = 0 Then
        LogError "HideAppWindow", "Could not obtain a valid hWnd for: " & frmTarget.Name
        HideAppWindow = False
        Exit Function
    End If

    ' -- Apply WS_EX_APPWINDOW so the form appears on the taskbar --------------
#If VBA7 Then
    Dim lExStyle As LongPtr
#Else
    Dim lExStyle As Long
#End If
    lExStyle = GetWindowLongPtr(hForm, GWL_EXSTYLE)
    SetWindowLongPtr hForm, GWL_EXSTYLE, lExStyle Or WS_EX_APPWINDOW
    ' -- Hide the Access shell then bring the form forward ---------------------
    ShowWindow Application.hWndAccessApp, SW_HIDE
    ShowWindow hForm, SW_SHOW
    DoEvents
    m_bAppWindowHidden = True
    HideAppWindow = True
    Exit Function
ErrHandler:
    LogError "HideAppWindow", Err.Number & " - " & Err.Description
    HideAppWindow = False
End Function

Public Function RestoreAppWindow(Optional ByVal nCmdShow As Long = SW_SHOW) As Boolean
    On Error GoTo ErrHandler
    If Not IsValidShowCmd(nCmdShow) Then
        LogError "RestoreAppWindow", "Invalid nCmdShow value: " & nCmdShow
        RestoreAppWindow = False
        Exit Function
    End If
    RestoreAppWindow = SetAccessWindow(nCmdShow)
    If RestoreAppWindow Then m_bAppWindowHidden = False
    Exit Function
ErrHandler:
    LogError "RestoreAppWindow", Err.Number & " - " & Err.Description
    RestoreAppWindow = False
End Function

Public Property Get IsAppWindowHidden() As Boolean
    IsAppWindowHidden = m_bAppWindowHidden
End Property

Private Function SetAccessWindow(ByVal nCmdShow As Long) As Boolean
    On Error GoTo ErrHandler
    ShowWindow Application.hWndAccessApp, nCmdShow
    DoEvents
    SetAccessWindow = True
    Exit Function
ErrHandler:
    LogError "SetAccessWindow", Err.Number & " - " & Err.Description
    SetAccessWindow = False
End Function

Private Function ActiveFormOrNothing() As Access.Form
    On Error Resume Next
    Set ActiveFormOrNothing = Screen.ActiveForm
    On Error GoTo 0
End Function

Private Function IsValidShowCmd(ByVal nCmdShow As Long) As Boolean
    Select Case nCmdShow
        Case SW_HIDE, SW_SHOWNORMAL, SW_SHOWMINIMIZED, SW_SHOWMAXIMIZED, SW_SHOW
            IsValidShowCmd = True
        Case Else
            IsValidShowCmd = False
    End Select
End Function

Private Sub LogError(ByVal sSource As String, ByVal sMessage As String)
    Dim sEntry As String
    sEntry = "[" & Format(Now, "yyyy-mm-dd hh:nn:ss") & "] " & "modWindowManager." & sSource & " >> " & sMessage
    Debug.Print sEntry
End Sub

وفى نموذج البدء فى حدث تحميل النموذج

Private Sub Form_Load()
    HideAppWindow
End Sub

او ان اردت عمل زر أمر لاخفاء اطار الاكسس ضع به فقط الاستدعاء التالى

    HideAppWindow

و ان اردت عمل زر أمر لاستعادة اطار الاكسس مرة أخرى ضع به فقط الاستدعاء التالى

    RestoreAppWindow

Debug Ace · منذ 17 ساعات

ملاحظة هامة
يجب ضبط خاصية النموذج Pop Up =Yes

Debug Ace · منذ 17 ساعات

13 دقائق مضت, Debug Ace said:

ملاحظة هامة
يجب ضبط خاصية النموذج Pop Up =Yes

وطبعا لان الخاصية دى لو مش مظبوطة تمام سوف يتم اخفاء اطار اكسس ومع احفاء النموذج تمام وسف تعلق القاعدة فى البرامج المشغلة فى الخلفية ولن تستطيع اعادة فتح القاعدة الا بالاغلاق القسرى من ال/ Task Manager

ومن اجل ذلك خطر على بالى تعديل كود الاخفاء الى الكود التالى

Public Function HideAppWindow(Optional ByVal frm As Access.Form = Nothing) As Boolean

    On Error GoTo ErrHandler

    ' -- Resolve the target form -----------------------------------------
    Dim frmTarget As Access.Form
'    Set frmTarget = IIf(frm Is Nothing, ActiveFormOrNothing(), frm)
    If frm Is Nothing Then
        Set frmTarget = ActiveFormOrNothing()
    Else
        Set frmTarget = frm
    End If

    If frmTarget Is Nothing And Forms.Count > 0 Then
        Set frmTarget = Forms(0)
    End If

    If frmTarget Is Nothing Then
        LogError "HideAppWindow", "No open form found to promote to the taskbar."
        HideAppWindow = False
        Exit Function
    End If

    ' -- [1] Checking PopUp first — completely independent of hWnd -------
    If Not frmTarget.PopUp Then
        LogError "HideAppWindow", _
            "Form '" & frmTarget.Name & "' must have PopUp = Yes " & _
            "to appear independently after hiding the Access shell."
        HideAppWindow = False
        Exit Function
    End If

    ' -- [2] Obtain hWnd after verifying the PopUp -----------------------
#If VBA7 Then
    Dim hForm As LongPtr
#Else
    Dim hForm As Long
#End If
    hForm = frmTarget.hWnd

    ' -- [3] hWnd Validation ---------------------------------------------
    If hForm = 0 Then
        LogError "HideAppWindow", _
            "Could not obtain a valid hWnd for: " & frmTarget.Name
        HideAppWindow = False
        Exit Function
    End If

    ' -- [4] Apply WS_EX_APPWINDOW  --------------------------------------
#If VBA7 Then
    Dim lExStyle As LongPtr
#Else
    Dim lExStyle As Long
#End If
    lExStyle = GetWindowLongPtr(hForm, GWL_EXSTYLE)
    SetWindowLongPtr hForm, GWL_EXSTYLE, lExStyle Or WS_EX_APPWINDOW

    ' -- [5] Hiding the shell and detecting the form ---------------------
    ShowWindow Application.hWndAccessApp, SW_HIDE
    ShowWindow hForm, SW_SHOW

    DoEvents
    m_bAppWindowHidden = True
    HideAppWindow = True
    Exit Function

ErrHandler:
    LogError "HideAppWindow", Err.Number & " - " & Err.Description
    HideAppWindow = False
End Function

**2saad** · منذ 8 ساعات

شكرا أخي الكريم

أنا طبقت الكود كما هو علي الملف تبعي

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

Debug Ace · منذ 2 ساعات

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

ابشر

Debug Ace · منذ 1 ساعه

كود داخل الوحدة النمطية

Option Private Module
Option Compare Database
Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As WindowRect) As Long
    Private Declare PtrSafe Function MoveWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
    Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal nCmdShow As Long) As Long
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
#Else
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As WindowRect) As Long
    Private Declare Function MoveWindow Lib "user32" (ByVal hWnd As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight  As Long, ByVal bRepaint As Long) As Long
    Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
#End If

Private Const GWL_EXSTYLE           As Long = -20
Private Const WS_EX_APPWINDOW       As Long = &H40000
Private Const SW_HIDE               As Long = 0
Private Const SW_SHOWNORMAL         As Long = 1
Private Const SW_SHOWNOACTIVATE     As Long = 4

Private Const SM_CXVIRTUALSCREEN    As Long = 78
Private Const SM_CYVIRTUALSCREEN    As Long = 79

Private Type WindowRect
    LeftPos   As Long
    TopPos    As Long
    RightPos  As Long
    BottomPos As Long
End Type

Private m_IsHidden      As Boolean
Private m_Rect          As WindowRect
Private m_StyleBackup   As Long

Public Sub HideAccessFrame()
    On Error GoTo ErrHandler

    If m_IsHidden Then Exit Sub

    #If VBA7 Then
        Dim hApp As LongPtr
    #Else
        Dim hApp As Long
    #End If

    hApp = Application.hWndAccessApp

    If hApp = 0 Then
        LogError "HideAccessFrame", "Could not obtain hWndAccessApp."
        Exit Sub
    End If
    
    If GetWindowRect(hApp, m_Rect) = 0 Then
        LogError "HideAccessFrame", "GetWindowRect failed."
        Exit Sub
    End If

    Dim lWidth  As Long
    Dim lHeight As Long

    lWidth = m_Rect.RightPos - m_Rect.LeftPos
    lHeight = m_Rect.BottomPos - m_Rect.TopPos

    m_StyleBackup = GetWindowLong(hApp, GWL_EXSTYLE)

    Dim lNewStyle As Long
    lNewStyle = m_StyleBackup And Not WS_EX_APPWINDOW
    SetWindowLong hApp, GWL_EXSTYLE, lNewStyle

    Dim lOffscreenX As Long
    Dim lOffscreenY As Long

    lOffscreenX = GetSystemMetrics(SM_CXVIRTUALSCREEN) + 200
    lOffscreenY = GetSystemMetrics(SM_CYVIRTUALSCREEN) + 200

    ' rollback
    If MoveWindow(hApp, lOffscreenX, lOffscreenY, lWidth, lHeight, True) = 0 Then
        LogError "HideAccessFrame", "MoveWindow failed — rolling back style."
        SetWindowLong hApp, GWL_EXSTYLE, m_StyleBackup
        ShowWindow hApp, SW_SHOWNORMAL
        Exit Sub
    End If

    ShowWindow hApp, SW_HIDE
    ShowWindow hApp, SW_SHOWNOACTIVATE
    DoEvents
    m_IsHidden = True
    Exit Sub

ErrHandler:
    LogError "HideAccessFrame", Err.Number & " - " & Err.Description
End Sub

Public Sub ShowAccessFrame()

    On Error GoTo ErrHandler

    If Not m_IsHidden Then Exit Sub

    #If VBA7 Then
        Dim hApp As LongPtr
    #Else
        Dim hApp As Long
    #End If
    
    hApp = Application.hWndAccessApp

    If hApp = 0 Then
        LogError "ShowAccessFrame", "Could not obtain hWndAccessApp."
        Exit Sub
    End If

    Dim lWidth  As Long
    Dim lHeight As Long

    lWidth = m_Rect.RightPos - m_Rect.LeftPos
    lHeight = m_Rect.BottomPos - m_Rect.TopPos

    If MoveWindow(hApp, m_Rect.LeftPos, m_Rect.TopPos, lWidth, lHeight, True) = 0 Then
        LogError "ShowAccessFrame", "MoveWindow failed — frame may be offscreen."
        Exit Sub
    End If

    SetWindowLong hApp, GWL_EXSTYLE, m_StyleBackup

    ShowWindow hApp, SW_SHOWNORMAL

    m_IsHidden = False
    Exit Sub

ErrHandler:
    LogError "ShowAccessFrame", Err.Number & " - " & Err.Description

End Sub

Public Function IsAccessHidden() As Boolean
    IsAccessHidden = m_IsHidden
End Function

Private Sub LogError(ByVal sSource As String, ByVal sMessage As String)
    Dim sEntry As String
    sEntry = "[" & Format(Now, "yyyy-mm-dd hh:nn:ss") & "] " & "modWindowManager." & sSource & " >> " & sMessage
    Debug.Print sEntry
End Sub

وفى النموذج فى حدث التحميل

HideAccessFrame

ولو اردت عمل زر امر لاستعادة الاطار مرة أخرى يكفى فقط استخدام

ShowAccessFrame

**Foksh** · منذ 1 ساعه

16 دقائق مضت, Debug Ace said:

ولو اردت عمل زر امر لاستعادة الاطار مرة أخرى يكفى فقط استخدام

مهو لو تم ارفاق ملف مطبق عليه الحل بتاعك ، كان انت ريحت نفسك وريحت صاحب الطلب 😁

Debug Ace · منذ 1 ساعه

تمام الكود السابق به مشكلة لو ان خاصية النموذج Pop Up =Yes فى كل النماذج لن تحدث اى مشكلة
ولكن لو اردت الانتقال باغلاق النموذج الحالى وفتح نموذج اخر لو كانت الحاصية للنموذج الجديد المراد فتحة Pop Up =No

للاسف سوف يتم اخفاء النموذج :mad:

طيب والحل ايه علشان نخلص من المشكلة العويصة دى

وانا قصدت وضع الحل بالتدرج لتكون مرجعا كان ممكن اضع الحل فورا ولكن دى نقطة مهمة

الحل فى ان نقوم بعمل الكود فى الوحدة النمطية العامة بالشكل التالى

Option Private Module
Option Compare Database
Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As WindowRect) As Long
    Private Declare PtrSafe Function MoveWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
    Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal nCmdShow As Long) As Long
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
#Else
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As WindowRect) As Long
    Private Declare Function MoveWindow Lib "user32" (ByVal hWnd As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight  As Long, ByVal bRepaint As Long) As Long
    Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
#End If

Private Const GWL_EXSTYLE           As Long = -20
Private Const WS_EX_APPWINDOW       As Long = &H40000
Private Const SW_HIDE               As Long = 0
Private Const SW_SHOWNORMAL         As Long = 1
Private Const SW_SHOWNOACTIVATE     As Long = 4

Private Const SM_CXVIRTUALSCREEN    As Long = 78
Private Const SM_CYVIRTUALSCREEN    As Long = 79

Private Type WindowRect
    LeftPos   As Long
    TopPos    As Long
    RightPos  As Long
    BottomPos As Long
End Type

Private m_IsHidden      As Boolean
Private m_Rect          As WindowRect
Private m_StyleBackup   As Long

Public Sub HideAccessFrame()
    On Error GoTo ErrHandler

    If m_IsHidden Then Exit Sub

    Dim sOffenders As String
    sOffenders = GetNonPopupObjects()

    If Len(sOffenders) > 0 Then
        MsgBox "لا يمكن إخفاء إطار Access." & vbCrLf & vbCrLf & _
               "الكائنات التالية تحتاج إلى ضبط PopUp = Yes :" & vbCrLf & _
               sOffenders, _
               vbExclamation Or vbMsgBoxRight Or vbMsgBoxRtlReading, _
               "modWindowManager"
        LogError "HideAccessFrame", "Aborted — non-popup objects: " & sOffenders
        Exit Sub
    End If

    #If VBA7 Then
        Dim hApp As LongPtr
    #Else
        Dim hApp As Long
    #End If

    hApp = Application.hWndAccessApp

    If hApp = 0 Then
        LogError "HideAccessFrame", "Could not obtain hWndAccessApp."
        Exit Sub
    End If

    If GetWindowRect(hApp, m_Rect) = 0 Then
        LogError "HideAccessFrame", "GetWindowRect failed."
        Exit Sub
    End If

    Dim lWidth  As Long
    Dim lHeight As Long
    lWidth = m_Rect.RightPos - m_Rect.LeftPos
    lHeight = m_Rect.BottomPos - m_Rect.TopPos

    m_StyleBackup = GetWindowLong(hApp, GWL_EXSTYLE)

    Dim lNewStyle As Long
    lNewStyle = m_StyleBackup And Not WS_EX_APPWINDOW
    SetWindowLong hApp, GWL_EXSTYLE, lNewStyle

    Dim lOffscreenX As Long
    Dim lOffscreenY As Long
    lOffscreenX = GetSystemMetrics(SM_CXVIRTUALSCREEN) + 200
    lOffscreenY = GetSystemMetrics(SM_CYVIRTUALSCREEN) + 200

    If MoveWindow(hApp, lOffscreenX, lOffscreenY, lWidth, lHeight, True) = 0 Then
        LogError "HideAccessFrame", "MoveWindow failed — rolling back style."
        SetWindowLong hApp, GWL_EXSTYLE, m_StyleBackup
        ShowWindow hApp, SW_SHOWNORMAL
        Exit Sub
    End If

    ShowWindow hApp, SW_HIDE
    ShowWindow hApp, SW_SHOWNOACTIVATE
    DoEvents

    m_IsHidden = True
    Exit Sub

ErrHandler:
    LogError "HideAccessFrame", Err.Number & " - " & Err.Description
End Sub

Public Sub ShowAccessFrame()

    On Error GoTo ErrHandler

    If Not m_IsHidden Then Exit Sub

    #If VBA7 Then
        Dim hApp As LongPtr
    #Else
        Dim hApp As Long
    #End If
    
    hApp = Application.hWndAccessApp

    If hApp = 0 Then
        LogError "ShowAccessFrame", "Could not obtain hWndAccessApp."
        Exit Sub
    End If

    Dim lWidth  As Long
    Dim lHeight As Long

    lWidth = m_Rect.RightPos - m_Rect.LeftPos
    lHeight = m_Rect.BottomPos - m_Rect.TopPos

    If MoveWindow(hApp, m_Rect.LeftPos, m_Rect.TopPos, lWidth, lHeight, True) = 0 Then
        LogError "ShowAccessFrame", "MoveWindow failed — frame may be offscreen."
        Exit Sub
    End If

    SetWindowLong hApp, GWL_EXSTYLE, m_StyleBackup

    ShowWindow hApp, SW_SHOWNORMAL

    m_IsHidden = False
    Exit Sub

ErrHandler:
    LogError "ShowAccessFrame", Err.Number & " - " & Err.Description

End Sub

Public Function IsAccessHidden() As Boolean
    IsAccessHidden = m_IsHidden
End Function

Private Sub LogError(ByVal sSource As String, ByVal sMessage As String)
    Dim sEntry As String
    sEntry = "[" & Format(Now, "yyyy-mm-dd hh:nn:ss") & "] " & "modWindowManager." & sSource & " >> " & sMessage
    Debug.Print sEntry
End Sub

Private Function IsFormOpen(ByVal sFormName As String) As Boolean
    IsFormOpen = (SysCmd(acSysCmdGetObjectState, acForm, sFormName) And acObjStateOpen) <> 0
End Function

Private Function IsFormPopup(ByVal sFormName As String) As Boolean

    On Error GoTo ErrHandler

    If IsFormOpen(sFormName) Then
        IsFormPopup = Forms(sFormName).PopUp
        Exit Function
    End If

    DoCmd.OpenForm sFormName, acNormal, , , , acHidden
    IsFormPopup = Forms(sFormName).PopUp
    DoCmd.Close acForm, sFormName, acSaveNo
    Exit Function

ErrHandler:
    LogError "IsFormPopup", Err.Number & " - " & Err.Description
    IsFormPopup = False
End Function

Private Function GetNonPopupObjects() As String

    Dim sResult As String
    Dim i       As Integer

    For i = 0 To Forms.Count - 1
        On Error Resume Next
        Dim oForm As Access.Form
        Set oForm = Forms(i)
        If Err.Number = 0 Then
            If Not oForm.PopUp Then
                sResult = sResult & "  [نموذج]  " & oForm.Name & vbCrLf
            End If
        End If
        Err.Clear
        On Error GoTo 0
    Next i

    For i = 0 To Reports.Count - 1
        On Error Resume Next
        Dim oReport As Access.Report
        Set oReport = Reports(i)
        If Err.Number = 0 Then
            If Not oReport.PopUp Then
                sResult = sResult & "  [تقرير]  " & oReport.Name & vbCrLf
            End If
        End If
        Err.Clear
        On Error GoTo 0
    Next i

    GetNonPopupObjects = sResult
End Function

Public Sub SwitchToForm(ByVal NewFormName As String, Optional ByVal OpenArgs As Variant)
    On Error GoTo ErrHandler

    If m_IsHidden Then
        If Not IsFormPopup(NewFormName) Then
            ShowAccessFrame
            MsgBox "تم استعادة إطار Access تلقائياً." & vbCrLf & vbCrLf & _
                   "النموذج """ & NewFormName & """ يحتاج إلى ضبط PopUp = Yes.", _
                   vbInformation Or vbMsgBoxRight Or vbMsgBoxRtlReading, _
                   "تنبيه"
            LogError "SwitchToForm", _
                "Frame restored — '" & NewFormName & "' has PopUp = No."
        End If
    End If

    Dim sCurrentForm As String
    sCurrentForm = Screen.ActiveForm.Name

    If IsMissing(OpenArgs) Then
        DoCmd.OpenForm NewFormName, acNormal, , , , acWindowNormal
    Else
        DoCmd.OpenForm NewFormName, acNormal, , , , acWindowNormal, OpenArgs
    End If

    DoEvents
    DoEvents

    If Not CurrentProject.AllForms(NewFormName).IsLoaded Then
        MsgBox "فشل فتح النموذج: " & NewFormName, _
               vbCritical Or vbMsgBoxRight Or vbMsgBoxRtlReading
        LogError "SwitchToForm", "Failed to load form: " & NewFormName
        Exit Sub
    End If

    With Forms(NewFormName)
        .Visible = True
        .SetFocus
        .Repaint
    End With

    If Not m_IsHidden Then
        If IsFormPopup(NewFormName) Then
            HideAccessFrame
        End If
    End If

    If IsFormOpen(sCurrentForm) Then
        DoCmd.Close acForm, sCurrentForm, acSaveNo
    End If

    Exit Sub

ErrHandler:
    LogError "SwitchToForm", Err.Number & " - " & Err.Description

    If m_IsHidden Then
        ShowAccessFrame
        LogError "SwitchToForm", "Frame force-restored due to error."
    End If
    
    MsgBox "خطأ أثناء التبديل: " & Err.Description, vbCritical Or vbMsgBoxRight Or vbMsgBoxRtlReading
End Sub

الان اضفنا دالة للتحقق من الخاصية وبعض الدوال المساعدة
والاهم اضفنا الدالة : SwitchToForm وظيفتها التنقل بين النماذج بسهولة والتبديل بينهم سواء كان فى الوضع العادى بدون: OpenArgs او باستخدام : OpenArgs

ويتم استخدامها بالشكل التالى بدون OpenArgs

' بدون OpenArgs
SwitchToForm "frmMain"

ويتم استخدامها مع OpenArgs بالشكل التالى

' مع OpenArgs
SwitchToForm "frmDashboard", "UserID=5"

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

SwitchToForm "frmReport", Array("2024", "Monthly")

تم تعديل منذ 16 دقائق بواسطه Debug Ace

Debug Ace · منذ 16 دقائق

56 دقائق مضت, Foksh said:

مهو لو تم ارفاق ملف مطبق عليه الحل بتاعك ، كان انت ريحت نفسك وريحت صاحب الطلب 😁

معذرة اصل انا لم اجد خط مرسوم علشان امشى عليه ولم اجد من يرسم لى الخط

الاكواد موجودة ومشروح كل شئ اللى عاوز ينفذ يقراء يفهم وينفذ :yes:

اللى مش عاوز براحته هو الخسران :biggrin:

وكل شخص بيتعلم من جميع التجارب الناجحة والغير ناجحة :smile2:

**kkhalifa1960** · منذ 5 دقائق

بعد اذن الاساتذة اسمحولي تفضل استاذ @2saad المرفق بعد التعديل . ووافني بالرد . واذا راق لك . وافني بالرد كي اشرح لك التفاصيل . :fff:

SaadPermissionsLast-2.rar

تسجيل الدخول

اخفاء شاشة الاكسس والتعامل مع النماذج

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

2saad

Foksh

Debug Ace

Debug Ace

Debug Ace

2saad

Debug Ace

Debug Ace

Foksh

Debug Ace

Debug Ace

kkhalifa1960

انشئ حساب جديد او قم بتسجيل دخولك لتتمكن من اضافه تعليق جديد

انشئ حساب جديد

تسجيل دخول

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

تصفح الموقع

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

Support

Important Information