Excelでドット絵作成ツールを作る その10
現状報告
こんな感じです。
「ブック出力」ボタンでファイル選択画面が開き、
選択したブックには、描画部分のみコピーされて保存されます。
コード
現時点でのコードは
'///標準モジュール/// <<画像出力>> Option Explicit Private Ext As String '拡張子 Dim SavePath As String 'ファイル保存ダイアログ Function getSavePath() As String Dim fPath As String Dim strExt As String strExt = Ext & "ファイル, *." & LCase(Ext) & ", 全てのファイル,*.*" fPath = Application.GetSaveAsFilename(fileFilter:=strExt) If fPath = "False" Then getSavePath = "" Else getSavePath = fPath End If End Function '画像出力 Sub imgOut() Dim rg As Range Dim cht As Chart Ext = Range("A23") '保存ファイル名を取得 SavePath = getSavePath If SavePath <> "" Then Call setSettings '設定を共通変数にセット Set rg = Range(BaseRng.Offset(1, 1), Cells(BaseRng.Row + Tate, _ BaseRng.Column + Yoko)) Application.ScreenUpdating = False rg.CopyPicture appearance:=xlScreen, Format:=xlPicture 'チャートを追加して画像貼り付け Set cht = ActiveSheet.ChartObjects.Add(0, 0, rg.Width, rg.Height).Chart cht.Parent.Select cht.Paste cht.Export FileName:=SavePath, filtername:=Ext cht.Parent.Delete Application.ScreenUpdating = True End If End Sub 'ブックに出力 Sub outToNewBook() Dim ws As Worksheet, cpWs As Worksheet Dim wb As Workbook Dim rg As Range Ext = "xlsx" '保存ファイル名を取得 SavePath = getSavePath If SavePath <> "" Then Set cpWs = Sheets("ドット絵") Application.ScreenUpdating = False Application.DisplayAlerts = False cpWs.Cells.Clear Call setSettings '設定を共通変数にセット Set rg = Range(BaseRng.Offset(1, 1), Cells(BaseRng.Row + Tate, _ BaseRng.Column + Yoko)) rg.Copy Destination:=cpWs.Range("A1") Set wb = Workbooks.Add cpWs.Copy before:=wb.Worksheets(1) For Each ws In wb.Worksheets If ws.Name <> cpWs.Name Then ws.Delete End If Next On Error GoTo err wb.SaveAs FileName:=SavePath On Error GoTo 0 wb.Close Application.DisplayAlerts = True Application.ScreenUpdating = True End If Exit Sub err: wb.Close MsgBox "出力できません" End End Sub
こんな感じです。*1
新規ブックに出力
新規ブックに出力する部分は、すでに出来ている画像出力と、以前書いた
vba-belle-equipe.hatenablog.com
こちらの記事を参考にしました。
（書き方忘れてました）
*1:変更のあったところだけです
思いつき連載 VBA王子 ニューヨークへ行く #11
前回
#11
「え？ VBAの勉強？ そりゃ、しなさいよ。しないとできないんでしょ？ じゃ、しなさいよ。え？ 通常業務は、やりながらに決まってるでしょ。え？ 時間？ 時間は作るんだよ。残業？ 残業はつけちゃダメだよ。自主的に残るのは構わないけどさ。え？ どういう意味かって？ そりゃ、そういう意味だよ」
係長への相談終了後、赤羽は自席に戻って息をついた。飽きることもなく右手の爪を見ていた浮間が、すっと寄ってくる。
「いやあ、感心感心。赤羽君は、サービスいいね」
「しませんよ。サービス残業なんて」
「だよね。私も絶対やんない」
あなたは普通の残業もしないんです、と言うかわりに赤羽はうなずいた。
「でも、あんなにすぐになおせたんだから、キミにとってはお茶の子さいさいでしょ」
北浦から受け取ったファイルは赤羽が試し、浮間の手に渡っていた。うまく動いたようだ。
ということは北浦の言う通り、浮間がどこかいじった結果、うまく動かなくなっていただけ、ということだろう。
「さっきも言いましたけど、あれは、北浦さんがなおしてくれたんです。自分はまだ『こんにちは』って表示させることしか・・・」
「北浦って誰だっけ？ ああ、あのおかっぱか」
「はい」
「てゆうか、お茶の子ってなんだろね」
「・・・なんでしょうね」
お茶の子について考えながら赤羽が地下に下りると、資料管理室は低いうなり声を発していた。
「・・・失礼します」
ドアを開けると、北浦はおかっぱ頭をきれいになびかせながら、陰気な目を向けてくる。赤羽は異常に気づかないふりをすることにした。
「浮間さんの件、大丈夫でした」
「・・・まあ、そうだろうな、あの女の場合。てゆうかこっちは大丈夫じゃなかったよ」
「何かありましたか」
「何かありましたよ。言ったよな？ 蕨だけは来させるなって」
ああ、と赤羽は言った。
でも自分のせいじゃないんです。川口さんと話していたら蕨係長に聞かれていて、じゃあ私が行くってことになったので、それを止めるのは無理です。
とは言わず、胸の中に留めておいた。
「ああ、じゃないんだよ。おかげでこっちは滅茶苦茶仕事増えたんだぞ」
「大変ですね」
北浦は舌打ちした。
「大変ですね、じゃないよ。お前にもやってもらうぞ」
「え、無理ですよ」
「当たり前だ。だから、早く使い物になれ」
「ええと、なりたいのは・・・」
「やまやまです」
「え？」
「なりたいのはやまやまです、で終わりだ。『が』とか、いらん」
やまやまってなんだろう。
自分はやまやまになりたかったのだろうか。
赤羽は自分の胸に聞いてみようとしたが、すぐに意識を戻される。
「それから？」
「え？」
「お前んとこの係長に相談するって言ってただろ。1日あたり24時間までならVBAの勉強をしてていいって承認してもらったか？」
いえ、と赤羽はやりとりを説明した。
ふん、と北浦は鼻を鳴らした。
「まあ、どうせそんなとこだろう。通常業務は一切変わらないということなら、話は簡単だ」
「簡単ですか」
「通常業務を一瞬で終わらせろ。そうしたら、空いた時間にVBAの訓練ができる」
「そんな」
「無茶なってか？ お前は何を見てたんだ。別のExcelファイルにシートをコピーして名前を変えるまで、一瞬で終わっただろ？」
「あ、そうですね」
「お前の業務で、マクロ化できる部分があれば、それだけ時間を短縮できるってことだ。だからとりあえず、洗い出しをするぞ」
「え、ひょっとして、マクロを作っていただけるんですか？」
「これは貸しだ」北浦は薄く笑った。「そのうち返してもらう」
「・・・なるほど」
そのうちが来る前になんとかしよう、と赤羽は心に決めた。
- つづく -
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:変更のあったところだけです
