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

はじめに

前回、

vba-belle-equipe.hatenablog.com

複数の履歴を残すようにしました。

現状報告

こんな感じです。

置換機能を実装しました。

それと、前回

重なってしまうことや、行が足りなくなることはそうそうないかな

とか言ってたんですが、普通に行数に制限があるしあんまり貯めても重くなるので、いくつ残すのか制限を設けるようにしました。

コード

現時点でのコードは

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

'置換
Sub replaceColor()
  Dim r As Range
  Dim minCol As Long, maxCol As Long
  Dim minRow As Long, maxRow As Long
  Dim clr1 As Long  '描画色
  Dim clr2 As Long  '選択色
  Dim cmvRng As Range   'キャンバスの範囲
  Dim drwRng As Range   '置換対象範囲
  
  Call setSettings    '共通変数のセット
  Application.EnableEvents = False
  Application.ScreenUpdating = False
  clr1 = Range(DrawColorAddress).Interior.Color
  clr2 = Range(SelectColorAddress).Interior.Color
  minCol = BaseRng.Column + 1
  maxCol = BaseRng.Column + Yoko
  minRow = BaseRng.Row + 1
  maxRow = BaseRng.Row + Tate
  Set cmvRng = Sheets("ドット絵作成").Range _
      (Cells(minRow, minCol), Cells(maxRow, maxCol))
  For Each r In cmvRng
    If r.Interior.Color = clr1 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
    drwRng.Interior.Color = clr2
    Call saveHistory   '履歴残す
  End If
  Application.ScreenUpdating = True
  Application.EnableEvents = True
End Sub



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

Option Explicit

Public Const TateHaba As Long = 10000   '１履歴に使う縦のセル数
Public Const MaxHistory As Long = 30    '履歴に残す数

'履歴保存
Sub saveHistory()
  Dim rg As Range
  Dim gyo As Long
  Dim cpRng As Range
  Application.ScreenUpdating = False
  If CurHistory >= MaxHistory Then
    Sheets("変更履歴").Rows("1:" & TateHaba).Delete
  Else
    CurHistory = CurHistory + 1
    CntHistory = CurHistory
  End If
  Call setCurHistory
  Set rg = Range(BaseRng.Offset(1, 1), Cells(BaseRng.Row + Tate, _
                          BaseRng.Column + Yoko))
  gyo = CurHistory * TateHaba + 1
  With Sheets("変更履歴")
    rg.Copy Destination:=.Cells(gyo, 1)   'コピー
    .Range(.Cells(gyo + Tate, 1), _
        .Cells(Rows.Count, Columns.Count)).Clear  'クリア
  End With
  Application.ScreenUpdating = True
End Sub

こんな感じです。*1

完成が見えてきた、ような気がしないでもないです。

*1:変更のあったところだけです