在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
Access软件网官方交流QQ群 (群号:54525238) Access源码网店
常见问答:
技术分类:
源码示例
- 【源码QQ群号19834647...(12.17)
- Access对子窗体数据进行批...(10.30)
- 最精简的组合框行来源数据快速输...(10.25)
- Access仿平台的多值选择器...(10.24)
- 【Access日期区间段查询】...(10.22)
- 【Access源码示例】VBA...(10.12)
- Access累乘示例,Acce...(10.09)
- 数值8.88,把整数8去掉,转...(10.08)
- 【Access自定义函数】一个...(09.30)
- 【Access选项卡示例】Ac...(09.09)
学习心得
最新文章
- Access系统自带的日期选择器不...(11.08)
- 分享一下Access工程中的acw...(11.07)
- Access快速开发平台--让有权...(11.04)
- Access快速开发平台--审批选...(11.01)
- ACCESS两张表先各自排序,然后...(10.31)
- Access对子窗体数据进行批量+...(10.30)
- SqlServer中如何用SQL命...(10.29)
- Access报表中的分组功能用代码...(10.28)
- 用Access计算库存结余的一个方...(10.26)
- 最精简的组合框行来源数据快速输入(...(10.25)