Copier une image sur le Clipboard

--Soumis par Dev Ashish---

Copier une image sur le Clipboard.

Access ne nous permet pas de copier tous les type d'image depuis un contrôle Image vers le Clipboard. Si l'image est incluse du genre embedded OLE, on peut utiliser RunCommand acCmdCopy, mais si elle est en référence (link), ou incluse dans un formulaire, il nous faire un effort supplémentaire pour les coordonnées de l'image à envoyer au clipboard.

Plan d'exécution:

Si l'image source (ctl.Picture) n'existe pas, le code étirera l'image de sorte qu'elle remplisse tout le contrôle. Celà est nécessaire car on ne dispose d'aucun moyen pour savoir si l'image ne remplis que partiellement ou ne dépasse les limites du contrôle qui la contient.
Si l'image source (ctl.picture) existe, il y a deux alternatives, dépendamment de la dimension du contrôle:

(a) Si l'image source est plus grande que le contrôle, étirer (rapetisser) l'image source aux dimensions du contrôle, de sorte qu'on ait toute l'image.

(b) Si l'image source est plus petite, ne pas la modifier, de façon à conserver sa résolution. Cela laissera un contour gris autour de l'image source copiée.

Si le contrôle contient une référence à une image incluse ( OLE Embedded, tel que le formulaire Employees dans Northwind), on place le focus sur le contrôle et exécute RunCommand acCmdCopy.

Problèmes:

Il semble y avoir un petit pourtour ( deux pixels de large) autour de l'image lorsque copiée. On recherche toujours la source de ce comportement. Entretemps, on suggère d'éliminer cette bordure à l'aide d'un logiciel d'édition d'images, si besoin est d'éliminer cette fine bordure.

Avertissement:

Ce code enlève temporairement le "RecordSelector" du formulaire et il peut également assigner la propriété SizeMode du contrôle d'image à "Stretched". Ces propriétés sont remises à leur état initial lorsque la fonction termine.

'*********** Code Start ***********
Private Type RECT
  Left As Long
  Right As Long
  Top 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 apiCreateCompatibleDC Lib "gdi32" _
  Alias "CreateCompatibleDC" _
  (ByVal hdc As Long) _
  As Long

Private Declare Function apiCreateCompatibleBitmap Lib "gdi32" _
  Alias "CreateCompatibleBitmap" _
  (ByVal hdc As Long, _
  ByVal nWidth As Long, _
  ByVal nHeight 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 apiGetObjectBmp Lib "gdi32" _
  Alias "GetObjectA" _
  (ByVal hObject As Long, _
  ByVal nCount As Long, _
  lpObject As BITMAP) _
  As Long

Private Declare Function apiOpenClipboard Lib "user32" _
  Alias "OpenClipboard" _
  (ByVal hwnd As Long) _
  As Long

Private Declare Function apiEmptyClipboard Lib "user32" _
  Alias "EmptyClipboard" _
  () As Long

Private Declare Function apiSetClipboardData Lib "user32" _
  Alias "SetClipboardData" _
  (ByVal wFormat As Long, _
  ByVal hMem As Long) As Long

Private Declare Function apiCloseClipboard Lib "user32" _
  Alias "CloseClipboard" _
  () As Long

Private Declare Function apiGetDeviceCaps Lib "gdi32" _
  Alias "GetDeviceCaps" (ByVal hdc As Long, _
  ByVal nIndex As Long) As Long

Private Declare Function apiGetSysMetrics Lib "user32" _
  Alias "GetSystemMetrics" _
  (ByVal nIndex As Long) As Long

  'Référence (handle) au  bitmap (HBITMAP).
Private Const CF_BITMAP = 2
  'Charge le bitmap
Private Const IMAGE_BITMAP& = 0
  'Copie le rectangle de la source directement
  'sur celui de la destination.
Private Const SRCCOPY = &HCC0020
  'Le nombre de pixels par pouce logique (horizontal)
  'Dans un système à plusieurs moniteurs, cette valeur est
  'la même pour tous les moniteurs
Private Const LOGPIXELSX = 88
  'Le nombre de pixels par pouce logique (vertical)
  'Dans un système à plusieurs moniteurs, cette valeur est
  'la même pour tous les moniteurs
Private Const LOGPIXELSY = 90
  'Largeur et hauteur, en pixels, du 
  'moniteur principal.
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
  'Hauteur, en pixel, de la barre titre normale
Private Const SM_CYCAPTION = 4
  'Largeur et hauteur, en pixel, de la bordure de fenêtre. C'est
  'équivalent à la valeur de  SM_CXEDGE pour des fenêtre avec aspect 3-D.
Private Const SM_CXBORDER = 5
Private Const SM_CYBORDER = 6
  'Largeur, en pixel, du cadre du périmètre de fenêtre
  'avec barre titre, mais qui n'est pas redimensionnable.
Private Const SM_CXDLGFRAME = 7
Private Const SM_CYDLGFRAME = 8
  'Largeur, en pixel, du cadre du périmètre de fenêtre
  'qui ne peut pas être redimensionnée
Private Const SM_CXFRAME = 32
Private Const SM_CYFRAME = 33

Function fImageToClipboard(frm As Form, _
            imageCtl As Control) As Boolean
'*******************************************
'Name:      fImageToClipboard (Function)
'Purpose:   Copie l'image affichée dans un 
'           contrôle d'image sur le  clipboard
'Author:    Dev Ashish
'Date:      February 09, 1999, 01:32:37 PM
'Called by: Any
'Calls:     Pacquet de fonctions de l'API, ConvertTwipsToPixels
'Inputs:    frm: Formulaire sur lequel l'image est affichée
'           imageCtl: Image Control qui contient ce qui est à
'           copier.
'Output:    True en cas de réussite, false autrement
'
'Crédits:
' La  méthode pour repérer les coordonées d'un
' contrôle fut initialement proposée 
' par Lyle Fairfield (lylefair@cgocable.net).
' Ici, une version légèrement modifiée de son 
'code original
'
'*******************************************
'
On Error GoTo ErrHandler
Dim hwnd As Long
Dim hdc As Long
Dim lngRet As Long
Dim hMemDC As Long
Dim hObject As Object
Dim blnBMPResize As Boolean
Dim lpRect As RECT
Dim lpObject As BITMAP
Dim hBitmap As Long
Dim intSizeMode As Integer
Dim blnRecordSelector As Boolean
Dim strPicture As String
Dim blnIsOLE As Boolean
Dim blnFileExists As Boolean

  'En premier lieu, déterminer si le contrôle d'image
  'possède un champ  OLE comme source
  'Si oui, utiliser acCmdCopy pour faire la copie
  'Si non, .Picture generère le code d'erreur 438 qui
  'assigne blnIsOLE à  true dans l'analyse d'exception d'erreur
  blnIsOLE = False
  strPicture = imageCtl.Picture
  If blnIsOLE Then
    imageCtl.SetFocus
    DoCmd.RunCommand acCmdCopy
    'Image copiée, on signale une erreur pour
    'sortir de cette fonction
    Err.Raise vbObjectError + 65530
  End If

  'Emmagasine la propriété  RecordSelector actuelle, du formulaire,
  'car le recordselector doit être à faux pour calculer avec précision
  'les coordonnées du contrôle.
  blnRecordSelector = frm.RecordSelectors
  frm.RecordSelectors = False

  hwnd = frm.hwnd
  'poignée du "display device context" (DC)
  'pour la zone client de la fenêtre spécifiée
  hdc = apiGetDC(hwnd)
  'création d'un contexte compatible en mémoire  (DC) 
  'à partir du contexte fourni
  hMemDC = apiCreateCompatibleDC(hdc)
  'Vérifier si le fichier de l'image existe ou non
  blnFileExists = (Not Dir(imageCtl.Picture) = vbNullString)

  If blnFileExists Then
    'Si le fichier existe, utiliser LoadPicture
    'pour le charger en mémoire
    Set hObject = LoadPicture(imageCtl.Picture)
    'remplir et placer le BITMAP dans le tampon
    lngRet = apiGetObjectBmp(hObject.handle, Len(lpObject), lpObject)
  End If
  With lpRect
    'Calcule les coordonnées de contrôle d'image
    .Left = imageCtl.Left
    .Top = imageCtl.Top
    .Right = imageCtl.Width + imageCtl.Left
    .Bottom = imageCtl.Top + imageCtl.Height
  End With

  With lpRect
    'Calcule les offset requis dus au type de formulaire,
    'bordure (Thin/Dialog/Sizeable) et
    'barre titre
    If Not frm.BorderStyle Then _
        .Top = .Top + apiGetSysMetrics(SM_CYCAPTION)

    Select Case frm.BorderStyle
      Case 1 ' thin
        .Left = .Left + apiGetSysMetrics(SM_CXBORDER)
        .Top = .Top + apiGetSysMetrics(SM_CYBORDER)
      Case 2 ' sizeable
        .Left = .Left + apiGetSysMetrics(SM_CXFRAME)
        .Top = .Top + apiGetSysMetrics(SM_CYFRAME)
      Case 3 ' dialog
        .Left = .Left + apiGetSysMetrics(SM_CXDLGFRAME)
        .Top = .Top + apiGetSysMetrics(SM_CYDLGFRAME)
    End Select
    'Tout cela est en twips, les fonctions API bouffent
    'des pixels.
    .Left = ConvertTwipsToPixels(.Left, 0)
    .Top = ConvertTwipsToPixels(.Top, 1)
    .Bottom = ConvertTwipsToPixels(.Bottom, 1)
    .Right = ConvertTwipsToPixels(.Right, 0)
  End With

  If blnFileExists Then
    'Si le fichier source existe
   With lpRect
      If .Right + .Left > lpObject.bmWidth Then
        'Si le contrôle d'image est plus large que l'image même,
        'utiliser la dimension du contrôle
        hBitmap = apiCreateCompatibleBitmap(hdc, _
                        .Right - .Left, .Bottom - .Top)
      Else
        'autrement, étirer l'image dans le contrôle
        'La propriété  SizeMode du contrôle sera modifiée
        'de sorte que l'image soit étirée dans le contrôle
        'avant d'être copiée sur le clipboard, afin d'éviter de
        'ne capturer qu'une portion de celle-ci
        blnBMPResize = True
        intSizeMode = imageCtl.SizeMode
        imageCtl.SizeMode = acOLESizeStretch
        'Repeindre le formulaire pour forcer les changements
        frm.Repaint
        'Maintenant, l'image et le contrôle d'image ont les mêmes coord.
        With lpObject
          'créer un bitmap compatible avec le contexte associé
          'au contexte spécifié
          hBitmap = apiCreateCompatibleBitmap(hdc, .bmWidth, .bmHeight)
        End With
      End If
      'Choisir le bitmap dans le contexte spécifié
      lngRet = apiSelectObject(hMemDC, hBitmap)
      'transfère les pixels du rectangle source au
      'rectangle destination
      lngRet = apiBitBlt(hMemDC, 0&, 0&, .Right - .Left, _
                .Bottom - .Top, hdc, .Left, .Top, SRCCOPY)
    End With
  Else
    With lpRect
      'Si le fichier source n'existe pas, créer un bitmap compatible
      'avec le contexte associé au contexte spécifié dont
      'les dimensions sont celle du contrôle d'image
      hBitmap = apiCreateCompatibleBitmap(hdc, .Right - .Left, _
                                                .Bottom - .Top)
      'Dans ce cas, l'image peut être plus petite que
      'le contrôle, On peut étirer
      'l'image dans le contrôle, en changeant  la propriété
      ' SizeMode. L'image devrait être étirée dans le 
      'contrôle pour éviter qu'on ne se retrouve 
      'qu'avec une portion de l'image effectivement
      'copiée dans le clipboard.
      blnBMPResize = True
      intSizeMode = imageCtl.SizeMode
      imageCtl.SizeMode = acOLESizeStretch
      'Repeindre le formulaire pour forcer les changements
      frm.Repaint

      'Choisir le Bitmap dans le contexte spécifié
      lngRet = apiSelectObject(hMemDC, hBitmap)
      'transférer les pixels depuis le rectangle source
      'vers le rectangle spécifié de destination
      lngRet = apiBitBlt(hMemDC, 0&, 0&, .Right - .Left, _
              .Bottom - .Top, hdc, .Left, .Top, SRCCOPY)
    End With
  End If
  'Copier l'image dans le clipboard
  Call apiOpenClipboard(hwnd)
  Call apiEmptyClipboard
  Call apiSetClipboardData(CF_BITMAP, hBitmap)

  fImageToClipboard = True
ExitHere:
  On Error Resume Next
  'Rétablir les porpirétés modifiées, puis
  'faire le nettoyage
  Call apiCloseClipboard
  If blnIsOLE Then _
    Screen.PreviousControl.SetFocus
  If blnBMPResize Then _
    imageCtl.SizeMode = intSizeMode
  frm.RecordSelectors = blnRecordSelector
  Call apiDeleteObject(hObject)
  Call apiDeleteDC(hMemDC)
  Call apiReleaseDC(hwnd, hdc)
  Exit Function
ErrHandler:
  If Err.Number = 438 Then
    blnIsOLE = True
    Resume Next
  Else
    fImageToClipboard = False
    Resume ExitHere
  End If
End Function

Private Function ConvertTwipsToPixels(lngTwips As Long, _
                                lngDirection As Long) _
                                As Long
    ' tiré de MS Knowledge Base
    Dim lngDC As Long
    Dim lngPixelsPerInch As Long
    Const nTwipsPerInch = 1440
    Const SM_CXSCREEN = 0
    Const SM_CYSCREEN = 1
    lngDC = apiGetDC(SM_CXSCREEN)
    If (lngDirection = SM_CXSCREEN) Then
        lngPixelsPerInch = apiGetDeviceCaps(lngDC, LOGPIXELSX)
    Else
        lngPixelsPerInch = apiGetDeviceCaps(lngDC, LOGPIXELSY)
    End If
    lngDC = apiReleaseDC(SM_CXSCREEN, lngDC)
    ConvertTwipsToPixels = lngTwips / nTwipsPerInch * lngPixelsPerInch
End Function
'*********** Code End ***********