--- Soumis par 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 repeinturage. 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 ***************