Option Explicit '起動済みの既存 パワーポイント スライド .Shapes から テキストを取り出す 'アクティブシートに名前とテキストをセット Sub test20220915ppスライド内シェイプ名取得() Dim ppApp As Object 'As PowerPoint.Application Set ppApp = Nothing On Error Resume Next '取得エラー時に次へ Set ppApp = GetObject(, "PowerPoint.Application") On Error GoTo 0 'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意 If ppApp Is Nothing Then MsgBox "パワポを取得できません。プレゼンスライドを開いてから、再テストしてね" Exit Sub End If Dim r As Range '基準、左上のセル。ここではB5 Set r = Range("b5") Range(r, r.Offset(99, 2)).ClearContents '99行データを決め打ちでクリア '見出しを書き込む r.Range("A1")よりr.Offset(1, 0)と書いた方がよかったかも? r.Range("A1") = "名前 Shape.Name" r.Range("B1") = "テキスト objShape.TextFrame.TextRange.Text" Dim p As Integer, y As Integer 'pページ、y行 Dim objShape As Object 'As PowerPoint.Shape パワポのシェイプ、テキスト、図形ほか y = 1 '取得したテキストデータを二行目から書きたいので p = ppApp.ActiveWindow.Selection.SlideRange.SlideIndex '選択しているページ For Each objShape In ppApp.ActivePresentation.Slides(p).Shapes r.Offset(y, 0) = objShape.Name 'オブジェクトの名前 0列目 'オブジェクトがテキストを持っているか?チェックしてからセット If objShape.HasTextFrame = msoTrue Then 'テキストフレームあり If objShape.TextFrame.HasText = msoTrue Then 'テキスト範囲あり r.Offset(y, 1) = objShape.TextFrame.TextRange.Text '1列目へテキスト End If End If y = y + 1 'セットする行を次へ Next MsgBox "処理終了" End Sub
過去に作成した
www.youtube.com
Excel VBA で PowerPointのタイトルテキストを取得したい Shapes から テキストを取り出す
ken3memo.hatenablog.com
だと、すべて、取得してしまうので、
現在処理中のスライドのみ、データを落とすように変更する。
蛇足2.Excelでアクティブスライドのppオブジェクトに名前を付ける※名前の変更
蛇足2.パワポのアクティブスライドのシェイプ名.Nameに値をセットして変更する
'起動済みのパワーポイント スライド .Shapes の名前 .Name変更
'アクティブシートの名前を使用してセット
Sub test20220915ppスライド内シェイプ名変更() Dim ppApp As Object 'As PowerPoint.Application Set ppApp = Nothing On Error Resume Next '取得エラー時に次へ Set ppApp = GetObject(, "PowerPoint.Application") On Error GoTo 0 'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意 If ppApp Is Nothing Then MsgBox "パワポを取得できません。プレゼンスライドを開いてから、再テストしてね" Exit Sub End If Dim r As Range '基準、左上のセル。ここではB5 Set r = Range("b5") Dim p As Integer, y As Integer 'pページ、y行 Dim objShape As Object 'As PowerPoint.Shape パワポのシェイプ、テキスト、図形ほか Dim 変更前Name As String Dim 変更後Name As String p = ppApp.ActiveWindow.Selection.SlideRange.SlideIndex 'pp変更ページ '見出しの次から処理する.Office(1,0)なのでOffice(y,0) y=1 For y = 1 To 999 '最大999 そのまえにブレイク Exit Forさせるけど 変更前Name = Trim("" & r.Offset(y, 0).Value) 'データセット 変更後Name = Trim("" & r.Offset(y, 1).Value) 'データセット If Len(変更前Name) = 0 Then Exit For 'データ無しの時ループを抜ける '.Nameの変更 Set objShape = Nothing On Error Resume Next '取得エラー時に次へ※名前の禁則文字や重複?エラー Set objShape = ppApp.ActivePresentation.Slides(p).Shapes(変更前Name) '↑ここで、変更前の名前でアクセスできたか?ここで判断する On Error GoTo 0 'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意 If objShape Is Nothing Then 'エラー判断、エラーの時 r.Offset(y, 2).Value = "エラー発生、名前を確認してください" Else r.Offset(y, 2).Value = "" objShape.Name = 変更後Name '.Nameに単純に代入する End If Next y MsgBox "処理終了" End Sub