Excelで画像をドット絵にしてみる
作ってみる
こんな感じにして、矢印の右下をクリックした時にそこから右下の範囲を1ピクセルずつ、色を取得して別シートに転記するようにしてみました。
コード
Option Explicit #If VBA7 Then Private Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hdc As LongPtr, ByVal x As Long, ByVal y As Long) As Long Private Declare PtrSafe Function GetCursorPos Lib "user32" (ByRef lpPoint As POINT) As LongPtr Private Declare PtrSafe Function GetWindowDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr #Else Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long Private Declare Function GetCursorPos Lib "user32" (ByRef lpPoint As POINT) As Long Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long #End If Private Type POINT x As Long y As Long End Type Sub drawPic() Dim pLocation As POINT Dim lColour As Long Dim i As Long, j As Long Dim lDC As Variant Dim tate As Long, yoko As Long Dim tateGeta As Long, yokoGeta As Long Application.ScreenUpdating = False tate = Range("B1") yoko = Range("B2") lDC = GetWindowDC(0) Call GetCursorPos(pLocation) tateGeta = pLocation.y yokoGeta = pLocation.x With Sheets("ドット絵") .Cells.Clear For i = 1 To tate For j = 1 To yoko lColour = GetPixel(lDC, j + yokoGeta, i + tateGeta) .Cells(i, j).Interior.Color = lColour Next Next End With Application.ScreenUpdating = True End Sub
こんな感じです。
課題
- 遅い
- 画像の範囲をぴったり指定できない
どっちも、わりと痛いです。
*1:謎のキャラクターは、Life Is Strange のある場所の落書きからご登場いただきました