Excelで佐々木希を描く with GDI+

Excelで佐々木希を描く with pythonをGDI+でやってみたもの。pythonなんていらんかったんや。

コード

x64版Excel用のコードだが、PtrSafeを削除してLongPtrをLongに修正すればx86版でも動くはず。ThisWorkbook.DrawImageをマクロ一覧から呼び出して実行する。

ThisWorkbook

Option Explicit

'GDI+ API定義
Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" ( _
    ByRef token As LongPtr, _
    ByRef inputbuf As GdiplusStartupInput, _
    Optional ByVal outputbuf As LongPtr = 0) As Long
Private Declare PtrSafe Sub GdiplusShutdown Lib "gdiplus" ( _
    ByVal token As LongPtr)
Private Declare PtrSafe Function GdipLoadImageFromFile Lib "gdiplus" ( _
    ByVal FileName As LongPtr, _
    ByRef image As LongPtr) As Long
Private Declare PtrSafe Function GdipDisposeImage Lib "gdiplus" ( _
    ByVal image As LongPtr) As Long
Private Declare PtrSafe Function GdipGetImageWidth Lib "gdiplus" ( _
    ByVal image As LongPtr, ByRef width As Long) As Long
Private Declare PtrSafe Function GdipGetImageHeight Lib "gdiplus" ( _
    ByVal image As LongPtr, ByRef height As Long) As Long
Private Declare PtrSafe Function GdipBitmapGetPixel Lib "gdiplus" ( _
    ByVal image As LongPtr, ByVal x As Long, ByVal y As Long, ByRef Color As Long) As Long

'GDI+用ユーザ定義型
Private Type GdiplusStartupInput
    GdiplusVersion As Long
    DebugEventCallback As LongPtr
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type


Public Sub DrawImage()
    If DrawImageFromFile("C:\Users\shela\Desktop\sasaki_nozomi.jpg") Then
        MsgBox "完了", Buttons:=vbOKOnly
    End If
End Sub


'画像を読み込んで1ピクセルを1セルで描画する
'対応フォーマット:GDI+準拠(BMP, JPEG, GIF, TIFF, PNG)
Public Function DrawImageFromFile(ByVal filePath As String) As Boolean

    Dim uGdiStartupInput As GdiplusStartupInput
    Dim nGdiToken As LongPtr
    Dim hImage As LongPtr
    Dim width As Long
    Dim height As Long
    Dim colorARGB As Long
    Dim wSheet As Worksheet
    Dim wRange As Range
    Dim strARGB As String
    Dim colorRGB As Long
    Dim x As Integer
    Dim y As Integer

    DrawImageFromFile = False

    uGdiStartupInput.GdiplusVersion = 1

    If GdiplusStartup(nGdiToken, uGdiStartupInput) <> 0 Then
        MsgBox "GDI+の初期化に失敗", Buttons:=vbCritical
        Exit Function
    End If

    '画像読み込み
    If GdipLoadImageFromFile(ByVal StrPtr(filePath), hImage) <> 0 Then
        MsgBox "画像の読み込みに失敗", Buttons:=vbCritical
        Call GdiplusShutdown(nGdiToken)
        Exit Function
    End If

    '幅取得
    If GdipGetImageWidth(hImage, width) <> 0 Then
        MsgBox "画像の幅の取得に失敗", Buttons:=vbCritical
        GoTo Err
    End If

    '高さ取得
    If GdipGetImageHeight(hImage, height) <> 0 Then
        MsgBox "画像の高さの取得に失敗", Buttons:=vbCritical
        GoTo Err
    End If

    On Error GoTo Err
    Application.ScreenUpdating = False

    '1シート目に描画
    Set wSheet = ThisWorkbook.Worksheets(1)
    wSheet.Cells.Delete

    '描画範囲のセル幅・高さ調整
    Set wRange = wSheet.Range(wSheet.Cells(1, 1), wSheet.Cells(height, width))
    wRange.ColumnWidth = 0.15
    wRange.RowHeight = 1.5
    Set wRange = Nothing

    For y = 0 To height - 1
        For x = 0 To width - 1
            'ピクセルの取得
            If GdipBitmapGetPixel(hImage, x, y, colorARGB) <> 0 Then
                MsgBox "ピクセルの取得に失敗", Buttons:=vbCritical
                GoTo Err
            End If

            'GDI+で取得される色はARGBなのでRGBに変換
            strARGB = Hex(colorARGB)
            colorRGB = RGB(CInt("&H" & Mid(strARGB, 3, 2)), CInt("&H" & Mid(strARGB, 5, 2)), CInt("&H" & Mid(strARGB, 7, 2)))

            'セルの背景色を取得した色に変更
            wSheet.Cells(y + 1, x + 1).Interior.Color = colorRGB
        Next x
    Next y

    DrawImageFromFile = True

Err:
    '終了処理

    On Error GoTo 0

    Set wSheet = Nothing
    Application.ScreenUpdating = True

    If GdipDisposeImage(hImage) <> 0 Then
        MsgBox "メモリの解放に失敗", Buttons:=vbCritical
    End If

    Call GdiplusShutdown(nGdiToken)

End Function

実行結果

もっと遅いと思っていたが、元画像のように225ピクセル四方くらいの画像なら意外と早かった。
ちなみにもっと大きな画像で実行すると、セルの書式が設定できなくなって途中でエラーになる。