【PowerPoint】色のついた四角形を並べる

Attribute VB_Name = "色四角"
Option Explicit
'   DocumentWindow object
'   Presentation object     プレゼンテーション
'   └Slide object          スライド
'     └Shape object        図形、Text box等
Sub 色四角を作成し配置()
    Dim sld_w As Single                     ' スライドの幅  (=ActiveWindow.Selection.SlideRange.Master.Width)
    Dim sld_h As Single                     ' スライドの高さ(=ActiveWindow.Selection.SlideRange.Master.Height)
' *** 図形を描くスライドの準備 ***
    Call set_slide                          ' 最後に白紙スライド追加
    ' スライドのサイズを取得
    With ActiveWindow.Selection
        sld_w = .SlideRange.Master.Width
        sld_h = .SlideRange.Master.Height
    End With
' *** 描画1：RGBグラデーション ***
    Call RGBW_32gradation(sld_w, sld_h)     ' R/G/B/Y/C/M/Wのグラデーション
' *** 図形を描くスライドの準備 ***
    Call set_slide                          ' 最後に白紙スライド追加
' *** 描画2：RGBグラデーション ***
    Call Hue_32gradation(sld_w, sld_h)      ' R/Y/G/C/B/M/Rのグラデーション
End Sub


Function set_slide()
'-------------------------------------------------------------------
' 関数: set_slide
' 説明: 現在のプレゼンテーションに白紙スライドを追加し、
'       最後のスライドへ移動します｡
' 引数:
'   なし
' 戻り値:
'   なし
'
' 使用例:
'       Call set_slide
'-------------------------------------------------------------------
'    ' ウィンドウの最大化
'    Application.ActiveWindow.WindowState = ppWindowMaximized
' Application.WindowState プロパティ (PowerPoint) | Microsoft Learn
' https://learn.microsoft.com/ja-jp/office/vba/api/powerpoint.application.windowstate
'        1 : ppWindowNormal
'        2 : ppWindowMinimized
'        3 : ppWindowMaximized
    ' 白紙スライドを末尾に挿入
    With ActivePresentation.Slides
        .Add _
            Index:=.Count + 1, _
            Layout:=ppLayoutBlank
    End With
    ' 最後のスライドに切り替える
    ActiveWindow.View.GotoSlide _
        Index:=ActivePresentation.Slides.Count
End Function


Function DrawSquare(ByVal shp_x As Single, ByVal shp_y As Single, _
                    ByVal shp_w As Single, ByVal shp_h As Single, _
                    ByVal R As Single, ByVal G As Single, ByVal B As Single)
'-------------------------------------------------------------------
' 関数: DrawSquare
' 説明: 指定した座標位置(shp_x, shp_y)とサイズ(shp_w, shp_h)に基づいて、
'       スライド上にRGB値(R, G, B)で塗りつぶされた四角形を描画
'       四角形は塗りつぶしの透明度および枠線の設定も同時に実施｡
' 引数:
'   shp_x      - 四角形の左上隅のX座標 (Single型)
'   shp_y      - 四角形の左上隅のY座標 (Single型)
'   shp_w      - 四角形の幅 (Single型)
'   shp_h      - 四角形の高さ (Single型)
'   R          - 塗りつぶし色の赤色成分 (Single型, 0～255)
'   G          - 塗りつぶし色の緑色成分 (Single型, 0～255)
'   B          - 塗りつぶし色の青色成分 (Single型, 0～255)
' 戻り値:
'   なし
'
' 使用例:
'   ' X=50, Y=50 の位置に幅200、高さ100 の青色系の四角形を描画
'   DrawSquare(50, 50, 200, 100, 0, 0, 255)
'-------------------------------------------------------------------
    Dim myDocument As Object
    Set myDocument = ActivePresentation.Slides(ActivePresentation.Slides.Count)
    With myDocument.Shapes.AddShape _
        (msoShapeRectangle, shp_x, shp_y, shp_w, shp_h)
            .Fill.ForeColor.RGB = RGB(R, G, B)      '塗りつぶしの色
            .Fill.Transparency = 0                  '塗りつぶしの透明度(0で不透明)
            .Line.Weight = 0                        '枠線の線幅(0で枠線なし)
            .Line.ForeColor.RGB = RGB(R, G, B)      '線の色
    End With
End Function


Function RGBW_32gradation(ByVal sld_w As Single, ByVal sld_h As Single)
'-------------------------------------------------------------------
' 関数: RGBW_32gradation
' 説明: 指定したスライドの幅(sld_w)と高さ(sld_h)に基づいて、
'       スライド上に7色×2行(計32階調/色)のグラデーションの
'       四角形を描画
'       7色は上からR/G/B/Y/C/M/W
' 引数:
'   sld_w      - スライドの幅 (Single型)
'   sld_h      - スライドの高さ (Single型)
' 戻り値:
'   なし
'
' 使用例:
'   ' 幅960、高さ540のスライドにグラデーションを描画する
'   Call RGBW_32gradation(960, 540)
'-------------------------------------------------------------------
    Dim shp_x As Single                 ' 四角形の左上隅のX座標
    Dim shp_y As Single                 ' 四角形の左上隅のY座標
    Dim shp_w As Single                 ' 四角形の幅
    Dim shp_h As Single                 ' 四角形の高さ
    Dim shp_r As Single                 ' 四角形の色(R)
    Dim shp_g As Single                 ' 四角形の色(G)
    Dim shp_b As Single                 ' 四角形の色(B)
    Dim R As Single, G As Single, B As Single
    Const Tone = 32                     ' 32階調
    Dim tone_s As Single
        tone_s = Round(256 / Tone, 0)   ' 1stepの減色量
    ' 四角のサイズを決定
    shp_w = sld_w / (Tone / 2)          ' 横方向：32階調 = 16階調×2行
    shp_h = sld_h / (7 * 2)             ' 縦方向：7色×2行
    ' 色の初期化(ベースは白)
    shp_r = 255
    shp_g = 255
    shp_b = 255
    ' 描画
    ' 各セルの位置に応じ、RGB各成分を横方向(shp_x)と縦方向(shp_y)で段階的に減少させ、
    ' 7種類の色パターンの四角形を描画。
    ' 1) 横方向: 左から右へ、1cellあたりtone_sずつ減算
    '    255から8ずつ減算(shp_x/shp_w：0～15→255～135)
    ' 2) 縦方向: 2段目はさらに減色量を加算して減算
    '    127(255-16×8)から8ずつ減算(127～7)
    For shp_y = 0 To shp_h * 2 - 1 Step shp_h   '縦(四角形の高さ×２)
        For shp_x = 0 To sld_w - 1 Step shp_w   '横(スライドの幅)
            R = shp_r - shp_x / shp_w * tone_s - (Tone / 2) * tone_s * shp_y / shp_h
            G = shp_g - shp_x / shp_w * tone_s - (Tone / 2) * tone_s * shp_y / shp_h
            B = shp_b - shp_x / shp_w * tone_s - (Tone / 2) * tone_s * shp_y / shp_h
            Call DrawSquare(shp_x, shp_y + 0 * shp_h, shp_w, shp_h, R, 0, 0)    ' R00 (R)
            Call DrawSquare(shp_x, shp_y + 2 * shp_h, shp_w, shp_h, 0, G, 0)    ' 0G0 (G)
            Call DrawSquare(shp_x, shp_y + 4 * shp_h, shp_w, shp_h, 0, 0, B)    ' 00B (B)
            Call DrawSquare(shp_x, shp_y + 6 * shp_h, shp_w, shp_h, R, G, 0)    ' RG0 (Y)
            Call DrawSquare(shp_x, shp_y + 8 * shp_h, shp_w, shp_h, 0, G, B)    ' 0GB (C)
            Call DrawSquare(shp_x, shp_y + 10 * shp_h, shp_w, shp_h, R, 0, B)   ' R0B (M)
            Call DrawSquare(shp_x, shp_y + 12 * shp_h, shp_w, shp_h, R, G, B)   ' RGB (W)
       Next
    Next
End Function


Function Hue_32gradation(ByVal sld_w As Single, ByVal sld_h As Single)
'-------------------------------------------------------------------
' 関数: Hue_32gradation
' 説明: 指定したスライドの幅(sld_w)と高さ(sld_h)に基づいて、
'       スライド上に色相を変化させたグラデーションの四角形を描画。
'       下記のRGB値の増減法を用いて、6種類の色相パターンを2行に
'       配し、計12段階の色変化を表現。
'       ・各色相パターン
'         000-060:  赤固定 (255)、青固定 (0)、緑が増加 (0～255)
'         060-120:  緑固定 (255)、青固定 (0)、赤が減少 (255～0)
'         120-180:  緑固定 (255)、赤固定 (0)、青が増加 (0～255)
'         180-240:  青固定 (255)、赤固定 (0)、緑が減少 (255～0)
'         240-300:  青固定 (255)、緑固定 (0)、赤が増加 (0～255)
'         300-360:  赤固定 (255)、緑固定 (0)、青が減少 (255～0)
' 引数:
'   sld_w      - スライドの幅 (Single型)
'   sld_h      - スライドの高さ (Single型)
' 戻り値:
'   なし
'
' 使用例:
'   ' 幅960、高さ540のスライドにグラデーションを描画する
'   Call Hue_32gradation(960, 540)
'-------------------------------------------------------------------
    Dim shp_x As Single                 ' 四角形の左上隅のX座標
    Dim shp_y As Single                 ' 四角形の左上隅のY座標
    Dim shp_w As Single                 ' 四角形の幅
    Dim shp_h As Single                 ' 四角形の高さ
    Dim shp_r As Single                 ' 四角形の色(R)
    Dim shp_g As Single                 ' 四角形の色(G)
    Dim shp_b As Single                 ' 四角形の色(B)
    Dim R As Single, G As Single, B As Single
    Const Tone = 32                     ' 32階調
    Dim tone_s As Single
        tone_s = Round(256 / Tone, 0)   ' 1stepの減色量
    ' 四角のサイズを決定
    shp_w = sld_w / (Tone / 2)          ' 横方向：32階調 = 16階調×2行
    shp_h = sld_h / (6 * 2)             ' 縦方向：6色×2行
    ' 色の初期化(ベースは白)
    shp_r = 255
    shp_g = 255
    shp_b = 255
    ' 描画
    ' 各セルの位置に応じ、RGB各成分を横方向(shp_x)と縦方向(shp_y)で段階的に減少させ、
    ' 色パターンの四角形を描画。
    ' 1) 横方向: 左から右へ、1cellあたりtone_sずつ減算
    '    255から8ずつ減算(shp_x/shp_w：0～15→255～135)
    ' 2) 縦方向: 2段目はさらに減色量を加算して減算
    '    127(255-16×8)から8ずつ減算(127～7)
    ' -------------------------------------------
    ' 色の計算例
    '       R = shp_r - shp_x / shp_w * 8 - 16 * 8 * shp_y / shp_h
    '       G = shp_g - shp_x / shp_w * 8 - 16 * 8 * shp_y / shp_h
    '       B = shp_b - shp_x / shp_w * 8 - 16 * 8 * shp_y / shp_h
    ' -------------------------------------------
    For shp_y = 0 To shp_h * 2 - 1 Step shp_h   '縦(四角形の高さ×２)
        For shp_x = 0 To sld_w - 1 Step shp_w   '横(スライドの幅)
            G = shp_x / shp_w * tone_s + (Tone / 2) * tone_s * shp_y / shp_h
                Call DrawSquare(shp_x, shp_y + 0 * shp_h, shp_w, shp_h, 255, G, 0)      ' 255G++000
            R = shp_r - shp_x / shp_w * tone_s - (Tone / 2) * tone_s * shp_y / shp_h    ' :  :  :
                Call DrawSquare(shp_x, shp_y + 2 * shp_h, shp_w, shp_h, R, 255, 0)      ' R--255000
            B = shp_x / shp_w * tone_s + (Tone / 2) * tone_s * shp_y / shp_h            ' :  :  :
                Call DrawSquare(shp_x, shp_y + 4 * shp_h, shp_w, shp_h, 0, 255, B)      ' 000255B++
            G = shp_g - shp_x / shp_w * tone_s - (Tone / 2) * tone_s * shp_y / shp_h    ' :  :  :
                Call DrawSquare(shp_x, shp_y + 6 * shp_h, shp_w, shp_h, 0, G, 255)      ' 000G--255
            R = shp_x / shp_w * tone_s + (Tone / 2) * tone_s * shp_y / shp_h            ' :  :  :
                Call DrawSquare(shp_x, shp_y + 8 * shp_h, shp_w, shp_h, R, 0, 255)      ' R++000255
            B = shp_b - shp_x / shp_w * tone_s - (Tone / 2) * tone_s * shp_y / shp_h    ' :  :  :
                Call DrawSquare(shp_x, shp_y + 10 * shp_h, shp_w, shp_h, 255, 0, B)     ' 255000B--
       Next
    Next
End Function


Function Checkerboard_2pattern(ByVal sld_w As Single, ByVal sld_h As Single)
'-------------------------------------------------------------------
' 関数: Checkerboard_2pattern
' 説明: 指定したスライドの幅(sld_w)と高さ(sld_h)に基づいて、
'       スライド上に市松模様のパターンを描画する関数。
'       定数div_countで設定された分割数により、スライドの幅を分割。
' 引数:
'   sld_w      - スライドの幅 (Single型)
'   sld_h      - スライドの高さ (Single型)
' 戻り値:
'   なし
'
' 使用例:
'   ' 幅960、高さ540のスライドに市松模様を描画する
'   Call Checkerboard_2pattern(960, 540)
'-------------------------------------------------------------------
    Dim shp_x As Single                 ' 四角形の左上隅のX座標
    Dim shp_y As Single                 ' 四角形の左上隅のY座標
    Dim shp_w As Single                 ' 四角形の幅
    Dim shp_h As Single                 ' 四角形の高さ
    Dim shp_r As Single                 ' 四角形の色(R)
    Dim shp_g As Single                 ' 四角形の色(G)
    Dim shp_b As Single                 ' 四角形の色(B)
    Dim R As Single, G As Single, B As Single
    Const div_count = 128               ' 分割数
    ' 四角のサイズを決定
    shp_w = sld_w / div_count
    shp_h = shp_w
    ' 色の初期化(ベースは白)
    shp_r = 255
    shp_g = 255
    shp_b = 255
    ' 描画
    For shp_y = 0 To sld_h / shp_h
        For shp_x = 0 To div_count - 1
            If (shp_x Mod 2 = 0) Xor (shp_y Mod 2 = 0) Then
                R = 255
            Else
                R = 0
            End If
            G = R
            B = R
            Call DrawSquare(shp_w * shp_x, shp_h * shp_y, shp_w, shp_h, R, G, B)
       Next
    Next
End Function

　これを使用すると、以下のようなものができる。

(追記)
【PowerPoint】色のついた四角形を並べる #VBA - Qiitaに続く。

You get articles that match your needs
You can efficiently read back useful information
You can use dark theme

What you can do with signing up