如何通过VBA数组在Excel中创建浮动图片形状？

无需依赖外部文件或单元格中转，直接将VBA数组中的RGB位图数据转换为工作表的浮动形状对象，核心思路是通过Windows API构建设备无关位图(DIB)，再转换为VBA可识别的IPicture对象插入工作表。

完整实现代码 #

首先在标准模块中添加以下API声明、类型定义和转换函数：

' 位图相关类型定义
Private 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

Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type

Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As RGBQUAD
End Type

' IPicture转换相关类型
Private Type PicDesc
    Size As Long
    Type As Long
    hBitmap As LongPtr
    hPal As LongPtr
End Type

' Windows API声明（兼容32/64位Excel）
Private Declare PtrSafe Function CreateDIBSection Lib "gdi32.dll" (ByVal hdc As LongPtr, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByRef ppvBits As LongPtr, ByVal hSection As LongPtr, ByVal dwOffset As Long) As LongPtr
Private Declare PtrSafe Function DeleteObject Lib "gdi32.dll" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As Any, RefIID As Any, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare PtrSafe Function GetDC Lib "user32.dll" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32.dll" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function CLSIDFromString Lib "ole32.dll" (ByVal lpsz As String, pclsid As Long) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

' IPicture接口GUID
Private Const IID_IPicture As String = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"

' 将RGB数组转换为IPicture对象
Function ArrayToPicture(rgbArray() As Byte, width As Long, height As Long) As IPicture
    Dim bmi As BITMAPINFO
    Dim hDIB As LongPtr
    Dim hDC As LongPtr
    Dim pBits As LongPtr
    Dim i As Long, j As Long
    Dim rowSize As Long
    
    ' 计算每行字节数（DIB要求行字节数为4的倍数）
    rowSize = ((width * 3 + 3) \ 4) * 4
    
    ' 初始化位图信息头
    With bmi.bmiHeader
        .biSize = Len(bmi.bmiHeader)
        .biWidth = width
        .biHeight = -height ' 负数值表示位图顶行在前（符合常规图像顺序）
        .biPlanes = 1
        .biBitCount = 24 ' 24位RGB格式
        .biCompression = 0 ' 无压缩
        .biSizeImage = rowSize * height
        .biXPelsPerMeter = 0
        .biYPelsPerMeter = 0
        .biClrUsed = 0
        .biClrImportant = 0
    End With
    
    ' 创建DIBSection获取内存指针
    hDC = GetDC(0)
    hDIB = CreateDIBSection(hDC, bmi, 0, pBits, 0, 0)
    ReleaseDC 0, hDC
    
    If hDIB = 0 Then Exit Function
    
    ' 将RGB数组数据复制到DIB内存
    ' 注：示例数组格式为 rgbArray(行索引, 列索引, 通道)，通道顺序R(0), G(1), B(2)
    For i = 0 To height - 1
        For j = 0 To width - 1
            CopyMemory ByVal pBits + i * rowSize + j * 3, rgbArray(i, j, 2), 1 ' B通道
            CopyMemory ByVal pBits + i * rowSize + j * 3 + 1, rgbArray(i, j, 1), 1 ' G通道
            CopyMemory ByVal pBits + i * rowSize + j * 3 + 2, rgbArray(i, j, 0), 1 ' R通道
        Next j
    Next i
    
    ' 将DIB转换为IPicture对象
    Dim picDesc As PicDesc
    Dim iid(0 To 3) As Long
    Dim hr As Long
    
    With picDesc
        .Size = Len(picDesc)
        .Type = vbPicTypeBitmap
        .hBitmap = hDIB
        .hPal = 0
    End With
    
    CLSIDFromString IID_IPicture, iid(0)
    hr = OleCreatePictureIndirect(picDesc, iid(0), True, ArrayToPicture)
    
    ' 转换失败则释放资源
    If hr <> 0 Then
        DeleteObject hDIB
        Set ArrayToPicture = Nothing
    End If
End Function

使用示例 #

下面的测试代码生成一个渐变RGB数组，转换为位图并插入当前工作表：

Sub TestGenerateBitmap()
    Dim width As Long, height As Long
    Dim rgbArray() As Byte
    Dim i As Long, j As Long
    Dim pic As IPicture
    Dim targetShp As Shape
    
    ' 设置位图尺寸
    width = 200
    height = 150
    
    ' 初始化三维RGB数组：行、列、RGB通道
    ReDim rgbArray(0 To height - 1, 0 To width - 1, 0 To 2)
    
    ' 填充测试数据（红-蓝水平渐变，绿垂直渐变）
    For i = 0 To height - 1
        For j = 0 To width - 1
            rgbArray(i, j, 0) = j * 255 \ width
            rgbArray(i, j, 1) = i * 255 \ height
            rgbArray(i, j, 2) = 255 - (j * 255 \ width)
        Next j
    Next i
    
    ' 数组转Picture对象
    Set pic = ArrayToPicture(rgbArray, width, height)
    
    ' 插入为工作表浮动形状
    If Not pic Is Nothing Then
        Set targetShp = ActiveSheet.Shapes.AddPicture( _
            pic, LinkToFile:=False, SaveWithDocument:=True, _
            Left:=50, Top:=50, Width:=width, Height:=height)
        targetShp.Name = "Generated_RGB_Bitmap"
    End If
End Sub

关键说明 #

• 数组格式适配：如果你的RGB数组格式不同（比如一维数组、BGR顺序），只需调整CopyMemory部分的赋值逻辑，匹配数组的存储顺序即可。
• 内存管理：代码通过OleCreatePictureIndirect让IPicture对象接管DIB句柄，无需手动释放；转换失败时会主动清理资源，避免内存泄漏。
• 兼容性：代码使用PtrSafe和LongPtr，支持32位和64位Excel；旧版32位Excel可移除PtrSafe并将LongPtr替换为Long。
• 性能优化：直接操作内存数组，跳过文件IO和单元格中转，适合处理较大的位图数据。

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