在access中复制图片到剪贴板

时　间:2009-11-03 00:12:21
作　者:LucasLynn   ID：7973  城市：北京
摘　要:在Access中复制图片到剪贴板
正　文:

'调用段代码,要放在窗体中:

Private Sub B_CopyToClipboard_Click()
    Dim MyPicCtl As Control
    Set MyPicCtl = Me.Image0    '图片控件为Image0
    Call ClipBoard_SetImage(MyPicCtl)
End Sub

'模块段代码，放在模块中:
Option Compare Database
Option Explicit

Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Declare Function CloseClipboard Lib "user32" () As Long
Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Declare Function EmptyClipboard Lib "user32" () As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags&, ByVal dwBytes As Long) As Long
Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
                       (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)

Declare Function SetEnhMetaFileBits Lib "gdi32" _
                                    (ByVal cbBuffer As Long, lpData As Byte) As Long
Declare Function SetWinMetaFileBits Lib "gdi32" _
                                    (ByVal cbBuffer As Long, lpbBuffer As Byte, _
                                     ByVal hDCRef As Long, lpmfp As Any) As Long
Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" _
                                 (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Declare Function DeleteEnhMetaFile Lib "gdi32" (ByVal hemf As Long) As Long
Declare Function GetActiveWindow Lib "user32" () As Long
Declare Function GetDesktopWindow Lib "user32" () As Long

' 剪贴板格式
Public Const CF_TEXT = 1
Public Const CF_BITMAP = 2
Public Const CF_METAFILEPICT = 3
Public Const CF_DIB = 8
Public Const CF_ENHMETAFILE = 14

' 全局内存标志
Public Const GMEM_MOVEABLE = &H2
Public Const GMEM_ZEROINIT = &H40
Public Const GMEM_SHARE = &H2000

Public Function ClipBoard_SetImage(MyPicCtl As Control)

    Dim hClipMemory As Long
    Dim lpClipMemory As Long
    Dim hGlobalMemory As Long
    Dim lpGlobalMemory As Long
    Dim cfm As Long
    Dim hMetafile As Long
    Dim AccessHwnd As Long    ' 存储PictureData属性的Byte数组
    Dim bPicData() As Byte    ' 重定义数组大小
    ReDim bPicData(LenB(MyPicCtl.PictureData) - 1)

    ' 复制数组
    bPicData = MyPicCtl.PictureData
    If (bPicData(0) <> 3 And bPicData(0) <> 14 And bPicData(0) <> 40) Then
        MsgBox ("不支持此格式。" & Chr$(13) & _
                "PictureData的第一个数据包含：" & bPicData(0))
        Exit Function
    End If

    If (bPicData(0) = 3) Then    ' *** 头文件 ***
        Call CopyMemory(cfm, bPicData(8), Len(cfm))
        hMetafile = SetWinMetaFileBits(UBound(bPicData) + 24 + 1 - 8, bPicData(24), 0&, cfm)
    Else
        If (bPicData(0) = 14) Then    ' *** 增强型头文件 ***
            hMetafile = SetEnhMetaFileBits(UBound(bPicData) + 1 - 8, bPicData(8))
        Else    ' (bPicData(0) = 40) ' *** DIB *** ' 分配可移动的全局内存
            hGlobalMemory = GlobalAlloc(GMEM_MOVEABLE or GMEM_SHARE or GMEM_ZEROINIT, _
                                        UBound(bPicData) + 1)
            If (hGlobalMemory = 0) Then
                MsgBox ("无法分配全局内存")
                Exit Function
            End If    ' 锁定内存块
            lpGlobalMemory = GlobalLock(hGlobalMemory)
            If (lpGlobalMemory = 0) Then
                MsgBox ("无法锁定全局内存")
                GlobalFree (hGlobalMemory)
                Exit Function
            End If
            ' 复制数据到全局内存
            Call CopyMemory(ByVal lpGlobalMemory, bPicData(0), UBound(bPicData) + 1)
        End If
    End If    ' 打开剪贴板
    AccessHwnd = GetActiveWindow()
    If (OpenClipboard(AccessHwnd) = 0) Then MsgBox "无法打开剪贴板，可能正在被其他程序使用。"

End Function