office2010 Win32API ShellExecute

Option Compare Database
Option Explicit

Const WM_CHAR = &H102
Const BM_CLICK = &HF5
Const SW_HIDE = 0
Const SW_SHOW = 5
Const WM_SETTEXT = &HC

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 PostMessage Lib "user32" _
                                Alias "PostMessageA" ( _
                                ByVal hwnd As LongPtr, _
                                ByVal wMsg As Long, _
                                ByVal wParam As LongPtr, _
                                ByVal lParam As LongPtr _
                                ) As Long

Declare PtrSafe Function ShowWindow Lib "user32" _
                                (ByVal hwnd As LongPtr, _
                                 ByVal nCmdShow As Long _
                                ) As Long

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

'ShellExecute
'http://msdn.microsoft.com/ja-jp/library/cc422072.aspx
Declare PtrSafe Function ShellExecute Lib "shell32.dll" _
                                Alias "ShellExecuteA" ( _
                                ByVal hwnd As LongPtr, _
                                ByVal lpOperation As String, _
                                ByVal lpFile As String, _
                                ByVal lpParameters As String, _
                                ByVal lpDirectory As String, _
                                ByVal nShowCmd As Long _
                                ) As LongPtr

Sub OpenaccdrWithPassword()
    Dim pHwnd As LongPtr, cHwnd As LongPtr, btnHwnd As LongPtr
    Dim rtnShellExe As LongPtr
    Dim targetDBName As String
    Dim targetDBFullName As String
    Dim dialogName As String
    Dim strDBPassword As String
        
    strDBPassword = "p@ssw0rd"
    
    dialogName = "データベース パスワードの入力"
    
    targetDBName = "target"
    targetDBFullName = Application.CurrentProject.Path & "\target.accdr"
    
    pHwnd = FindWindow(vbNullString, targetDBName)
    If pHwnd <> 0 Then Exit Sub
    
    pHwnd = FindWindow(vbNullString, dialogName)
    If pHwnd <> 0 Then Exit Sub
    
    rtnShellExe = ShellExecute(0, "open", targetDBFullName, _
                               vbNullString, vbNullString, SW_SHOW)
    If rtnShellExe <= 32 Then Exit Sub

    Do 'カウンタつけて何かの時に対処せねばね
        pHwnd = FindWindow(vbNullString, dialogName)
'        Debug.Print pHwnd
        If pHwnd <> 0 Then Exit Do
    Loop
    ShowWindow pHwnd, SW_HIDE
    Do
        cHwnd = FindWindowEx(pHwnd, 0, "RichEdit20W", vbNullString)
'        Debug.Print cHwnd
        If cHwnd <> 0 Then Exit Do
    Loop
    
    Do
        btnHwnd = FindWindowEx(pHwnd, 0, "button", "OK")
'        Debug.Print btnHwnd
        If btnHwnd <> 0 Then Exit Do
    Loop
    
    SendMessage cHwnd, WM_SETTEXT, 0, ByVal strDBPassword
    
    PostMessage btnHwnd, BM_CLICK, 0, 0

    Application.Quit

End Sub