APIs: Placer une image dans la fenêtre d'Access	Author(s) Dev Ashish

Placer une image dans la fenêtre d'Access.

Note: Pour tester le code de cet article, vous devez avoir également le code pour AddressOf.

    En sous-classant la portion  MDIClient de la fenêtre d'Access, on peut capturer les messages WM_PAINT  que Windows transmet lors d'un peinturage. En utilisant ces événements, on peut tracer une image dans la fenêtre d'Access.

CMDIWindow.cls

modMDIClient.bas

Note: j'ai reçu du courrier d'un utilisateur dont ce code laissait vide une portion du formulaire après qu'on le libère d'une autre fenêtre qui le recouvrait partiellement. Si vous expérimentez le même comportement, vous est-il possible de me faire parvenir votre configuration et toute information pertinente permettant de débugger ce cas, via le lien Feedback.

    Créer un formulaire frmPutPicture et dans ses procédures événementielles OnOpen et OnUnload, appeler les sous-routines Hook et UnHook comme suit:

'********** 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 **********

Mettre ce code dans un nouveau module que l'on nomme modMDIClient (ce doit être précisément ce nom).

'********** 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/accessfr/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 **********

Créer un nouveau module de classe, CMDIWindow, et y insérer le code qui suit:

'********** Code Start **********
'--------------------------------------------------------------
'Remerciements tous spéciaux à  Terry Kreft (terry.kreft@mps.co.uk)
'sans son aise, ce code n'aurait jamais fonctionné
'
'NOTE:  Ce code ne peut fonctionner sans Address Of de Ken Getz
'et Michael Kaplan.
'--------------------------------------------------------------
'
'*************************
'NE PAS PARCOURIR CE CODE 
'EN MODE DEBUG
'Utiliser de petits bitmaps pour accroître
'le temps de réponse.
'*************************
'

'Changer pour un fichier point-BMP existant
Private Const conPICPATH = "C:\win98\Setup.bmp"

'Utiliser une de constantes:  1, 2, 3, 4, 5
' où
'   1 = Effet mosaïque
'   2 = Centrer l'image
'   3 = Positionner dans le coin supérieur gauche
'   4 = Positionner dans le coin inférieur droit
'   5 = Étirer pour remplir la fenêtre
'
Private Const conDRAWMODE = 1

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 apiGetWindow Lib "user32" _
  Alias "GetWindow" _
  (ByVal hwnd As Long, _
  ByVal wCmd As Long) _
  As Long
    
Private Declare Function apiGetClassName Lib "user32" _
  Alias "GetClassNameA" _
  (ByVal hwnd As Long, _
  ByVal lpClassname As String, _
  ByVal nMaxCount As Long) _
  As Long
    
Private Declare Function apiGetWindowText Lib "user32" _
  Alias "GetWindowTextA" _
  (ByVal hwnd As Long, _
  ByVal lpString As String, _
  ByVal aint 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 apiSendMessageLong Lib "user32" _
  Alias "SendMessageA" _
  (ByVal hwnd As Long, _
  ByVal wMsg As Long, _
  ByVal wParam As Long, _
  ByVal lParam As Long) _
  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 GW_HWNDFIRST = 0
Private Const GW_HWNDNEXT = 2
Private Const GW_CHILD = 5
Private Const GW_OWNER = 4
Private Const SRCCOPY = &HCC0020
Private Const MAX_LEN = 255
Private lpPrevWndProc  As Long
Private Const GWL_WNDPROC  As Long = (-4)

Function fPaintMDI(ByVal hwnd As Long, _
            ByVal Msg As Long, _
            ByVal wParam As Long, _
            ByVal lParam As Long) As Long
Dim lngRet As Long
    
  On Error Resume Next
    
  Select Case Msg
    Case WM_PAINT:
      Call sPaintMDIClient
  End Select
  fPaintMDI = apiCallWindowProc( _
                 ByVal lpPrevWndProc, _
                 ByVal hwnd, _
                 ByVal Msg, _
                 ByVal wParam, _
                 ByVal lParam)
End Function

Sub sPaintMDIClient()
  Dim hWndMDI As Long
  Dim lngDC As Long
  Dim lngRet As Long
  Dim ShadowDC As Long
  Dim hObject As Object
  Dim lpObject As BITMAP
  Dim intI As Integer
  Dim intJ As Integer
  Dim lpRect As RECT
  Dim intWidth As Integer
  Dim intHeight As Integer
  Dim intTargetX As Integer
  Dim intTargetY As Integer
  
  hWndMDI = fGetMDIhWnd
    
  lngDC = apiGetDC(hWndMDI)
  lngRet = apiGetClientRect(hWndMDI, lpRect)
  With lpRect
    intWidth = Abs(.left - .right)
    intHeight = Abs(.top - .bottom)
  End With
  Set hObject = LoadPicture(conPICPATH)
  ShadowDC = apiCreateCompatibleDC(lngDC)
  lngRet = apiGetObjectBmp(hObject.handle, Len(lpObject), lpObject)
  lngRet = apiSelectObject(ShadowDC, hObject.handle)
  
  Select Case conDRAWMODE
    Case 1:     'Mosaïque
      For intI = 0 To intWidth Step lpObject.bmWidth
        For intJ = 0 To intHeight Step lpObject.bmHeight
          lngRet = apiBitBlt(lngDC, intI, intJ, _
                    lpObject.bmWidth, lpObject.bmHeight, _
                    ShadowDC, 0, 0, SRCCOPY)
        Next intJ
      Next intI
    Case 2:     'Centrer l'image
      With lpRect
        intTargetX = Abs(.right - .left) \ 2
        intTargetY = Abs(.bottom - .top) \ 2
      End With
      lngRet = apiBitBlt(lngDC, intTargetX, intTargetY, _
                lpObject.bmWidth, lpObject.bmHeight, _
                ShadowDC, 0, 0, SRCCOPY)
    Case 3:     'Coin supérieur gauche
      lngRet = apiBitBlt(lngDC, 0, 0, _
                lpObject.bmWidth, lpObject.bmHeight, _
                ShadowDC, 0, 0, SRCCOPY)
    Case 4:     'Coin inférieur droit
      With lpRect
        intTargetX = Abs(.right - lpObject.bmWidth)
        intTargetY = Abs(.bottom - lpObject.bmHeight)
        lngRet = apiBitBlt(lngDC, intTargetX, intTargetY, _
                  lpObject.bmWidth, lpObject.bmHeight, _
                  ShadowDC, 0, 0, SRCCOPY)
      End With
    Case 5:     'Étirer
      lngRet = apiSetStretchBltMode(lngDC, STRETCH_ORSCANS)
      lngRet = apiStretchBlt(lngDC, 0, 0, intWidth, intHeight, _
                    ShadowDC, 0, 0, lpObject.bmWidth, _
                    lpObject.bmHeight, SRCCOPY)
    Case Else:
      'Ne rien faire, constante non reconnue
  End Select
  'ménage général
  Set hObject = Nothing
  lngRet = apiDeleteDC(ShadowDC)
  lngRet = apiReleaseDC(hWndMDI, lngDC)
End Sub

Function fGetMDIhWnd() As Long
Dim hwnd As Long
  hwnd = apiGetWindow(hWndAccessApp, GW_CHILD)
  Do While Not hwnd = 0
    If fGetClassName(hwnd) = "MDIClient" Then
      fGetMDIhWnd = hwnd
      Exit Do
    End If
    hwnd = apiGetWindow(hwnd, GW_HWNDNEXT)
  Loop
End Function

Private Function fGetClassName(hwnd As Long)
  Dim strBuffer As String
  Dim lngRet As Long

  strBuffer = String$(32, 0)
  lngRet = apiGetClassName(hwnd, strBuffer, Len(strBuffer))
  If lngRet > 0 Then
    fGetClassName = left$(strBuffer, lngRet)
  End If
End Function

Private Function fGetCaption(hwnd As Long)
  Dim strBuffer As String
  Dim lngRet As Long

  strBuffer = String$(MAX_LEN, 0)
  lngRet = apiGetWindowText(hwnd, strBuffer, Len(strBuffer))
  If lngRet > 0 Then
    fGetCaption = left$(strBuffer, lngRet)
  End If
End Function

Sub sHook(hwnd As Long, strFunction As String)
  lpPrevWndProc = apiSetWindowLong(hwnd, _
                      GWL_WNDPROC, _
                      AddrOf(strFunction))
  'Obliger à repeindre
  Call apiSendMessageLong(hwnd, WM_PAINT, 0&, 0&)
End Sub

Sub sUnhook(hwnd As Long)
Dim lngTmp As Long
  On Error Resume Next
  lngTmp = apiSetWindowLong(hwnd, _
            GWL_WNDPROC, _
            lpPrevWndProc)
  Call sFillMDIClient(hwnd)
End Sub

Private Sub sFillMDIClient(ByVal hwnd As Long)
Dim lngDC As Long
Dim lpRect As RECT
Dim lngColor As Long
Dim hBrush As Long
Dim lngTmp As Long

  'Effacer l'arrière plan
  lngTmp = apiGetClientRect(hwnd, lpRect)
  lngDC = apiGetDC(hwnd)
  lngColor = apiGetSysColor(COLOR_APPWORKSPACE)
  hBrush = apiCreateSolidBrush(lngColor)
  lngTmp = apiFillRect(lngDC, lpRect, hBrush)
  lngTmp = apiDeleteDC(lngDC)
End Sub

'***************** Code End ***************