Excelでドット絵作成ツールを作る その9
現状報告
こんな感じです。
やり直し、元に戻すのボタンの押せない感を出してみました。
（実際には押せないわけではなくてマクロの中で判断して、何もしないで終わる）
コード
現時点でのコードは
'///標準モジュール/// <<変更履歴>> '元に戻す Sub doUndo() Call setSettings '設定を共通変数にセット If CurHistory <= 0 Then Exit Sub End If CurHistory = CurHistory - 1 Call setCurHistory Call copyFromHistory Call changeBtnClr End Sub 'やり直し Sub doRedo() Call setSettings '設定を共通変数にセット If CurHistory >= CntHistory Then Exit Sub End If CurHistory = CurHistory + 1 Call setCurHistory Call copyFromHistory Call changeBtnClr End Sub 'ボタン色変更 Sub changeBtnClr() Dim btn1 As Shape, btn2 As Shape Set btn1 = Sheets("ドット絵作成").Shapes("btn_undo") Set btn2 = Sheets("ドット絵作成").Shapes("btn_redo") Call setSettings If CurHistory = 0 Then Call enableBtn(btn1, False) Else Call enableBtn(btn1, True) End If If CurHistory = CntHistory Then Call enableBtn(btn2, False) Else Call enableBtn(btn2, True) End If End Sub 'ボタンの有効、無効切り替え Sub enableBtn(btn As Shape, flg As Boolean) Select Case flg Case False '押せないように見せる With btn .Fill.ForeColor.RGB = 10921638 .Line.ForeColor.RGB = 8355711 .TextFrame2.TextRange.Characters(1, 1). _ Font.Fill.ForeColor.RGB = 14277081 End With Case True '押せるように見せる With btn .Fill.ForeColor.RGB = 13998939 .Line.ForeColor.RGB = 10252609 .TextFrame2.TextRange.Characters(1, 1). _ Font.Fill.ForeColor.RGB = 16777215 End With End Select End Sub
こんな感じです。*1
今後
現状ではやり直し、元に戻すが終わったタイミングでボタン色の判定をしています。
が、使ってみて、判定箇所の追加や変更があるかもという気がします。
あと載せたい機能としては「新しいブックに描画部分だけコピーして保存」くらいを考えています。
*1:変更のあったところだけです
Excelでドット絵作成ツールを作る その8
現状報告
こんな感じです。
置換機能を実装しました。
それと、前回
重なってしまうことや、行が足りなくなることはそうそうないかな
とか言ってたんですが、普通に行数に制限があるしあんまり貯めても重くなるので、いくつ残すのか制限を設けるようにしました。
コード
現時点でのコードは
'///標準モジュール/// <<描画>> '置換 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:変更のあったところだけです
人工知能は天使か悪魔か
羽生さんの番組、面白かったです。
なんとなく知ってはいましたが、自動運転、小説や絵画の創作、病気の発見など、色々なことができるようになっているみたいですね。
- ゲームに勝つための最善の手を見つける
- 病気の兆候を発見する
- 事故らないように運転する
という、「いいこと」というか、ゴールがわかりやすいものに関してはどんどん活用されるべきだろうと思います。
ただ、「タワーを崩すという命令に背く（友人がせっかく積み上げたから）」という部分に関しては危うさを感じました。
その判断をどうやってさせるのか？ ということなんですよね。
何がよくて何がよくないのか、という「判断」の部分を人工知能に任せてよいのかどうか。
例えば
ゲームには負けたけどみんな笑ってるからいいか
みたいなシーンがありましたが、
世間的にはあんまりよくないことでも、近くの人が喜んでくれるからOK
みたいなことにつながるんじゃないでしょうか。
まあ、そんなことを言いつつ、実際には
「俺の仕事をコンピュータなんかにやらせてたまるか！」
とか
「人工知能は自我に目覚めて人間に危害を加えるから危険だ！」
みたいなことで、役に立つ分野でも導入が阻害されることのほうが現実的には心配です。
うまいこと、便利な世の中になっていけばいいなと。
あと、羽生さんが花札強いのと英語しゃべれるのがすごいなと思いました。
Excelでドット絵作成ツールを作る その7
コード
現時点でのコードは
'///標準モジュール/// <<mod00変更履歴>> Option Explicit Public Const TateHaba As Long = 10000 '１履歴に使う縦のセル数 '履歴保存 Sub saveHistory() Dim rg As Range Dim gyo As Long Application.ScreenUpdating = False CurHistory = CurHistory + 1 CntHistory = CurHistory 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 '元に戻す Sub doUndo() Call setSettings '設定を共通変数にセット If CurHistory <= 0 Then Exit Sub End If CurHistory = CurHistory - 1 Call setCurHistory Call copyFromHistory End Sub 'やり直し Sub doRedo() Call setSettings '設定を共通変数にセット If CurHistory >= CntHistory Then Exit Sub End If CurHistory = CurHistory + 1 Call setCurHistory Call copyFromHistory End Sub '現在の表示が履歴のどの段階なのかを記録 Sub setCurHistory() Application.EnableEvents = False With Sheets("ドット絵作成") .Range(CurHistoryAddress) = CurHistory .Range(CntHistoryAddress) = CntHistory End With Application.EnableEvents = True End Sub Sub copyFromHistory() Dim rg As Range Dim Tgt As Range '貼り付け前選択セル Dim gyo As Long gyo = CurHistory * TateHaba + 1 With Sheets("変更履歴") Set rg = .Range(.Cells(gyo, 1), .Cells(gyo + Tate - 1, 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
こんな感じです。
今回いじったのは履歴の部分だけでした。
今後の課題
ボタンを押せない時に、押せない感を出したいところです。
（ただの図形にマクロをくっつけているので、標準ではできない）
あと、画像出力だけではなくて、描画した部分を新しいブックに出力したりしたいかなと思います。
