【转载 / 源码】在Access中复制图片到剪贴板

LucasLynn

<DIV class=quote>

调用段代码：

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) & _

               "ictureData的第一个数据包含：" & 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 "无法打开剪贴板，可能正在被其他程序使用。

9399100

找这个东西，很久了。