如何用Excel VBA将二维0/1变量数据导出为黑白图像

当然可以，你提到的工作表方法可行，但确实有更高效的直接绘图方案，以下两种方法供你选择：

方案一：直接用GDI+绘制图像（无需依赖工作表） #

这种方法完全在内存中操作，不涉及Excel单元格，速度更快，适合大数据量场景，是最优解。

Option Explicit

' 声明GDI+相关API
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Type GdiplusStartupInput
    GdiplusVersion As Long
    DebugEventCallback As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type

Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" (ByRef token As LongPtr, ByRef inputbuf As GdiplusStartupInput, ByRef outputbuf As LongPtr) As Long
Private Declare PtrSafe Function GdiplusShutdown Lib "gdiplus" (ByVal token As LongPtr) As Long
Private Declare PtrSafe Function GdipCreateBitmapFromScan0 Lib "gdiplus" (ByVal width As Long, ByVal height As Long, ByVal stride As Long, ByVal pixelFormat As Long, ByVal scan0 As LongPtr, ByRef bitmap As LongPtr) As Long
Private Declare PtrSafe Function GdipSaveImageToFile Lib "gdiplus" (ByVal image As LongPtr, ByVal filename As LongPtr, ByRef clsidEncoder As GUID, ByVal encoderParams As LongPtr) As Long
Private Declare PtrSafe Function GdipDisposeImage Lib "gdiplus" (ByVal image As LongPtr) As Long
Private Declare PtrSafe Function CLSIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByRef pclsid As GUID) As Long

Sub ExportBinaryMapToImage()
    ' 替换为你的二维0/1数组
    Dim binaryMap() As Integer
    binaryMap = Array( _
        Array(1, 0, 1, 0), _
        Array(0, 1, 0, 1), _
        Array(1, 0, 1, 0), _
        Array(0, 1, 0, 1) _
    )
    
    Dim imgWidth As Long, imgHeight As Long
    imgWidth = UBound(binaryMap(0)) + 1
    imgHeight = UBound(binaryMap) + 1
    
    ' 初始化GDI+
    Dim gdiToken As LongPtr
    Dim gdiInput As GdiplusStartupInput
    gdiInput.GdiplusVersion = 1
    GdiplusStartup gdiToken, gdiInput, 0
    
    ' 准备像素数据：32位ARGB格式，每行字节数=宽度*4
    Dim stride As Long
    stride = imgWidth * 4
    Dim pixelData() As Byte
    ReDim pixelData(0 To stride * imgHeight - 1)
    
    ' 填充像素：0=黑色(ARGB:0,0,0,255)，1=白色(255,255,255,255)
    Dim y As Long, x As Long, idx As Long
    For y = 0 To imgHeight - 1
        For x = 0 To imgWidth - 1
            idx = y * stride + x * 4
            If binaryMap(y)(x) = 1 Then
                pixelData(idx) = 255     ' B通道
                pixelData(idx + 1) = 255 ' G通道
                pixelData(idx + 2) = 255 ' R通道
                pixelData(idx + 3) = 255 ' A通道（不透明）
            Else
                pixelData(idx) = 0
                pixelData(idx + 1) = 0
                pixelData(idx + 2) = 0
                pixelData(idx + 3) = 255
            End If
        Next x
    Next y
    
    ' 创建位图并保存为PNG
    Dim hBitmap As LongPtr
    GdipCreateBitmapFromScan0 imgWidth, imgHeight, stride, &H26200A, VarPtr(pixelData(0)), hBitmap
    
    Dim clsidPNG As GUID
    CLSIDFromString StrPtr("{557CF406-1A04-11D3-9A73-0000F81EF32E}"), clsidPNG
    Dim savePath As String
    savePath = Environ("USERPROFILE") & "\Desktop\BinaryMap.png"
    GdipSaveImageToFile hBitmap, StrPtr(savePath), clsidPNG, 0
    
    ' 释放资源
    GdipDisposeImage hBitmap
    GdiplusShutdown gdiToken
    
    MsgBox "图像已保存到：" & savePath
End Sub

方案优势： #

• 无Excel工作表依赖，处理大数组时速度远快于单元格方法
• 精确控制每个像素，无排版误差
• 直接生成标准PNG/JPG格式，无需后续调整

方案二：优化你的工作表方法 #

如果更熟悉Excel操作，可以用以下简化版代码减少冗余：

Sub OptimizedWorksheetToImage()
    ' 替换为你的二维0/1数组
    Dim binaryMap() As Integer
    binaryMap = Array( _
        Array(1, 0, 1, 0), _
        Array(0, 1, 0, 1), _
        Array(1, 0, 1, 0), _
        Array(0, 1, 0, 1) _
    )
    
    ' 创建临时工作表
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets.Add
    ws.Name = "TempMap"
    
    ' 批量写入数据
    Dim y As Long
    For y = LBound(binaryMap) To UBound(binaryMap)
        ws.Cells(y + 1, 1).Resize(1, UBound(binaryMap(y)) + 1).Value = binaryMap(y)
    Next y
    
    Dim targetRange As Range
    Set targetRange = ws.UsedRange
    
    ' 设置正方形单元格+隐藏网格线
    targetRange.ColumnWidth = 2
    targetRange.RowHeight = 14
    ws.DisplayGridlines = False
    
    ' 批量添加条件格式
    targetRange.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=0"
    targetRange.FormatConditions(1).Interior.Color = vbBlack
    targetRange.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=1"
    targetRange.FormatConditions(2).Interior.Color = vbWhite
    
    ' 复制导出图像
    targetRange.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    Dim chartObj As ChartObject
    Set chartObj = ws.ChartObjects.Add(0, 0, targetRange.Width, targetRange.Height)
    chartObj.Chart.Paste
    chartObj.Chart.Export Environ("USERPROFILE") & "\Desktop\BinaryMap_Worksheet.png", "PNG"
    
    ' 清理临时工作表
    Application.DisplayAlerts = False
    ws.Delete
    Application.DisplayAlerts = True
    
    MsgBox "图像已保存！"
End Sub

优化点： #

• 批量写入数据，避免逐个单元格赋值
• 自动创建/清理临时工作表，不污染现有数据
• 一次性设置条件格式，简化操作

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