PowerPointで六角形のハニカム構造パターンを作るマクロ

PowerPointで六角形の図形をタイル状に並べてハニカム構造のパターンを作るマクロ「ハニカム」をご紹介します。

Illustratorでパターンオプションのタイルの種類を「六角形」に設定して図形を並べた状態のパターンが作れるマクロです。

この記事の目次

ハニカム構造を作成するマクロ
ハニカムでいろんな図形を並べてみよう！
正六角形を作る

ハニカム構造を作成するマクロ

コード

Sub ハニカム()

    Dim copyNum As String
    Dim shpW As Single
    Dim shpH As Single
    Dim n As Long
    Dim shp As Shape
    Dim List() As Variant
    
    'コピー数を入力
    copyNum = InputBox("コピー数を入力してください。")
    
    '数値以外が入力された場合はマクロを終了
    If IsNumeric(copyNum) Then
        ElseIf copyNum = "" Then
        Exit Sub
    Else
        msg = "数値を入力してください。"
        MsgBox msg
        Exit Sub
    End If
    
    '六角形のサイズ
    shpW = Round(2.2 * 720 / 25.4, 1)
    shpH = Round(2 * 720 / 25.4, 1)
    
    '選択中のスライド番号を取得
    n = ActiveWindow.Selection.SlideRange.SlideIndex
    
    With ActivePresentation.Slides(n).Shapes

        '縦方向に繰り返し処理
        For i = 1 To copyNum
        
            '六角形を作成
            Set shp = .AddShape( _
            Type:=msoShapeHexagon, _
            Left:=0, _
            Top:=shpH * (i - 1), _
            Width:=shpW, _
            Height:=shpH)
        
            '図形の色
            shp.Fill.ForeColor.RGB = RGB(255, 255, 255)
            '線幅
            shp.Line.Weight = 1
            '線の色
            shp.Line.ForeColor.RGB = RGB(0, 0, 0)
            '図形の名前
            shp.Name = "shp" & i
            
        Next i
    
        'すべての図形を配列に追加
        For a = 1 To copyNum
            ReDim Preserve List(a)
            List(a) = "shp" & a
        Next a

        'すべての図形をグループ化
        .Range(List).Group
        'グループ化した図形をコピー
        .Range.Copy
        'グループ化解除
        .Range.Ungroup
   
        '横方向に繰り返し処理
        For i = 1 To copyNum
        
            'グループ化した図形をペースト
            With .Paste
            
                '横位置
                .Left = Round(1.7 * 720 / 25.4, 1) * i
                '偶数、奇数の判定
                If (i Mod 2) = 0 Then
                    '偶数列の縦位置
                    .Top = 0
                Else
                    '奇数列の縦位置
                    .Top = Round(1 * 720 / 25.4, 1)
                End If
                'グループ化解除
                .Ungroup
                
            End With
        Next i
    End With
End Sub