サクラクレパスクーピーの柄をランダムに生成するExcelマクロを考えてみた

おそらく誰もが触ったことのあるサクラクレパス社のクレヨンのクーピー。カラフルな柄のパッケージデザインでおなじみですが、これをExcelで自動生成するというくだらないマクロを考えたので、その過程を書いてみたいと思います。

どんなExcelマクロ？

先日ツイートした以下の内容をご覧ください。文字通り、Excelの図形オブジェクトを使ってクーピーの模様っぽいものをランダムに生成するというしょーもないマクロです。

サクラクレパスのクーピーの模様をランダムに生成するマジでどうでもいいマクロが完成しました。#Excel #VBA #マクロ pic.twitter.com/vvbroNhTRQ

— （有） (@tdyu05) September 10, 2019

ちなみに、正式な模様は以下です。

 

見ての通り、実際はもっと鮮やかでちゃんと練られているデザインですね。 

なぜ作ったのか？

ぶっちゃけ特に意味はありません。4歳になる息子がよくお絵かきをするのにクーピーを使っているのですが、そのパッケージを何気なくを見ていたときに、「これ、柄のパターンに法則がある！プログラミングで生成できるかも！？」とふと思ったのがきっかけです。

というわけで、生成する要件を考えてみる

パターンに法則がある、というふうに書きましたが、正確には生成するロジックがある程度決まっているということですね。ざっと見たとき、以下のことが言えそうです。

よし、これなら簡単そうだ。というわけでVBAで作ってみました。

作り方

最後にソースコードは載せますので、ここではポイントだけ載せておきます。

図形描画のために必要な変数をセット

基本ですが変数を以下のように定義しました。leftPositionは図形の左端の位置。topPositionは図形の上端の位置です。

図形に色を当てるための関数を用意しておく

図形にはランダムに色を付ける必要があるのでそのために以下の関数を作りました。ランダムにR、G、Bの値を生成し、それを配列として返すようにします。

Function createRGB() As Variant
    Dim r As Integer, g As Integer, b As Integer
    Dim arr As Variant
    Randomize
    r = Int(Rnd * 256)
    g = Int(Rnd * 256)
    b = Int(Rnd * 256)     
    arr = Array(r, g, b)
    createRGB = arr
End Function

縦に並んだ2つの棒を作る

以下の通りです。図形を生成するのは、ShapesオブジェクトのAddShapeメソッドです。引数は、1：図形の種類、2：最左端の位置、3：最上端の位置、4：幅、5：高さです。最後に先程生成した色をFillプロパティで適用します。

'//RGB値を取得
arr = createRGB
'//上の棒を生成（※jはループのためのカウンタです）
Set s = ActiveSheet.Shapes.AddShape(Type:=msoShapeRectangle, Left:=leftPosition + (j * lineWidth), Top:=topPosition, Width:=lineWidth, Height:=upperHeight)
'//線はオフ
s.Line.Visible = msoFalse
'//取得した色を当てはめる
s.Fill.ForeColor.RGB = RGB(arr(0), arr(1), arr(2))


'//以下は下の棒を生成するもの。上とほぼ同じなので省略 
arr2 = createRGB
Set s2 = ActiveSheet.Shapes.AddShape(Type:=msoShapeRectangle, Left:=leftPosition + (j * lineWidth), _Top:=topPosition + upperHeight, Width:=lineWidth, Height:=lowerHeight)
s2.Line.Visible = msoFalse
s2.Fill.ForeColor.RGB = RGB(arr2(0), arr2(1), arr2(2))

上下の2つの棒を区切るサブ図形を生成する

上下にある2つの棒を区切る小さな図形（サブ図形：丸と三角形と四角形）を生成します。これは違うプロシージャ（createSubShape）に書いたので、メインのプロシージャから、引数とともにCallで呼び出します。サブ図形の種類については、ランダムな数字を生成してそれを渡します。本マクロでは0：丸、1：三角形、2：四角形です。

Call createSubShape(leftPosition2, upperHeight, n)
'//第1引数：左端の位置、第2引数：上の棒の長さ、第3引数：図形の種類

サブ図形についての生成については、AddShapeメソッドで図形を生成し、引数で図形の種類、上端の位置、図形の高さを決めて、色を塗って・・・とやることは一緒なので省略します。少しだけ計算が面倒だったのが正三角形の上端の位置の算出です。参考までに以下に書いておきます。

ちなみに、このクーピーの模様では三角形が逆向きになることもあります。これもランダムに発生させます。そのために、まずランダムな数字（0か1）を生成させ、もし0が出たら図形をひっくり返すという風にしています。図形をひっくり返すには、ShapeオブジェクトのFlipメソッドを用い、引数を msoFlipVerticalにします。

どんな図形ができたか！？

上記の図形生成を、Forループで左端の位置をずらしながら実行しました。そうすると以下のような模様ができ上がります。さあどうだ！！

 えっ・・・なんか微妙・・・・

なんか不自然ですね・・・これでは本家本元のかわいらしいクーピーの模様に到底及びません！！ 

ということで改善方法を考えてみました。

何がおかしいのか？

図形の位置や色を一切の条件なしにランダム生成すると変な模様ができてしまうので、原因を考え、ある程度ランダム化に制限を設けることにしました。その制限が以下のものです。

確かに、クーピーの模様をよく見てみると、

①上の棒と下の棒の長さ関係は列ごとによって結構ばらついている
②サブ図形は同じものが隣り合っていない
③地味な色が少ない

ということがわかります。というわけで①に関しては、前回の列の長さを記憶してそれと比較し、サブ図形の高さの1．5倍分以上は離れるようにしました。②に関しても前回の図形と比較して、同じ図形が出ないようにすればOKです。

残る③の地味な色避ける方法ですが、これを厳密に調整するのは困難なので、「最低限、無彩色に近い色（白、黒、灰色）は避ける」という方向にしました（※ただ実際の模様には、黒っぽい無彩色はあるみたいですけど）

ちなみに無彩色に近い色というのは、簡単にいうとR、G、B各数値が同じような値の色です。例えばRGB（100,110,102）とかで色を調べてみてください。緑味の灰色で地味な色ができます。

今回、完全に地味な色は排除しきれないものの、取り急ぎ以下のロジックを作りました。

（1）R、G、Bの各数値をランダムに生成する
（2）RとG、GとB、BとRの各数値の差の絶対値を調べる
（3）それら3つの絶対値を全部足して90以下だったら、R、G、Bのどれか1つをランダムに選んで数値を100上げるor下げる

こうすれば明らかに白、黒、灰色っぽい色は生成されなくなります。

でき上がり！

この設定変更を加えたマクロを実行すると、例えば以下のような図形が生成されます。どうでしょうか！？先程よりはだいぶ良くなったでしょうか！？

正直なところ、本家本元のデザインには全然及びませんが、まぁ最初よりはマシになったといえるでしょう。 

ただ、このマクロはまだ難点が残っており、上の棒と下の棒、または棒とサブ図形、または列同士で似たような色相の色が隣り合ってしまいます。

これはR、G、Bの中で最も数値が高い色を調べることで、似たような色相が隣にできてしまうことは回避できるのですが、もうめんどくさいのでこれはやりませんでした。

というわけで以上、全く実用性のないお遊びマクロの解説でした。最後に、今回作成したマクロのソースコードを以下に載せておきます。以下のコードをコピペしてdrawプロシージャを実行すれば動くはずです。

Dim topPosition As Integer
Dim maxHeight As Integer
Dim prevHeight As Integer
Dim lineWidth As Integer
Dim leftPosition As Integer
Dim num As Integer
Sub draw()
deleteAll
flg = False
topPosition = 105 '//図形の一番上の位置
maxHeight = 400 '//図形の縦の長さ
prevHeight = 0
lineWidth = 50
leftPosition = 0
num = 0
Call test
End Sub
Sub test()
    Dim arr As Variant
    Dim s As Shape, s2 As Shape
    Dim upperHeight As Integer, lowerHeight As Integer
    Dim prevHeight As Integer
    
    Randomize

    For j = 0 To 15

        Do
        upperHeight = Int(Rnd * maxHeight)
            '//短すぎたり長すぎたりしたらやり直し
            If upperHeight < lineWidth Or upperHeight > maxHeight - lineWidth Then
                flg = True
            Else
                If Abs(upperHeight - prevHeight) > (lineWidth * 1.5) Then
                    flg = False
                Else
                    flg = True
                End If
            End If
        Loop Until flg = False
        '//前回の高さを記憶しておく
        prevHeight = upperHeight
        
        '//下の方の長方形の長さを定義
        lowerHeight = maxHeight - upperHeight
        
        arr = createRGB
        Set s = ActiveSheet.Shapes.AddShape(Type:=msoShapeRectangle, Left:=leftPosition + (j * lineWidth), Top:=topPosition, Width:=lineWidth, Height:=upperHeight)
        s.Line.Visible = msoFalse
        s.Fill.ForeColor.RGB = RGB(arr(0), arr(1), arr(2))
        
        arr2 = createRGB
        Set s2 = ActiveSheet.Shapes.AddShape(Type:=msoShapeRectangle, Left:=leftPosition + (j * lineWidth), Top:=topPosition + upperHeight, Width:=lineWidth, Height:=lowerHeight)
        s2.Line.Visible = msoFalse
        s2.Fill.ForeColor.RGB = RGB(arr2(0), arr2(1), arr2(2))
        
        Dim n As Integer
        flg2 = False
        Do
            n = Int(Rnd * 3)
            If n = prev Then
                flg2 = False
            Else
                flg2 = True
            End If
        Loop Until flg2 = True
        
        prev = n
        Dim leftPosition2 As Integer
        leftPosition2 = leftPosition + (j * lineWidth)
        Call createSubShape(leftPosition2, upperHeight, n)
    Next j
End Sub
Function createRGB() As Variant
    Dim r As Integer, g As Integer, b As Integer
    Dim arr As Variant
    Randomize
    r = Int(Rnd * 256)
    g = Int(Rnd * 256)
    b = Int(Rnd * 256)
    
    '//RGBそれぞれの差を見てどれも同じような数値だった場合、
    '//RGBどれか1つの数値を上げる（または下げる）
    diff1 = Abs(r - g)
    diff2 = Abs(r - b)
    diff3 = Abs(b - g)
    
    If (r + g + b) / 3 > 128 Then
        tmp = -1
    Else
        tmp = 1
    End If
     If diff1 + diff2 + diff3 < 90 Then
        'MsgBox (r & "と" & g & "と" & b & " " & num)
        Dim i As Integer
        i = Int(Rnd * 3)
        Select Case i
            Case 0
                r = r + (100 * tmp)
            Case 1
                g = g + (100 * tmp)
            Case 2
                b = b + (100 * tmp)
        End Select
    End If
        
    arr = Array(r, g, b)
    createRGB = arr

End Function
Sub createSubShape(ByVal ml As Integer, ByVal uh As Integer, ByVal i As Integer)
    Dim s As Shape
    Dim halfHeight As Integer
    halfHeight = lineWidth / 2
    arr = createRGB
    
    Select Case i
    Case 0
        Set s = ActiveSheet.Shapes.AddShape(msoShapeOval, ml, topPosition + uh - halfHeight, lineWidth, lineWidth)
    Case 1
        Dim h As Variant
        h = lineWidth / 2 * Sqr(3)
        Set s = ActiveSheet.Shapes.AddShape(msoShapeIsoscelesTriangle, ml, topPosition + uh - h, lineWidth, h)
        Randomize
        Dim n As Integer
        n = Int(Rnd * 2)
        If n = 0 Then
            s.Flip msoFlipVertical
            s.Top = uh + topPosition
        End If
    Case 2
        Set s = ActiveSheet.Shapes.AddShape(msoShapeRectangle, ml, topPosition + uh - halfHeight, lineWidth, lineWidth)
    End Select

    s.Line.Visible = msoFalse
    s.Fill.ForeColor.RGB = RGB(arr(0), arr(1), arr(2))
    
End Sub
Sub deleteAll()
  Dim shp As Shape

  For Each shp In ActiveSheet.Shapes
    If shp.Type <> msoFormControl And shp.Name <> "topRect" Then
    shp.Delete
    End If
  Next shp

End Sub