趣味プログラミングblog

シェイプ一覧の取得→エクセルを編集→リネーム実行という流れになるわけだけど
一発もののためにそんな作業を毎度やるのがめんどくさくなって
シェイプ一覧を作成する段階で名称を変更するマクロに改造してしまった。


エクセルとパワポは非連動なので、名称変更する処理については、
シェイプ一覧の再取得を行って差分がなければ名称変更するような処理にするべきだけど
そこまではできてない。

---

前置きはこのくらいにして、中身の話。
まずは転記対象の選定。

スライド番号、シェイプ番号、シェイプタイプ、シェイプ名あたりは欲しいところ。
シェイプ名は置換するので、変換後のシェイプ名もタイトルに加える。
シェイプの位置やテキストも取ったら増えてきちゃった。

テーブルの中の右上の文字も取ることにしたので、列番号もついでに出力することにした。

Dim tGyo As Long: tGyo = 3
Cells(1, 1) = tarPP.Name
Cells(tGyo, 1) = "No."
Cells(tGyo, 2) = "sld."
Cells(tGyo, 3) = "shp"
Cells(tGyo, 4) = "タイプ"
Cells(tGyo, 5) = "名前"
Cells(tGyo, 6) = "変換後"
Cells(tGyo, 7) = "Left"
Cells(tGyo, 8) = "Top"
Cells(tGyo, 9) = "Contents"
Cells(tGyo, 10) = "cols"

---

処理字体は割と単純。

まずはパワポを扱うので以下のおまじない。

Dim ppApp As Object: Set ppApp = CreateObject("PowerPoint.Application")
If ppApp.Visible = 0 Then errorEnd ("解析対象のPPTを開いてから実行してください。")
Dim tarPP As Object: Set tarPP = ppApp.ActivePresentation

これで、エクセル側のオブジェクト「tarPP」でパワポのActivePresentationを操作できる。


スライドループとシェイプループで、tarPP内の全シェイプに対して処理を実行。

シェイプタイプによって異なるけど、タイトルとかは以下の書き方で文字列を取得できる。
tarPP.slides(sld).Shapes(shp).TextFrame.TextRange.text


シェイプがテーブルの場合は以下のようにめっちゃ長くなる。（左上を取得する場合）
tarPP.slides(sld).Shapes(shp).Tabl.cell(1,1).Shape.TextFrame.TextRange.text

今回は右上のセルなので、tarTBLを定義して
tarTBL.cell(1, tarTBL.Columns.Count)で右上を指定した。

テーブルとそれ以外で文字の取り方が異なるし、図の場合は文字列を取れないので、
tarPP.slides(sld).Shapes(shp).Typeを使ってタイプ判定して処理を分岐した。


テーブルを作るメリットとして、ファイル内にどんなオブジェクトがあるか一覧表示されるので、プログラムの分岐条件を決めるのに試行錯誤しなくて済む。

PowerPointをVBAで扱う場合は、一覧表示しておいて損はないかも。


そんな感じで以下、ソース。
ソースコードファイルは こちら。

---

Option Explicit

Sub PowerPointのシェイプ一覧を取得()
Dim ppApp As Object: Set ppApp = CreateObject("PowerPoint.Application")
If ppApp.Visible = 0 Then errorEnd ("解析対象のPPTを開いてから実行してください。")
Dim tarPP As Object: Set tarPP = ppApp.ActivePresentation
Dim tarTBL As Object, tblText As String

Const strNewName = "targetTable"
Const strNewName2 = "targetTitle"

Dim txtBuf As String

'出力先の初期化
Dim tGyo As Long: tGyo = 3
range(Cells(4, 1), Cells(Rows.Count, Columns.Count)).ClearContents
Cells(1, 1) = tarPP.Name
Cells(tGyo, 1) = "No."
Cells(tGyo, 2) = "sld."
Cells(tGyo, 3) = "shp"
Cells(tGyo, 4) = "タイプ"
Cells(tGyo, 5) = "名前"
Cells(tGyo, 6) = "変換後"
Cells(tGyo, 7) = "Left"
Cells(tGyo, 8) = "Top"
Cells(tGyo, 9) = "Contents"
Cells(tGyo, 10) = "cols"

Dim cnt As Long

Const debugFlag = 0
Dim figType As Long '.ActivePresentation.Slides(sld).Shapes(shp).Type
Dim sld As Long, eSld As Long
Dim shp As Long, eShp As Long
eSld = tarPP.slides.Count
For sld = 1 To eSld
For shp = 1 To tarPP.slides(sld).Shapes.Count
'Set tarShp = tarPP.Slides(sld).Shapes(shp) プロパティ確認用に定義（デバッグ用）
With tarPP.slides(sld).Shapes(shp)
cnt = cnt + 1
Cells(tGyo + cnt, 1) = cnt
Cells(tGyo + cnt, 2) = sld
Cells(tGyo + cnt, 3) = shp
Cells(tGyo + cnt, 4) = .Type
Cells(tGyo + cnt, 5) = .Name
Cells(tGyo + cnt, 6) = .Name
Cells(tGyo + cnt, 7).NumberFormatLocal = "0.0"
Cells(tGyo + cnt, 7) = .Left
Cells(tGyo + cnt, 8).NumberFormatLocal = "0.0"
Cells(tGyo + cnt, 8) = .Top

If .Type = 19 Then 'table
Set tarTBL = .Table
tblText = tarTBL.cell(1, tarTBL.Columns.Count).Shape.TextFrame.TextRange.text
If tarTableCheck(tblText) Then
.Name = strNewName '名称を変更
Cells(tGyo + cnt, 5) = .Name
Cells(tGyo + cnt, 6) = .Name
End If
Cells(tGyo + cnt, 9) = "cell(1," & tarTBL.Columns.Count & ")=" & tblText
Cells(tGyo + cnt, 10) = tarTBL.Columns.Count
ElseIf .Type = 13 Then 'picture
Else
txtBuf = .TextFrame.TextRange.text
If Right(txtBuf, 6) = "月レポート】" Then
.Name = strNewName2 '名称を変更
Cells(tGyo + cnt, 5) = .Name
Cells(tGyo + cnt, 6) = .Name
End If
Cells(tGyo + cnt, 9) = txtBuf

End If
End With
Next shp
Next sld
End Sub


Function tarTableCheck(tblText As String) As Boolean
If tblText = "情報" Or tblText = "空きメモリ" Or tblText = "CPU使用率" Or tblText = "ディスク空き容量" Then
tarTableCheck = True
Else
tarTableCheck = False
End If
End Function



Sub PowerPointのシェイプ名を置換()

Dim ppApp As Object: Set ppApp = CreateObject("PowerPoint.Application")
If ppApp.Visible = 0 Then errorEnd ("作業対象のPPTを開いてから実行してください。")
Dim tarPP As Object: Set tarPP = ppApp.ActivePresentation
If tarPP.Name <> Cells(1, 1) Then errorEnd ("PPTファイル名が一致しないため中断します。")

Dim Gyo As Long
Dim edGyo As Long: edGyo = Cells(Rows.Count, 1).End(xlUp).Row

For Gyo = 4 To edGyo
If Cells(Gyo, "E") <> Cells(Gyo, "F") Then
tarPP.slides(Cells(Gyo, "B") - 0).Select
tarPP.slides(Cells(Gyo, "B") - 0).Shapes(Cells(Gyo, "E")).Name = Cells(Gyo, "F")
End If
Next Gyo

End Sub



Private Sub errorEnd(msg)
MsgBox msg
End
End Sub