Excelで画像をドット絵にしてみる

はじめに
参照ページ
作ってみる
- コード
結果
課題

はじめに

vba-belle-equipe.hatenablog.com

Excelでドット絵作成ツールを作ったりしていると、

「画像を読み込んでそのままドット絵として表示できないかな」

ということを自然と思ってしまうわけです。

で、調べてみました。

参照ページ

stackoverflow.com

マウスが示しているポイントの色を（APIを使って）ゲットする方法について、こちらに情報がありました。

作ってみる

f:id:vba-belle-equipe:20160527163118j:plain

こんな感じにして、矢印の右下をクリックした時にそこから右下の範囲を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