API: Copy an image to the Clipboard

    Access does not allow us to copy all types on images from an Image control to the Clipboard.  If the image is an embedded OLE type, we can use RunCommand acCmdCopy, but if it's linked or embedded in the form, we have to work off of the coordinates of the image control to paint the image onto the clipboard.

How it works:

1. If source image (ctl.Picture) doesn't exist, the code will stretch the image to fit in the control. This is necessary because we have no way of knowing whether the image contained is larger or smaller than the control it's contained in.
2. If source image (ctl.picture) exists, there are two possibilities depending on the image size:

(a) If source image size is greater than size of the image control, then stretch the image in the control to assure that we copy the entire image.       

(b) If source image size is less than the size of the image control, don't stretch the image, but copy the entire  image control to the clipboard.  This is done to preserve the resolution of smaller images.  This will also leave a gray background around the image itself.

3. If the control contains OLE Embedded images (as in Employees form in Northwind), we can directly SetFocus to the control and use RunCommand acCmdCopy.

Issues:

There appears to be a small border (about 2 pixels wide) around the image when it's copied.  This issue is still being investigated and the interim solution is to crop out the border using an Imaging app.

Caution: 

This code will temporarily remove the form's RecordSelector and it might also set the Image Control's SizeMode property to Stretched. These properties will be reset to their original values when the function terminates.

'*********** Code Start ***********
' This code was originally written by Dev Ashish.
' It is not to be altered or distributed,
' except as part of an application.
' You are free to use it in any application,
' provided the copyright notice is left unchanged.
'
' Code Courtesy of
' Dev Ashish
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

  'A handle to a bitmap (HBITMAP).
Private Const CF_BITMAP = 2
  'Loads a bitmap
Private Const IMAGE_BITMAP& = 0
  'Copies the source rectangle directly to
  'the destination rectangle.
Private Const SRCCOPY = &HCC0020
  'Number of pixels per logical inch along the screen width.
  'In a system with multiple display monitors, this value is
  'the same for all monitors
Private Const LOGPIXELSX = 88
  'Number of pixels per logical inch along the screen height.
  'In a system with multiple display monitors, this value is the
  'same for all monitors
Private Const LOGPIXELSY = 90
  'Width and height, in pixels, of the screen of the
  'primary display monitor.
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
  'Height, in pixels, of a normal caption area.
Private Const SM_CYCAPTION = 4
  'Width and height, in pixels, of a window border. This is
  'equivalent to the SM_CXEDGE value for windows with the 3-D look.
Private Const SM_CXBORDER = 5
Private Const SM_CYBORDER = 6
  'Thickness, in pixels, of the frame around the perimeter
  'of a window that has a caption but is not sizable.
Private Const SM_CXDLGFRAME = 7
Private Const SM_CYDLGFRAME = 8
  'Thickness, in pixels, of the sizing border around the perimeter
  'of a window that can be resized.
Private Const SM_CXFRAME = 32
Private Const SM_CYFRAME = 33

Function fImageToClipboard(frm As Form, _
            imageCtl As Control) As Boolean
'*******************************************
'Name:      fImageToClipboard (Function)
'Purpose:   Copies the image displayed in an
'           image control to the clipboard
'Author:    Dev Ashish
'Date:      February 09, 1999, 01:32:37 PM
'Called by: Any
'Calls:     Bunch of API functions, ConvertTwipsToPixels
'Inputs:    frm: Form on which image control is located
'           imageCtl: Image Control who's contents are to
'           be copied
'Output:    True on success; false on failure
'
'Credits:
' The method to retrieve a control's
' coordinates were first proposed
' by Lyle Fairfield (lylefair@cgocable.net).
' This is a slightly modified version of
' his original code
'
'*******************************************
'
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

  'First try to determine if the image control
  'has an OLE field as source
  'If yes, then use acCmdCopy to copy to clipboard
  'If no, .Picture generates a runtime error 438 which
  'sets the blnIsOLE flag to true in the error handler
  blnIsOLE = False
  strPicture = imageCtl.Picture
  If blnIsOLE Then
    imageCtl.SetFocus
    DoCmd.RunCommand acCmdCopy
    'Image copied, raise an error so that we
    'can exit the function
    Err.Raise vbObjectError + 65530
  End If

  'store the form's RecordSelector property value
  'The recordselector will need to be false
  'before we can get the coords of the control accurately.
  blnRecordSelector = frm.RecordSelectors
  frm.RecordSelectors = False

  hwnd = frm.hwnd
  'retrieve a handle to a display device context (DC)
  'for the client area of the specified window
  hdc = apiGetDC(hwnd)
  'create a memory device context (DC) compatible
  'with the specified device
  hMemDC = apiCreateCompatibleDC(hdc)
  'Find out if the picture file exists or not
  blnFileExists = (Not Dir(imageCtl.Picture) = vbNullString)

  If blnFileExists Then
    'If the source file exists, then use LoadPicture
    'to load the image into memory
    Set hObject = LoadPicture(imageCtl.Picture)
    'fill and place the BITMAP object into the buffer
    lngRet = apiGetObjectBmp(hObject.handle, Len(lpObject), lpObject)
  End If
  With lpRect
    'Compute the coords for the image control
    .Left = imageCtl.Left
    .Top = imageCtl.Top
    .Right = imageCtl.Width + imageCtl.Left
    .Bottom = imageCtl.Top + imageCtl.Height
  End With

  With lpRect
    'Compute the offsets needed because of the form's
    'borderstyle (Thin/Dialog/Sizeable) and
    'caption bar
    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
    'All previous measurements were in Twips.
    'convert to Pixels for API functions.
    .Left = ConvertTwipsToPixels(.Left, 0)
    .Top = ConvertTwipsToPixels(.Top, 1)
    .Bottom = ConvertTwipsToPixels(.Bottom, 1)
    .Right = ConvertTwipsToPixels(.Right, 0)
  End With

  If blnFileExists Then
    'If source file exists
   With lpRect
      If .Right + .Left > lpObject.bmWidth Then
        'If the image control is wider than the image
        'take the width of the control
        hBitmap = apiCreateCompatibleBitmap(hdc, _
                        .Right - .Left, .Bottom - .Top)
      Else
        'otherwise stretch the image in the control
        'Image control's SizeMode property value will have to be
        'changed. The image will have to be stretched
        'into the image control before we can successfully copy
        'it to the clipboard to avoid taking just portions of it
        blnBMPResize = True
        intSizeMode = imageCtl.SizeMode
        imageCtl.SizeMode = acOLESizeStretch
        'Repaint the form for the changes to take effect
        frm.Repaint
        'Now the image and image control should have same coords
        With lpObject
          'create a bitmap compatible with the device associated
          'with the specified device context
          hBitmap = apiCreateCompatibleBitmap(hdc, .bmWidth, .bmHeight)
        End With
      End If
      'Select the Bitmap into the specified device context
      lngRet = apiSelectObject(hMemDC, hBitmap)
      'transfers pixels from source rectangle to
      'the specified destination rectangle
      lngRet = apiBitBlt(hMemDC, 0&, 0&, .Right - .Left, _
                .Bottom - .Top, hdc, .Left, .Top, SRCCOPY)
    End With
  Else
    With lpRect
      'If source file doesn't exist, then create a bitmap compatible
      'with the device associated with the specified device context
      'with size same as the size of the image control
      hBitmap = apiCreateCompatibleBitmap(hdc, .Right - .Left, _
                                                .Bottom - .Top)
      'In this case also, the image might be smaller
      'than the control.  We should
      'stretch the image in the control
      'Image control's SizeMode property value will have to be
      'changed. The image will have to be stretched
      'into the image control before we can successfully copy
      'it to the clipboard to avoid taking just portions of it
      blnBMPResize = True
      intSizeMode = imageCtl.SizeMode
      imageCtl.SizeMode = acOLESizeStretch
      'Repaint the form for the changes to take effect
      frm.Repaint

      'Select the Bitmap into the specified device context
      lngRet = apiSelectObject(hMemDC, hBitmap)
      'transfers pixels from source rectangle to
      'the specified destination rectangle
      lngRet = apiBitBlt(hMemDC, 0&, 0&, .Right - .Left, _
              .Bottom - .Top, hdc, .Left, .Top, SRCCOPY)
    End With
  End If
  'Copy the image to the clipboard
  Call apiOpenClipboard(hwnd)
  Call apiEmptyClipboard
  Call apiSetClipboardData(CF_BITMAP, hBitmap)

  fImageToClipboard = True
ExitHere:
  On Error Resume Next
  'Restore property values and
  'perform cleanup.
  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
    ' from 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 ***********