اذهب الي المحتوي
أوفيسنا

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

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

عندما نتحدث عن توسيط النماذج والتقارير لابد من الأخذ فى الاعتبار ان خاصية PopUp لها تأثير كبير
فإن كانت PopUp = True لها أكواد تقوم بعمل التوسيط للنماذج والتقارير داخل الشاشة خاصة ولا تقوم بعملها ان كانت PopUp = False والعكس كذلك
واحيانا ننسى ذكر هذا الأمر عند عرض الاكواد والامثلة ولذلك تعمل عند البعض ولا تعمل عند اخرين
بل واحيانا اثناء التصميم ننسى هذا الامر ايضا ومن أجل ذلك بعد البحث المرير وترتيب الأفكار بفضل الله تعالى تم دمج الأكواد حتى تعمل تبعا للخاصية PopUp ايما كان اعدادها
حتى وان نسى المستخدم ذلك الامر أوحتى إن كان لا يدرى عنه شئ

المرفق الاتى ان شاء الله به حل المشكلة تماما

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

اولا الكلاس : clsAutoCenter
 

'|---01/11/2021__________________________________________________________________________________________|
'|___www.officena.net_______________________|___________________________________________________________|
'|                                          |                                                           |
'|    __  _                                 |           _  +-----------officena-----------+ _           |
'|    \ `/ |                                |          /o) |             |||||            | (o\         |
'|     \__`!                                |         / /  |           @(~O^O~)@          |  \ \        |
'|     / ,' `-.__________________           |        ( (_  | _   ----oOo--Moh--oOo----- _ |  _) )       |
'|    '-'\_____                U `-.        |       ((\ \) +/o)----------3ssam---------(o\+ (/ /))      |
'|        \____()-=O=O=O=O=O=[]====--)      |       (\\\ \_/ /                          \ \_/ ///)      |
'|         `.___ ,-----,_______...-'        |        \      /                            \      /       |
'|              /    .'                     |         \____/________Mohammed Essam________\____/        |
'|             /   .'                       |                                                           |
'|            /  .'                         |                         01/11/2021                        |
'|            `-'                           |                                                           |
'|_____www.officena.net_____________________|___________________________________________________________|
'|_____Thank you for visiting https://www.officena.net__________________________________________________'
Option Compare Database
Option Explicit


Private Type RECT       'RECT structure used for API calls.
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type


Private Type POINTAPI   'POINTAPI structure used for API calls.
    X As Long
    Y As Long
End Type

Private m_hWnd As Long          'Handle of the window.
Private m_rctWindow As RECT     'Rectangle describing the sides of the last polled location of the window.

Private Const m_ERR_INVALIDHWND = 1
Private Const m_ERR_NOPARENTWINDOW = 2

#If VBA7 Then
    Private Declare PtrSafe Function apiIsWindow Lib "user32" Alias "IsWindow" (ByVal hWnd As LongPtr) As Long
    
    Private Declare PtrSafe Function apiMoveWindow Lib "user32" Alias "MoveWindow" (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
        'Moves and resizes a window in the coordinate system of its parent window.
    
    Private Declare PtrSafe Function apiGetWindowRect Lib "user32" Alias "GetWindowRect" (ByVal hWndPtr As Long, lpRect As RECT) As Long
        'After calling, the lpRect parameter contains the RECT structure describing the sides of the window in screen coordinates.
    
    Private Declare PtrSafe Function apiScreenToClient Lib "user32" Alias "ScreenToClient" (ByVal hWnd As LongPtr, lpPoint As POINTAPI) As Long
        'Converts lpPoint from screen coordinates to the coordinate system of the specified client window.
    
    Private Declare PtrSafe Function apiGetParent Lib "user32" Alias "GetParent" (ByVal hWnd As LongPtr) As Long
        'Returns the handle of the parent window of the specified window.

#Else
    Private Declare Function apiIsWindow Lib "user32" Alias "IsWindow" (ByVal hWnd As Long) As Long
    
    Private Declare Function apiMoveWindow Lib "user32" 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
        'Moves and resizes a window in the coordinate system of its parent window.
    
    Private Declare Function apiGetWindowRect Lib "user32" Alias "GetWindowRect" (ByVal hWnd As Long, lpRect As RECT) As Long
        'After calling, the lpRect parameter contains the RECT structure describing the sides of the window in screen coordinates.
    
    Private Declare Function apiScreenToClient Lib "user32" Alias "ScreenToClient" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
        'Converts lpPoint from screen coordinates to the coordinate system of the specified client window.
    
    Private Declare Function apiGetParent Lib "user32" Alias "GetParent" (ByVal hWnd As Long) As Long
        'Returns the handle of the parent window of the specified window.
#End If


Private Sub RaiseError(ByVal lngErrNumber As Long, ByVal strErrDesc As String)
'Raises a user-defined error to the calling procedure.

    Err.Raise vbObjectError + lngErrNumber, "clFormWindow", strErrDesc
    
End Sub

Private Sub UpdateWindowRect()
'Places the current window rectangle position (in pixels, in coordinate system of parent window) in m_rctWindow.

    Dim ptCorner As POINTAPI
    
    If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
        apiGetWindowRect m_hWnd, m_rctWindow   'm_rctWindow now holds window coordinates in screen coordinates.
        
        If Not Me.Parent Is Nothing Then
            'If there is a parent window, convert top, left of window from screen coordinates to parent window coordinates.
            With ptCorner
                .X = m_rctWindow.Left
                .Y = m_rctWindow.Top
            End With
        
            apiScreenToClient Me.Parent.hWnd, ptCorner
        
            With m_rctWindow
                .Left = ptCorner.X
                .Top = ptCorner.Y
            End With
    
            'If there is a parent window, convert bottom, right of window from screen coordinates to parent window coordinates.
            With ptCorner
                .X = m_rctWindow.Right
                .Y = m_rctWindow.Bottom
            End With
        
            apiScreenToClient Me.Parent.hWnd, ptCorner
        
            With m_rctWindow
                .Right = ptCorner.X
                .Bottom = ptCorner.Y
            End With
        End If
    Else
        RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
    End If
    
End Sub

Public Property Get hWnd() As Long
'Returns the value the user has specified for the window's handle.

    If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
        hWnd = m_hWnd
    Else
        RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
    End If
    
End Property


Public Property Let hWnd(ByVal lngNewValue As Long)
'Sets the window to use by specifying its handle.
'Only accepts valid window handles.

    If lngNewValue = 0 Or apiIsWindow(lngNewValue) Then
        m_hWnd = lngNewValue
    Else
        RaiseError m_ERR_INVALIDHWND, "The value passed to the hWnd property is not a valid window handle."
    End If
    
End Property


Public Property Get Left() As Long
'Returns the current position (in pixels) of the left edge of the window in the coordinate system of its parent window.

    If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
        UpdateWindowRect
        Left = m_rctWindow.Left
    Else
        RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
    End If
    
End Property


Public Property Let Left(ByVal lngNewValue As Long)
'Moves the window such that its left edge falls at the position indicated
'(measured in pixels, in the coordinate system of its parent window).

    If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
        UpdateWindowRect
        With m_rctWindow
            apiMoveWindow m_hWnd, lngNewValue, .Top, .Right - .Left, .Bottom - .Top, True
        End With
    Else
        RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
    End If
    
End Property

'----------------------------------------------------

Public Property Get Top() As Long
'Returns the current position (in pixels) of the top edge of the window in the coordinate system of its parent window.

    If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
        UpdateWindowRect
        Top = m_rctWindow.Top
    Else
        RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
    End If

End Property


Public Property Let Top(ByVal lngNewValue As Long)
'Moves the window such that its top edge falls at the position indicated
'(measured in pixels, in the coordinate system of its parent window).

    If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
        UpdateWindowRect
        With m_rctWindow
            apiMoveWindow m_hWnd, .Left, lngNewValue, .Right - .Left, .Bottom - .Top, True
        End With
    Else
        RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
    End If

End Property

'----------------------------------------------------

Public Property Get Width() As Long
'Returns the current width (in pixels) of the window.
    
    If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
        UpdateWindowRect
        With m_rctWindow
            Width = .Right - .Left
        End With
    Else
        RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
    End If

End Property


Public Property Let Width(ByVal lngNewValue As Long)
'Changes the width of the window to the value provided (in pixels).

    If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
        UpdateWindowRect
        With m_rctWindow
            apiMoveWindow m_hWnd, .Left, .Top, lngNewValue, .Bottom - .Top, True
        End With
    Else
        RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
    End If

End Property

'----------------------------------------------------

Public Property Get Height() As Long
'Returns the current height (in pixels) of the window.
    
    If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
        UpdateWindowRect
        With m_rctWindow
            Height = .Bottom - .Top
        End With
    Else
        RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
    End If

End Property


Public Property Let Height(ByVal lngNewValue As Long)
'Changes the height of the window to the value provided (in pixels).

    If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
        UpdateWindowRect
        With m_rctWindow
            apiMoveWindow m_hWnd, .Left, .Top, .Right - .Left, lngNewValue, True
        End With
    Else
        RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
    End If

End Property

Public Property Get Parent() As clsAutoCenter
'Returns the parent window as a clFormWindow object.
'For forms, this should be the Access MDI window.

    Dim fwParent As New clsAutoCenter
    Dim lngHWnd As Long
    
    If m_hWnd = 0 Then
        Set Parent = Nothing
    ElseIf apiIsWindow(m_hWnd) Then
        lngHWnd = apiGetParent(m_hWnd)
        fwParent.hWnd = lngHWnd
        Set Parent = fwParent
    Else
        RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
    End If

    Set fwParent = Nothing
    
End Property

 

ثانيا الموديول ولن يفرق اسم الموديول فى شئ 
 

'|---01/11/2021__________________________________________________________________________________________|
'|___www.officena.net_______________________|___________________________________________________________|
'|                                          |                                                           |
'|    __  _                                 |           _  +-----------officena-----------+ _           |
'|    \ `/ |                                |          /o) |             |||||            | (o\         |
'|     \__`!                                |         / /  |           @(~O^O~)@          |  \ \        |
'|     / ,' `-.__________________           |        ( (_  | _   ----oOo--Moh--oOo----- _ |  _) )       |
'|    '-'\_____                U `-.        |       ((\ \) +/o)----------3ssam---------(o\+ (/ /))      |
'|        \____()-=O=O=O=O=O=[]====--)      |       (\\\ \_/ /                          \ \_/ ///)      |
'|         `.___ ,-----,_______...-'        |        \      /                            \      /       |
'|              /    .'                     |         \____/________Mohammed Essam________\____/        |
'|             /   .'                       |                                                           |
'|            /  .'                         |                         01/11/2021                        |
'|            `-'                           |                                                           |
'|_____www.officena.net_____________________|___________________________________________________________|
'|_____Thank you for visiting https://www.officena.net__________________________________________________'
Option Compare Database
Option Explicit

Private Type RECT
    X1 As Long
    Y1 As Long
    X2 As Long
    Y2 As Long
End Type
#If VBA7 Then
    Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
#Else
    Private Declare Function GetDesktopWindow Lib "user32" () As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, Rectangle As RECT) As Boolean
    Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
#End If
Private Const WU_LOGPIXELSX = 88
Private Const WU_LOGPIXELSY = 90


'  Call CenterForm(Me)
'  Call CenterReport(Me)

Sub CenterForm(F As Form)
If F.PopUp = False Then
      Dim fw As New clsAutoCenter
      fw.hWnd = F.hWnd
      With fw
          .Top = (.Parent.Height - .Height) / 2
          .Left = (.Parent.Width - .Width) / 2
      End With
      Set fw = Nothing
ElseIf F.PopUp = True Then
    Dim formWidth As Long, formHeight As Long
    Dim MaxWidth As Long, maxHeight As Long
    Dim ScreenWidth As Long, ScreenHeight As Long
    Dim formAllMarginsHeight As Long, formAllMarginsWidth As Long

    GetScreenResolution ScreenWidth, ScreenHeight
    ScreenWidth = ConvertPixelsToTwips(ScreenWidth, 0)
    ScreenHeight = ConvertPixelsToTwips(ScreenHeight, 0)
    MaxWidth = ScreenWidth * 0.6
    maxHeight = ScreenHeight * 0.9

    formAllMarginsHeight = F.WindowHeight - F.Section(acDetail).Height
    formAllMarginsWidth = F.Width

    formWidth = formAllMarginsWidth
    formHeight = formAllMarginsHeight
    
    If formHeight < F.WindowHeight Then
        formHeight = F.WindowHeight
    End If
    DoCmd.MoveSize (ScreenWidth - formWidth) / 2, (ScreenHeight - formHeight) / 2, formWidth, formHeight
End If
End Sub


Sub CenterReport(R As Report)
If R.PopUp = False Then
      Dim fw As New clsAutoCenter
      fw.hWnd = R.hWnd
      With fw
          .Top = (.Parent.Height - .Height) / 2
          .Left = (.Parent.Width - .Width) / 2
      End With
      Set fw = Nothing
ElseIf R.PopUp = True Then
    Dim ReportWidth As Long, ReportHeight As Long
    Dim MaxWidth As Long, maxHeight As Long
    Dim ScreenWidth As Long, ScreenHeight As Long
    Dim ReportAllMarginsHeight As Long, ReportAllMarginsWidth As Long

    GetScreenResolution ScreenWidth, ScreenHeight
    ScreenWidth = ConvertPixelsToTwips(ScreenWidth, 0)
    ScreenHeight = ConvertPixelsToTwips(ScreenHeight, 0)
    MaxWidth = ScreenWidth * 0.6
    maxHeight = ScreenHeight * 0.9

    ReportAllMarginsHeight = R.WindowHeight - R.Section(acDetail).Height
    ReportAllMarginsWidth = R.Width

    ReportWidth = ReportAllMarginsWidth
    ReportHeight = ReportAllMarginsHeight
    
    If ReportHeight < R.WindowHeight Then
        ReportHeight = R.WindowHeight
    End If
    DoCmd.MoveSize (ScreenWidth - ReportWidth) / 2, (ScreenHeight - ReportHeight) / 2, ReportWidth, ReportHeight
End If
End Sub

Function ConvertTwipsToPixels(lngTwips As Long, lngDirection As Long) As Long
    Dim lngPixelsPerInch As Long
    Const nTwipsPerInch = 1440

#If VBA7 Then
    Dim lngDC As LongPtr
#Else
    Dim lngDC As Long
#End If
    
    lngDC = GetDC(0)
    If (lngDirection = 0) Then
        lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSX)
    Else
        lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSY)
    End If
    lngDC = ReleaseDC(0, lngDC)
    ConvertTwipsToPixels = (lngTwips / nTwipsPerInch) * lngPixelsPerInch
End Function

Function ConvertPixelsToTwips(lngPixels As Long, lngDirection As Long) As Long
    Dim lngPixelsPerInch As Long
    Const nTwipsPerInch = 1440
    
#If VBA7 Then
    Dim lngDC As LongPtr
#Else
    Dim lngDC As Long
#End If
    
    lngDC = GetDC(0)

    If (lngDirection = 0) Then
        lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSX)
    Else
        lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSY)
    End If
    lngDC = ReleaseDC(0, lngDC)
    ConvertPixelsToTwips = (lngPixels * nTwipsPerInch) / lngPixelsPerInch
End Function

Private Sub GetScreenResolution(ByRef Width As Long, ByRef Height As Long)
    Dim R As RECT
    Dim RetVal As Long

#If VBA7 Then
    Dim hWnd As LongPtr
#Else
    Dim hWnd As Long
#End If
    hWnd = GetDesktopWindow()
    RetVal = GetWindowRect(hWnd, R)
    Width = R.X2 - R.X1
    Height = R.Y2 - R.Y1
End Sub

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

	Call CenterForm(Me)

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

	Call CenterReport(Me)

فى حالة كانت  PopUp = True

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

 

اما فى حالة  PopUp = False
يتم توسيط النماذج والتقارير فى داخل اطار برنامج الاكسس نفسه

 

والان اليكم المرفق بالمثال العملى




 

 

AutoCentre.mdb

تم تعديل بواسطه ابا جودى
  • Like 4
  • Thanks 1
رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • اضف...

Important Information