Powerpointにbeamer風のMPSのナビゲーションバーを追加
-
MPS風のナビゲーションバーをPowerPointで表示するマクロ。Copilotに手伝ってもらいました。ご自由にお使いください。
コピーしてマクロに貼り付けてRunAddWhiteCirclesForSections()を実行してください。セクション名とそのセクションの合計ページ数は
sectionsとPagesの中身を変えてください。
スライドの色に塗りつぶしを変えたい場合は、コード内のRGB(255, 80, 118) の部分をすべて背景と同じ色に変更してください。
普通のbeamer風のものや正準形式じゃない物もあるので、必要な方はご連絡お願いします。
参考画像:
Sub AddWhiteCirclesForSections(sections As Variant, pages As Variant, startPage As Integer, endPage As Integer)
Dim pptSlide As Slide
Dim circleDiameter As Single
Dim marginTop As Single
Dim spacing As Single
Dim slideWidth As Single
Dim totalSections As Integer
Dim totalWidth As Single
Dim sectionWidths() As Single
Dim startX As Single
Dim sectionStartX As Single
Dim i As Integer, j As Integer
Dim currentPage As Integer
Dim newShape As shape
Dim textBox As shape
Dim textBoxWidth As Single
Dim whiteCircleX As Single
Dim hasWhiteCircle As Boolean
Dim verticalLine As shape
' 円の直径（ポイント単位）
circleDiameter = 10.7
' 上側の余白
marginTop = 18
' 円同士の間隔
spacing = 3
' スライド幅を取得
slideWidth = ActivePresentation.PageSetup.slideWidth
' セクションの総数を計算
totalSections = UBound(sections) - LBound(sections) + 1
' 各セクションの幅を計算
ReDim sectionWidths(totalSections - 1)
totalWidth = 0
For i = 0 To totalSections - 1
sectionWidths(i) = pages(i) * circleDiameter + (pages(i) - 1) * spacing
totalWidth = totalWidth + sectionWidths(i)
Next i
' セクション間のスペースを均等に配置
Dim interSectionSpacing As Single
interSectionSpacing = (slideWidth - totalWidth) / (totalSections + 1)
' 初期の左位置を計算
startX = interSectionSpacing
' 処理対象のスライド番号を初期化
currentPage = startPage - 1
' プレゼンテーション内のすべてのスライドをループ
For Each pptSlide In ActivePresentation.Slides
' 1ページ目（タイトルスライド）をスキップ
If pptSlide.SlideIndex >= startPage And pptSlide.SlideIndex <= endPage Then
' 処理対象のスライド番号を増加
currentPage = currentPage + 1
' 各セクションに対して処理
sectionStartX = startX
Dim sectionPageSum As Integer
sectionPageSum = 0
For i = 0 To totalSections - 1
sectionPageSum = sectionPageSum + pages(i)
' 丸（または三角）の中心座標を格納する配列
Dim centers(1, 1) As Single
hasWhiteCircle = False ' 白い円があるかどうかをリセット
' 指定された数の丸を上部に配置
For j = 0 To pages(i) - 1
Dim centerX As Single
Dim centerY As Single
centerX = sectionStartX + j * (circleDiameter + spacing) + circleDiameter / 2
centerY = marginTop + circleDiameter / 2
If j = 0 Then
centers(0, 0) = centerX
centers(0, 1) = centerY
ElseIf j = pages(i) - 1 Then
centers(1, 0) = centerX
centers(1, 1) = centerY
End If
If currentPage = sectionPageSum - pages(i) + j + startPage Then
' 現在のスライド番号に対応する丸を塗りつぶす白丸に設定
Set newShape = pptSlide.Shapes.AddShape(msoShapeOval, _
sectionStartX + j * (circleDiameter + spacing), _
marginTop, _
circleDiameter, _
circleDiameter)
newShape.Fill.ForeColor.RGB = RGB(255, 255, 255) ' 塗りつぶしを白に設定
newShape.Line.ForeColor.RGB = RGB(255, 255, 255) ' 枠線を白に設定
hasWhiteCircle = True
whiteCircleX = centerX
ElseIf currentPage > sectionPageSum - pages(i) + j + startPage Then
' 現在のスライド番号より左の丸を左下向きの直角三角形に設定
If j = Int(pages(i) / 2) Then
Set newShape = pptSlide.Shapes.AddShape(msoShapeOval, _
sectionStartX + j * (circleDiameter + spacing), _
marginTop, _
circleDiameter, _
circleDiameter)
newShape.Fill.ForeColor.RGB = RGB(255, 80, 118) ' 塗りつぶしを設定
newShape.Line.ForeColor.RGB = RGB(255, 255, 255) ' 枠線を白に設定
If currentPage - startPage >= sectionPageSum And currentPage > sectionPageSum - pages(i) + startPage - 1 Then
newShape.Line.ForeColor.RGB = RGB(192, 192, 192) ' 枠線を灰に設定
End If
Else
Set newShape = pptSlide.Shapes.AddShape(msoShapeRightTriangle, _
sectionStartX + j * (circleDiameter + spacing), _
marginTop + 1, _
circleDiameter, _
circleDiameter)
newShape.Rotation = 180 ' 左下向きに回転
If j > pages(i) / 2 Then
newShape.Rotation = 90 '左下向きに回転
End If
newShape.Fill.ForeColor.RGB = RGB(255, 80, 118) ' 塗りつぶしを設定
newShape.Line.ForeColor.RGB = RGB(255, 255, 255) ' 枠線を白に設定
If currentPage - startPage >= sectionPageSum And currentPage > sectionPageSum - pages(i) + startPage - 1 Then
newShape.Line.ForeColor.RGB = RGB(192, 192, 192) ' 枠線を灰に設定
End If
End If
Else
' その他の丸を灰色の塗りつぶしなしに設定
Set newShape = pptSlide.Shapes.AddShape(msoShapeOval, _
sectionStartX + j * (circleDiameter + spacing), _
marginTop, _
circleDiameter, _
circleDiameter)
newShape.Fill.ForeColor.RGB = RGB(255, 80, 118) ' 塗りつぶしを設定
newShape.Line.ForeColor.RGB = RGB(192, 192, 192) ' 枠線を灰色に設定
End If
newShape.Line.Visible = msoTrue
newShape.Tags.Add "SectionShape", "True"
' 縦の短い線を追加
Set verticalLine = pptSlide.Shapes.AddLine(centerX, centerY, centerX, centerY + circleDiameter / 2 + 5)
verticalLine.Line.ForeColor.RGB = newShape.Line.ForeColor.RGB
verticalLine.Line.Weight = 1
verticalLine.Tags.Add "SectionVerticalLine", "True"
verticalLine.ZOrder msoSendToBack
Next j
' 白丸列の中央にセクション名をテキストボックスで配置
textBoxWidth = sectionWidths(i) + 100
Set textBox = pptSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, _
sectionStartX - (textBoxWidth - sectionWidths(i)) / 2, _
marginTop - 20, _
textBoxWidth, _
12) ' テキストボックスの高さを12ポイントに設定
textBox.Tags.Add "SectionTextBox", "True" ' タグを付ける
textBox.TextFrame.TextRange.Text = sections(i)
textBox.TextFrame.TextRange.Font.Size = 14 ' フォントサイズを14ptに設定
textBox.TextFrame.TextRange.Font.Bold = msoTrue ' 太字を設定
If currentPage - startPage + 1 <= sectionPageSum And currentPage > sectionPageSum - pages(i) + startPage - 1 Then
textBox.TextFrame.TextRange.Font.Color.RGB = RGB(255, 255, 255) ' テキストの色を白に設定
Else
textBox.TextFrame.TextRange.Font.Color.RGB = RGB(192, 192, 192) ' テキストの色を灰色に設定
End If
textBox.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
textBox.TextFrame.VerticalAnchor = msoAnchorMiddle
textBox.Fill.Visible = msoFalse ' 背景を透明に設定
textBox.Line.Visible = msoFalse ' 枠線を非表示に設定
' 白い円より左側の線を灰色にするために線を追加
If hasWhiteCircle Then
Dim overlayLine As shape
Set overlayLine = pptSlide.Shapes.AddLine(centers(0, 0), centers(0, 1), whiteCircleX, centers(0, 1))
overlayLine.Line.ForeColor.RGB = RGB(255, 255, 255) ' 線の色を灰色に設定
overlayLine.Line.Weight = 1 ' 線の太さを設定
overlayLine.Tags.Add "SectionLineOverlay", "True" ' タグを付ける
overlayLine.ZOrder msoSendToBack
End If
' 丸（または三角）の端と端を繋ぐ線を引く
Dim lineShape As shape
Set lineShape = pptSlide.Shapes.AddLine(centers(0, 0), centers(0, 1), centers(1, 0), centers(1, 1) - 0.5)
lineShape.Line.ForeColor.RGB = RGB(192, 192, 192) ' 線の色を灰色に設定
lineShape.Line.Weight = 1 ' 線の太さを設定
lineShape.Tags.Add "SectionLine", "True" ' タグを付ける
lineShape.ZOrder msoSendToBack ' 最背面に移動
' 次のセクションのスタート位置を計算
sectionStartX = sectionStartX + sectionWidths(i) + interSectionSpacing
Next i
ElseIf (pptSlide.SlideIndex < startPage And pptSlide.SlideIndex > 1) Or (pptSlide.SlideIndex = endPage + 1) Then
' 2ページ目はすべて灰色の塗りつぶしなし
sectionStartX = startX
For i = 0 To totalSections - 1
For j = 0 To pages(i) - 1
Set newShape = pptSlide.Shapes.AddShape(msoShapeOval, _
sectionStartX + j * (circleDiameter + spacing), _
marginTop, _
circleDiameter, _
circleDiameter)
newShape.Fill.Visible = msoFalse ' 塗りつぶしを非表示
newShape.Line.ForeColor.RGB = RGB(192, 192, 192) ' 枠線を灰色に設定
newShape.Line.Visible = msoTrue
newShape.Tags.Add "SectionShape", "True"
' 縦の短い線を追加
centerX = sectionStartX + j * (circleDiameter + spacing) + circleDiameter / 2
centerY = marginTop + circleDiameter / 2
Set verticalLine = pptSlide.Shapes.AddLine(centerX, centerY + circleDiameter / 2, centerX, centerY + circleDiameter / 2 + 5)
verticalLine.Line.ForeColor.RGB = newShape.Line.ForeColor.RGB
verticalLine.Line.Weight = 1
verticalLine.Tags.Add "SectionVerticalLine", "True"
Next j
' セクション名をテキストボックスで配置
textBoxWidth = sectionWidths(i) + 100
Set textBox = pptSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, _
sectionStartX - (textBoxWidth - sectionWidths(i)) / 2, _
marginTop - 24, _
textBoxWidth, _
12) ' テキストボックスの高さを12ポイントに設定
textBox.Tags.Add "SectionTextBox", "True" ' タグを付ける
textBox.TextFrame.TextRange.Text = sections(i)
textBox.TextFrame.TextRange.Font.Size = 14 ' フォントサイズを14ptに設定
textBox.TextFrame.TextRange.Font.Bold = msoTrue ' 太字を設定
textBox.TextFrame.TextRange.Font.Color.RGB = RGB(192, 192, 192) ' テキストの色を灰色に設定
textBox.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
textBox.TextFrame.VerticalAnchor = msoAnchorMiddle
textBox.Fill.Visible = msoFalse ' 背景を透明に設定
textBox.Line.Visible = msoFalse ' 枠線を非表示に設定
sectionStartX = sectionStartX + sectionWidths(i) + interSectionSpacing
Next i
End If
Next pptSlide
MsgBox "すべてのスライドにセクションごとの白丸とテキストを配置しました！（タイトルスライドは除外）"
End Sub
Sub RemoveWhiteCirclesAndText()
Dim pptSlide As Slide
Dim shape As shape
' プレゼンテーション内のすべてのスライドをループ
For Each pptSlide In ActivePresentation.Slides
' スライド内のすべてのシェイプを逆順にループ（削除時のインデックスエラーを防ぐため）
For i = pptSlide.Shapes.Count To 1 Step -1
Set shape = pptSlide.Shapes(i)
' タグを持つシェイプを削除
If shape.Tags("SectionShape") = "True" Or shape.Tags("SectionTextBox") = "True" Or shape.Tags("SectionLine") = "True" Or shape.Tags("SectionLineOverlay") = "True" Or shape.Tags("SectionVerticalLine") = "True" Then
shape.Delete
End If
Next i
Next pptSlide
End Sub
' サンプル呼び出し
Sub RunAddWhiteCirclesForSections()
Dim sections As Variant
Dim pages As Variant
Dim startPage As Integer
Dim endPage As Integer
Call RemoveWhiteCirclesAndText
' 配列をVariant型で定義
sections = Array("背景", "TRGの基礎", "研究 (アルゴリズム)", "研究 (数値計算)", "まとめ")
pages = Array(3, 21, 5, 16, 3)
' 開始ページと終了ページを指定
startPage = 4
endPage = 51 ' 例として51ページ目まで
Call AddWhiteCirclesForSections(sections, pages, startPage, endPage)
End Sub