PowerPoint でダイヤログを開く

2022年11月2日

EXCEL と ACCESS にはファイルダイヤログがありますが、PowerPoint にはありませんので、 EXCEL のファイルダイヤログを使います。

ユーザーフォームに書くコード

とりあえず CODE の全体は次のようになります。
ボタン「ダイヤログ」のクリックすると MsgBox を実行するために getFileName を実行して戻り値を取得しようとします。
値を取得したらメッセージを表示します。

copy

Option Explicit

'// 64bit版
#If VBA7 And Win64 Then
    Private Declare PtrSafe Function SetForegroundWindow Lib "user32" _
        (ByVal hwnd As LongPtr) As Long
'// 32bit版
#Else
    Private Declare Function SetForegroundWindow Lib "user32" _
        (ByVal hwnd As Long) As Long
#End If

Private xlApp               As Object

'-----------------------------------------
'フォームを開くときに実行するコード
Private Sub UserForm_Initialize()

    If Not xlApp Is Nothing Then
        Set xlApp = Nothing
    End If

    Set xlApp = CreateObject("Excel.application")

End Sub

'-----------------------------------------
'ボタン「閉じる」のクリック
Private Sub bu閉じる_Click()

    Unload Me

End Sub

'-----------------------------------------
'フォームが閉じるときに実行されるコード
Private Sub UserForm_Terminate()

    Set xlApp = Nothing

End Sub

'-----------------------------------------
'ボタン「ダイヤログ」のクリック
Private Sub buダイヤログ_Click()

    MsgBox getFileName("Accessを選択")

End Sub

'-----------------------------------------
'エクセルのダイヤログを開き選択したファイルのパスを返します。
Private Function getFileName(ByVal myTitle As String) As String
    Const msoFileDialogFilePicker = 3
    Dim ThisPath            As String
    Dim BUF                 As String

    '開いている PowerPoint のパス
    ThisPath = ActivePresentation.Path

    BUF = ""

    'エクセルのダイヤログを開きます。
    With xlApp

        'これをしないとExcelはPowerPointに隠れたままです。
        Call SetForegroundWindow(.hwnd)

        With .FileDialog(msoFileDialogFilePicker)

            .InitialFileName = ThisPath & "\"
            .AllowMultiSelect = False
            .Title = myTitle
            .Filters.Add "ACCESS", "*.accdb"
            .Filters.Add "すべてのファイル", "*.*"
            .FilterIndex = 1
            .ButtonName = "開く"

            If .Show = True Then
                BUF = .SelectedItems(1)
            End If

        End With

        'エクセルを閉じる
        .Quit

    End With

    getFileName = BUF
    
End Function