パワポに埋め込まれたOLE型のExcelシートを探る OLEFormatのProgIDやObjectを使用する

パワポに埋め込まれたOLE型のExcelシート
Shape.OLEFormat.ProgID = Excel.Sheet.12
など埋め込み型を吸い上げて別ファイルに保存する処理を探ってみた。
youtu.be
https://youtu.be/-GFfMCoBXAQ
目次
00:00 0.キッカケは知恵袋の質問
00:14 1.挿入からオブジェクトを埋め込む
01:55 2.パワポのスライドの下シェイプのOLE埋め込みを探ってみる
02:29 2.1 ウォッチ式に追加して確認してみる
06:14 2.2 Workbookと言えばSheetsでしょ？
07:08 2.3 ここで保存してみたくなるのが人情
11:00 3. Excelから攻めてみる
18:48 3.1 恥ずかしいバグ、デバック時は変数を確認
4.終わりの挨拶

0.キッカケは知恵袋の質問

detail.chiebukuro.yahoo.co.jp
＞パワポに埋め込まれたエクセルファイルの扱い方
＞
＞このパワポファイルを名称変更で拡張子をzipにすると
＞埋め込まれていた表がエクセルファイルとして確認できるという方法をネットで見かけました。
＞
＞試してみたところ、
＞ほとんどの表はエクセルファイルになったんですが、
＞一部の表はoleObjectのbinファイルになってしまいました。
＞この原因が分かる方いらっしゃいますか？全てエクセルファイルにする方法はあるのでしょうか？
＞
＞パワポから埋め込み型の表を全て抽出できるようなvbaコードが作成可能であればそちらも教えていただきたいです。

1.挿入からオブジェクトを埋め込む

挿入オブジェクトを選択すると
※なんか、小さなアイコンだったけど

どのオブジェクトを選ぶのか？と出てくるので、
Excel 関係を選んでテストしてみます。

2.パワポのスライドの下シェイプのOLE埋め込みを探ってみる

For Each objShape In objSlide.Shapes 'スライド内のシェイプ達を一つ一つあさる
で、スライド内のシェイプを取り出し、
Debug.Print objShape.Id, objShape.Name
objShape.Select 'わかりやすいように該当オブジェクトを選択
Stop '止める
Next
上記みたいな感じて止めて、テストしてみます。

'パワーポイント Shape を1つ1つSTOPで止める ウォッチ式で確認テスト用
Sub シェイプの選択とストップ()
    
    Dim nPAGE As Integer
    nPAGE = ActiveWindow.Selection.SlideRange.SlideIndex '現在選択しているページ
    
    Dim objSlide As PowerPoint.Slide  'スライド
    Set objSlide = ActivePresentation.Slides(nPAGE) '↑現在のページを変数に
    
    Dim objShape As PowerPoint.Shape  'シェイプ
    
    'テストで選択ページの.Shapesを探る
    Debug.Print "Id", "Name"
    For Each objShape In objSlide.Shapes  'スライド内のシェイプ達を一つ一つあさる
        Debug.Print objShape.Id, objShape.Name
        objShape.Select  'わかりやすいように該当オブジェクトを選択
        Stop  '止める
    Next

    MsgBox "終了"
End Sub

2.1 ウォッチ式に追加して確認してみる

hasXXXX

で hasOLE??? があるかなぁと思ったら、なかった。残念。

続けて、探ると、

- : OLEFormat : : OLEFormat/OLEFormat : Module1.シェイプの選択とストップ
: ProgID : "Excel.Sheet.12" : String : Module1.シェイプの選択とストップ

OLEFormatの下に、
ProgIDがあるので、これが使えそうです。

また、

+ : Object : : Object/Workbook : Module1.シェイプの選択とストップ

と、
Object 名前そのままじゃないか、
が、
Object/Workbook
となっているので、使ってみます。

2.2 Workbookと言えばSheetsでしょ？

イミディエイトで確認してみます。

? objShape.OLEFormat.ProgID
Excel.Sheet.12
? objShape.OLEFormat.Object.sheets.count
1
? objShape.OLEFormat.Object.sheets(1).name
Sheet1
? objShape.OLEFormat.Object.sheets(1).cells(2,2)
初手B2が少し前に流行ったネタですね。

2.3 ここで保存してみたくなるのが人情じゃなかったメソッドも使えるのかチェック

Workbook.SaveAs メソッド (Excel)
learn.microsoft.com

SaveAs (FileName、 FileFormat、 Password、 WriteResPassword、 ReadOnlyRecommended、 CreateBackup、 AccessMode、
ConflictResolution、 AddToMru、 TextCodepage、 TextVisualLayout、 Local)

上記メソッドが、あって、
ファイル名は適当で"D:\2023\test.xls"
とFileFormat 旧のxlsでテストしてみます(※埋め込み形式に、97-2003形式があったのでこれに対応？)
learn.microsoft.com
から

xlExcel8 56 Excel 97-2003 ブック *.xls

を選択。
※ xlExcel8 の 56

んっ？ちょっと待った

xlWorkbookDefault 51 ブックの既定 *.xlsx
xlWorkbookNormal -4143 ブックの標準 *.xls

なんか、xlWorkbookNormal -4143 があるね。
長いよ、
平成・令和なら、
いつもの.xlsx xlWorkbookDefault 51
かな

さて、テストしますか。
objShape.OLEFormat.Object.saveas "d:\2023\test", 51

あれれ、上手くいかないぞ・・・
空のファイル？

3.Excelから攻めてみる

OLEのオブジェクト経由でプロパティやメソッドが上手く動作しなかったので
(※勘違いかもしれないけど)

Excelから起動済みのPowerPonitを捕まえて、
スライドをループ
シェイプをループ

OLEオブジェクトがWorkBookだったら、
ExcelにSheetsをコピーする。

そんな別構想で攻めてみます。

動画の11:00～
https://www.youtube.com/watch?v=-GFfMCoBXAQ&t=660s
を下記のソースと合わせて、確認してください。

Option Explicit

'Excelから開かれている既存のPowerPointを捕まえて
'埋め込まれている OLEオブジェクトのExcelシートを吸い上げるイメージで
'再チャレンジしてみた。

Sub ExcelからPP内のOLE型にアクセスして別名保存する()

    '起動済みのパワポを捕まえる
    Dim ppApp As Object
    
    Set ppApp = Nothing
    On Error Resume Next  'エラーが発生しても強引に次の命令に行け
    Set ppApp = GetObject(, "PowerPoint.Application")
    On Error GoTo 0  '忘れないで戻すぞ

    If ppApp Is Nothing Then
        MsgBox "OLEが埋まっているパワポを開いてから、再テストしてね"
        Exit Sub
    End If
    
    'データをセットする
    
    Dim p As Integer  'pp:スライドのページ
    
    Dim ppSlide As Object  'PowerPoint.Slide  'スライド
    Dim ppShape As Object  'PowerPoint.Shape  'シェイプ
    
    'プレゼンスライドのループ
    For p = 1 To ppApp.ActivePresentation.Slides.Count
        Set ppSlide = ppApp.ActivePresentation.Slides(p)
        
        Debug.Print vbCrLf, "ページ:", p
        Debug.Print "Id", "Name", "Type"

        For Each ppShape In ppSlide.Shapes  'スライド内のシェイプ達を一つ一つあさる
            Debug.Print ppShape.ID, ppShape.Name, ppShape.Type
            'OLE埋め込みのExcelを探して処理する
            If ppShape.Type = 7 Then '7:msoEmbeddedOLEObject 埋め込み OLEオブジェクト
                If TypeName(ppShape.OLEFormat.Object) = "Workbook" Then  'Excelシートなら
                   
                    Dim ppOLEwb As Excel.Workbook
                    Set ppOLEwb = ppShape.OLEFormat.Object
                    
                    '新しいBookを作成する
                    Dim newWB As Workbook
                    Set newWB = Application.Workbooks.Add
                    
                    '新しいシートを作成する ※複数シートは次回？
                    Dim newSH As Worksheet
                    'Set newSH = newWB.Worksheets.Add
                    Set newSH = newWB.Sheets(1)
                    newSH.Name = "OLE埋め込みシート"  'シート名を合わせないとね
                    
                    'pp内の埋め込みから吸い上げて(.Copyして)→Excelへ
                    ppOLEwb.Sheets(1).Cells.Copy
                    newWB.Activate     '新しいWorkbookに貼り付ける
                    ActiveSheet.Paste  '複数シートに対応しないとなぁ
                    ActiveSheet.Cells(1, 1).Copy   'バッファを消したくて？
                    ActiveSheet.Cells(1, 1).Select
                    DoEvents
                    
                    '名前を付けて保存する
                    Dim strFileName As String  '保存ファイル名
                    
                    strFileName = ThisWorkbook.Path & "\埋め込みExcel" & p & ".xlsx"
                    Application.DisplayAlerts = False  '警告メッセージを非表示
                    newWB.SaveAs strFileName  '保存する 連続実行できない・・
                    newWB.Close               '閉じる
                    Application.DisplayAlerts = True   '警告メッセージを非表示
                    
                    Set newSH = Nothing
                    Set newWB = Nothing
                    Set ppOLEwb = Nothing
                End If
            End If
        Next
    Next p
    
    MsgBox "セット終了、ファイルを確認してください"

End Sub

3.1 恥ずかしいバグ、デバック時は変数を確認

デバッグ時は、落ち着いて、変数を確認しましょう。
ActiveWorkbook.Path
と
ThisWorkbook.Path
やりがちな、間違いでした。

'新しいBookを作成する
Dim newWB As Workbook
Set newWB = Application.Workbooks.Add
で新規ブックを作成後、
newWB.Activate '新しいWorkbookに貼り付ける
ActiveSheet.Paste
↑あっ、
この新規ブックは未保存なので、
ActiveWorkbook.Path
が空でした。

上記の恥ずかしいシーンは 18:48 ～
https://www.youtube.com/watch?v=-GFfMCoBXAQ&t=1128s
※これがバグ、不具合の原因↑です。あ～、はずかし・・・

4.終わりの挨拶

なんか、できそうで、できないのが・・・