VBA：分享一段有趣的代码

突发奇想着利用Excel单元格作为像素点，读取某张图片，将图片像素点设置成单元格的底色。

正文开始：
1、将Excel列宽设置为0.5
2、将Excel行高设置为5
3、执行下面代码

Sub ReadPixelColors()
    Dim img As Object
    Set img = CreateObject("WIA.ImageFile")
    Dim SheetObject As Object
    
    ' 替换路径为你的图片路径
    img.LoadFile "图片路径"
    
    Dim x As Long, y As Long
    Dim pixelColor As Long
    Dim v As Object
    Dim red As Integer, green As Integer, blue As Integer
    Dim ColorR As Integer, ColorG As Integer, ColorB As Integer
    Dim Letter As String
    Dim RowIndex As Long
    
    Set SheetObject = Application.ActiveSheet
    
    With SheetObject
            RowIndex = 1
             For x = 0 To img.width - 1
                 For y = 0 To img.height - 1
                        Letter = NumberToLetter(x + 1)
                        Set v = img.ARGBData
                        pixelColor = GetPixel(v, x, y, img.width, img.height)
                        ColorR = GetRed(pixelColor)
                        ColorG = GetGreen(pixelColor)
                        ColorB = GetBlue(pixelColor)
                        DoEvents
                        .Range(Letter & y + 1).Interior.Color = RGB(ColorR, ColorG, ColorB)
                        '.Range(Letter & (x + 1)) = ColorR & "-" & ColorG & "-" & ColorB
                Next y
                RowIndex = RowIndex + 1
            Next x
    End With
End Sub

Function GetPixel(v, x, y, width, height)
    If x > width Or x < 1 Or _
        y > height Or y < 1 Or _
        v.Count <> width * height Then
        GetPixel = 0
        Exit Function
    End If
    
    GetPixel = v(x + (y - 1) * width)
End Function

Function Get4ByteHex(val)
    Dim s As String
    s = Hex(val)
    Do While Len(s) < 8
        s = "0" & s
    Loop
    Get4ByteHex = Right(s, 8)
End Function

Function Get1ByteHex(val)
    Dim s As String
    s = Hex(val)
    Do While Len(s) < 2
        s = "0" & s
    Loop
    Get1ByteHex = Right(s, 2)
End Function

Function GetAlpha(val)
    Dim s As String
    s = Get4ByteHex(val)
    GetAlpha = CLng("&amp;h" & Left(s, 2))
End Function

Function GetRed(val)
    Dim s As String
    s = Get4ByteHex(val)
    GetRed = Application.Hex2Dec(Mid(s, 3, 2))
End Function

Function GetGreen(val)
    Dim s As String
    s = Get4ByteHex(val)
    GetGreen = Application.Hex2Dec(Mid(s, 5, 2))
End Function

Function GetBlue(val)
    Dim s As String
    s = Get4ByteHex(val)
    GetBlue = Application.Hex2Dec(Right(s, 2))
End Function

Function GetARGB(a, r, g, b)
    Dim s As String
    s = "&amp;h" & Get1ByteHex(a) & Get1ByteHex(r) & Get1ByteHex(g) & Get1ByteHex(b)
    GetARGB = CLng(s)
End Function


Public Function NumberToLetter(ColNumber As Long) As String
    '''将数字通过Ascii码表转为字母'''
    Dim ascii_start As Integer
    Dim multiple As Integer
    Dim res_head As String
    Dim residue As Integer
    Dim temp As String

    ascii_start = 64
    multiple = ColNumber \ 26

    If multiple > 0 Then
        res_head = ""
        residue = ColNumber Mod 26

        If residue = 0 Then
            res_residue = Chr(ascii_start + 26)
            multiple = multiple - 1
        Else
            res_residue = Chr(ascii_start + residue)
        End If
        If multiple > 0 Then
            res_head = Chr(ascii_start + multiple)
        End If

        NumberToLetter = res_head & res_residue
    Else
        NumberToLetter = Chr(ascii_start + ColNumber)
    End If
End Function

效果展示：