Excelでドット絵作成ツールを作る その2

はじめに

前回、

vba-belle-equipe.hatenablog.com

セルが選択されたら描画色で塗る、という基本的なところを作りました。

現状報告

こんな感じです。

描画色を

• Excel標準のパレットウィンドウから選択できるように
• 履歴から選択できるように

してみました。

参考ページ

パレットウィンドウ（カラーピッカー）の実装に関して、下記のページを参考にさせていただきました。
（ほとんどそのままです）

Excel VBA 背景色をパレットウィンドウから指定する PCまなぶ

コード

現時点でのコードは

'///シートモジュール///

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Dim clr1 As Long  '描画色
  Dim r As Range
  Dim minCol As Long, maxCol As Long
  Dim minRow As Long, maxRow As Long
  
  '選択範囲多すぎる場合何もしない
  If Target.Count > 1000 Then
    Exit Sub
  End If
  
  '//描画色選択//
  Dim lngNewColor As Long
  
  '(カラーピッカー)
  If Target.Address = DrawColorAddress Then
    lngNewColor = GetColorDlg
    Call changeDrawColor(lngNewColor)
    Exit Sub
  End If
  
  '(選択履歴)
  If Target.Count = 1 And _
    Not Application.Intersect(Target, Range("D1:D35")) Is Nothing Then
    lngNewColor = Target.Interior.Color
    Call changeDrawColor(lngNewColor)
    Exit Sub
  End If
  
  '描画
  clr1 = Range("B4").Interior.Color
  minCol = 7
  maxCol = 24
  minRow = 2
  maxRow = 29
  For Each r In Target
    If minCol <= r.Column And r.Column <= maxCol And _
        minRow <= r.Row And r.Row <= maxRow Then
     ' Debug.Print r.Address
      r.Interior.Color = clr1
    End If
  Next
End Sub


'///標準モジュール///

Option Explicit

Private Type ChooseColor
  lStructSize As Long
  hWndOwner As Long
  hInstance As Long
  rgbResult As Long
  lpCustColors As String
  flags As Long
  lCustData As Long
  lpfnHook As Long
  lpTemplateName As String
End Type

Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" _
                                      (pChoosecolor As ChooseColor) As Long

Private Const CC_RGBINIT = &H1                '色のデフォルト値を設定
Private Const CC_LFULLOPEN = &H2              '色の作成を行う部分を表示
Private Const CC_PREVENTFULLOPEN = &H4        '色の作成ボタンを無効にする
Private Const CC_SHOWHELP = &H8               'ヘルプボタンを表示

Public Const DrawColorAddress As String = "$B$4:$B$5"

Public Function GetColorDlg() As Long
'機能 ： 色の設定ダイアログを表示し、そこで選択された色のRGB値を返す
'引数 ： lngDefColor デフォルト表示する色
'返値 ： 成功時 RGB値   キャンセル時-1  エラー時 -2  （ゼロは黒なので注意）

  Dim udtChooseColor As ChooseColor
  Dim lngRet As Long
  Dim lngDefColor As Long
  lngDefColor = Range(DrawColorAddress).Interior.Color

  With udtChooseColor
    'ダイアログの設定
    .lStructSize = Len(udtChooseColor)
    .lpCustColors = String$(64, Chr$(0))
    .flags = CC_RGBINIT + CC_LFULLOPEN
    .rgbResult = lngDefColor
    'ダイアログを表示
    lngRet = ChooseColor(udtChooseColor)
    'ダイアログからの返り値をチェック
    If lngRet <> 0 Then
      If .rgbResult > RGB(255, 255, 255) Then
        'エラー
        GetColorDlg = -2
      Else
        '正常終了、RGB値を返り値にセット
        GetColorDlg = .rgbResult
      End If
    Else
      'キャンセルが押されたとき
      GetColorDlg = -1
    End If

  End With

End Function


'描画色変更
Sub changeDrawColor(lngNewColor As Long)
  Dim i As Long
  If Range(DrawColorAddress).Interior.Color = lngNewColor Then
    Exit Sub
  End If
  Range(DrawColorAddress).Interior.Color = lngNewColor
  '色選択履歴
  For i = 35 To 2 Step -1
    Cells(i, 4).Interior.Color = Cells(i - 1, 4).Interior.Color
  Next
  Cells(1, 4).Interior.Color = lngNewColor
  Range("A1").Select
  
End Sub

こんな感じです。

早くもボリュームが出てきました（コピペですが）