求助：MS Access 365中提取StaticDIB类型OLE图像数据的方法

StaticDIB是设备无关位图的静态OLE封装，Access的Unbound Object Frame没有直接导出为图像文件的内置方法，需要通过VBA结合Windows API解析内存中的DIB结构并写入文件。以下是具体实现方案：

实现步骤与代码 #

1. 模块中声明Windows API与辅助函数 #

在Access的标准模块中添加以下代码（适配64位Access 365）：

Option Explicit

#If VBA7 Then
    Declare PtrSafe Function GetObject Lib "user32.dll" Alias "GetObjectA" (ByVal hObject As LongPtr, ByVal nCount As Long, lpObject As Any) As Long
    Declare PtrSafe Function GlobalLock Lib "kernel32.dll" (ByVal hMem As LongPtr) As LongPtr
    Declare PtrSafe Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As LongPtr) As Long
    Declare PtrSafe Function CreateFile Lib "kernel32.dll" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As LongPtr) As LongPtr
    Declare PtrSafe Function WriteFile Lib "kernel32.dll" (ByVal hFile As LongPtr, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Any) As Long
    Declare PtrSafe Function CloseHandle Lib "kernel32.dll" (ByVal hObject As LongPtr) As Long
    
    Type BITMAP
        bmType As Long
        bmWidth As Long
        bmHeight As Long
        bmWidthBytes As Long
        bmPlanes As Integer
        bmBitsPixel As Integer
        bmBits As LongPtr
    End Type
    
    Type BITMAPFILEHEADER
        bfType As Integer
        bfSize As Long
        bfReserved1 As Integer
        bfReserved2 As Integer
        bfOffBits As Long
    End Type
    
    Type BITMAPINFOHEADER
        biSize As Long
        biWidth As Long
        biHeight As Long
        biPlanes As Integer
        biBitCount As Integer
        biCompression As Long
        biSizeImage As Long
        biXPelsPerMeter As Long
        biYPelsPerMeter As Long
        biClrUsed As Long
        biClrImportant As Long
    End Type
#Else
    ' 兼容32位Access的API声明
    Declare Function GetObject Lib "user32.dll" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
    Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
    Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long
    Declare Function CreateFile Lib "kernel32.dll" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
    Declare Function WriteFile Lib "kernel32.dll" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Any) As Long
    Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
    
    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
    
    Type BITMAPFILEHEADER
        bfType As Integer
        bfSize As Long
        bfReserved1 As Integer
        bfReserved2 As Integer
        bfOffBits As Long
    End Type
    
    Type BITMAPINFOHEADER
        biSize As Long
        biWidth As Long
        biHeight As Long
        biPlanes As Integer
        biBitCount As Integer
        biCompression As Long
        biSizeImage As Long
        biXPelsPerMeter As Long
        biYPelsPerMeter As Long
        biClrUsed As Long
        biClrImportant As Long
    End Type
#End If

Const GENERIC_WRITE = &H40000000
Const FILE_SHARE_READ = &H1
Const CREATE_ALWAYS = 2
Const FILE_ATTRIBUTE_NORMAL = &H80

Function ExportStaticDIBToBMP(ctlOLE As Object, savePath As String) As Boolean
    Dim stdPic As StdPicture
    Dim bmp As BITMAP
    Dim bmpFileHeader As BITMAPFILEHEADER
    Dim bmpInfoHeader As BITMAPINFOHEADER
    Dim hFile As LongPtr
    Dim bytesWritten As Long
    Dim dibData() As Byte
    Dim dibSize As Long
    
    On Error GoTo ErrorHandler
    
    ' 确认控件中是StaticDIB类型
    If ctlOLE.Class <> "StaticDIB" Then
        ExportStaticDIBToBMP = False
        Exit Function
    End If
    
    ' 获取StdPicture对象
    Set stdPic = ctlOLE.Object
    
    ' 获取位图信息
    GetObject stdPic.handle, Len(bmp), bmp
    
    ' 构建BITMAPINFOHEADER
    With bmpInfoHeader
        .biSize = Len(bmpInfoHeader)
        .biWidth = bmp.bmWidth
        .biHeight = bmp.bmHeight
        .biPlanes = bmp.bmPlanes
        .biBitCount = bmp.bmBitsPixel
        .biCompression = 0 ' BI_RGB
        .biSizeImage = bmp.bmWidthBytes * bmp.bmHeight
        .biXPelsPerMeter = 0
        .biYPelsPerMeter = 0
        .biClrUsed = 0
        .biClrImportant = 0
    End With
    
    ' 构建BITMAPFILEHEADER
    With bmpFileHeader
        .bfType = &H4D42 ' "BM"标识
        .bfOffBits = Len(bmpFileHeader) + Len(bmpInfoHeader) + IIf(bmp.bmBitsPixel <= 8, 2 ^ bmp.bmBitsPixel * 4, 0)
        .bfSize = .bfOffBits + bmpInfoHeader.biSizeImage
        .bfReserved1 = 0
        .bfReserved2 = 0
    End With
    
    ' 锁定DIB内存并读取像素数据
    Dim dibPtr As LongPtr
    dibPtr = GlobalLock(stdPic.handle)
    If dibPtr = 0 Then
        ExportStaticDIBToBMP = False
        Exit Function
    End If
    
    ReDim dibData(1 To bmpInfoHeader.biSizeImage)
    CopyMemory dibData(1), ByVal dibPtr + Len(bmpInfoHeader), bmpInfoHeader.biSizeImage
    GlobalUnlock stdPic.handle
    
    ' 创建并写入BMP文件
    hFile = CreateFile(savePath, GENERIC_WRITE, FILE_SHARE_READ, ByVal 0&, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)
    If hFile = -1 Then
        ExportStaticDIBToBMP = False
        Exit Function
    End If
    
    ' 依次写入文件头、信息头、像素数据
    WriteFile hFile, bmpFileHeader, Len(bmpFileHeader), bytesWritten, ByVal 0&
    WriteFile hFile, bmpInfoHeader, Len(bmpInfoHeader), bytesWritten, ByVal 0&
    WriteFile hFile, dibData(1), UBound(dibData), bytesWritten, ByVal 0&
    
    CloseHandle hFile
    ExportStaticDIBToBMP = True
    
    Exit Function
    
ErrorHandler:
    ExportStaticDIBToBMP = False
    If hFile <> 0 Then CloseHandle hFile
End Function

2. 调用函数导出图像 #

在表单的代码模块中，比如按钮点击事件里调用：

Private Sub cmdExportImage_Click()
    Dim savePath As String
    savePath = "C:\Temp\exported_image.bmp" ' 替换为实际保存路径
    
    If ExportStaticDIBToBMP(Me.oleUnbound, savePath) Then
        MsgBox "图像保存成功"
    Else
        MsgBox "保存失败"
    End If
End Sub

注：oleUnbound是你的Unbound Object Frame控件名称，需替换为实际控件名。

注意事项 #

• 确保Access已启用对VBA宏的信任（文件选项→信任中心→信任中心设置→宏设置）。
• 代码适配64位Access 365，若使用32位版本，保留#Else块的API声明即可。
• 保存路径需确保有写入权限，建议结合Application.FileDialog让用户选择保存路径。

内容的提问来源于stack exchange，提问作者BiigJiim