VBAでステレオグラム（立体視）を描いてみた

VBAでステレオグラム（立体視/マジカル・アイ）を描いてみた
この動画のマクロはWindows11/Office2013で作成してます。

#If Win64 Then
    ' Excel が64ビット版の場合の関数定義です。
    Private Declare PtrSafe Function MessageBoxTimeoutA Lib "User32.dll" _
        (ByVal hWnd As LongPtr, _
        ByVal lpText As String, _
        ByVal lpCaption As String, _
        ByVal uType As VbMsgBoxStyle, _
        ByVal wLanguageID As Long, _
        ByVal dwMilliseconds As Long) As Long
#Else
    ' Excel が32ビット版の場合の関数定義です。
    Private Declare Function MessageBoxTimeoutA Lib "User32.dll" _
        (ByVal hWnd As Long, _
        ByVal lpText As String, _
        ByVal lpCaption As String, _
        ByVal uType As VbMsgBoxStyle, _
        ByVal wLanguageID As Long, _
        ByVal dwMilliseconds As Long) As Long
#End If
Const dots = "ドット"
Const ptrn = "図形"
Const strg = "ステレオグラム"

Const dots_size = 64
Const img_size_w = 300
Const img_size_h = 150

Sub Macro1()
    
    'Sheetの初期化
    MakeSheet dots
    MakeSheet ptrn
    MakeSheet strg
    
    Sheets(dots).Activate
    Call make_dots
    MessageBoxTimeoutA 0, "ドット模様を書いた", "メッセージ", 1, 65536, 3 * 1000


    Sheets(ptrn).Activate
    MessageBoxTimeoutA 0, "パターンを描くぜ", "メッセージ", 1, 65536, 3 * 1000
    Call make_img
    
    MessageBoxTimeoutA 0, "ステレオグラムを描くぜ", "メッセージ", 1, 65536, 3 * 1000
    Sheets(strg).Activate
    Call make_autostereogram
    MessageBoxTimeoutA 0, "見れ", "メッセージ", 1, 65536, 3 * 1000

End Sub

Function make_dots()
    For r = 1 To dots_size
        For c = 1 To dots_size
            '乱数を発生させセルに値を入れ、背景色をその乱数で塗る
            g = Int(Rnd * 255)
            Sheets(dots).Cells(c, r).Value = g
            Sheets(dots).Cells(c, r).Interior.Color = RGB(g, g, g)
        Next
    Next
End Function

Function make_img()
    'Sheet2に
    '半径が高さの1/3の円を描く
    For r = 1 To img_size_w
        For c = 1 To img_size_h
            If (r - img_size_w / 2) ^ 2 + (c - img_size_h / 2) ^ 2 < (img_size_h / 3) ^ 2 Then
                Sheets(ptrn).Cells(c, r).Value = 1
                Sheets(ptrn).Cells(c, r).Interior.Color = RGB(0, 0, 0)
            Else
                Sheets(ptrn).Cells(c, r).Value = 0
            End If
        Next
        '下側に境界線をつける
        Sheets(ptrn).Cells(img_size_h + 1, r).Interior.Color = RGB(255, 0, 0)
    Next
End Function

Function make_autostereogram()
    
    shift_amplitude = 0.15
    For r = 1 To img_size_w
        For c = 1 To img_size_h
            If r <= dots_size Then
                'はじめの64(dots_size)セルはドットパターンをそのままコピー
                Sheets(strg).Cells(c, r).Value = Sheets(dots).Cells(c Mod dots_size + 1, r).Value
            Else
                '図形パターンが重ならないところは64列前と同じ色にする
                '図形パターンと重なるところは、64-α列前と同じ色にする。これで模様がずれるはず。
                shift = Int(Sheets(ptrn).Cells(c, r).Value * shift_amplitude * dots_size)
                Sheets(strg).Cells(c, r).Value = Sheets(strg).Cells(c, r - dots_size + shift).Value
            End If
            'セル背景色にセル値の色をぬる
            g = Sheets(strg).Cells(c, r).Value
            Sheets(strg).Cells(c, r).Interior.Color = RGB(g, g, g)
            DoEvents
        Next
    Next
    Range(Sheets(strg).Cells(1, 1), Sheets(strg).Cells(img_size_w, img_size_h)).ClearContents
End Function
Function MakeSheet(xMakeSheet As String)
    '既存のシートを削除
    Application.DisplayAlerts = False ' メッセージを非表示
    If ExistsSheet(xMakeSheet) Then Sheets(xMakeSheet).Delete
    Application.DisplayAlerts = True ' メッセージを表示
    'シートを追加
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = xMakeSheet
    'シートを神エクセル方眼紙にする
    px = 3
    Cells.ColumnWidth = px * 0.15
    Cells.RowHeight = px * 1.5
End Function
Function ExistsSheet(bName As String)
    Dim ws As Variant
    ExistsSheet = False
    '全シート繰り返す
    For Each ws In Sheets
        If LCase(ws.Name) = LCase(bName) Then
            ExistsSheet = True ' シートが存在した
            Exit Function
        End If
    Next
End Function