'[To load a normal form as MDIChild]
'It's not exactly working like a real MDIChild, see for yourself.

'For suggestions,
'E.B. Knoppert, ProFinance WOERDEN Netherlands
'ebknoppert@hotmail.com


[PROJECT1 (DLL)]
// Class1

Option Explicit

Dim F As New Form1

Private Sub Class_Terminate()

    Unload F
    Set F = Nothing

End Sub

Public Function MyDLLForm() As Variant

    Set MyDLLForm = F

End Function

[PROJECT2 (EXE)]
// MDIFORM1

Option Explicit
    
Dim FrmClass As New Class1

Private Sub TestMnu_Click(Index As Integer)

    Select Case Index
    Case 0

        If LoadAsMDIChild(FrmClass.MyDLLForm) Then

            FrmClass.MyDLLForm.Show
            FrmClass.MyDLLForm.Move 2000, 2000

        End If

        If LoadAsMDIChild(Form1) Then

            Form1.Show
            Form1.Move 100, 100
            Form1.Command1.SetFocus

        End If

    Case 10

        Unload Me

    End Select

End Sub

Private Sub MDIForm_Unload(Cancel As Integer)

    'BE SURE you unload the childs manually!
    Unload Form1
    Set FrmClass = Nothing

End Sub

// MODULE1

Option Explicit

Public Type FormAsMDIChildType

    PrevProcedure   As Long
    childBackColor  As Long

    'might be necessary to extend with more properties?

End Type

Public Type RECT

    Left    As Long
    Top     As Long
    Right   As Long
    Bottom  As Long

End Type

Public Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Public Declare Function DefMDIChildProc Lib "user32" Alias "DefMDIChildProcA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Public Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Public Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Public Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Public Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Public Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Public Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Public Const GMEM_FIXED = &H0
Public Const GMEM_ZEROINIT = &H40
Public Const GW_CHILD = 5
Public Const GWL_EXSTYLE = (-20)
Public Const GWL_STYLE = (-16)
Public Const GWL_USERDATA = (-21)
Public Const GWL_WNDPROC = (-4)
Public Const WM_DESTROY = &H2
Public Const WM_ERASEBKGND = &H14
Public Const WS_CHILD = &H40000000
Public Const WS_EX_MDICHILD = &H40&

'Unhook procedure.
Public Sub LoadAsMDIChild_UnHook(hwnd As Long)

    On Error Resume Next

    Dim ChildProperties As FormAsMDIChildType
    Dim hGlobalMemory   As Long
    Dim lpGlobalMemory  As Long

    'Hook in process?
    'We are using the GWL_USERDATA entry, be sure you don't use that yourself!
    hGlobalMemory = GetWindowLong(hwnd, GWL_USERDATA)

    If hGlobalMemory Then

        lpGlobalMemory = GlobalLock(hGlobalMemory)

        CopyMemory ByVal VarPtr(ChildProperties), ByVal lpGlobalMemory, LenB(ChildProperties)

        SetWindowLong hwnd, GWL_WNDPROC, ChildProperties.PrevProcedure
        SetWindowLong hwnd, GWL_USERDATA, 0

        GlobalUnlock hGlobalMemory
        GlobalFree hGlobalMemory

    End If

End Sub

'Hook procedure.
Function LoadAsMDIChild(ChildForm As Form) As Boolean

    On Error Resume Next

    Dim ChildProperties As FormAsMDIChildType
    Dim hGlobalMemory   As Long
    Dim hMDICLIENT      As Long
    Dim L               As Long
    Dim lpGlobalMemory  As Long
    Dim MDIFrame        As MDIForm

    'Search for the MDIFrame.
    For L = 0 To Forms.Count - 1

        If TypeOf Forms(L) Is MDIForm Then

            Set MDIFrame = Forms(L)
            Exit For

        End If

    Next L

    If MDIFrame Is Nothing Then Exit Function
    If ChildForm Is Nothing Then Exit Function

    'Retrieve the MDICLIENT-class handle.
    hMDICLIENT = GetWindow(MDIFrame.hwnd, GW_CHILD)
    If hMDICLIENT = 0 Then Exit Function

    'Already in use?
    If GetWindowLong(ChildForm.hwnd, GWL_USERDATA) Then Exit Function

    'Solve problem, must be unloaded before hook.
    Unload ChildForm

    'Unhook if hooked.
    LoadAsMDIChild_UnHook ChildForm.hwnd

    'Use some memory by handle instead of by name.
    hGlobalMemory = GlobalAlloc(GMEM_FIXED Or GMEM_ZEROINIT, LenB(ChildProperties))
    lpGlobalMemory = GlobalLock(hGlobalMemory)

    'Store some properties.
    ChildProperties.PrevProcedure = GetWindowLong(ChildForm.hwnd, GWL_WNDPROC)
    ChildProperties.childBackColor = ChildForm.BackColor
    'System color? convert to plain value.
    If ChildProperties.childBackColor < 0 Then ChildProperties.childBackColor = RGB(192, 192, 192)

    'Copy settings to memory pointer.
    CopyMemory ByVal lpGlobalMemory, ByVal VarPtr(ChildProperties), LenB(ChildProperties)

    'Release memoryblock.
    GlobalUnlock hGlobalMemory

    'Store hGlobalMemory in Form's userdata entry.
    SetWindowLong ChildForm.hwnd, GWL_USERDATA, hGlobalMemory

    'Make form react as child.
    L = GetWindowLong(ChildForm.hwnd, GWL_STYLE)
    L = L Or WS_CHILD
    SetWindowLong ChildForm.hwnd, GWL_STYLE, L

    L = GetWindowLong(ChildForm.hwnd, GWL_EXSTYLE)
    L = L Or WS_EX_MDICHILD
    SetWindowLong ChildForm.hwnd, GWL_EXSTYLE, L

    'Subclass it as MDI child.
    SetWindowLong ChildForm.hwnd, GWL_WNDPROC, AddressOf MDIChildForm_Proc

    'Make it parent of the MDICLIENT-class.
    SetParent ChildForm.hwnd, hMDICLIENT

    'All childs are getting a count value upon creation.
    'This procedure lacks this, therefore it might not react fully as MDIChild.
    '(CLIENTCREATESTRUCT)

    LoadAsMDIChild = True

End Function

Function MDIChildForm_Proc(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

    On Error Resume Next

    Dim ChildProperties As FormAsMDIChildType
    Dim hbrOld          As Long
    Dim hBrush          As Long
    Dim hGlobalMemory   As Long
    Dim lpGlobalMemory  As Long
    Dim R               As RECT

    'Only a few messages are required to do something with.
    Select Case wMsg
    Case WM_ERASEBKGND, WM_DESTROY

        'Retrieve hGlobalMemory to access.
        hGlobalMemory = GetWindowLong(hwnd, GWL_USERDATA)

        'Valid?
        If hGlobalMemory Then

            'Copy settings in local typevar.
            lpGlobalMemory = GlobalLock(hGlobalMemory)
            CopyMemory ByVal VarPtr(ChildProperties), ByVal lpGlobalMemory, LenB(ChildProperties)
            GlobalUnlock hGlobalMemory

            Select Case wMsg
            Case WM_ERASEBKGND

                'Unfortunatly, when subclassed, the brush for the background is lost.
                'We need it to do it ourselves.
                'Might be overlooking something else. (Forecolor?)
                'Label controls are no longer painted correctly.
                hBrush = CreateSolidBrush(ChildProperties.childBackColor)

                If hBrush Then

                    hbrOld = SelectObject(wParam, hBrush)

                    GetClientRect hwnd, R
                    FillRect wParam, R, hBrush

                    If hbrOld Then SelectObject wParam, hbrOld

                    DeleteObject hBrush

                    MDIChildForm_Proc = 1
                    Exit Function

                End If

            Case WM_DESTROY

                'Unhooking is better..
                LoadAsMDIChild_UnHook hwnd

            End Select

        End If

    End Select

    'Reply messages. (note the procedure)
    MDIChildForm_Proc = DefMDIChildProc(hwnd, wMsg, wParam, lParam)

End Function
