PowerPoint2010のマクロに関して

質問

現在, パワポのマクロをVBAで作成しているのですが,
ネット上でも資料が少なくて困っています。

マクロの内容は、ページ内に
総ページ数から現在のページがどの程度進んでいるかを図で表すようなもの
を設置するといったものです。
図は、総ページ3ページなら
■□□　←　1ページ

■■□　←　2ページ
といった感じです。

現在、四角を配置することまではできたのですが、
その四角の色を変更することができなくて迷っています。
ソースコードは以下のように書いています。

Sub ページ進行表示()

Dim PCount
Dim Color1, Color2
Color1 = RGB(255, 0, 0)
Color2 = RGB(255, 180, 180)

ActivePresentation.Slides(1).Select
PCount = ActivePresentation.Slides.Count

For i = 1 To PCount
ActivePresentation.Slides(i).Select
For j = 1 To PCount
ActivePresentation.Slides.Item(i).Shapes.AddShape(msoShapeRectangle, 10 + (j * 10), 10, 5, 20).Select
ActivePresentation.Slides.Item(i).Shapes(i).Fill.ForeColor = Color
Next
Next

End Sub

追加した図形を選択して色を変更する方法を教えてください

回答No.1

DreamyCat · ベストアンサー

＜＜ネット上でも資料が少なくて困っています。＞＞
そうだと思いますが、私の場合はすべて「ヘルプ」しか使いません。

いくつか間違いがありましたので以下のように。

Option Explicit

Sub ページ進行表示()
Dim i As Long, j As Long
Dim PCount As Long
Dim Color1, Color2
Color1 = RGB(255, 0, 0)
Color2 = RGB(255, 180, 180)

ActivePresentation.Slides(1).Select
PCount = ActivePresentation.Slides.Count

For i = 1 To PCount
ActivePresentation.Slides(i).Select
For j = 1 To PCount
ActivePresentation.Slides.Item(i).Shapes.AddShape(msoShapeRectangle, 10 + (j * 10), 10, 5, 20).Select
ActivePresentation.Slides(i).Shapes(ActivePresentation.Slides(i).Shapes.Count).Fill.ForeColor.RGB = Color1
Next
'DoEvents: DoEvents
Next

End Sub

回答No.2

Siegrune

## 余計なお世話なんですが。

私なら四角を使わずにテキストボックスでやってしまいます。
ページ数が多ければ、判断する処理を加えて.Sizeを小さくするだけですむし。
例）適当ですいません。（色も変数にしたほうがいいし、省略できるのも多いんだけど。）
Sub ページ進行表示()

Dim PCount

ActivePresentation.Slides(1).Select
PCount = ActivePresentation.Slides.Count

For i = 1 To PCount
ActivePresentation.Slides(i).Select
ActivePresentation.Slides.Item(i).Shapes.AddTextbox(msoTextOrientationHorizontal, 48.125, 485.5, 266.5, 28.875).Select
ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Characters(Start:=1, Length:=0).Select
With ActiveWindow.Selection.TextRange
.Text = String(i - 1, "■")
With .Font
.NameAscii = "Arial"
.NameFarEast = "ＭＳ Ｐゴシック"
.NameOther = "Arial"
.Size = 18
.Bold = msoFalse
.Italic = msoFalse
.Underline = msoFalse
.Shadow = msoFalse
.Emboss = msoFalse
.BaselineOffset = 0
.AutoRotateNumbers = msoTrue
.Color.RGB = RGB(Red:=0, Green:=0, Blue:=153)
End With
End With
ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Characters(Start:=i, Length:=0).Select
With ActiveWindow.Selection.TextRange
.Text = "■"
With .Font
.NameAscii = "Arial"
.NameFarEast = "ＭＳ Ｐゴシック"
.NameOther = "Arial"
.Size = 18
.Bold = msoFalse
.Italic = msoFalse
.Underline = msoFalse
.Shadow = msoFalse
.Emboss = msoFalse
.BaselineOffset = 0
.AutoRotateNumbers = msoTrue
.Color.RGB = RGB(Red:=0, Green:=153, Blue:=0)
End With
End With
If i < PCount Then
ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Characters(Start:=i + 1, Length:=0).Select
With ActiveWindow.Selection.TextRange
.Text = String(PCount - i, "□")
With .Font
.NameAscii = "Arial"
.NameFarEast = "ＭＳ Ｐゴシック"
.NameOther = "Arial"
.Size = 18
.Bold = msoFalse
.Italic = msoFalse
.Underline = msoFalse
.Shadow = msoFalse
.Emboss = msoFalse
.BaselineOffset = 0
.AutoRotateNumbers = msoTrue
.Color.RGB = RGB(Red:=0, Green:=153, Blue:=0)
End With
End With
End If
Next
End Sub

>パワポのマクロをVBAで作成しているのですが,
>ネット上でも資料が少なくて困っています。
私は基本的には、「新しいマクロの記録」ばっかりです。