API: Put an image in Access window

Note: In order to test the code in this article under Access 97, you will need the AddressOf code as well. Also, you will need to comment out the existing lines in Hook procedure as noted in the comments.

    By subclassing the MDIClient area of the Access window, we can trap the WM_PAINT message that Windows sends to a window during repainting. Using these events, we can draw any picture in the Access window.

CMDIWindow.cls

modMDIClient.bas

Note: I've received emails from at least one user that this code leaves empty areas on the window when overlapping windows are moved out of the way. If you experience the same behavior, please report the configuration and any debug info to me via the Feedback link.

    Create a form frmPutPicture and from it's Open and Close events, call the Hook and UnHook subroutines as

'********** Code Start **********
' Private variable
Private mclsMDIClientWnd As CMDIWindow

Private Sub Form_Open(Cancel As Integer)
On Error GoTo ErrHandler

    ' Instantiate the class
    Set mclsMDIClientWnd = New CMDIWindow
    
    ' Specify one image to automatically
    ' display in the MDIClient window when
    ' the form opens
    With mclsMDIClientWnd
        .DrawMode = 1
        .ImagePath = "D:\install\images\mordor.bmp"
        ' Start subclassing
        ' THIS ONLY NEEDS TO BE DONE ONCE
        ' IF YOU HAVE TO CALL HOOK AGAIN,
        ' CALL UNHOOK FIRST OTHERWISE YOU
        ' WILL LIKELY CRASH!!!
        .Hook
    End With
ExitHere:
    Exit Sub
ErrHandler:
    With Err
        MsgBox "Error: " & .Number & vbCrLf & .Description, _
            vbCritical + vbOKOnly, .Source
    End With
    Resume ExitHere
End Sub

Private Sub cmdChangeImage_Click()
    ' Change the DrawMode and image
    ' on the fly
    With mclsMDIClientWnd
        .DrawMode = 2
        .ImagePath = "D:\install\images\meditate.jpg"
    End With
End Sub

Private Sub Form_Close()
    ' Un-subclass and destroy the instance
    Call mclsMDIClientWnd.Unhook
    Set mclsMDIClientWnd = Nothing
End Sub
'********** Code End **********

Place this code in a new module and name the module modMDIClient. (Warning: The module must be named as modMDIClient.)

'********** Code Start **********
' module name MUST be "modMDIClient"
' This module is only needed if you are using
' Access 2000. Under Access 97, you
' will be using Michael Kaplan's and Ken Getz's
' AddrOf function. For more details,
' see http://www.mvps.org/access/api/api0031.htm

' The class needs to set a refer to itself
Public pobjMDIClient As CMDIWindow

Public Function WndProc( _
            ByVal hWnd As Long, _
            ByVal Msg As Long, _
            ByVal wParam As Long, _
            ByVal lParam As Long) _
            As Long
    ' Whatever messages are received,
    ' just pass it on to the MDIClientWndProc
    ' message handler of the CMDIWindow
    ' instance currently held in pobjMDIClient
    '
    ' This does NOT account for multi-instancing
    ' and trying to multi-instance the class will
    ' likely result in a GPF.  But then again, you
    ' only have one MDIClient window to draw upon!
    WndProc = pobjMDIClient.MDIClientWndProc( _
                        hWnd, _
                        Msg, _
                        wParam, _
                        lParam)
End Function
'*********** Code End **********

Create a new class module, CMDIWindow, and paste the following code in it.

'*********** Class CMDIWindow Start  **********
'--------------------------------------------------------------
'Special thanks to Terry Kreft (terry.kreft@mps.co.uk)
'without whose help, this code would have never worked
'--------------------------------------------------------------

Private Type RECT
   left As Long
   top As Long
   right As Long
   bottom As Long
End Type

Private Type BITMAP
  bmType As Long
  bmWidth As Long
  bmHeight As Long
  bmWidthBytes As Long
  bmPlanes As Integer
  bmBitsPixel As Integer
  bmBits As Long
End Type

Private Declare Function apiGetDC _
    Lib "user32" Alias "GetDC" _
    (ByVal hWnd As Long) _
    As Long
    
Private Declare Function apiReleaseDC _
    Lib "user32" Alias "ReleaseDC" _
    (ByVal hWnd As Long, _
    ByVal hDC As Long) _
    As Long
    
Private Declare Function apiGetClientRect _
    Lib "user32" Alias "GetClientRect" _
    (ByVal hWnd As Long, _
    lpRect As RECT) _
    As Long
    
Private Declare Function apiCreateCompatibleDC _
    Lib "gdi32" Alias "CreateCompatibleDC" _
    (ByVal hDC As Long) _
    As Long
    
Private Declare Function apiDeleteDC _
    Lib "gdi32" Alias "DeleteDC" _
    (ByVal hDC As Long) _
    As Long
    
Private Declare Function apiSelectObject _
    Lib "gdi32" Alias "SelectObject" _
    (ByVal hDC As Long, _
    ByVal hObject As Long) _
    As Long
    
Private Declare Function apiBitBlt _
    Lib "gdi32" Alias "BitBlt" _
    (ByVal hDestDC As Long, _
    ByVal x As Long, _
    ByVal y As Long, _
    ByVal nWidth As Long, _
    ByVal nHeight As Long, _
    ByVal hSrcDC As Long, _
    ByVal xSrc As Long, _
    ByVal ySrc As Long, _
    ByVal dwRop As Long) _
    As Long
    
Private Declare Function apiDeleteObject _
    Lib "gdi32" Alias "DeleteObject" _
    (ByVal hObject As Long) _
    As Long
    
Private Declare Function apiSetStretchBltMode _
    Lib "gdi32" Alias "SetStretchBltMode" _
    (ByVal hDC As Long, _
    ByVal nStretchMode As Long) _
    As Long
    
Private Declare Function apiStretchBlt _
    Lib "gdi32" Alias "StretchBlt" _
    (ByVal hDC As Long, _
    ByVal x As Long, _
    ByVal y As Long, _
    ByVal nWidth As Long, _
    ByVal nHeight As Long, _
    ByVal hSrcDC As Long, _
    ByVal xSrc As Long, _
    ByVal ySrc As Long, _
    ByVal nSrcWidth As Long, _
    ByVal nSrcHeight As Long, _
    ByVal dwRop As Long) _
    As Long
    
Private Declare Function apiGetObjectBmp _
    Lib "gdi32" Alias "GetObjectA" _
    (ByVal hObject As Long, _
    ByVal nCount As Long, _
    lpObject As BITMAP) _
    As Long
    
Private Declare Function apiCallWindowProc _
    Lib "user32" Alias "CallWindowProcA" _
    (ByVal lpPrevWndFunc As Long, _
    ByVal hWnd As Long, _
    ByVal Msg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As Long) _
    As Long
    
Private Declare Function apiSetWindowLong _
    Lib "user32" Alias "SetWindowLongA" _
    (ByVal hWnd As Long, _
    ByVal nIndex As Long, _
    ByVal wNewWord As Long) _
    As Long
    
Private Declare Function apiCreateSolidBrush _
    Lib "gdi32" Alias "CreateSolidBrush" _
    (ByVal crColor As Long) _
    As Long
    
Private Declare Function apiFillRect _
    Lib "user32" Alias "FillRect" _
    (ByVal hDC As Long, _
    lpRect As RECT, _
    ByVal hBrush As Long) _
    As Long
    
Private Declare Function apiGetSysColor _
    Lib "user32" Alias "GetSysColor" _
    (ByVal nIndex As Long) _
    As Long
    
Private Declare Function apiSendMessage _
    Lib "user32" Alias "SendMessageA" _
    (ByVal hWnd As Long, _
    ByVal wMsg As Long, _
    wParam As Any, _
    lParam As Any) _
    As Long
    
Private Declare Function apiFindWindowEx _
    Lib "user32" Alias "FindWindowExA" _
    (ByVal hWnd1 As Long, _
    ByVal hWnd2 As Long, _
    ByVal lpsz1 As String, _
    ByVal lpsz2 As String) _
    As Long

Private Const COLOR_APPWORKSPACE& = 12
Private Const WM_ERASEBKGND = &H14
Private Const WM_PAINT = &HF
Private Const STRETCH_HALFTONE& = 4
Private Const STRETCH_ORSCANS& = 2
Private Const IMAGE_BITMAP& = 0
Private Const LR_DEFAULTCOLOR& = &H0
Private Const LR_LOADFROMFILE& = &H10
Private Const LR_DEFAULTSIZE& = &H40
Private Const SRCCOPY = &HCC0020
Private lpPrevWndProc  As Long
Private Const GWL_WNDPROC  As Long = (-4)

Private hBmp As BITMAP
Private mobjPic As Object
Private hDCSrc As Long
Private hDCDest As Long
Private lpRectDest As RECT
Private mlngWidth As Long
Private mlngHeight As Long
Private mintI As Integer
Private mintJ As Integer
Private mlngTargetX As Long
Private mlngTargetY As Long
Private lpRectSrc As RECT
Private mhWndMDIClient As Long
Private mintAccessVer As Integer

Private mstrImagePath As String
Private mintDrawMode As Integer

Public Property Let ImagePath(Path As String)
    ' Assign a new picture
    mstrImagePath = Path
    ' Clear the background image
    ' so that the new image can be rendered
    Call sFillMDIClient(mhWndMDIClient)
    ' if the picture object is set to nothing
    ' the code will reload the file
    Set mobjPic = Nothing
    'Force a paint
    Call apiSendMessage(mhWndMDIClient, WM_PAINT, ByVal 0&, ByVal 0&)
End Property

Public Property Get ImagePath() As String
    ' Returns the path to the image being currently displayed
    ImagePath = mstrImagePath
End Property

Public Property Let DrawMode(Mode As Integer)
    mintDrawMode = Mode
    ' Clear the background image
    ' so that the new image can be rendered
    Call sFillMDIClient(mhWndMDIClient)
    ' if the picture object is set to nothing
    ' the code will reload the file
    Set mobjPic = Nothing
    'Force a paint
    Call apiSendMessage(mhWndMDIClient, WM_PAINT, ByVal 0&, ByVal 0&)
End Property

Public Property Get DrawMode() As Integer
    ' Returns the current draw mode
    DrawMode = mintDrawMode
End Property

Public Function MDIClientWndProc( _
            ByVal hWnd As Long, _
            ByVal Msg As Long, _
            ByVal wParam As Long, _
            ByVal lParam As Long) _
            As Long
' Message Handler
    Select Case Msg
        Case WM_PAINT:
            ' repaint the window
            Call sPaintMDIClient
    End Select
    ' return the message back
    MDIClientWndProc = apiCallWindowProc( _
                        lpPrevWndProc, _
                        hWnd, _
                        Msg, _
                        wParam, _
                        lParam)
End Function

Private Sub sPaintMDIClient()

    ' Get the dimensions for the MDIClient window
    Call apiGetClientRect(mhWndMDIClient, lpRectDest)
    With lpRectDest
        mlngWidth = (.right - .left)
        mlngHeight = (.bottom - .top)
    End With
    
    ' If the image object is invalid, then
    If mobjPic Is Nothing Then
        ' Load the image file from disk
        Set mobjPic = LoadPicture(mstrImagePath)
        ' Render it memory and get a valid handle to the image
        hDCSrc = apiCreateCompatibleDC(hDCDest)
        Call apiGetObjectBmp(mobjPic.Handle, Len(hBmp), hBmp)
        Call apiSelectObject(hDCSrc, mobjPic.Handle)
    End If

    Select Case mintDrawMode
        Case 1:     'Tile the image over the MDIClient area
            For mintI = 0 To mlngWidth Step hBmp.bmWidth
                For mintJ = 0 To mlngHeight Step hBmp.bmHeight
                    Call apiBitBlt(hDCDest, mintI, mintJ, _
                        hBmp.bmWidth, hBmp.bmHeight, _
                        hDCSrc, 0, 0, SRCCOPY)
                Next
            Next
        Case 2:     'Display the image in the center
            With hBmp
                Call apiBitBlt(hDCDest, mlngWidth \ 2, mlngHeight \ 2, _
                        .bmWidth, .bmHeight, _
                        hDCSrc, 0, 0, SRCCOPY)
            End With
        Case 3:     'Display the image aligned to Top Left corner
            With hBmp
                Call apiBitBlt(hDCDest, 0, 0, _
                    .bmWidth, .bmHeight, _
                    hDCSrc, 0, 0, SRCCOPY)
            End With
        Case 4:     'Display the image aligned to Bottom Right corner
            With lpRectDest
                mlngTargetX = (.right - hBmp.bmWidth)
                mlngTargetY = (.bottom - hBmp.bmHeight)
                Call apiBitBlt(hDCDest, mlngTargetX, mlngTargetY, _
                        hBmp.bmWidth, hBmp.bmHeight, _
                        hDCSrc, 0, 0, SRCCOPY)
            End With
        Case 5:     'Stretch the bitmap
            Call apiSetStretchBltMode(hDCDest, STRETCH_ORSCANS)
            Call apiStretchBlt(hDCDest, 0, 0, mlngWidth, mlngHeight, _
                    hDCDest, 0, 0, hBmp.bmWidth, _
                    hBmp.bmHeight, SRCCOPY)
        Case Else:
            'Do nothing, invalid value
    End Select

End Sub

Public Sub Hook()

    If mhWndMDIClient <= 0 Or Len(ImagePath) = 0 _
            Or Len(Dir(ImagePath)) = 0 Or DrawMode = 0 Then
        ' if ImagePath or DrawMode is invalid, or if a handle to the
        ' MDI Client window wasn't returned, then error out
        Err.Raise 5
    End If
    
    If mintAccessVer >= 9 Then       ' Access 2000 ONLY
        lpPrevWndProc = apiSetWindowLong( _
                                mhWndMDIClient, _
                                GWL_WNDPROC, _
                                AddressOf modMDIClient.WndProc)
    ElseIf mintAccessVer = 8 Then       ' Access 97  ONLY
        ' You will obviously need Michael Kaplan's and
        ' Ken Getz's AddrOf function in Access 97
        'lpPrevWndProc = apiSetWindowLong( _
                                mhWndMDIClient, _
                                GWL_WNDPROC, _
                                AddrOf("WndProc"))
    End If
End Sub

Public Sub Unhook()
    ' Restore the default message handler
    Call apiSetWindowLong( _
            mhWndMDIClient, _
            GWL_WNDPROC, _
            lpPrevWndProc)
    ' Clear out the window
    Call sFillMDIClient(mhWndMDIClient)
    mhWndMDIClient = 0
End Sub

Private Sub sFillMDIClient(ByVal hWnd As Long)
Dim lpRect As RECT
Dim lngColor As Long
Dim hBrush As Long

  'Clear the background
  Call apiGetClientRect(hWnd, lpRect)
  lngColor = apiGetSysColor(COLOR_APPWORKSPACE)
  hBrush = apiCreateSolidBrush(lngColor)
  Call apiFillRect(hDCDest, lpRect, hBrush)
End Sub

Private Function fMDIClienthWnd() As Long
Const WC_MDICLIENT = "MDIClient"
    ' Try to find a window whose class is WC_MDICLIENT
    ' and is a child of hWndAccessApp
    fMDIClienthWnd = apiFindWindowEx(hWndAccessApp, _
                                    0, _
                                    WC_MDICLIENT, _
                                    vbNullString)
End Function

Private Sub Class_Initialize()
On Error GoTo ErrHandler
    ' Get the hWnd of MDIClient window
    mhWndMDIClient = fMDIClienthWnd
    If mhWndMDIClient Then
        ' if a valid hWnd was returned, then get a
        ' device context for drawing purposes
        hDCDest = apiGetDC(mhWndMDIClient)
    End If
    ' Since we can't use AddressOf in a class,
    ' set up the external message directer
    ' The module name MUST be modMDIClient
    ' in order for this to work
    Set modMDIClient.pobjMDIClient = Me
    mintAccessVer = CInt(SysCmd(acSysCmdAccessVer))
ExitHere:
    Exit Sub
ErrHandler:
    With Err
        .Raise .Number, .Source, .Description, .HelpFile, .HelpContext
    End With
    Resume ExitHere
End Sub

Private Sub Class_Terminate()
    ' Cleanup
    Set mobjPic = Nothing
    Call apiDeleteDC(hDCDest)
    Call apiReleaseDC(mhWndMDIClient, hDCSrc)
End Sub
'*********** Class CMDIWindow End  **********