Excelでドット絵作成ツールを作る その3
現状報告
こんな感じです。
といいつつ見た目は前回と変わっていませんが、
- キャンバスサイズを変更できるように（Worksheet_Changeから）
- 手動モードの時に、シートイベントをスルーするように
してみました。
あと、共通の処理をまとめたりしてみました。
コード
現時点でのコードは
'///シートモジュール/// Option Explicit Private Sub Worksheet_Change(ByVal target As Range) Call junbi '共通変数セット 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) ' Debug.Print target.Address '選択範囲多すぎる場合何もしない If target.Count > 1000 Then Exit Sub End If Call junbi '共通変数セット '//描画色選択// 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(RirekiAddress)) Is Nothing Then lngNewColor = target.Interior.Color Call changeDrawColor(lngNewColor) Exit Sub End If Call drawCells(target) '描画 End Sub '///標準モジュール/// Option Explicit 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 junbi() '手動モードなら何もしない If Range("A1") = "手動モード" Then End End If '共通変数をセット Set BaseRng = Range(CamvasBaseAddress) Tate = Range("B15") Yoko = Range("B18") Set CamvasRng = Range(BaseRng, Cells(BaseRng.Row + Tate + 1, _ BaseRng.Column + Yoko + 1)) End Sub '描画色変更 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 'キャンバス 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 minCol As Long, maxCol As Long Dim minRow As Long, maxRow As Long Dim clr1 As Long '描画色 clr1 = Range(DrawColorAddress).Interior.Color minCol = BaseRng.Column + 1 maxCol = minCol + Yoko + 1 minRow = BaseRng.Row + 1 maxRow = minRow + Tate + 1 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 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
こんな感じです。
- モードの変更をどうするか
- 共通で使うセル（range）をアドレスの文字列で定数っぽく使っているけどそれでいいのか
- 色の履歴は、同じ色なら追加しなくてもよいか
など、いろいろ悩みます。
Excelでドット絵作成ツールを作る その2
参考ページ
パレットウィンドウ（カラーピッカー）の実装に関して、下記のページを参考にさせていただきました。
（ほとんどそのままです）
コード
現時点でのコードは
'///シートモジュール/// 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
こんな感じです。
早くもボリュームが出てきました（コピペですが）
Excelでドット絵作成ツールを作る その1
はじめに
先週までブロック積みゲーム
vba-belle-equipe.hatenablog.com
を作っていました。
その中で意外と時間を使ったのが、ご褒美画面。
なんでExcelでドット絵描くのこんなにめんどくさいんだよー*1
と、誰に頼まれたわけでもないのに頑張ってドット絵を描きながら、考えていたのが今回のツールです。
完成予想図
とりあえず、こんな感じになればいいな、というシートを作ってみました。
機能はそんなになくてもいいから、使いやすくできればいいなと。
言いつつも色々と追加しそうな感じもあるので、結構長期シリーズになるかもしれないなと。
マクロを使うので、「元に戻す」あたりをどうするかな、という感じです。*2
コード
現時点でのコードは
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 > 100 Then Exit Sub End If clr1 = Range("B4").Interior.Color minCol = 5 maxCol = 22 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
こんな感じです。
シートモジュールで、特定の範囲が選択された時に「描画色」セルの色に変える、という感じにしています。
サラゲッタさんの独り言 その9
動かないマクロはない。動かない理由があるだけだ。
- Ｍ.サラゲッタ -
思いつき連載 VBA王子 ニューヨークへ行く #8
前回
#8
ただでさえ狭い資料管理室が、パイプ椅子を一つ開いたことでほとんど身動きがとれなくなっている。
赤羽は北浦の隣に座って説明を聞きながら、圧迫感と戦っていた。
「・・・とまあ、うちの会社にはVBAで作られたシステムがこれだけある」
マウスとキーボードを流れるように操っていた北浦の動きが止まり、説明がひと段落したことに気付く。
「こんなにあったんですね」
「おおまかに言うと、VBAというのは、こういうシステムが作れるプログラミング言語ということになるが、いきなりそんなことを言われてもよくわからんだろうから、もうちょっと身近なところから説明してやろう」北浦は何か書いてあるかのように虚空を見つめて固まった後、続けた。
「例えばな、Excelファイルのシートの名前をテキストとしてコピーしたい時、どうする？」
「テキストとして？」
「例えば、Wordとか、メモ帳に貼り付けるために」
「ああ、なるほど」シートの名前、と何回かつぶやいた後、赤羽は言った。「コピーしたいと思った時、ないですね」
「な？」
「何が、な？ なんですか」
「わかった。じゃあお前が普段の業務で使うExcelでやっている操作を見せてみろ」
「操作ですか？ ええと、コピペとか？」
「・・・まあ、そこからでいいよ」
「あ、それにしよう」
赤羽がよくわからないながらもExcelをいじっていると、しばらくして、北浦が指を鳴らした。
「え？」
「その、別のExcelファイルにシートをコピーして、名前を変えるってやつ」
「これ・・・をどうすればいいですか」
「それ、１つのシートにつきどれくらいかかるか、もう一回やってみろ」
「えっと、移動先ブックを選んで、コピーして」赤羽はマウスをカチカチと操作する。「右クリックして、名前を・・・変える。・・・こんなもんですね」
「なるほど。結構速いな」北浦は、にやりと笑う。
「何回もやってるので」
「ただ、シート名のルールが決まっているようであれば・・・」北浦はノートパソコンを自分の膝に乗せて、キーボードを叩き始めた。「こうすれば」
「打つの速いですね」
「何回もやってるからな。・・・さあ、このボタンを押すがよい」
「あ、はい」シートに表示されている「ボタン１」を、赤羽はクリックした。
「どうだ？」
「あ、コピーされました」
「シートの名前もちゃんと、和暦プラス月になってるだろ」
「あ、ほんとですね。すごい」
「で、これを実現しているのがこの部分だ」
「うわー、英語ですね」見覚えのないウインドウが現れ、赤羽は悲鳴をあげた。
「英語だ。けど、少しやれば気にならなくなる。プログラミングと英語力はほとんど関係ないぞ。実際、俺は英語全然わからん」
「え、そうなんですか」
「Ken go to the library までしかわからん」
「goes ですよ」
まったく、と北浦は鼻から息を吐いた。「これだからインテリは」
「初めて言われました」
階段を昇る赤羽の足どりは軽かった。
自分のやっている業務が、まるでロボットに任せるかのように楽になるかもしれない。
あれもできるかな、あれもめんどくさいんだよな、と手作業から解放されたい仕事が、次々に浮かんでくる。
行き先が広報課であることも、彼をご機嫌にさせていた。北浦に頼まれたおつかいのためだ。
「とりあえず、こっちの修正は、急いだほうがいい。ちょっと確認したいことがあるから、新人の女の子に言って、都合のいい時に来てもらってくれ」
「川口さんですか？」
「確か、そんな名前だったな」
赤羽の中に、北浦に対する感謝の念が初めて生まれた瞬間だった。
- つづく -
