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

[ابو عبد الرحمن اشرف]

اخواني الاعزاء الفضلاء واساتذتي الكرام 

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

مثال علي نمذج erad

الي حضراتكم المرفق

 

عقاري.rar

[kkhalifa1960]

تفضل أخي هذه المشاركة للأخت زهره العبد الله جزاها الله كل الخير .

 

[ابو عبد الرحمن اشرف]

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

تفضل أخي هذه المشاركة للأخت زهره العبد الله جزاها الله كل الخير .

 

اخي الحبيب خليفة ما فهمته بناءا علي ما قرأته وهو 

اذا رغبت في وضع الكود الموضوع تحت زر الامر " اعادة التحجيم " في حدث عند الفتح او التحميل فلا يوجد مشكله .

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

 

On Error Resume Next

    ReSizeForm Me 'اعادة تحجيم النموذج الرئيسي
    ReSizeForm subForm.Form 'اعادة تحجيم النموذج الفرعي
    Me.cmdClose.SetFocus
    Me.cmdResize.Enabled = False
 

ثم ننسخ الوحدة النمطية هذه الي قاعدة البيانات 

Option Compare Database
Option Explicit
'قم بتغيير الارقام بناء على دقة الشاشة التي سوف تستخدمها للعرض مثلا  640 × 480 او 800 × 600 او 1024 × 768 بيكسل
Private Const DESIGN_HORZRES As Long = 640
Private Const DESIGN_VERTRES As Long = 480
'مقدار عدد البكسلات في البوصة الواحده 96 يفضل تركه كما هو لانه قياسي
Private Const DESIGN_PIXELS As Long = 96

Private Const WM_HORZRES As Long = 8
Private Const WM_VERTRES As Long = 10
Private Const WM_LOGPIXELSX As Long = 88
Private Const TITLEBAR_PIXELS As Long = 18
Private Const COMMANDBAR_PIXELS As Long = 26
Private Const COMMANDBAR_LEFT As Long = 0
Private Const COMMANDBAR_TOP As Long = 1
Private OrigWindow As tWindow

Private Type tRect
    left As Long
    Top As Long
    right As Long
    bottom As Long
End Type

Private Type tDisplay
    Height As Long
    Width As Long
    DPI As Long
End Type

Private Type tWindow
    Height As Long
    Width As Long
End Type

Private Type tControl
    Name As String
    Height As Long
    Width As Long
    Top As Long
    left As Long
End Type

Private Declare Function WM_apiGetDeviceCaps Lib "gdi32" Alias "GetDeviceCaps" _
(ByVal hdc As Long, ByVal nIndex As Long) As Long

Private Declare Function WM_apiGetDesktopWindow Lib "user32" Alias "GetDesktopWindow" _
() As Long

Private Declare Function WM_apiGetDC Lib "user32" Alias "GetDC" _
(ByVal hwnd As Long) As Long

Private Declare Function WM_apiReleaseDC Lib "user32" Alias "ReleaseDC" _
(ByVal hwnd As Long, ByVal hdc As Long) As Long

Private Declare Function WM_apiGetWindowRect Lib "user32.dll" Alias "GetWindowRect" _
(ByVal hwnd As Long, lpRect As tRect) As Long

Private Declare Function WM_apiMoveWindow Lib "user32.dll" Alias "MoveWindow" _
(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 WM_apiIsZoomed Lib "user32.dll" Alias "IsZoomed" _
(ByVal hwnd As Long) As Long

'الغرض من هذه الوظيفة هو احضار معلومات الطول والعرض والبيكسل الحالي لشاشة العرض
Private Function getScreenResolution() As tDisplay

Dim hDCcaps As Long
Dim lngRtn As Long

On Error Resume Next

    hDCcaps = WM_apiGetDC(0)
    With getScreenResolution
        .Height = WM_apiGetDeviceCaps(hDCcaps, WM_VERTRES)
        .Width = WM_apiGetDeviceCaps(hDCcaps, WM_HORZRES)
        .DPI = WM_apiGetDeviceCaps(hDCcaps, WM_LOGPIXELSX)
    End With
    lngRtn = WM_apiReleaseDC(0, hDCcaps)
    
End Function

'الغرض من هذه الوظيفة هو اعادة قيم عناصر النموذج كاملة في الطول والعرض وتكبيرها حسب مقاس الشاشة الحالية
Private Function getFactor(blnVert As Boolean) As Single

Dim sngFactorP As Single

On Error Resume Next

    If getScreenResolution.DPI <> 0 Then
        sngFactorP = DESIGN_PIXELS / getScreenResolution.DPI
    Else
        sngFactorP = 1
    End If
    If blnVert Then
        getFactor = (getScreenResolution.Height / DESIGN_VERTRES) * sngFactorP
    Else
        getFactor = (getScreenResolution.Width / DESIGN_HORZRES) * sngFactorP
    End If
    
End Function

'الغرض من هذه الوظيفة هي القيام بإستدعاءها في حدث عند الفتح وعند التحميل
Public Sub ReSizeForm(ByVal frm As Access.Form)

Dim rectWindow As tRect
Dim lngWidth As Long
Dim lngHeight As Long
Dim sngVertFactor As Single
Dim sngHorzFactor As Single
Dim sngFontFactor As Single

On Error Resume Next

    sngVertFactor = getFactor(True)
    sngHorzFactor = getFactor(False)
    
    sngFontFactor = VBA.IIf(sngHorzFactor < sngVertFactor, sngHorzFactor, sngVertFactor)
    Resize sngVertFactor, sngHorzFactor, sngFontFactor, frm
    If WM_apiIsZoomed(frm.hwnd) = 0 Then
        Access.DoCmd.RunCommand acCmdAppMaximize
        
        Call WM_apiGetWindowRect(frm.hwnd, rectWindow)
        
        With rectWindow
            lngWidth = .right - .left
            lngHeight = .bottom - .Top
        End With
        
        If frm.Parent.Name = VBA.vbNullString Then
            Call WM_apiMoveWindow(frm.hwnd, ((getScreenResolution.Width - _
            (sngHorzFactor * lngWidth)) / 2) - getLeftOffset, _
            ((getScreenResolution.Height - (sngVertFactor * lngHeight)) / 2) - _
            getTopOffset, lngWidth * sngHorzFactor, lngHeight * sngVertFactor, 1)
        End If
    End If
    Set frm = Nothing
    
End Sub

'الغرض من هذه الوظيفة هي اعادة تحجيم مقاسات الاقسام الخاصة بالنموذج مثل قسم تفصيل وقسم رأس النموذج وتذييل النموذج
Private Sub Resize(sngVertFactor As Single, sngHorzFactor As Single, sngFontFactor As _
Single, ByVal frm As Access.Form)

Dim ctl As Access.Control
Dim arrCtls() As tControl
Dim lngI As Long
Dim lngJ As Long
Dim lngWidth As Long
Dim lngHeaderHeight As Long
Dim lngDetailHeight As Long
Dim lngFooterHeight As Long
Dim blnHeaderVisible As Boolean
Dim blnDetailVisible As Boolean
Dim blnFooterVisible As Boolean
Const FORM_MAX As Long = 31680

On Error Resume Next
    
    With frm
        .Painting = False
        lngWidth = .Width * sngHorzFactor
        lngHeaderHeight = .Section(Access.acHeader).Height * sngVertFactor
        lngDetailHeight = .Section(Access.acDetail).Height * sngVertFactor
        lngFooterHeight = .Section(Access.acFooter).Height * sngVertFactor
        
        .Width = FORM_MAX
        .Section(Access.acHeader).Height = FORM_MAX
        .Section(Access.acDetail).Height = FORM_MAX
        .Section(Access.acFooter).Height = FORM_MAX
        
        blnHeaderVisible = .Section(Access.acHeader).Visible
        blnDetailVisible = .Section(Access.acDetail).Visible
        blnFooterVisible = .Section(Access.acFooter).Visible
        .Section(Access.acHeader).Visible = False
        .Section(Access.acDetail).Visible = False
        .Section(Access.acFooter).Visible = False
    End With
    ReDim arrCtls(0)
    For Each ctl In frm.Controls
        If ((ctl.ControlType = Access.acTabCtl) Or _
        (ctl.ControlType = Access.acOptionGroup)) Then
            With arrCtls(lngI)
                .Name = ctl.Name
                .Height = ctl.Height
                .Width = ctl.Width
                .Top = ctl.Top
                .left = ctl.left
            End With
            lngI = lngI + 1
            ReDim Preserve arrCtls(lngI)
        End If
    Next ctl
    
    For Each ctl In frm.Controls
        If ctl.ControlType <> Access.acPage Then
            With ctl
                .Height = .Height * sngVertFactor
                .left = .left * sngHorzFactor
                .Top = .Top * sngVertFactor
                .Width = .Width * sngHorzFactor
                .FontSize = .FontSize * sngFontFactor
                
                Select Case .ControlType
                    Case Access.acListBox
                        .ColumnWidths = adjustColumnWidths(.ColumnWidths, sngHorzFactor)
                    Case Access.acComboBox
                        .ColumnWidths = adjustColumnWidths(.ColumnWidths, sngHorzFactor)
                        .ListWidth = .ListWidth * sngHorzFactor
                    Case Access.acTabCtl
                        .TabFixedWidth = .TabFixedWidth * sngHorzFactor
                        .TabFixedHeight = .TabFixedHeight * sngVertFactor
                End Select
                
            End With
        End If
    Next ctl
    
    For lngJ = 0 To lngI
        With frm.Controls.Item(arrCtls(lngJ).Name)
            .left = arrCtls(lngJ).left * sngHorzFactor
            .Top = arrCtls(lngJ).Top * sngVertFactor
            .Height = arrCtls(lngJ).Height * sngVertFactor
            .Width = arrCtls(lngJ).Width * sngHorzFactor
        End With
    Next lngJ
    With frm
        .Width = lngWidth
        .Section(Access.acHeader).Height = lngHeaderHeight
        .Section(Access.acDetail).Height = lngDetailHeight
        .Section(Access.acFooter).Height = lngFooterHeight
        .Section(Access.acHeader).Visible = blnHeaderVisible
        .Section(Access.acDetail).Visible = blnDetailVisible
        .Section(Access.acFooter).Visible = blnFooterVisible
        .Painting = True
    End With
    Erase arrCtls
    Set ctl = Nothing

End Sub

'الغرض من هذه الوظيفة هو حساب مجموع البيكسل لكامل شاشة الاكسيس ناحية اليمين ووضع النموذج في منتصف الشاشة
Private Function getTopOffset() As Long

Dim cmdBar As Object
Dim lngI As Long

On Error GoTo err

     For Each cmdBar In Application.CommandBars
        If ((cmdBar.Visible = True) And (cmdBar.Position = COMMANDBAR_TOP)) Then
            lngI = lngI + 1
        End If
     Next cmdBar
     getTopOffset = (TITLEBAR_PIXELS + (lngI * COMMANDBAR_PIXELS))

exit_fun:
    Exit Function
    
err:
    getTopOffset = TITLEBAR_PIXELS + COMMANDBAR_PIXELS
    Resume exit_fun
     
End Function

'الغرض من هذه الوظيفة هو حساب مجموع البيكسل لكامل شاشة الاكسيس ناحية اليسار ووضع النموذج في منتصف الشاشة
Private Function getLeftOffset() As Long

Dim cmdBar As Object
Dim lngI As Long

On Error GoTo err

     For Each cmdBar In Application.CommandBars
        If ((cmdBar.Visible = True) And (cmdBar.Position = COMMANDBAR_LEFT)) Then
            lngI = lngI + 1
        End If
     Next cmdBar
     getLeftOffset = (lngI * COMMANDBAR_PIXELS)

exit_fun:
    Exit Function
    
err:
    getLeftOffset = 0
    Resume exit_fun
     
End Function
 
'الغرض من هذه الوظيفة هو اعادة تحجيم كامل عرض الاعمدة وعدم ترك فراغات من الناحية اليسرى
Private Function adjustColumnWidths(strColumnWidths As String, sngFactor As Single) As String
On Error GoTo Err_adjustColumnWidths

Dim astrColumnWidths() As String
Dim strTemp As String
Dim lngI As Long
Dim lngJ As Long

    ReDim astrColumnWidths(0)
    For lngI = 1 To VBA.Len(strColumnWidths)
        Select Case VBA.Mid(strColumnWidths, lngI, 1)
            Case Is <> ";"
                astrColumnWidths(lngJ) = astrColumnWidths(lngJ) & VBA.Mid( _
                strColumnWidths, lngI, 1)
            Case ";"
                lngJ = lngJ + 1
                ReDim Preserve astrColumnWidths(lngJ)
        End Select
    Next lngI
    lngI = 0
    strTemp = VBA.vbNullString
    Do Until lngI > UBound(astrColumnWidths)
        If Not IsNull(astrColumnWidths(lngI)) And astrColumnWidths(lngI) <> "" Then
            strTemp = strTemp & CSng(astrColumnWidths(lngI)) * sngFactor & ";"
        End If
        lngI = lngI + 1
    Loop
    adjustColumnWidths = strTemp
    Erase astrColumnWidths
    
Exit_adjustColumnWidths:
    On Error Resume Next
    Exit Function

Err_adjustColumnWidths:
    Erase astrColumnWidths 'Destroy array.
    Resume Exit_adjustColumnWidths
    
End Function

'الغرض من هذه الوظيفة اعادة حجم النموذج الى وضعه الطبيعي قبل اعادة التحجيم ويتم استدعاؤها عن تحميل النموذج
Public Sub getOrigWindow(frm As Access.Form)

On Error Resume Next

    OrigWindow.Height = frm.WindowHeight
    OrigWindow.Width = frm.WindowWidth

End Sub

'الغرض من هذه الوظيفة هو اعادة مقاس النموذج الى وضعه الطبيعي عند حدث الاغلاق
Public Sub RestoreWindow()

On Error Resume Next

    Access.DoCmd.MoveSize , , OrigWindow.Width, OrigWindow.Height
    Access.DoCmd.Save
    
End Sub

هل فهمي لامر صحيح هكذا اخي 

[ابو عبد الرحمن اشرف]

10 ساعات مضت, ابو عبد الرحمن اشرف said:

اخي الحبيب خليفة ما فهمته بناءا علي ما قرأته وهو 

اذا رغبت في وضع الكود الموضوع تحت زر الامر " اعادة التحجيم " في حدث عند الفتح او التحميل فلا يوجد مشكله .

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

 

On Error Resume Next

    ReSizeForm Me 'اعادة تحجيم النموذج الرئيسي
    ReSizeForm subForm.Form 'اعادة تحجيم النموذج الفرعي
    Me.cmdClose.SetFocus
    Me.cmdResize.Enabled = False
 

ثم ننسخ الوحدة النمطية هذه الي قاعدة البيانات 

Option Compare Database
Option Explicit
'قم بتغيير الارقام بناء على دقة الشاشة التي سوف تستخدمها للعرض مثلا  640 × 480 او 800 × 600 او 1024 × 768 بيكسل
Private Const DESIGN_HORZRES As Long = 640
Private Const DESIGN_VERTRES As Long = 480
'مقدار عدد البكسلات في البوصة الواحده 96 يفضل تركه كما هو لانه قياسي
Private Const DESIGN_PIXELS As Long = 96

Private Const WM_HORZRES As Long = 8
Private Const WM_VERTRES As Long = 10
Private Const WM_LOGPIXELSX As Long = 88
Private Const TITLEBAR_PIXELS As Long = 18
Private Const COMMANDBAR_PIXELS As Long = 26
Private Const COMMANDBAR_LEFT As Long = 0
Private Const COMMANDBAR_TOP As Long = 1
Private OrigWindow As tWindow

Private Type tRect
    left As Long
    Top As Long
    right As Long
    bottom As Long
End Type

Private Type tDisplay
    Height As Long
    Width As Long
    DPI As Long
End Type

Private Type tWindow
    Height As Long
    Width As Long
End Type

Private Type tControl
    Name As String
    Height As Long
    Width As Long
    Top As Long
    left As Long
End Type

Private Declare Function WM_apiGetDeviceCaps Lib "gdi32" Alias "GetDeviceCaps" _
(ByVal hdc As Long, ByVal nIndex As Long) As Long

Private Declare Function WM_apiGetDesktopWindow Lib "user32" Alias "GetDesktopWindow" _
() As Long

Private Declare Function WM_apiGetDC Lib "user32" Alias "GetDC" _
(ByVal hwnd As Long) As Long

Private Declare Function WM_apiReleaseDC Lib "user32" Alias "ReleaseDC" _
(ByVal hwnd As Long, ByVal hdc As Long) As Long

Private Declare Function WM_apiGetWindowRect Lib "user32.dll" Alias "GetWindowRect" _
(ByVal hwnd As Long, lpRect As tRect) As Long

Private Declare Function WM_apiMoveWindow Lib "user32.dll" Alias "MoveWindow" _
(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 WM_apiIsZoomed Lib "user32.dll" Alias "IsZoomed" _
(ByVal hwnd As Long) As Long

'الغرض من هذه الوظيفة هو احضار معلومات الطول والعرض والبيكسل الحالي لشاشة العرض
Private Function getScreenResolution() As tDisplay

Dim hDCcaps As Long
Dim lngRtn As Long

On Error Resume Next

    hDCcaps = WM_apiGetDC(0)
    With getScreenResolution
        .Height = WM_apiGetDeviceCaps(hDCcaps, WM_VERTRES)
        .Width = WM_apiGetDeviceCaps(hDCcaps, WM_HORZRES)
        .DPI = WM_apiGetDeviceCaps(hDCcaps, WM_LOGPIXELSX)
    End With
    lngRtn = WM_apiReleaseDC(0, hDCcaps)
    
End Function

'الغرض من هذه الوظيفة هو اعادة قيم عناصر النموذج كاملة في الطول والعرض وتكبيرها حسب مقاس الشاشة الحالية
Private Function getFactor(blnVert As Boolean) As Single

Dim sngFactorP As Single

On Error Resume Next

    If getScreenResolution.DPI <> 0 Then
        sngFactorP = DESIGN_PIXELS / getScreenResolution.DPI
    Else
        sngFactorP = 1
    End If
    If blnVert Then
        getFactor = (getScreenResolution.Height / DESIGN_VERTRES) * sngFactorP
    Else
        getFactor = (getScreenResolution.Width / DESIGN_HORZRES) * sngFactorP
    End If
    
End Function

'الغرض من هذه الوظيفة هي القيام بإستدعاءها في حدث عند الفتح وعند التحميل
Public Sub ReSizeForm(ByVal frm As Access.Form)

Dim rectWindow As tRect
Dim lngWidth As Long
Dim lngHeight As Long
Dim sngVertFactor As Single
Dim sngHorzFactor As Single
Dim sngFontFactor As Single

On Error Resume Next

    sngVertFactor = getFactor(True)
    sngHorzFactor = getFactor(False)
    
    sngFontFactor = VBA.IIf(sngHorzFactor < sngVertFactor, sngHorzFactor, sngVertFactor)
    Resize sngVertFactor, sngHorzFactor, sngFontFactor, frm
    If WM_apiIsZoomed(frm.hwnd) = 0 Then
        Access.DoCmd.RunCommand acCmdAppMaximize
        
        Call WM_apiGetWindowRect(frm.hwnd, rectWindow)
        
        With rectWindow
            lngWidth = .right - .left
            lngHeight = .bottom - .Top
        End With
        
        If frm.Parent.Name = VBA.vbNullString Then
            Call WM_apiMoveWindow(frm.hwnd, ((getScreenResolution.Width - _
            (sngHorzFactor * lngWidth)) / 2) - getLeftOffset, _
            ((getScreenResolution.Height - (sngVertFactor * lngHeight)) / 2) - _
            getTopOffset, lngWidth * sngHorzFactor, lngHeight * sngVertFactor, 1)
        End If
    End If
    Set frm = Nothing
    
End Sub

'الغرض من هذه الوظيفة هي اعادة تحجيم مقاسات الاقسام الخاصة بالنموذج مثل قسم تفصيل وقسم رأس النموذج وتذييل النموذج
Private Sub Resize(sngVertFactor As Single, sngHorzFactor As Single, sngFontFactor As _
Single, ByVal frm As Access.Form)

Dim ctl As Access.Control
Dim arrCtls() As tControl
Dim lngI As Long
Dim lngJ As Long
Dim lngWidth As Long
Dim lngHeaderHeight As Long
Dim lngDetailHeight As Long
Dim lngFooterHeight As Long
Dim blnHeaderVisible As Boolean
Dim blnDetailVisible As Boolean
Dim blnFooterVisible As Boolean
Const FORM_MAX As Long = 31680

On Error Resume Next
    
    With frm
        .Painting = False
        lngWidth = .Width * sngHorzFactor
        lngHeaderHeight = .Section(Access.acHeader).Height * sngVertFactor
        lngDetailHeight = .Section(Access.acDetail).Height * sngVertFactor
        lngFooterHeight = .Section(Access.acFooter).Height * sngVertFactor
        
        .Width = FORM_MAX
        .Section(Access.acHeader).Height = FORM_MAX
        .Section(Access.acDetail).Height = FORM_MAX
        .Section(Access.acFooter).Height = FORM_MAX
        
        blnHeaderVisible = .Section(Access.acHeader).Visible
        blnDetailVisible = .Section(Access.acDetail).Visible
        blnFooterVisible = .Section(Access.acFooter).Visible
        .Section(Access.acHeader).Visible = False
        .Section(Access.acDetail).Visible = False
        .Section(Access.acFooter).Visible = False
    End With
    ReDim arrCtls(0)
    For Each ctl In frm.Controls
        If ((ctl.ControlType = Access.acTabCtl) Or _
        (ctl.ControlType = Access.acOptionGroup)) Then
            With arrCtls(lngI)
                .Name = ctl.Name
                .Height = ctl.Height
                .Width = ctl.Width
                .Top = ctl.Top
                .left = ctl.left
            End With
            lngI = lngI + 1
            ReDim Preserve arrCtls(lngI)
        End If
    Next ctl
    
    For Each ctl In frm.Controls
        If ctl.ControlType <> Access.acPage Then
            With ctl
                .Height = .Height * sngVertFactor
                .left = .left * sngHorzFactor
                .Top = .Top * sngVertFactor
                .Width = .Width * sngHorzFactor
                .FontSize = .FontSize * sngFontFactor
                
                Select Case .ControlType
                    Case Access.acListBox
                        .ColumnWidths = adjustColumnWidths(.ColumnWidths, sngHorzFactor)
                    Case Access.acComboBox
                        .ColumnWidths = adjustColumnWidths(.ColumnWidths, sngHorzFactor)
                        .ListWidth = .ListWidth * sngHorzFactor
                    Case Access.acTabCtl
                        .TabFixedWidth = .TabFixedWidth * sngHorzFactor
                        .TabFixedHeight = .TabFixedHeight * sngVertFactor
                End Select
                
            End With
        End If
    Next ctl
    
    For lngJ = 0 To lngI
        With frm.Controls.Item(arrCtls(lngJ).Name)
            .left = arrCtls(lngJ).left * sngHorzFactor
            .Top = arrCtls(lngJ).Top * sngVertFactor
            .Height = arrCtls(lngJ).Height * sngVertFactor
            .Width = arrCtls(lngJ).Width * sngHorzFactor
        End With
    Next lngJ
    With frm
        .Width = lngWidth
        .Section(Access.acHeader).Height = lngHeaderHeight
        .Section(Access.acDetail).Height = lngDetailHeight
        .Section(Access.acFooter).Height = lngFooterHeight
        .Section(Access.acHeader).Visible = blnHeaderVisible
        .Section(Access.acDetail).Visible = blnDetailVisible
        .Section(Access.acFooter).Visible = blnFooterVisible
        .Painting = True
    End With
    Erase arrCtls
    Set ctl = Nothing

End Sub

'الغرض من هذه الوظيفة هو حساب مجموع البيكسل لكامل شاشة الاكسيس ناحية اليمين ووضع النموذج في منتصف الشاشة
Private Function getTopOffset() As Long

Dim cmdBar As Object
Dim lngI As Long

On Error GoTo err

     For Each cmdBar In Application.CommandBars
        If ((cmdBar.Visible = True) And (cmdBar.Position = COMMANDBAR_TOP)) Then
            lngI = lngI + 1
        End If
     Next cmdBar
     getTopOffset = (TITLEBAR_PIXELS + (lngI * COMMANDBAR_PIXELS))

exit_fun:
    Exit Function
    
err:
    getTopOffset = TITLEBAR_PIXELS + COMMANDBAR_PIXELS
    Resume exit_fun
     
End Function

'الغرض من هذه الوظيفة هو حساب مجموع البيكسل لكامل شاشة الاكسيس ناحية اليسار ووضع النموذج في منتصف الشاشة
Private Function getLeftOffset() As Long

Dim cmdBar As Object
Dim lngI As Long

On Error GoTo err

     For Each cmdBar In Application.CommandBars
        If ((cmdBar.Visible = True) And (cmdBar.Position = COMMANDBAR_LEFT)) Then
            lngI = lngI + 1
        End If
     Next cmdBar
     getLeftOffset = (lngI * COMMANDBAR_PIXELS)

exit_fun:
    Exit Function
    
err:
    getLeftOffset = 0
    Resume exit_fun
     
End Function
 
'الغرض من هذه الوظيفة هو اعادة تحجيم كامل عرض الاعمدة وعدم ترك فراغات من الناحية اليسرى
Private Function adjustColumnWidths(strColumnWidths As String, sngFactor As Single) As String
On Error GoTo Err_adjustColumnWidths

Dim astrColumnWidths() As String
Dim strTemp As String
Dim lngI As Long
Dim lngJ As Long

    ReDim astrColumnWidths(0)
    For lngI = 1 To VBA.Len(strColumnWidths)
        Select Case VBA.Mid(strColumnWidths, lngI, 1)
            Case Is <> ";"
                astrColumnWidths(lngJ) = astrColumnWidths(lngJ) & VBA.Mid( _
                strColumnWidths, lngI, 1)
            Case ";"
                lngJ = lngJ + 1
                ReDim Preserve astrColumnWidths(lngJ)
        End Select
    Next lngI
    lngI = 0
    strTemp = VBA.vbNullString
    Do Until lngI > UBound(astrColumnWidths)
        If Not IsNull(astrColumnWidths(lngI)) And astrColumnWidths(lngI) <> "" Then
            strTemp = strTemp & CSng(astrColumnWidths(lngI)) * sngFactor & ";"
        End If
        lngI = lngI + 1
    Loop
    adjustColumnWidths = strTemp
    Erase astrColumnWidths
    
Exit_adjustColumnWidths:
    On Error Resume Next
    Exit Function

Err_adjustColumnWidths:
    Erase astrColumnWidths 'Destroy array.
    Resume Exit_adjustColumnWidths
    
End Function

'الغرض من هذه الوظيفة اعادة حجم النموذج الى وضعه الطبيعي قبل اعادة التحجيم ويتم استدعاؤها عن تحميل النموذج
Public Sub getOrigWindow(frm As Access.Form)

On Error Resume Next

    OrigWindow.Height = frm.WindowHeight
    OrigWindow.Width = frm.WindowWidth

End Sub

'الغرض من هذه الوظيفة هو اعادة مقاس النموذج الى وضعه الطبيعي عند حدث الاغلاق
Public Sub RestoreWindow()

On Error Resume Next

    Access.DoCmd.MoveSize , , OrigWindow.Width, OrigWindow.Height
    Access.DoCmd.Save
    
End Sub

هل فهمي لامر صحيح هكذا اخي 

اخي خليفة وضعت الكود السابق ولم يفلح

فوضعت هذا الكود اخي 

Dim sngFactorP As Single

On Error Resume Next

    If getScreenResolution.DPI <> 0 Then
        sngFactorP = DESIGN_PIXELS / getScreenResolution.DPI
    Else
        sngFactorP = 1
    End If
    If blnVert Then
        getFactor = (getScreenResolution.Height / DESIGN_VERTRES) * sngFactorP
    Else
        getFactor = (getScreenResolution.Width / DESIGN_HORZRES) * sngFactorP
    End If
 

 

هل هذا صحيح