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

はじめに

前回、

vba-belle-equipe.hatenablog.com

画像出力ができるようになりました。

現状報告

こんな感じです。

見た目が変わらないと寂しいので、「元に戻す」ボタンを変えてみました。

元に戻す

• 描画の際に「履歴」シートに現状を記録し、
• 「元に戻す」ボタンで、描画部分に貼り付けて戻す

という風にしています。

履歴シート

今のところ、単純に

こんな感じです。

コード

現時点でのコードは

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

Option Explicit
Private Tgt As Range

Private Sub Worksheet_Change(ByVal target As Range)
  Call setSettings   '設定を共通変数にセット
  If target.Address = TateAddress Or target.Address = YokoAddress Then
    Call setCamvas      'キャンバスセット
    Exit Sub
  End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal target As Range)
  Application.ScreenUpdating = False
  Set Tgt = target
  '手動モードか、選択範囲多すぎる場合何もしない
  If Range("A1") = "手動モード" Or target.Count > 1000 Then
    Call exitChangeEvent
  End If
  
  Call setSettings     '設定を共通変数にセット
  
  '//描画色選択//
  Dim lngNewColor As Long
  
  '----(カラーピッカー)
  If target.Address = DrawColorAddress Then
    lngNewColor = GetColorDlg
    If lngNewColor <> -1 Then
      Call changeDrawColor(lngNewColor)
    End If
    Call exitChangeEvent
  End If
  
  '----(選択履歴)
  If target.Count = 1 And _
    Not Application.Intersect(target, Range(RirekiAddress)) Is Nothing Then
    lngNewColor = target.Interior.Color
    Call changeDrawColor(lngNewColor)
    Call exitChangeEvent
  End If
  
  Call drawCells(target)  '描画
  Call exitChangeEvent
End Sub

Sub exitChangeEvent()
  Application.CutCopyMode = False
  Tgt.Select
  Application.ScreenUpdating = True
  End
End Sub



'///標準モジュール///    <<mod00共通処理>>

Option Explicit

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Const DrawColorAddress As String = "$B$4:$B$5"
Public Const RirekiAddress As String = "$D$1:$D$35"
Public Const TateAddress As String = "$B$15"
Public Const YokoAddress As String = "$B$18"
Public Const CamvasBaseAddress As String = "$F$1"

Public BaseRng As Range             '描画範囲
Public CamvasRng As Range           'キャンバス基準（左上セル）
Public Tate As Long, Yoko As Long   'キャンバスサイズ（縦、横）

'設定を共通変数にセット
Sub setSettings()
  With Sheets("ドット絵作成")
    Set BaseRng = .Range(CamvasBaseAddress)
    Tate = .Range("B15")
    Yoko = .Range("B18")
    Set CamvasRng = .Range(BaseRng, .Cells(BaseRng.Row + Tate + 1, _
                          BaseRng.Column + Yoko + 1))
  End With
End Sub



'///標準モジュール///    <<描画>>

Option Explicit

'描画色変更
Sub changeDrawColor(lngNewColor As Long)
  Dim i As Long
  Application.ScreenUpdating = False
  If Range(DrawColorAddress).Interior.Color = lngNewColor Then
    Exit Sub
  End If
  Range(DrawColorAddress).Interior.Color = lngNewColor
  Range("A1").Select
  '色選択履歴
  Dim fnd As Boolean
  fnd = False
  For i = 1 To 35
    If Cells(i, 4).Interior.Color = lngNewColor Then
      fnd = True
      Exit For
    End If
  Next
  If fnd Then Exit Sub  '新しい色が履歴にある場合何もしない
  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
  Application.ScreenUpdating = True
End Sub

'キャンバス
Sub setCamvas()
  Dim r As Range
  Application.ScreenUpdating = False
  Cells.Interior.Pattern = xlSolid
  For Each r In CamvasRng
    If r.Row = BaseRng.Row Or r.Row = BaseRng.Row + Tate + 1 Or _
       r.Column = BaseRng.Column Or r.Column = BaseRng.Column + Yoko + 1 Then
       r.Interior.Pattern = xlGrid
    End If
  Next
  Application.ScreenUpdating = True
End Sub

'描画
Sub drawCells(target As Range)
  Dim r As Range
  Dim copyRng As Range
  Dim minCol As Long, maxCol As Long
  Dim minRow As Long, maxRow As Long
  Dim clr1 As Long  '描画色
  Dim drwRng As Range
  
  Application.ScreenUpdating = False
  clr1 = Range(DrawColorAddress).Interior.Color
  minCol = BaseRng.Column + 1
  maxCol = BaseRng.Column + Yoko
  minRow = BaseRng.Row + 1
  maxRow = BaseRng.Row + Tate
  Set copyRng = Sheets("ドット絵作成").Range _
      (Cells(minRow, minCol), Cells(maxRow, maxCol))
  For Each r In target
    If minCol <= r.Column And r.Column <= maxCol And _
        minRow <= r.Row And r.Row <= maxRow Then
      If drwRng Is Nothing Then
        Set drwRng = r
      Else
        Set drwRng = Union(drwRng, r)
      End If
    End If
  Next
  
  '範囲内セルを描画する
  If drwRng Is Nothing Then
  
  Else
    Call saveHistory   '履歴残す
    drwRng.Interior.Color = clr1
  End If
  target.Select
  Application.ScreenUpdating = True
End Sub



'///標準モジュール///    <<mod00変更履歴>>

Option Explicit

'履歴保存
Sub saveHistory()
  Dim rg As Range
  Application.ScreenUpdating = False
  Set rg = Range(BaseRng.Offset(1, 1), Cells(BaseRng.Row + Tate, _
                          BaseRng.Column + Yoko))
  rg.Copy Destination:=Sheets("変更履歴").Cells(1, 1)
  Application.ScreenUpdating = True
End Sub

'やり直し
Sub doUndo()
  Call copyFromHistory
End Sub

Sub copyFromHistory()
  Dim rg As Range
  Dim Tgt As Range    '貼り付け前選択セル
  Call setSettings    '設定を共通変数にセット
  With Sheets("変更履歴")
    Set rg = .Range(.Cells(1, 1), .Cells(Tate, Yoko))
  End With
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  rg.Copy
  Sheets("ドット絵作成").Activate
  Set Tgt = Selection
  BaseRng.Offset(1, 1).Select
  ActiveSheet.Paste
  Tgt.Select
  Application.EnableEvents = True
  Application.ScreenUpdating = True
End Sub

こんな感じです。*1

カブっている処理をまとめたりしています。

画面のちらつき

履歴を残す際に画面がちらつくのをなおすのに結構時間をとられました。

Application.ScreenUpdating = False

を入れたりいれなかったりして検証したり、

rg.Copy
Sheets("変更履歴").Cells(1, 1).PasteSpecial Paste:=xlPasteAll

を

rg.Copy Destination:=Sheets("変更履歴").Cells(1, 1)

に変更したりで、今のところ大丈夫な感じです。

今後の課題

まだ「元に戻す」が直前の画像に戻すだけなので、もう少し履歴をとりたいところです。

*1:カラーピッカー（色選択）と画像出力の部分は変更ないので今回は割愛します