' API宣言
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private 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
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" ( _
ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As String) As LongPtr
Private Declare PtrSafe Function SetForegroundWindow Lib "user32" ( _
ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32" ( _
ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function SetClipboardData Lib "user32" ( _
ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" ( _
ByVal wFlags As Long, ByVal dwBytes As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalLock Lib "kernel32" ( _
ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" ( _
ByVal hMem As LongPtr) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
ByVal dest As LongPtr, ByVal src As LongPtr, ByVal CB As LongPtr)
Sub SaveAsCurrentFolder()
Dim hwndDialog As LongPtr
Dim hwndEdit1 As LongPtr
Dim hwndEdit2 As LongPtr
Dim hwndEdit3 As LongPtr
Dim hwndEdit4 As LongPtr
Dim hwndEdit5 As LongPtr
Dim saveFolder As String
' 保存先のパスstr
saveFolder = Sheets(1).Cells(1, 1)
'クリップボードに格納関数
call_ClipBoardSave (saveFolder)
' ダイアログのウィンドウハンドルを取得
hwndDialog = FindWindow("#32770", vbNullString)
If hwndDialog = 0 Then
MsgBox "ダイアログが見つかりません。", vbCritical
Exit Sub
End If
' フォーカスをダイアログに移す
SetForegroundWindow hwndDialog
' ダイアログ内のpath入れるbarのハンドルを取得（SPY++で確認）
hwndEdit1 = FindWindowEx(hwndDialog, 0, "WorkerW", vbNullString)
hwndEdit2 = FindWindowEx(hwndEdit1, 0, "ReBarWindow32", vbNullString)
hwndEdit3 = FindWindowEx(hwndEdit2, 0, "Address Band Root", vbNullString)
hwndEdit4 = FindWindowEx(hwndEdit3, 0, "msctls_progress32", vbNullString)
hwndEdit5 = FindWindowEx(hwndEdit4, 0, "ToolbarWindow32", vbNullString)
' "ToolbarWindow32"を選択
SetForegroundWindow hwndEdit5
SendKeys "%d", True ' Alt + d
Application.Wait (Now + TimeValue("0:00:01"))
' クリップボードの内容を貼り付け
SendKeys "^v", True ' Ctrl + V
Application.Wait (Now + TimeValue("0:00:02"))
' Enterキーを送信してフォルダに移動
SendKeys "{ENTER}", True
Application.Wait (Now + TimeValue("0:00:01"))
Stop
End Sub
Private Function call_ClipBoardSave(saveFolder As String)
With CreateObject("Forms.TextBox.1")
.MultiLine = True
.text = saveFolder
.SelStart = 0
.SelLength = .TextLength
.Copy
End With
End Function