فتح عده نماذج في نموذج واحد وبحجم واحد

اخي عبدالمانع

يعطيك الف عافيه

وكود رائع بالفعل

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

شكرا لمروك الكريم أستاذه / زهرة

الذين لم يعمل معهم المثال اليهم الكود البرمجي ...

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

Option Compare Database
Option Explicit

Private Declare Function SetParent Lib "user32" _
(ByVal hWndChild As Long, ByVal hWndNewParent 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 GetWindowLong Lib "user32" _
Alias "GetWindowLongA" (ByVal hWnd As Long, _
ByVal nIndex As Long) As Long

Private Declare Sub SetWindowPos Lib "user32" _
(ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, _
ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long)

Private Declare Function GetSystemMenu Lib "user32" _
(ByVal hWnd As Long, ByVal bRevert As Long) As Long

Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, _
ByVal nPosition As Long, ByVal wFlags As Long) As Long

Private Const GWL_STYLE = (-16)
Private Const GWL_HWNDPARENT = (-8)
Private Const GWL_WNDPROC = (-4)

Private Const WS_OVERLAPPEDWINDOW = &HCF0000
Private Const WS_POPUP = &H80000000
Private Const WS_THICKFRAME = &H40000
Private Const WS_VSCROLL = &H200000
Private Const WS_HSCROLL = &H100000
Private Const WS_CLIPSIBLINGS = &H4000000
Private Const WS_CLIPCHILDREN = &H2000000
Private Const WS_DLGFRAME = &H400000
Private Const WS_CAPTION = &HC00000
Private Const WS_BORDER = &H800000
Private Const WS_SYSMENU = &H80000

Private Const HWND_TOP = 0&
Private Const HWND_TOPMOST = -1

Private Const SWP_NOSIZE = 1
Private Const SWP_NOMOVE = 2
Private Const SWP_SHOWWINDOW = &H40
Private Const SWP_DRAWFRAME = &H20

Private Const MF_BYPOSITION = &H400&
Private Const MF_REMOVE = &H1000&

Dim frmChild As Form
Dim frmParent As Form

Public Function ChildWindowX(ChildName As String, ParentName As String, PosX As Long, PosY As Long)
Dim style As Long
Dim hWndChild As Long
Dim hWndParent As Long
Dim intObjState As Integer
Dim SysMenu As Long
Dim RectPos As Long
Dim rectposold As Long
'open child
    DoCmd.OpenForm ChildName
'open parent
    DoCmd.OpenForm ParentName
'set forms
    Set frmChild = Forms(ChildName)
    Set frmParent = Forms(ParentName)
'retrieve window handles
    hWndChild = frmChild.hWnd
    hWndParent = frmParent.hWnd
'set parent of child window
    SetParent hWndChild, hWndParent
'get child style
    style = GetWindowLong(hWndChild, GWL_STYLE)
'Popup
    style = style Or WS_POPUP
'Clip against fellow sibling windows
    style = style Or WS_CLIPSIBLINGS
'make child invisible to prevent graphical errors
    frmChild.Visible = False
'Apply style
    SetWindowLong hWndChild, GWL_STYLE, style
'place child in parent structure
    SetWindowLong hWndChild, GWL_HWNDPARENT, hWndParent
'set pos
    SetWindowPos hWndChild, HWND_TOP, PosX, PosY, 0&, 0&, _
    SWP_NOSIZE Or SWP_SHOWWINDOW
'Get sys menu on child
    SetParent hWndChild, hWndParent
    SysMenu = GetSystemMenu(hWndChild, 0)
'Remove sys menu "Next"
    RemoveMenu SysMenu, 8, MF_REMOVE Or MF_BYPOSITION '"next"
    RemoveMenu SysMenu, 7, MF_REMOVE Or MF_BYPOSITION 'menu line
End Function

Public Function ChildTopX(hWndChild As Long)
    SetWindowPos hWndChild, HWND_TOP, 0&, 0&, 0&, 0&, _
    SWP_NOSIZE Or SWP_NOMOVE Or SWP_SHOWWINDOW
End Function

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

"None"

"Size"

"Dialogue"

"Thin"

كل نموذج لوحدة ثم تعمل نموذج آخر باي اسم تريد وتضع فية الكود عند التحميل :-

ChildWindowX "None", Me.Name, 15, 35
ChildWindowX "Size", Me.Name, 200, 30
ChildWindowX "Dialogue", Me.Name, 100, 140
ChildWindowX "Thin", Me.Name, 250, 100

وتضع عند تغيير الحجم الكود هذا :-

ChildTopX Me.hWnd

ارجوا ان يكون الشرح واضح ،،،

عبدالمانع

يعطيكــــــــم العافيــــــــــــــــــــــــــــــــة