VBA_WindowsAPI_名前を付けて保存

やること

VBAにて、ダイアログ「名前を付けて保存」を操作します。
これを作っておくとWeb上のデータをダウンロードする処理で使い回せるのと、
ファイルダウンロード時にフォルダとファイル名を指定することができます。

APIについて

Application Program Interface の略です。
VBAのみではできない他のアプリケーションの機能を使用する場合に呼び出すものです。
今回のダイアログ「名前を付けて保存」の操作はVBAのみで完結できないため、
WindowsAPIを使用する必要があります。

また、使用する際はAPIを使用する「宣言」が必要になります。
赤枠のところ（プロシージャ外）で使用するものを宣言します。

マニュアルについて

使用したいAPIがあるがどう宣言したら良いのか、という場合でも
Microsoft公式より取得できるヘルプファイルを使用すると楽です。
exeファイルを実行すると下記フォルダにヘルプファイルが格納されます。
　フォルダ：C:\Office 2010 Developer Resources\Documents\Office2010Win32API_PtrSafe
　ファイル：Win32API_PtrSafe.TXT

ヘルプファイル上で検索をかけてまるっと使えます。

↓

事前確認

ファイル名を指定する部分や保存ボタンを操作するには、
それぞれの部品の「ハンドル」と呼ばれる番号が必要になります。
各部品のハンドルはダイアログを表示する度に値が変わるため、
その都度取得する必要があります。

手順

ざっくりと処理のフローを書き起こすとこんな感じです。
　１．ウィンドウの存在確認
　２．ウィンドウの親ハンドルを取得
　３．ファイル名、保存ボタンのハンドル（子ハンドル）を取得
　４．取得した子ハンドルをもとにフルパスを入力
　５．保存クリック

使用する関数

下記の3つです。
・FindWindow
・FindWindowEx
・SendMessage

指定ウィンドウのハンドルを取得

関数：FindWindow
引数：・ByVal lpClassName As String：クラス名
　　　・ByVal lpWindowName As String：ウィンドウタイトル
戻値：ウィンドウハンドル

Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr

クラス名とウィンドウタイトルを文字列で渡してハンドルを受け取ります。
ダイアログ（名前を付けて保存）のクラスは「#32770」なので、下記の通り渡します。

hWnd = FindWindow("#32770", "名前を付けて保存")

ファイル名入力部分、ボタンのハンドルを取得

関数： FindWindowEx
引数：・ByVal hWnd1 As LongPtr：親ハンドル
　　　・ByVal hWnd2 As LongPtr：子ハンドル
　　　・ByVal lpsz1 As String：クラス名
　　　・ByVal lpsz2 As String：ウィンドウタイトル
　　　　・vbNullString で省略可
戻値：（第3引数で指定したクラスの）ハンドル

Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr

フォルダ、ファイル名を指定し保存するため、下記赤枠部分のハンドルを取得します。

保存ボタンは親ハンドルから取得できますが、ファイル名指定の箇所は深いところにあります。

'保存(S)ボタンのハンドル取得
btnSavehWnd = FindWindowEx(hWnd, 0&, vbNullString, "保存(&S)")

'ファイル名(N):のハンドル取得
InputhWnd = FindWindowEx(hWnd, 0&, "DUIViewWndClassName", vbNullString)
InputhWnd = FindWindowEx(InputhWnd, 0&, "DirectUIHWND", vbNullString)
InputhWnd = FindWindowEx(InputhWnd, 0&, "FloatNotifySink", vbNullString)
InputhWnd = FindWindowEx(InputhWnd, 0&, "ComboBox", vbNullString)
InputhWnd = FindWindowEx(InputhWnd, 0&, "Edit", vbNullString) 

※0&・・・0の型（Long）指定

文字列の送信、クリック操作

関数：SendMessage
引数：・ByVal hwnd As LongPtr：ハンドル
　　　・ByVal wMsg As Long：メッセージの種類
　　　・ByVal wParam As LongPtr：パラメータ（メッセージに関するもの、コマンド渡しに使用）
　　　・lParam As Any：パラメータ（ポインタ等、イベント処理に使用）
戻値：・0：取得エラー
　　　・0以外：メッセージの文字数

Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr

ファイル名入力欄にはフルパス、保存ボタンにはクリックする処理を送ります。

Const CstrFolder As String = "C:\temp\dltest"
Const CstrFileNm As String = "テスト.png"

'格納先設定
strFilePath = CstrFolder & "\" & CstrFileNm
Call SendMessage(InputhWnd, &HC, 0, ByVal strFilePath)

'保存ボタン押下
Call SendMessage(btnSavehWnd, &HF5, 0, 0&)

第4引数はByvalと指定しないと文字化けして保存できません。
【Byval指定なし】

【Byval指定あり】

使用例

Option Explicit
'API宣言****************************************************************************************************
'親ハンドルを取得
Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
'子ハンドルを取得
Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
'ハンドルを指定しメッセージを送信
Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
'***********************************************************************************************************
'定数定義
Public Const CstrFolder         As String = "C:\temp\dltest"
Public Const CstrFileNm         As String = "テスト.png"
Public Const CstrSavDialogNm    As String = "名前を付けて保存"
Public Const CstrSavDialogCls   As String = "#32770"
Public Const CintLoopMaxCnt     As Integer = 10

Sub test()
    '変数定義
    Dim strErrMsg   As String
    Dim intRet      As Integer
    
    intRet = SaveFileDialog(strErrMsg)
    If 0 = intRet Then
        '正常終了
        MsgBox "処理が正常終了しました。" _
               , vbInformation + vbOKOnly, "確認"
    Else
        '異常終了
        MsgBox "処理が異常終了しました。" & vbCrLf _
               & "番号：" & intRet & vbCrLf _
               & strErrMsg, vbCritical + vbOKOnly, "確認"
    End If
End Sub
'***********************************************************************************************************
Function SaveFileDialog( _
    ByRef strErrMsg As String)

    '変数定義
    Dim intRet      As Integer
    Dim ParenthWnd  As Long
    Dim ChildhWnd   As Long
    Dim btnSavehWnd As Long
    Dim strFilePath As String
    Dim intLoopCnt  As Integer

    '初期設定
    On Error GoTo Err01
    '-------------------------------------------------------------------------------------------------------
    '親ハンドル取得
    Do
        'クラス名とウィンドウ名を指定し、ハンドルを取得
        ParenthWnd = FindWindow(CstrSavDialogCls, CstrSavDialogNm)

        'ハンドルを取得できた場合、ループ終了
        If ParenthWnd <> 0 Then Exit Do
        DoEvents
        intLoopCnt = intLoopCnt + 1

        '試行回数チェック
        If intLoopCnt > CintLoopMaxCnt Then
            strErrMsg = "ダイアログ「" & CstrSavDialogNm & "」が見つかりませんでした。"
            SaveFileDialog = 11
            Exit Function
        End If
    Loop
    '-------------------------------------------------------------------------------------------------------
    'カウンター初期化
    intLoopCnt = 0
    '-------------------------------------------------------------------------------------------------------
    '子ハンドル取得（ボタン「保存」）
    Do
        'ボタン「保存」ハンドル取得
        btnSavehWnd = FindWindowEx(ParenthWnd, 0&, vbNullString, "保存(&S)")
        
        'ハンドルを取得できた場合、ループ終了
        If btnSavehWnd <> 0 Then Exit Do
        
        DoEvents
        intLoopCnt = intLoopCnt + 1
        
        '試行回数チェック
        If intLoopCnt > CintLoopMaxCnt Then
            strErrMsg = "ボタン「保存」が見つかりませんでした。"
            SaveFileDialog = 12
            Exit Function
        End If
    Loop
    '-------------------------------------------------------------------------------------------------------
    'カウンター初期化
    intLoopCnt = 0
    '-------------------------------------------------------------------------------------------------------
    '子ハンドル取得（入力「ファイル名」）
    Do
        '入力「ファイル名」ハンドル取得
        ChildhWnd = FindWindowEx(ParenthWnd, 0&, "DUIViewWndClassName", vbNullString)
        ChildhWnd = FindWindowEx(ChildhWnd, 0&, "DirectUIHWND", vbNullString)
        ChildhWnd = FindWindowEx(ChildhWnd, 0&, "FloatNotifySink", vbNullString)
        ChildhWnd = FindWindowEx(ChildhWnd, 0&, "ComboBox", vbNullString)
        ChildhWnd = FindWindowEx(ChildhWnd, 0&, "Edit", vbNullString)
        
        'ハンドルを取得できた場合、ループ終了
        If ChildhWnd <> 0 Then Exit Do
        
        DoEvents
        intLoopCnt = intLoopCnt + 1
        
        '試行回数チェック
        If intLoopCnt > CintLoopMaxCnt Then
            strErrMsg = "入力「ファイル名」が見つかりませんでした。"
            SaveFileDialog = 13
            Exit Function
        End If
    Loop
    '-------------------------------------------------------------------------------------------------------
    'フルパス作成
    strFilePath = CstrFolder & "\" & CstrFileNm
    
    'ファイル存在確認
    If "" <> Dir(strFilePath) Then
        'ファイル退避
        intRet = FileBackup(strFilePath, strErrMsg)
        '処理結果チェック
        If 0 <> intRet Then
            SaveFileDialog = 14
            Exit Function
        End If
    End If
    '-------------------------------------------------------------------------------------------------------
    '保存先設定
    Call SendMessage(ChildhWnd, &HC, 0, ByVal strFilePath)

    '保存ボタン押下
    Call SendMessage(btnSavehWnd, &HF5, 0, 0&)

    '終了
    Exit Function
'-------------------------------------------------------------------------------------------------------
Err01:
    SaveFileDialog = -11
    strErrMsg = "関数：SaveFileDialog 処理を中断しました。" & vbCrLf & _
                "内容：" & Err.Description
End Function
'-------------------------------------------------------------------------------------------------------
Function FileBackup(ByVal FilePath As String, _
                    ByRef strErrMsg As String)

    '変数定義
    Dim strTimeStamp        As String   'タイムスタンプ
    Dim lngLastSepPos       As Long     'フォルダパス文字数
    Dim strFolder           As String   'フォルダパス
    Dim strFileWithExt      As String   'ファイル名 + ファイル形式
    Dim strFileName         As String   'ファイル名
    Dim strFileExt          As String   'ファイル形式
    Dim strNewFileName      As String   '変更後ファイル名
    Dim strNewFullPath      As String   '変更後フルパス

    '初期設定
    On Error GoTo Err01
    strTimeStamp = Format(Now, "yyyyMMddhhmmss")
    '-------------------------------------------------------------------------------------------------------
    'フォルダ情報取得
    lngLastSepPos = InStrRev(FilePath, "\")
    strFolder = Left(FilePath, lngLastSepPos - 1)
    
    'ファイル情報取得
    strFileWithExt = Right(FilePath, Len(FilePath) - InStrRev(FilePath, "\"))
    strFileName = Left(strFileWithExt, InStrRev(strFileWithExt, ".") - 1)
    strFileExt = Right(FilePath, Len(FilePath) - InStrRev(FilePath, "."))

    'リネーム準備
    strNewFileName = strFileName & "_" & strTimeStamp & "." & strFileExt
    strNewFullPath = strFolder & "\" & strNewFileName

    'ファイルをリネーム
    Name FilePath As strNewFullPath
    
    '終了
    Exit Function
'-------------------------------------------------------------------------------------------------------
Err01:
    FileBackup = -12
    strErrMsg = "関数：FileBackup 処理を中断しました。" & vbCrLf & _
                "内容：" & Err.Description
End Function

既に同名ファイルが存在する場合、既存のファイルに日時を追加しリネームしています。

おわりに

過去に似た処理を作ったのは覚えていましたが、どうやって書いたっけ？とうろ覚えでした。
以前はいまいちピンとこなかった部分の勉強になったと思います。

参考：
https://learn.microsoft.com/ja-jp/windows/win32/apiindex/windows-api-list
https://bw-rocket.com/2020/10/06/post-1792/

エンジニアファーストの会社　株式会社CRE-CO　S.K