VBAでデジタル迷彩ジェネレータを作ってみた

初めて投稿します。

最近モデルを作って3Dプリンタで印刷するのが趣味になってきているのですが、
表面の色を何にするか、結構悩んだりします。
あるモデルは、意表をついて迷彩柄にしてみようと意気込んだのですが、
自分で描いてみたもののどうにもしっくりきませんでした。

なので、どうせならプログラミングで描いてやろうと思い立ち、
デザイン的にも新しいデジタル迷彩を描くジェネレータを
みんな大好きVBAで作りました。

次はシマウマ柄を作ろうかな。。

■できあがったもの

・無事ジェネレートできた
できあがり：

・パラメータとエクセルのセルサイズ調整は必要かも

■詳細

他のバージョン：
海軍バージョンなど。。

VBAの始め方は、、釈迦に説法だろうけど、
エクセルで新規作成して、Alt＋F11を押すと
ソースコードを貼りつけるところがでてくるので、以下を貼りつける、、、と。

アルゴリズムの簡単な解説的な何か：

ソースコード：

～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～

Const GWHOLE As Long = 500 'キャンバスサイズ
Const RWHOLE As Long = 500 'キャンバスサイズ
Const GSIZEMAX As Long = 40 '一つの島の最大サイズ
Const RSIZEMAX As Long = 8 '一つの島の最大サイズ
Const RSIZESTART As Long = 5 '列方向の初期値
Const RRESTRICTMAX As Long = 7 '列方向に対して一行分で増減する最大サイズ
Const RRESTRICTMIN As Long = 3 '列方向に対して一行分で増減する最小サイズ
Const LOOPNUM As Long = 100 '何個描くか 20000
Const RRATE As Long = 10 '何分の1の間は列方向を積極的に増減させるか（大きいほど縦型模様になる）
Const COLORNUM As Long = 3 '何色使うか（色数-1）

Sub main()
Dim z As Long, zz As Long, zzz As Long
Dim nowG As Long '最初は無作為に選んで、その後インクリメント
Dim nowR As Long '最初は無作為に選んで、その後は直前の列から制限を持った開始列からインクリメント
Dim gSize As Long, rSize As Long '縦横のサイズ。ランダム値が入る
Dim rStepLeft As Long, rStepRight As Long '列方向に対して一行分で増減するサイズ（左端と右端）
Dim rRestrict As Long '列方向に対して一行分で増減する最大サイズ
Dim colorNo As Long '何色で塗るか
Dim colorRGB As Variant '何色で塗るか
Dim colorList As Variant
colorList = Array(RGB(30, 0, 0), RGB(190, 165, 125), RGB(180, 200, 130), RGB(85, 95, 0)) '緑本物志向
' colorList = Array(RGB(30, 0, 0), RGB(160, 170, 170), RGB(75, 100, 140), RGB(225, 237, 255)) '青本物志向
' colorList = Array(RGB(30, 30, 30), RGB(90, 90, 90), RGB(150, 150, 150), RGB(235, 235, 235)) '灰本物志向
' colorList = Array(RGB(60, 30, 30), RGB(130, 90, 90), RGB(200, 150, 150), RGB(255, 235, 235)) '赤本物志向
' colorList = Array(RGB(60, 60, 60), RGB(150, 0, 150), RGB(200, 0, 200), RGB(255, 0, 255)) '紫
' colorList = Array(RGB(100, 70, 0), RGB(150, 100, 0), RGB(200, 150, 0), RGB(255, 180, 0)) '黄色
' colorList = Array(RGB(100, 70, 0), RGB(150, 100, 0), RGB(200, 160, 0), RGB(255, 220, 0)) '黄色明るい
' colorList = Array(RGB(0, 0, 60), RGB(0, 0, 120), RGB(0, 0, 180), RGB(0, 0, 255)) '青
' colorList = Array(RGB(0, 40, 60), RGB(0, 80, 120), RGB(0, 120, 180), RGB(0, 180, 255)) '水色
' colorList = Array(RGB(100, 0, 0), RGB(150, 0, 0), RGB(200, 0, 0), RGB(255, 0, 0)) '赤
' colorList = Array(RGB(100, 0, 30), RGB(150, 0, 50), RGB(200, 0, 100), RGB(255, 0, 150)) 'ピンク
' colorList = Array(RGB(0, 100, 0), RGB(0, 150, 0), RGB(0, 200, 0), RGB(0, 255, 0)) '緑
' colorList = Array(RGB(230, 230, 150), RGB(150, 150, 255), RGB(255, 150, 150), RGB(150, 255, 150)) 'パステル
' colorList = Array(RGB(255, 180, 0), RGB(0, 0, 255), RGB(255, 0, 0), RGB(0, 255, 0)) '派手

'画面更新無し
Application.ScreenUpdating = False

'キャンバスを白紙に、セルサイズ調整
Call makeCanvasClear

'作りたい個数分だけループ
For z = 0 To LOOPNUM

'初期位置を無作為に決める
Randomize
nowG = CLng(GWHOLE * Rnd) + 1
nowR = CLng(RWHOLE * Rnd) + 1

'サイズを無作為に決める。列サイズは各行で微調整されるので初期サイズ
gSize = CLng(GSIZEMAX * Rnd) + 1
rSize = CLng(RSIZESTART * Rnd) + 1
rRestrict = CLng(RRESTRICTMAX * Rnd) + RRESTRICTMIN

'色を無作為に決める
colorNo = CLng(COLORNUM * Rnd)
colorRGB = colorList(colorNo)

'行方向のループ
For zz = nowG To nowG + gSize

'各行で初期列を微調整
Randomize
If zz < (nowG + gSize / RRATE) Then '前半なら幅プラスを多めに
rStepLeft = CLng(rRestrict * (Rnd - 1))
rStepRight = CLng(rRestrict * (Rnd - 0)) * 2 '右側は左側に引きずられるので2倍にする

ElseIf zz < (nowG + gSize / RRATE * (RRATE - 1)) Then '中盤は均等に
rStepLeft = CLng(rRestrict * (Rnd - 0.5))
rStepRight = CLng(rRestrict * (Rnd - 0.5))

Else '後半は幅マイナスを多めに
rStepLeft = CLng(rRestrict * (Rnd - 0))
rStepRight = CLng(rRestrict * (Rnd - 1)) * 2 '右側は左側に引きずられるので2倍にする
End If

'左端が1未満になる場合の調整
nowR = nowR + rStepLeft
If nowR < 1 Then
nowR = 1
End If

'列サイズが0なら打ち切り
rSize = rSize + rStepRight
If rSize < 1 Then
Exit For
End If

'列方向のループ
For zzz = nowR To nowR + rSize
Cells(zz, zzz).Interior.Color = colorRGB
Next
Next
Next

'画面更新無し 解除
Application.ScreenUpdating = True

End Sub

'キャンバスを白紙に
Sub makeCanvasClear()

Cells.Select

Selection.ColumnWidth = 0.85
Selection.RowHeight = 8.25

With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With

Selection.ClearContents
Range("A1").Select

End Sub

～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～