将图片导入Excel背景...纯娱乐

只对应了24位深,测试通过,巨卡的...

Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Private Type BITMAPFILEHEADER  'this struct's size: 14byte
    bfType As Integer 'must be "BM"
    bfSize As Long 'bmp file size in bytes
    bfReserved1 As Integer 'reserved must be 0
    bfReserved2 As Integer 'reserved must be 0
    bfOffBits As Long 'pic data start pos from 0?
End Type

Private Type BITMAPINFOHEADER 'struct size:40 byte
    biSize As Long 'this struct's size in byte (40)
    biWidth As Long 'picture width in pix
    biHeight As Long 'picture height in pix
    biPlanes As Integer 'must be 1
    biBitCount As Integer 'bit count per pix. mustbe in 1(mono)/4(16color)/8(256color)/24(full color)
    biCompression As Long 'picture compress type. mustbe in 0(no compress)/1(BI_RLE8 compress)/2(BI_RLE4 compress)
    biSizeImage As Long 'picture size in bytes
    biXPelsPerMeter As Long 'pix count per meter V
    biYPelsPerMeter As Long 'pix count per meter H
    biClrUsed As Long 'used color count in color table
    biClrImportant As Long 'important color count in display
End Type

Private Type MY_BMP_HEAD
    file_header As BITMAPFILEHEADER
    bmp_header As BITMAPINFOHEADER
End Type
Public gBM As MY_BMP_HEAD
Public gOrigBmpData() As Byte

Sub readBinFile(ByVal fn$, ByRef gOrigBmpData() As Byte, ByRef outBinDataLen&)
    Open fn For Binary As #1
    outBinDataLen = FileLen(fn)
    ReDim gOrigBmpData(0 To outBinDataLen - 1) As Byte
    Get #1, , gOrigBmpData
    Close #1
End Sub

Sub tessss()
    Dim dataLen&, sh As Worksheet
    Dim need_y As Long, y&
    
    Call readBinFile("E:\maxw\study\gitee\misc\bmpparser\BmpParser\bmp_files\splash_bit24_452x302.bmp", gOrigBmpData, dataLen)
    'Set sh = Sheets.Add(, Sheets(Sheets.Count))
    Set sh = Sheets("pic")
    Cells.Interior.Pattern = xlNone
    sh.Cells.ColumnWidth = 0.06 '* 10
    sh.Cells.RowHeight = 0.6 '* 10
    
    CopyMemory gBM.file_header.bfType, gOrigBmpData(0), 2 'cause of vb can not using like #pragma pack in c
    CopyMemory gBM.file_header.bfSize, gOrigBmpData(2), 12 + 40
    need_y = gBM.bmp_header.biHeight 'gBmpOutputHei > gBM.bmp_header.biHeight ? gBM.bmp_header.biHeight : gBmpOutputHei;
    For y = 0 To need_y - 1
        Call proc1row(y)
    Next
End Sub

Sub proc1row(ByVal y&)
    Dim pOrigIdx&, needWid&, rgb&, r As Byte, g As Byte, b As Byte, x&
    pOrigIdx = get_data_buf_header_by_row(y)
    needWid = gBM.bmp_header.biWidth 'gBmpOutputWid > gBM.bmp_header.biWidth ? gBM.bmp_header.biWidth : gBmpOutputWid;
    For x = 0 To needWid - 1
        rgb = get_1RGB(pOrigIdx, x, r, g, b)
        Cells(y + 1, x + 1).Interior.Color = VBA.rgb(r, g, b)
    Next
End Sub

Function get_data_buf_header_by_row(ByVal r&) As Long '//r:row: start@0
    Dim row_byte_len&, offset&
    row_byte_len = get_byte_cnt_per_row(gBM.bmp_header.biBitCount, gBM.bmp_header.biWidth)
    offset = 0
    If (gBM.bmp_header.biHeight > 0) Then '{//正?表示数据倒向排列
        offset = row_byte_len * (gBM.bmp_header.biHeight - r - 1)
    Else
        offset = row_byte_len * r
    End If
    get_data_buf_header_by_row = offset
End Function


Function get_byte_cnt_per_row(ByVal bitCount&, ByVal wid&) As Long
    Dim row_byte_cnt&, yu& '; //?行占用的byte数
    row_byte_cnt = 0
    Select Case bitCount
    Case 1
        row_byte_cnt = (wid + 7) / 8 '; //?8个pix占用一个byte
    Case 4
        row_byte_cnt = (wid + 1) / 2 '; //?2个pix占用一个byte
    Case 8
        row_byte_cnt = wid '; //?1个pix占用一个byte
    Case 24
        row_byte_cnt = wid * 3 '; //?1个pix占用3个byte
    Case Else
        row_byte_cnt = 0 ';
    End Select
    
    yu = row_byte_cnt Mod 4
    If yu <> 0 Then '; //align with 4
        row_byte_cnt = row_byte_cnt + (4 - yu)
    End If
    'row_byte_cnt = (CInt((row_byte_cnt + 3) / 4)) * 4
    get_byte_cnt_per_row = row_byte_cnt
End Function

Function get_1RGB(ByVal buf_line_headerIDX, ByVal x&, ByRef r As Byte, ByRef g As Byte, ByRef b As Byte) As Long '//col_idx:start@0
    Dim div&, modV&, ret&, color_tab_idx&

    get_1RGB = 0
    'RGBQUAD* pt = (RGBQUAD*)gColorTbl.buf;
    Select Case (gBM.bmp_header.biBitCount)
    Case 1
        div = x / 8
        modV = x Mod 8
        modV = 7 - modV '; //reverse
        'color_tab_idx = ((buf_line_headerIDX[div] >> modV) & 0x1);
        'ret = RGB(pt[color_tab_idx].rgbRed, pt[color_tab_idx].rgbGreen, pt[color_tab_idx].rgbBlue);
        'break;
    Case 4:
     '   div = x / 2;
      '  modV = x % 2;
       ' modV = 1 - modV; //reverse
        'color_tab_idx = ((buf_line_headerIDX[div] >> (modV * 4)) & 0xF);
        'ret = RGB(pt[color_tab_idx].rgbRed, pt[color_tab_idx].rgbGreen, pt[color_tab_idx].rgbBlue);
        'break;
    Case 8:
        'color_tab_idx = buf_line_headerIDX[x];
        'color_tab_idx &= 0xFF;
        'ret = RGB(pt[color_tab_idx].rgbRed, pt[color_tab_idx].rgbGreen, pt[color_tab_idx].rgbBlue);
        'break;
    Case 24:
        'ret = RGB(buf_line_headerIDX[x * 3 + 2], buf_line_headerIDX[x * 3 + 1], buf_line_headerIDX[x * 3])
        r = gOrigBmpData(buf_line_headerIDX + x * 3 + 2)
        g = gOrigBmpData(buf_line_headerIDX + x * 3 + 1)
        b = gOrigBmpData(buf_line_headerIDX + x * 3)
    Case Else
        ret = 0
    End Select
    get_1RGB = ret
End Function