Attribute VB_Name = "PPTshapeList"
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