VBA でパワーポイントの画像形式を調べる方法

Question

VBAプログラムを使用してパワーポイントに張付けてある写真画像の形式(JPG,PNG等)を取得するにはどうしたらよいのでしょうか,教えて下さい.

該当のソースコード

``VBA
Sub Abc()
Dim sld As Slide
Dim sh As Shape

For Each sld In ActivePresentation.Slides
For Each sh In sld.Shapes
If sh.Type = 13 Then '画像
ここにshの画像を取得する命令を入れたい
Else
End If
Next
Next

Answer 1

パワーポイントに張付けてある写真画像の形式(JPG,PNG等)を取得するにはどうしたらよいのでしょうか

簡単な方法は無さそうに思います。

Office の内部的には画像形式を記録しているらしく、クリップボードにコピーすると Art::GVML ClipFormat 形式のデータとして確認することが出来ました。（Art::GVML ClipFormat の構造としては zip 形式の構造になっているようです。）
この情報をうまく取り出せれば、判定が行えるかもしれません。

■ Microsoft Office に貼り付けた画像からクリップボード経由で元解像度の画像を得る
https://seesaawiki.jp/w/kou1okada/d/Microsoft%20Office

＜参考情報＞
■ InsideClipboard - Nirsoft
https://www.nirsoft.net/utils/inside_clipboard.html

＜追記（2021.10.28＞
Art::GVML ClipFormat 形式のクリップボードデータを zip ファイルで出力するサンプルを書いてみました。
C:\TEMP 配下に clip1.zip のようなファイル名で保存するようにしてあります。必要に応じて変更下さい。
なお、このプログラムは自己責任でご利用下さい。
Win32 APIを使用しており、十分なテストも行っていない為、予期しないクラッシュ等が発生する可能性があります。

Option Explicit

Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare PtrSafe Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Private Function GetClipboardRawData(ByVal format As Long, bytes() As Byte) As Boolean
    Dim hWnd As Long
    Dim nSize As Long
    Dim hClipMemory As Long
    If OpenClipboard(0&) Then
        hWnd = GetClipboardData(format)
        If hWnd Then nSize = GlobalSize(hWnd)
        If nSize Then hClipMemory = GlobalLock(hWnd)

        If hClipMemory Then
            ReDim bytes(0 To nSize - 1) As Byte
            MoveMemory bytes(0), ByVal hClipMemory, nSize
            Call GlobalUnlock(hWnd)
            GetClipboardRawData = True
        End If
        EmptyClipboard
        CloseClipboard
        DoEvents
    End If
End Function

Sub ClipboardToZip(ByVal format As Long, ByVal strZipFileName As String)
    Dim bytes() As Byte
    Dim result As Boolean
    result = GetClipboardRawData(format, bytes)

    Open strZipFileName For Binary As #1
    Put #1, , bytes
    Close #1
End Sub

Sub Main()
    Dim sld As Slide
    Dim sh As Shape

    Dim format As Long
    format = 50173 ' Art::GVML ClipFormat
    
    Dim strOutputPath As String
    strOutputPath = "C:\TEMP" ' 任意の出力先に変更下さい。
    Dim strZipFileName As String

    Dim n As Long
    n = 0
    For Each sld In ActivePresentation.Slides
        For Each sh In sld.Shapes
            If sh.Type = 13 Then
                n = n + 1
                ' 画像をクリップボードにコピー
                sh.Copy
                ' 出力先のファイル名を設定
                strZipFileName = strOutputPath & "\clip" & n & ".zip"
                ' クリップボードの内容をファイル出力
                Call ClipboardToZip(format, strZipFileName)
            End If
        Next
    Next
End Sub

＜参考情報２＞
■ クリップボードのデータを取り出す方法
https://www.moug.net/tech/acvba/0020003.html

Comments

[nathea]

簡単ではなさそうですね.
クリップボードに格納するにはshapeオブジェクト.copyで出来るのですが,それをどうやってファイルとして格納,展開出来るのか,まだ分かりません.
もう少しトライしてみます. ありがとうございます.

[cx20]

> それをどうやってファイルとして格納,展開出来るのか,まだ分かりません.

クリップボードデータを zip ファイルに出力するサンプルを書いてみました。