Option Compare Database
Option Explicit
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
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 Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(hpvDest As Any, hpvSource As Any, ByVal cbCopy 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 Sub PasteToImage(ByRef imgDest As Image)
Dim hBMP As Long
Dim arrData() As Byte
Dim biClrUsed As Long, biSizeImage As Long
OpenClipboard Application.hWndAccessApp
hBMP = GetClipboardData(CF_DIB)
CloseClipboard
If hBMP <> 0 Then
ReDim arrData(39)
CopyMemory ByVal VarPtr(arrData(0)), ByVal hBMP, 40
biClrUsed = ReadBytes(arrData, 32, 2)
biSizeImage = ReadBytes(arrData, 20, 4)
ReDim arrData(39 + biClrUsed * 8 + biSizeImage)
CopyMemory ByVal VarPtr(arrData(0)), ByVal hBMP, 40 + biClrUsed * 8 + biSizeImage
imgDest.PictureData = arrData
End If
End Sub
'以下均为二进制数据读取函数
Public Function Byt2Lng(ByRef arrData() As Byte, ByVal p As Long) As Long
CopyMemory VarPtr(Byt2Lng), VarPtr(arrData(p)), 4
End Function
Public Function Byt2Int(ByRef arrData() As Byte, ByVal p As Long) As Integer
CopyMemory VarPtr(Byt2Int), VarPtr(arrData(p)), 2
End Function
Public Function ReadBytes(arrData() As Byte, p As Long, t As Integer) As Long
If t >= 1 And t <= 4 Then CopyMemory VarPtr(ReadBytes), VarPtr(arrData(p)), t
End Function
Public Sub WriteBytes(ByRef arrData() As Byte, p As Long, Value As Long, t As Integer)
If t >= 1 And t <= 4 Then CopyMemory VarPtr(arrData(p)), VarPtr(Value), t
End Sub
