Excelでドット絵を作成するマクロを作ってみた

FB友達の○○○さんが、ドットでスーパーマリオの絵を描いていたので

 

自分もドット絵を簡単に描けるプログラムをマクロで組んでみた

中身は、カラーバーをクリックすることにより色選択をして

セルをクリックすると、セルの色が選択した色に変わるもの

 

色を塗るプログラムはこちら

========================================================

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim r, c As Integer
Dim myColor, palletR, palletG, palletB As Long

r = ActiveCell.Row      'アクティブセルの行を取得
c = ActiveCell.Column   'アクティブセルの列を取得

Cells(9, 35) = r  'アクティブセルの行を(9,35)のセルに代入
Cells(9, 39) = c  'アクティブセルの列を(9,39)のセルに代入

'パレットの中から色を決める
If c = 31 Then              '選んだセルがパレットの範囲内かIF構文で確認(パレットは(10〜23,31))
    If r > 10 Then
        If r < 24 Then
       
            myColor = ActiveCell.Interior.Color  'パレットの色番号を取得
   
            palletR = myColor Mod 256               '色のR成分を取得
            palletG = Int(myColor / 256) Mod 256    '色のG成分を取得
            palletB = Int(myColor / 256 / 256)      '色のB成分を取得
           
            Cells(10, 35).Value = palletR           'セル(10,35)にR成分を代入
            Cells(10, 39).Value = palletG           'セル(10,39)にG成分を代入
            Cells(10, 43).Value = palletB           'セル(10,43)にB成分を代入
           
        End If
    End If
   
End If

'選んだセルを決めた色に塗りつぶす
If c > 1 Then               '選んだセルがドット絵の範囲内かIF構文で確認(枠は(2〜26,2〜26))
    If c < 27 Then
        If r > 1 Then
            If r < 27 Then
                If Selection.Rows.Count > 1 Then
                    Exit Sub
                End If
                If Selection.Columns.Count > 1 Then
                    Exit Sub
                End If
            Cells(r, c).Interior.Color = RGB(Cells(10, 35).Value, Cells(10, 39).Value, Cells(10, 43).Value)
            '選んだセルを選んだ色に塗りつぶす
            End If
        End If
    End If
End If

End Sub

 

========================================================

複数セルの色変更はこちら(標準モジュール)

===============================

Sub ボタン5_Click()
Dim r, c As Integer
Dim numr, numc As Variant

r = ActiveCell.Row
c = ActiveCell.Column

If c > 1 Then               '選んだセルがドット絵の範囲内かIF構文で確認(枠は(2〜26,2〜26))
    If c < 27 Then
        If r > 1 Then
            If r < 27 Then
                Select_Range = ActiveWindow.RangeSelection.Address
                numr = Selection.Rows.Count
                numc = Selection.Columns.Count
                Range(Selection(1), Selection(Selection.Count)).Interior.Color = RGB(Cells(10, 35).Value, Cells(10, 39).Value, Cells(10, 43).Value)
            '選んだセルを選んだ色に塗りつぶす
            End If
        End If
    End If
End If

 

 

 

End Sub

==============================

 

色の消去

==============================

Sub ボタン4_Click()
'
' ボタン4_Click Macro
' マクロ記録日 : 2012/12/8  ユーザー名 : taka
'

'
   
Dim r, c  As Integer
r = ActiveCell.Row
c = ActiveCell.Column

    Range("B2:Z26").Select
    Selection.Interior.Color = RGB(255, 255, 255)
    Cells(r, c).Select
    ActiveCell.Interior.Color = RGB(255, 255, 255)
End Sub

=============================

 

割と簡単に作れて、子供たちも喜んで遊んでた♪
小3の娘の作品はこちら