may the VBA be with you

Excel VBAとか業務自動化とか

Excelでドット絵作成ツールを作る v1.0.0 配布の巻

ツールの説明

f:id:vba-belle-equipe:20160525123516p:plain

Excelのセルをドットに見立ててドット絵を作成するツールです

動作環境

Excel2016 で動作確認済です。

Excel2007以降であれば大丈夫なのではと思いますが、動作報告いただければ助かります。

操作方法

モード切替で、モードが切り替わります

通常モード

キャンバス内のセルをクリックやドラッグで選択すると、「描画色」に塗ることができます

元に戻す&やりなおす

通常モードでの描画操作は、それぞれのボタンで「元に戻す」「やりなおす」ことができます
(描画の履歴を残して再現しているだけなので、標準のものとは動きが異なります)

手動モード

選択しただけで色が変わったりしないので、標準のコピーやペースト機能が使えます

設定

描画色、置換色

「通常モード」の時にセルをクリックすると、Excel標準の色選択画面が開きます。

f:id:vba-belle-equipe:20160525125624p:plain


キャンバスのサイズ

たて、よこのサイズを個別に指定できます。

あまり大きいと重くなるのと、操作画面が見にくくなるので、とりあえずたて、よこ共に上限を100としています。
(下にも記載しましたが、VBAの改変は自由なので、解除可能です)

画像ファイル種別

PNG,JPG,GIF,BMPが出力できます。(透過には対応していません)


ファイルのダウンロード

Excelドット絵作成_v1_0_0.xlsm - Google ドライブ

上記リンク先からダウンロードしてください。

できなかったらゴメンナサイ。

はじめの準備

ファイルを開いたときになんだかメッセージが出てきたら、以下を実行してください

編集を有効にする

f:id:vba-belle-equipe:20160525131327p:plain

保護ビューで開いた場合、「編集を有効にする」をクリック

コンテンツの有効化

f:id:vba-belle-equipe:20160525131348p:plain

セキュリティの警告が出たら、「コンテンツの有効化」をクリック


諸注意とか

  • ファイルの改変、再配布は自由です(特に断りもいりません)
  • ファイルをダウンロード、開いたことによるいかなる損害も当サイトは責任は負えません

参考ページ

パレットウィンドウ(カラーピッカー)の実装に関して、下記のページを参考にさせていただきました。
(ほとんどそのままです)

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