Excelでドット絵作成ツールを作る v1.0.0 配布の巻
動作環境
Excel2016 で動作確認済です。
Excel2007以降であれば大丈夫なのではと思いますが、動作報告いただければ助かります。
操作方法
モード切替で、モードが切り替わります
通常モード
キャンバス内のセルをクリックやドラッグで選択すると、「描画色」に塗ることができます
元に戻す&やりなおす
通常モードでの描画操作は、それぞれのボタンで「元に戻す」「やりなおす」ことができます
(描画の履歴を残して再現しているだけなので、標準のものとは動きが異なります)
手動モード
選択しただけで色が変わったりしないので、標準のコピーやペースト機能が使えます
設定
キャンバスのサイズ
たて、よこのサイズを個別に指定できます。
あまり大きいと重くなるのと、操作画面が見にくくなるので、とりあえずたて、よこ共に上限を100としています。
(下にも記載しましたが、VBAの改変は自由なので、解除可能です)
はじめの準備
ファイルを開いたときになんだかメッセージが出てきたら、以下を実行してください
編集を有効にする
保護ビューで開いた場合、「編集を有効にする」をクリック
コンテンツの有効化
セキュリティの警告が出たら、「コンテンツの有効化」をクリック
諸注意とか
- ファイルの改変、再配布は自由です(特に断りもいりません)
- ファイルをダウンロード、開いたことによるいかなる損害も当サイトは責任は負えません
参考ページ
パレットウィンドウ(カラーピッカー)の実装に関して、下記のページを参考にさせていただきました。
(ほとんどそのままです)
Excel VBA 背景色をパレットウィンドウから指定する PCまなぶ
質問、ご意見等
コメントに残していただくか、ホームページの問い合わせからお願いします。
コード
前回
vba-belle-equipe.hatenablog.com
から、
- モード切替ボタン追加
- キャンバス変更時にキャンバス外を白くする
あたりが変更されています。
'///シートモジュール(ドット絵作成シート)/// Option Explicit Private Tgt As Range Const MaxTate As Long = 100 'たての最大ドット数 Const MaxYoko As Long = 100 'よこの最大ドット数 Const MaxTarget As Long = 10000 '一度に描画できるドットの最大数 Private Sub Worksheet_Change(ByVal target As Range) If target.Address = TateAddress Or target.Address = YokoAddress Then Call setSettings '設定を共通変数にセット If Tate > MaxTate Or Yoko > MaxYoko Then End End If Call setCamvas 'キャンバスセット Exit Sub End If End Sub Private Sub Worksheet_SelectionChange(ByVal target As Range) Application.EnableEvents = False Application.ScreenUpdating = False Set Tgt = target '手動モードか、選択範囲多すぎる場合何もしない If Range("A1") = "手動モード" Or target.Count > MaxTarget 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 '--------(選択色) ElseIf target.Address = SelectColorAddress Then lngNewColor = GetColorDlg If lngNewColor <> -1 Then Range(SelectColorAddress).Interior.Color = lngNewColor Range("A1").Select End If 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() If Range("A1") = "手動モード" Then Else Application.CutCopyMode = False End If Tgt.Select Application.ScreenUpdating = True Application.EnableEvents = 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 SelectColorAddress As String = "$B$7:$B$8" 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 Const CurHistoryAddress As String = "$A$30" Public Const CntHistoryAddress As String = "$A$32" Public BaseRng As Range '描画範囲 Public CamvasRng As Range 'キャンバス基準(左上セル) Public Tate As Long, Yoko As Long 'キャンバスサイズ(縦、横) Public CurHistory As Long '履歴の現在位置 Public CntHistory 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)) CurHistory = .Range(CurHistoryAddress) CntHistory = .Range(CntHistoryAddress) ' Debug.Print CurHistory End With 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 'キャンバス外を白くする Set r = Range(Cells(1, BaseRng.Column + Yoko + 1), _ Cells(Rows.Count, Columns.Count)) Set r = Union(r, Range(Cells(BaseRng.Row + Tate + 1, BaseRng.Column), _ Cells(Rows.Count, BaseRng.Column + Yoko + 1))) r.Interior.Color = 16777215 Application.ScreenUpdating = True 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 '///標準モジュール(ボタン)/// Option Explicit 'ボタン色変更 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 '手動、通常モード切替 Sub modeChange() Dim str As String With Sheets("ドット絵作成") str = .Range("A1") Select Case str Case "手動モード" .Range("A1") = "通常モード" Case Else .Range("A1") = "手動モード" End Select End With End Sub '///標準モジュール(出力)/// 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 '///標準モジュール(描画)/// 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 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 drwRng.Interior.Color = clr1 Call saveHistory '履歴残す Call changeBtnClr End If target.Select Application.ScreenUpdating = True End Sub '置換 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 Call changeBtnClr Application.ScreenUpdating = True Application.EnableEvents = True End Sub '///標準モジュール(変更履歴)/// Option Explicit Public Const TateHaba As Long = 10000 '1履歴に使う縦のセル数 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 '元に戻す 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 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 '初期化 Sub allClear() Dim r As Range Dim minCol As Long, maxCol As Long Dim minRow As Long, maxRow As Long Dim cmvRng As Range 'キャンバスの範囲 Call setSettings '共通変数のセット Sheets("変更履歴").Cells.Clear Sheets("ドット絵").Cells.Clear Application.EnableEvents = False Application.ScreenUpdating = False 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)) cmvRng.Interior.Color = 16777215 Range(RirekiAddress).Interior.Color = 16777215 CurHistory = -1 Call saveHistory '履歴残す Call changeBtnClr Application.ScreenUpdating = True Application.EnableEvents = True End Sub