三流君のソースコード置き場

ブログにソースコードをアップして、ブログの検索機能で利用してます(利用予定です)

よく検索されるキーワード: [VBA]/ [VBS]/ [CreateObject]/ [Excel]/ [ADO]


蛇足1.パワポのアクティブスライドからオブジェクトの名前をエクセルに落とす

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 VBAPowerPointのタイトルテキストを取得したい 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


youtu.be

挨拶・自己紹介:
失敗続きのAB型の変わり者 :三流プログラマー Ken3です
フリーのエンジニア・個人事業主です・・と書くと聞こえはイイが(それとなくカッコよく聞こえるが)、 現在は小さな案件の受注請負 と 短期派遣 で 日々つつましく?ほそぼそと暮らしてます。
(※詳細は[三流君 三流プログラマーとは?]を見てください)


Ken3 ホームページ 目次

分類:HPを大きく分けると4つの柱(分類)です。
・[Excel/Access VBA]の解説
・[ASP(Active Server Pages)]の解説。
・[元コンビニ店長時代の話]が弟に巻き込まれ、失敗した脱サラ、畑違い?の仕事で失敗。
・[プログラマーの愚痴]では、あまり見せたくない三流プログラマーの内面かな。
三流君を踏み台にする
主に上記4つの分類でHP作成やメルマガの発行を行ってます。
※更新頻度が落ちていて情報の鮮度が悪いです。

三流解説動画の再生リスト
https://www.youtube.com/user/ken3video/playlists

[連絡先はココのフォームから]←連絡先の入力フォームです、気軽に書いてください
本当に三流なんです(笑):たまにスゴイですねなんて言われることもありますが、
真実は→ [三流君の真実は...] ←を初めに見てくださるとわかると思います。
(からくりは、成功例↑しか載せてなくて ヒドイ失敗例はお蔵入り迷宮入りが多かったりします)