office2010 Win32API EnumWindows

Option Compare Database
Option Explicit

Private Const WM_SETTEXT = &HC
Private Const BM_CLICK = &HF5
Private Const IDOK = &H1
Private Const IDC_EDIT = &H8A5

Private pHwnd As LongPtr
'Type UserDefined01
'    taskID As Long
'    Hwnd As LongPtr
'End Type

Private Declare PtrSafe Function GetWindowText Lib "user32" _
                                Alias "GetWindowTextA" ( _
                                ByVal hwnd As LongPtr, _
                                ByVal lpString As String, _
                                ByVal cch As Long _
                                ) As Long

'http://msdn.microsoft.com/ja-jp/library/cc410851.aspx
Private Declare PtrSafe Function EnumWindows Lib "user32" ( _
                                ByVal lpEnumFunc As LongPtr, _
                                ByVal lParam As Any _
                                ) As Long
'Private Declare PtrSafe Function EnumWindows Lib "user32" ( _
'                                ByVal lpEnumFunc As LongPtr, _
'                                      lParam As Any _
'                                ) As Long

Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" ( _
                                ByVal hwnd As LongPtr, _
                                lpdwProcessId As Long _
                                ) As Long
                                
Private Declare PtrSafe Function GetLastActivePopup Lib "user32" ( _
                                ByVal hwndOwnder As LongPtr _
                                ) As LongPtr
 
Private Declare PtrSafe Function GetDlgItem Lib "user32" ( _
                                ByVal hDlg As LongPtr, _
                                ByVal nIDDlgItem As Long _
                                ) As LongPtr
 
Private 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

Private Function ProcIDFromWnd(ByVal hwnd As LongPtr) As Long
    Dim idProc As Long
    GetWindowThreadProcessId hwnd, idProc
    ProcIDFromWnd = idProc
End Function

Private Function GetWinHandleProc(ByVal tmpHwnd As LongPtr, _
                                  ByVal lParam As Long _
                                  ) As Boolean
    If lParam = ProcIDFromWnd(tmpHwnd) Then
        Dim wText As String, wTextLength As Long
        wText = String(255, Chr(0))
        wTextLength = GetWindowText(tmpHwnd, wText, 255)
        If "Microsoft Access" = Left(wText, wTextLength) Then
            pHwnd = tmpHwnd
            GetWinHandleProc = False
            Exit Function
        End If
    End If
    GetWinHandleProc = True
End Function

'Private Function GetWinHandleProc(ByVal tmpHwnd As LongPtr, _
'                                  ByRef lParam As UserDefined01 _
'                                  ) As Boolean
'    If lParam.taskID = ProcIDFromWnd(tmpHwnd) Then
'        Dim wText As String, wTextLength As Long
'        wText = String(255, Chr(0))
'        wTextLength = GetWindowText(tmpHwnd, wText, 255)
'        If "Microsoft Access" = Left(wText, wTextLength) Then
'            lParam.Hwnd = tmpHwnd
'            GetWinHandleProc = False
'            Exit Function
'        End If
'    End If
'    GetWinHandleProc = True
'End Function

Private Function GetWinHandle(taskID As Long) As LongPtr
    pHwnd = 0
    EnumWindows AddressOf GetWinHandleProc, taskID
    GetWinHandle = pHwnd
End Function

'Private Function GetWinHandle(taskID As Long) As LongPtr
'    Dim tmp As UserDefined01
'    tmp.taskID = taskID
'    tmp.Hwnd = 0
'    EnumWindows AddressOf GetWinHandleProc, tmp
'    GetWinHandle = tmp.Hwnd
'End Function

Sub OpenAccdrWithPassword( _
            targetDBFullPath As String, _
            pswd As String, _
            Optional WindowStyle As VbAppWinStyle = vbNormalFocus)
             
    Dim taskID As Long
    Dim targetDBHwnd As LongPtr
    Dim pswdDlgHwnd As LongPtr
    Dim dlgEditHwnd As LongPtr, dlgButtonOKHwnd As LongPtr
     
    If Dir(targetDBFullPath) = "" Then Exit Sub
     
    taskID = Shell("msaccess.exe /runtime " & _
                    targetDBFullPath, _
                    WindowStyle)
    If taskID = 0 Then Exit Sub
 
   'この部分たまたま動作しているのではないか？ 
    targetDBHwnd = GetWinHandle(taskID)
    
    Do
        pswdDlgHwnd = GetLastActivePopup(targetDBHwnd)
    Loop While targetDBHwnd = pswdDlgHwnd
     
    dlgEditHwnd = GetDlgItem(pswdDlgHwnd, IDC_EDIT)
    dlgButtonOKHwnd = GetDlgItem(pswdDlgHwnd, IDOK)
 
    SendMessage dlgEditHwnd, WM_SETTEXT, 0, ByVal pswd
    SendMessage dlgButtonOKHwnd, BM_CLICK, 0, 0
End Sub