Excel VBA Offsetを使用して変更に強いコードを作成する例題としてPowerPointの情報をシートへ書き込むテスト

例題としてPowerPointの情報をシートへ書き込むVBAのテストコード
これをOffset対応↓↓↓してみました。
https://youtu.be/XIBG8T3b2mY?si=B7oHpByqEjXkNy3t&t=868
↑3/14のプレミアライブで使用したソースコード:ソースをぶっかけて、アレンジ味変して使ってくださいね。

'起動済みの既存 パワーポイントのスライドから
'パワポのシェイプ情報とイメージjpgをexcelシートへ書き出す
'ex:新規ブックを追加して、pp:スライドの情報をex:シート単位で貼り付ける
Sub test20240312_03ppスライドをページ単位でexシートへ情報を書き出す()

    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
    
    '新規に貼り付け先のExcelブックを作成したいので
    Dim wbNEW As Workbook
    Set wbNEW = Workbooks.Add  '新規ブックの追加
    
    Dim shNEW As Worksheet '新規のシート用に変数を作成する
    
    Dim strJPGNAME As String  '一時保存する名前
    strJPGNAME = ThisWorkbook.Path & "\ppスライドtemp.jpg"

    Dim picShape As Shape  '挿入画像はShapeなので

    Dim p As Integer, y As Integer   'pページ、y行
    Dim objShape As Object  'As PowerPoint.Shape 'パワポのシェイプ、テキスト、図形ほか
    
    'パワポのスライドをExcelシートに
    For p = 1 To ppApp.ActivePresentation.Slides.Count  'スライド数ループ pページ
      'pp画像を用意する 単純に.Exportでテンポラリ画像を作成
        ppApp.ActivePresentation.Slides(p).Export strJPGNAME, "JPG"
        DoEvents  '↑jpgファイルを作成しているので、念のため
        
        '画像をシートへ貼る Pictures.InsertがActiveSheetだったので※後で調べる・・・
        Set shNEW = wbNEW.Sheets.Add(Before:=wbNEW.Worksheets(wbNEW.Worksheets.Count))
        '新規シートを一番後ろに追加するために↑細工してみた

        shNEW.Name = "スライド" & p   'シート名をスライド1,2,3..にする
        shNEW.Columns("A:A").ColumnWidth = 79.5  '列幅を変更する
        
        ' 画像を0,0へ 埋め込み形式で挿入 ファイル名,リンク,保存保持,left,top,Width,Height
        Set picShape = shNEW.Shapes.AddPicture(strJPGNAME, False, True, 0, 0, -1, -1)
        
        picShape.Name = "ppスライド" & p
        picShape.Width = 480   '挿入後幅を調整する
        
      'ここから、シェイプの情報を書きこむ
        '書き込み開始位置の左上のセルを指定して、offictで対応する
        Dim rBASE As Range   '拠点、書き込みの左上を代入する
        Set rBASE = shNEW.Range("B1")

        rBASE.Select
        '0行目に見出しを書き込む
        rBASE.Offset(0, 0) = "Page番号"
        rBASE.Offset(0, 1) = "ID"
        rBASE.Offset(0, 2) = "名前 Shape.Name"
        rBASE.Offset(0, 3) = "種類 .Type"      '※あると便利
        rBASE.Offset(0, 4) = "左位置.Left"     '位置等で絞り込む？時、便利
        rBASE.Offset(0, 5) = "上位置.Top"
        rBASE.Offset(0, 6) = "幅 .Width"    '幅と高さ 24/03/02
        rBASE.Offset(0, 7) = "高さ .Height"
        rBASE.Offset(0, 8) = "テキスト 先頭から10文字"  'テキストがあれば判断時便利かな？
        
        'pページのスライド内のシェイプを探る
        y = 1 '基準の一つ下からセットする
        For Each objShape In ppApp.ActivePresentation.Slides(p).Shapes
            rBASE.Offset(y, 0) = p   'スライド番号(ページ番号)
            rBASE.Offset(y, 1) = objShape.ID    'IDで今回、区別したいので※24/03/02追加
            rBASE.Offset(y, 2) = objShape.Name  'オブジェクトの名前
            rBASE.Offset(y, 3) = objShape.Type  '※種類
         
            rBASE.Offset(y, 4) = objShape.Left  '位置 左上の左 判断材料
            rBASE.Offset(y, 5) = objShape.Top   '位置 左上の縦
         
            rBASE.Offset(y, 6) = objShape.Width '
            rBASE.Offset(y, 7) = objShape.Height
            
            'オブジェクトがテキストを持っているか？チェックしてからセット
            If objShape.HasTextFrame = msoTrue Then 'テキストフレームあり
                If objShape.TextFrame.HasText = msoTrue Then 'テキスト範囲あり
                    rBASE.Offset(y, 8) = Left(objShape.TextFrame.TextRange.Text, 10)
                    'テキストを10文字だけ書き込む↑,99文字など好みの文字で
                End If
            End If
            
            y = y + 1   'セットする行を次へ
            
        Next
        
    Next
    
    MsgBox "処理終了、画像を確認してください"

End Sub

ソースコード:↑ソース↓をぶっかけて、アレンジ味変して使ってくださいね。

コードの詳細は、前回の２つのサンプル
ア.PowerPointスライド内のシェイプ情報をExcelへ
https://www.youtube.com/live/o0PVL1v27Ts?si=tMgpmk38hF_VRvzb&t=178
ken3memo.hatenablog.com

イ.PowerPointスライドイメージをシート別にExcelへ
https://www.youtube.com/live/ingF9kqRRho?si=AHjz4OqXQ_ZaP8GY&t=2359
ken3memo.hatenablog.com

この二つを見てください。
と宣伝を入れつつ、
貴重な昼休みにプレミアライブ配信は、不発かなぁ・・・

4.キッカケのコメントを紹介する

いただいたコメント

k3のプログラムコードを見て、正直に言ってがっかりしました。
向上心がないのは自由ですが、それがコードの質にも影響しています。
適当なコードは、メンテナンス性や効率性に欠け、将来的に大きな問題を引き起こす可能性があります。
k3氏:
Cells.ClearContents '全クリア
Range("A1").Select
'見出しを書き込む
Range("A1") = "Page番号"
Range("B1") = "ID"
Offset使用コード:
'Offsetで対応する
Dim r As Range '拠点
Set r = Range("A1")
r.CurrentRegion.ClearComments '拠点.CurrentRegion

'見出し
r.Offset(0, 0) = "Page番号"
r.Offset(0, 1) = "ID"
あなたは中年という立場で、若手のプロクラマーにとって見本となるべきです。
しかし、あなたのコードは、彼らに悪い影響を与えるだけです。
あなたは自分の仕事に誇りを持ち、もっと真剣に取り組むべきです。
あなたのコードを改善するために、最新の技術やベストプラクティスを学ぶことをお勧めします。
あなたの姿勢とコードを見直してください。

いただいたコメントを元に修正する

5.終わりの挨拶

こんな感じで、OffSetでコードを作成すると、
好みの味に修正しやすいと思います。

自分好みにアレンジして、使ってみてください。

※冒頭と同じURLです
例題としてPowerPointの情報をシートへ書き込むテスト
これをOffset対応してみました。
https://youtu.be/XIBG8T3b2mY?si=B7oHpByqEjXkNy3t&t=868
↑3/14のプレミアライブで使用したソースコード:ソースをぶっかけて、アレンジ味変して使ってくださいね。

#ExcelVBA #Offset #オフセット #マクロ #VBA #PowerPointVBA