access2010 comctl32 TaskDialog

OS/環境を選ぶことになるのかな。

小ブタ大ブタをコールしません

Office2010 Win32API MessageBoxEX

使う予定がこっちの方だった。

Office2010 Win32API MessageBoxW

マクロでMsgBoxメソッドを使う分には問題ないのだけど、VBAだとあれなので。

access2010 access2007 アプリケーションウィンドウの中央寄せ -2-

以前のポストをちょっと加工

アプリケーションウインドウが最大化されているときなど判断して移動とリサイズ

access2010 access2007 アプリケーションウィンドウの中央寄せ -1-

うむ。これは使うことあるので加工させてもらった。

元ネタは、Accessウィンドウをディスクトップの中央に表示する(hatena chips)
マルチモニタ環境で使いたかったので。だけどデュアルモニタまでしか確認してない。

access2010 Kiosk Form

Option Compare Database
Option Explicit

Public Const HWND_TOP = 0
Public Const HWND_BOTTOM = 1
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2
Public Const SW_SHOW = 5
Public Const SW_HIDE = 0
Public Const SWP_NOSIZE = &H1
Public Const SWP_NOMOVE = &H2
Public Const SWP_SHOWWINDOW = &H40
Public Const SW_MAXIMIZE = 3

Declare PtrSafe Function SetWindowPos Lib "user32" _
                            (ByVal Hwnd As LongPtr, _
                             ByVal hWndInsertAfter As LongPtr, _
                             ByVal x As Long, _
                             ByVal y As Long, _
                             ByVal cx As Long, _
                             ByVal cy As Long, _
                             ByVal wFlags As Long _
                             ) As Long
 
Declare PtrSafe Function ShowWindow Lib "user32" _
                                (ByVal Hwnd As LongPtr, _
                                 ByVal nCmdShow As Long _
                                ) As Long

Option Compare Database
Option Explicit
'境界線スタイル：なし、スクロールバーとかは非表示にしておく
Private Sub Form_Close()
    ShowWindow Application.hWndAccessApp, SW_SHOW
End Sub

Private Sub Form_Load()
    If Not Me.PopUp Then Exit Sub
    ShowWindow Application.hWndAccessApp, SW_HIDE
    ShowWindow Me.Hwnd, SW_MAXIMIZE
End Sub

Private Sub cmdClose_Click()
    DoCmd.Close
End Sub

Private Sub コマンド2_Click()
    DoCmd.OpenForm "フォーム2"
End Sub

Private Sub Form_Load()
    If Not Me.PopUp Then Exit Sub

    SetWindowPos Me.Hwnd, HWND_TOPMOST, 0, 0, _
                 0, 0, SWP_NOSIZE Or SWP_NOMOVE Or SWP_SHOWWINDOW
End Sub

これでいいか？なんの考慮もしてない。Alt+Tabなど抑制はしない。これ以降はお好みでどうぞ。 なんの考えもなくコード書くもんじゃないと悟った夜。

access2010 IAccessible.accStateプロパティ(oleacc)

accStateプロパティを参照して、リボンが最小化されているか調べる。
また、リボンの最小化を実行する。

Option Compare Database
Option Explicit

Const CHILDID_SELF = 0&
Const OBJID_CLIENT = &HFFFFFFFC
Const ROLE_SYSTEM_PUSHBUTTON = &H2B

Declare PtrSafe Function AccessibleChildren Lib "oleacc" ( _
                                ByVal paccContainer As IAccessible, _
                                ByVal iChildStart As Long, _
                                ByVal cChildren As Long, _
                                ByRef rgvarChildren As Any, _
                                ByRef pcObtained As Long _
                                ) As Long

Declare PtrSafe Function AccessibleObjectFromWindow Lib "oleacc" ( _
                                ByVal hWnd As LongPtr, _
                                ByVal dwId As Long, _
                                riid As Any, _
                                ByRef ppvObject As IAccessible _
                                ) As Long

Declare PtrSafe Function IIDFromString Lib "ole32" ( _
                                ByVal lpsz As LongPtr, _
                                lpiid As Any _
                                ) As Long
 
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

'リボンが最小化されているかどうか
Function IsRibbonMinimize() As Boolean
    Dim IID(0 To 3) As Long, acc As IAccessible, targetAcc As IAccessible
    
    IIDFromString StrPtr("{618736E0-3C3D-11CF-810C-00AA00389B71}"), _
                  IID(0)
    AccessibleObjectFromWindow getHwnd, _
                               OBJID_CLIENT, _
                               IID(0), _
                               acc
    Set targetAcc = GetAcc(acc, "リボンの最小化", ROLE_SYSTEM_PUSHBUTTON)
    
    Select Case targetAcc.accState(CHILDID_SELF)
        Case 1048576
            IsRibbonMinimize = False
        Case 1048584
            IsRibbonMinimize = True
    End Select
End Function

'リボンを最小化する
Sub RibbonMinimize()
    Dim IID(0 To 3) As Long, acc As IAccessible, targetAcc As IAccessible
    
    IIDFromString StrPtr("{618736E0-3C3D-11CF-810C-00AA00389B71}"), _
                  IID(0)
    AccessibleObjectFromWindow getHwnd, _
                               OBJID_CLIENT, _
                               IID(0), _
                               acc
    Set targetAcc = GetAcc(acc, "リボンの最小化", ROLE_SYSTEM_PUSHBUTTON)
    
    If targetAcc.accState(CHILDID_SELF) = 1048576 Then
        targetAcc.accDoDefaultAction CHILDID_SELF
    End If
End Sub

Function getHwnd() As LongPtr
    Dim pHwnd As LongPtr
    pHwnd = FindWindowEx(hWndAccessApp, 0, "MsoCommandBarDock", "MsoDockTop")
    pHwnd = FindWindowEx(pHwnd, 0, "MsoCommandBar", "Ribbon")
    pHwnd = FindWindowEx(pHwnd, 0, "MsoWorkPane", "Ribbon")
    pHwnd = FindWindowEx(pHwnd, 0, "NUIPane", "")
    pHwnd = FindWindowEx(pHwnd, 0, "NetUIHWND", "")
    getHwnd = pHwnd
End Function

'**** 引用 http://www.ka-net.org/ ****
Function GetAcc(myAcc As IAccessible, _
                        myAccName As String, _
                        myAccRole As Long _
                        ) As IAccessible
  Dim ReturnAcc As IAccessible
  Dim ChildAcc As IAccessible
  Dim List() As Variant
  Dim Count As Long
  Dim i As Long
    
  If (myAcc.accState(CHILDID_SELF) <> 32769) And _
     (myAcc.accName(CHILDID_SELF) = myAccName) And _
     (myAcc.accRole(CHILDID_SELF) = myAccRole) Then
    Set ReturnAcc = myAcc
  Else
    Count = myAcc.accChildCount
    If Count > 0& Then
      ReDim List(Count - 1&)
      If AccessibleChildren(myAcc, 0&, ByVal Count, List(0), Count) = 0& Then
        For i = LBound(List) To UBound(List)
          If TypeOf List(i) Is IAccessible Then
            Set ChildAcc = List(i)
            Set ReturnAcc = GetAcc(ChildAcc, myAccName, myAccRole)
            If Not ReturnAcc Is Nothing Then Exit For
          End If
        Next
      End If
    End If
  End If
  Set GetAcc = ReturnAcc
End Function

access2010 IAccessible.accLocationメソッド(oleacc)

Option Compare Database
Option Explicit

Const CHILDID_SELF = 0&

Declare PtrSafe Function AccessibleObjectFromWindow Lib "oleacc" ( _
                                ByVal hWnd As LongPtr, _
                                ByVal dwId As Long, _
                                riid As Any, _
                                ByRef ppvObject As IAccessible _
                                ) As Long

Declare PtrSafe Function IIDFromString Lib "ole32" ( _
                                ByVal lpsz As LongPtr, _
                                lpiid As Any _
                                ) As Long

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

Function ODocTabsHwnd() As LongPtr
    Dim pHwnd As LongPtr
    pHwnd = FindWindowEx(Application.hWndAccessApp, _
                         0, _
                         vbNullString, _
                         "ODocTabs")
    pHwnd = FindWindowEx(pHwnd, _
                         0, _
                         "NetUIHWND", _
                         vbNullString)
    ODocTabsHwnd = pHwnd
End Function

Sub DocumentTabsPos()
    Dim IID(0 To 3) As Long, acc As IAccessible
    Dim xLeft As Long, yTop As Long, _
        xWidth As Long, yHeight As Long
    
    IIDFromString StrPtr("{618736E0-3C3D-11CF-810C-00AA00389B71}"), _
                  IID(0)
    AccessibleObjectFromWindow ODocTabsHwnd, _
                               CHILDID_SELF, _
                               IID(0), _
                               acc
    acc.accLocation xLeft, yTop, xWidth, yHeight
    Debug.Print xLeft, yTop, xWidth, yHeight
End Sub

access2010 “閉じる”をできるだけ検知

閉じるということをできるだけ検知してみようとしている。
基本的にフォームだけなのだけど、PopUpの時もしくはカスケード表示の時のフォーム上のシステムメニュー(っていうでしたっけ、フォームアイコン右クリメニュー)は検知できていない。
以下コードは64bit用。

access2010 access2007 更新前処理イベント内で閉じるボタンのクリックを判定する方法

YU-TANGさんところの
更新前処理イベント内で閉じるボタンのクリックを判定する方法
をaccess2010でやってみた。
タブ付きドキュメントである場合の件。とりあえず動作することは確認できた。

Option Compare Database
Option Explicit

'*************************
'参照設定
'oleacc.dll
'*************************

Const ROLE_SYSTEM_LIST = &H21
Const ROLE_SYSTEM_PUSHBUTTON = &H2B
Const ROLE_SYSTEM_BUTTONMENU = &H39
Const ROLE_SYSTEM_PROPERTYPAGE = &H26
Const ROLE_SYSTEM_MENUITEM = &HC
Const ROLE_SYSTEM_CLIENT = &HA

Private IsRibbonAction As Boolean

Type POINTAPI
        X As Long
        Y As Long
End Type
 
#If VBA7 Then
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" _
                                Alias "RtlMoveMemory" ( _
                                Destination As Any, _
                                Source As Any, _
                                ByVal Length As LongPtr)
                                 
Private Declare PtrSafe Function GetCursorPos Lib "user32" ( _
                                lpPoint As POINTAPI _
                                ) As Long
#If Win64 Then
Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" ( _
                                ByVal llXY As LongLong, _
                                ByRef ppvObject As Any, _
                                ByRef pvarChild As Variant _
                                ) As Long
 
Private Function PointToLongLong(point As POINTAPI) As LongLong
    Dim ll As LongLong, cbLongLong As LongPtr
    cbLongLong = LenB(ll)
    If LenB(point) = cbLongLong Then
        CopyMemory ll, point, cbLongLong
    End If
    PointToLongLong = ll
End Function
#Else
Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" ( _
                                ByVal xScreen As Long, _
                                ByVal yScreen As Long, _
                                ByRef ppvObject As Any, _
                                ByRef pvarChild As Variant _
                                ) As Long
#End If
#Else
Private Declare Function GetCursorPos Lib "user32" ( _
                                lpPoint As POINTAPI _
                                ) As Long
 
Private Declare Function AccessibleObjectFromPoint Lib "oleacc" ( _
                                ByVal xScreen As Long, _
                                ByVal yScreen As Long, _
                                ByRef ppvObject As Any, _
                                ByRef pvarChild As Variant _
                                ) As Long
#End If
 
Function IsCloseButtonClicked() As Boolean
    Dim xy As POINTAPI, acc As IAccessible
    Dim Child As Variant, btnName As String, tabCaption As String
    
    If IsRibbonAction Then
        IsCloseButtonClicked = True
        IsRibbonAction = False
        Exit Function
    End If
    
    GetCursorPos xy
 
#If Win64 Then
    AccessibleObjectFromPoint PointToLongLong(xy), acc, Child
#Else
    AccessibleObjectFromPoint xy.X, xy.Y, acc, Child
#End If
 
    If acc Is Nothing Then
        IsCloseButtonClicked = False
        Exit Function
    End If
 
    btnName = acc.accName(Child)
 
    tabCaption = CodeContextObject.Caption
    If tabCaption = "" Then
        tabCaption = CodeContextObject.Name
    End If

    Select Case acc.accRole(Child)
        Case ROLE_SYSTEM_LIST
            MsgBox "タスクバー:すべてのウィンドウを閉じる" & _
                    vbCrLf & btnName
        Case ROLE_SYSTEM_PUSHBUTTON
            If InStr(1, btnName, "を閉じる") > 1 Then
                MsgBox "フォーム閉じるボタン" & _
                        vbCrLf & btnName
            Else
                MsgBox "Application閉じるボタン" & _
                        vbCrLf & btnName
            End If
        Case ROLE_SYSTEM_BUTTONMENU
            MsgBox "システムメニュー:閉じる" & _
                    vbCrLf & btnName
        Case ROLE_SYSTEM_MENUITEM
            MsgBox "フォームアイコンダブルクリック" & _
                    vbCrLf & btnName
        Case ROLE_SYSTEM_PROPERTYPAGE
            '結果的にこうなる
            MsgBox "Applicationアイコンダブルクリック" & _
                    vbCrLf & btnName
        Case Else
            MsgBox "不明 もしくは、Backstageのコマンド" & _
                    vbCrLf & btnName
    End Select
    IsCloseButtonClicked = True
End Function

'RibbonXmlで検知:フォームが開いていること前提
Sub onActionClose(ctr As Object, CancelDefault)
    If Screen.ActiveForm.Dirty Then
        MsgBox "RibbonXmlで管理できるコマンド:" & ctr.ID
        IsRibbonAction = True
    End If
    CancelDefault = False
End Sub

<customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui">
  <commands>
    <command idMso="WindowClose" onAction="onActionClose" />
    <command idMso="CloseDocument" onAction="onActionClose" />
    <command idMso="FileCloseDatabase" onAction="onActionClose" />
    <command idMso="FileExit" onAction="onActionClose" />
  </commands>
</customUI> 

a2007でも動作するけどOfficeメニューから閉じる動作については対応は今のところ放置。同様に、BackStageから閉じる場合も反応できない。この辺はリボンカスタマイズでなんとかなるかな。タスクバーから閉じる場合もダメなんす。 a2010Runtimeだけシステムメニューから閉じるの場合反応なし。a2010（x64）についてはからっきし動作しない。調査してみるけど、これは俺には無理かも。AccessibleObjectFromPoint にXYをどのように渡すかだろうか。

64bitも動作するようになった。座標をLongLongで渡して成功。そして、デレクティブ。
でも、考えないといけないこと、たくさんあるな。どうしようかな。いずれにせよ、とりあえず。

いろいろ継ぎはぎしてみてBackstageとかOfficemenuもRibbonXmlで一応握ってみたと。
んー、やっぱりとりあえずレベル。たまに失敗している気配はしている。検証甘いから、何も考えずに実装するするにはちょっと心もとない。Accessibleを使うっつーところだけがポイントだろうか。

access2010 access2007 GUID取得

以前から使ってたのはちょっとなんだから、見直し。
accessに StringFromGUIDってのがあるから使ってみる。
ふむふむ、StringFromGUIDの引数はByte配列だと。でこうなった。

Option Compare Database
Option Explicit

Private Type GUID
    GUIDData(0 To 15) As Byte
End Type

#If VBA7 Then
Private Declare PtrSafe Function CoCreateGuid Lib "ole32" ( _
                                pGUID As GUID _
                                ) As Long

Private Declare PtrSafe Sub CopyMemory Lib "kernel32" _
                                Alias "RtlMoveMemory" ( _
                                Destination As Any, _
                                Source As Any, _
                                ByVal Length As LongPtr)
#Else
Private Declare Function CoCreateGuid Lib "ole32" ( _
                                pGUID As GUID _
                                ) As Long

Private Declare Sub CopyMemory Lib "kernel32.dll" _
                                Alias "RtlMoveMemory" ( _
                                Destination As Any, _
                                Source As Any, _
                                ByVal Length As Long)
#End If

Function GetNewGUID() As String
    Dim tmpGUID As GUID, tmpData(0 To 15) As Byte
    If CoCreateGuid(tmpGUID) = 0 Then
        CopyMemory tmpData(0), tmpGUID.GUIDData(0), 16
        GetNewGUID = Mid(StringFromGUID(tmpData), 7, 38)
    End If
End Function

これで速度はおよそ5倍になった。概ね満足。
いっそのことCopyMemoryも無くしちゃえばいいんじゃね？
と、なってさらにこうなった。

Option Compare Database
Option Explicit
                                
#If VBA7 Then
Private Declare PtrSafe Function CoCreateGuid Lib "ole32" ( _
                                ByVal pGUID As LongPtr _
                                ) As Long
#Else
Private Declare Function CoCreateGuid Lib "ole32" ( _
                                ByVal pGUID As Long _
                                ) As Long
#End If

Function GetNewGUID() As String
    Dim aryGUID(0 To 15) As Byte
    If CoCreateGuid(VarPtr(aryGUID(0))) = 0 Then
        GetNewGUID = Mid(StringFromGUID(aryGUID), 7, 38)
    End If
End Function

さらに速くなったということはない。

そして、ふと、思った。
何の気なしに、VarPtrとかStrPtrとかLongPtrとか使ってるけど、これって本当に大丈夫なのだろうかと。32bitOS+32bitOfficeは問題なかろうと思うけど。
あえて際を行くことはやらなければよいのだろうな。きっと。

office2010 Win32API CopyMemory

Option Compare Database
Option Explicit

#If VBA7 Then
Declare PtrSafe Sub CopyMemory Lib "kernel32" _
                                Alias "RtlMoveMemory" ( _
                                Destination As Any, _
                                Source As Any, _
                                ByVal Length As LongPtr)
#Else
Declare Sub CopyMemory Lib "kernel32.dll" _
                                Alias "RtlMoveMemory" ( _
                                Destination As Any, _
                                Source As Any, _
                                ByVal Length As Long)
#End If

office2010 Win32API 条件付きコンパイル WindowFromPoint

#If VBA7 Then
'************** VBA7共通 **************
Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long

Declare PtrSafe Sub CopyMemory Lib "kernel32" _
                                Alias "RtlMoveMemory" ( _
                                Destination As Any, _
                                Source As Any, _
                                ByVal Length As LongPtr)
'**************************************
    #If Win64 Then
    '************** VBA7x64用 **************
    Declare PtrSafe Function GetWindowLong Lib "user32" _
                                    Alias "GetWindowLongPtrA" ( _
                                    ByVal hwnd As LongPtr, _
                                    ByVal nIndex As Long _
                                    ) As LongPtr
     
    Declare PtrSafe Function SetWindowLong Lib "user32" _
                                    Alias "SetWindowLongPtrA" ( _
                                    ByVal hwnd As LongPtr, _
                                    ByVal nIndex As Long, _
                                    ByVal dwNewLong As LongPtr _
                                    ) As LongPtr
    
    Declare PtrSafe Function GetTickCount64 Lib "kernel32" () As LongLong
      
    Declare PtrSafe Function WindowFromPoint Lib "user32" ( _
                                    ByVal point As LongLong _
                                    ) As LongPtr
     
    Type POINTAPI
            x As Long
            y As Long
    End Type
     
    Function PointToLongLong(point As POINTAPI) As LongLong
        Dim ll As LongLong
        Dim cbLongLong As LongPtr
         
        cbLongLong = LenB(ll)

        If LenB(point) = cbLongLong Then
            CopyMemory ll, point, cbLongLong
        End If
         
        PointToLongLong = ll
    End Function
    '***************************************
    #Else
    '************** VBA7x86用 **************
    Declare PtrSafe Function GetWindowLong Lib "user32" _
                                    Alias "GetWindowLongA" ( _
                                    ByVal hwnd As LongPtr, _
                                    ByVal nIndex As Long _
                                    ) As LongPtr
     
    Declare PtrSafe Function SetWindowLong Lib "user32" _
                                    Alias "SetWindowLongA" ( _
                                    ByVal hwnd As LongPtr, _
                                    ByVal nIndex As Long, _
                                    ByVal dwNewLong As LongPtr _
                                    ) As LongPtr
     
    Declare PtrSafe Function WindowFromPoint Lib "user32" ( _
                                    ByVal xPoint As Long, _
                                    ByVal yPoint As Long _
                                    ) As LongPtr
    '***************************************
    #End If
#Else
'************** Office2007以前 **************
Declare Function GetWindowLong Lib "user32" _
                                Alias "GetWindowLongA" ( _
                                ByVal hwnd As Long, _
                                ByVal nIndex As Long _
                                ) As Long
 
Declare Function SetWindowLong Lib "user32" _
                                Alias "SetWindowLongA" ( _
                                ByVal hwnd As Long, _
                                ByVal nIndex As Long, _
                                ByVal dwNewLong As Long _
                                ) As Long
 
Declare Function GetTickCount Lib "kernel32" () As Long
 
Declare Function WindowFromPoint Lib "user32" ( _
                                ByVal xPoint As Long, _
                                ByVal yPoint As Long _
                                ) As Long
#End If

office2010 Win32API GetWindowText/SetWindowText

#If VBA7 Then
Declare PtrSafe Function SetWindowText Lib "user32" _
                                Alias "SetWindowTextW" ( _
                                ByVal Hwnd As LongPtr, _
                                ByVal lpString As LongPtr _
                                ) As Long

Declare PtrSafe Function GetWindowText Lib "user32" _
                                Alias "GetWindowTextW" ( _
                                ByVal Hwnd As LongPtr, _
                                ByVal lpString As LongPtr, _
                                ByVal cch As Long _
                                ) As Long
#Else
Declare Function SetWindowText Lib "user32" _
                                Alias "SetWindowTextW" ( _
                                ByVal hwnd As Long, _
                                ByVal lpString As Long _
                                ) As Long

Declare Function GetWindowText Lib "user32" _
                                Alias "GetWindowTextW" ( _
                                ByVal Hwnd As Long, _
                                ByVal lpString As Long, _
                                ByVal cch As Long _
                                ) As Long
#End If

'textLength = GetWindowText(Hwnd, StrPtr(buffer), Len(buffer))
'成功：終端Null除く文字数 / 失敗：0 / cch超える分は切り捨て

'result = SetWindowText(Hwnd, StrPtr(Strings))
'成功：0 / 失敗：0以外

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

office2010 Win32API GetDlgItem/GetLastActivePopup

Option Compare Database
Option Explicit

Private Const GW_HWNDNEXT = &H2
Private Const WM_SETTEXT = &HC
Private Const BM_CLICK = &HF5
Private Const IDOK = &H1
Private Const IDCANCEL = &H2
Private Const IDHELP = &H9
Private Const IDC_EDIT = &H8A5 '決め打ち

'http://msdn.microsoft.com/ja-jp/library/cc364779.aspx
Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" ( _
                                ByVal hwnd As LongPtr, _
                                lpdwProcessId As Long _
                                ) As Long
'http://msdn.microsoft.com/ja-jp/library/cc364757.aspx
Private Declare PtrSafe Function GetWindow Lib "user32" ( _
                                ByVal hwnd As LongPtr, _
                                ByVal wCmd As Long _
                                ) As LongPtr

'http://msdn.microsoft.com/ja-jp/library/cc364718.aspx
Private Declare PtrSafe Function GetParent Lib "user32" ( _
                                ByVal hwnd As LongPtr _
                                ) As LongPtr

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

'http://msdn.microsoft.com/ja-jp/library/cc364701.aspx
Private Declare PtrSafe Function GetLastActivePopup Lib "user32" ( _
                                ByVal hwndOwnder As LongPtr _
                                ) As LongPtr

'http://msdn.microsoft.com/ja-jp/library/cc364621.aspx
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

'http://support.microsoft.com/kb/242308/ja
'EnumWindows
Private Function ProcIDFromWnd(ByVal hwnd As LongPtr) As Long
   Dim idProc As Long
   
   ' Get PID for this HWnd
   GetWindowThreadProcessId hwnd, idProc
   
   ' Return PID
   ProcIDFromWnd = idProc
End Function
      
Private Function GetWinHandle(hInstance As Long) As LongPtr
   Dim tempHwnd As LongPtr
   
   ' Grab the first window handle that Windows finds:
   tempHwnd = FindWindow(vbNullString, vbNullString)
   
   ' Loop until you find a match or there are no more window handles:
   Do Until tempHwnd = 0
      ' Check if no parent for this window
      If GetParent(tempHwnd) = 0 Then
         ' Check for PID match
         If hInstance = ProcIDFromWnd(tempHwnd) Then
            ' Return found handle
            GetWinHandle = tempHwnd
            ' Exit search loop
            Exit Do
         End If
      End If
   
      ' Get the next window handle
      tempHwnd = GetWindow(tempHwnd, GW_HWNDNEXT)
   Loop
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)
    'hInstanceなのか？
    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

access2010 access2007 Win32API レジストリ その2

Option Compare Database
Option Explicit
 
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type

Private Const HKEY_CURRENT_USER = &H80000001
 
Private Const ERROR_SUCCESS = 0
 
Private Const REG_SZ = 1 ' Unicode nul terminated string
Private Const REG_DWORD = 4 '32-bit number
 
Private Const REG_OPTION_NON_VOLATILE = 0
 
Private Const KEY_ALL_ACCESS = &HF003F
Private Const KEY_SET_VALUE = &H2
 
#If VBA7 Then
Private Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As LongPtr
    bInheritHandle As Long
End Type
 
Private Const strTrustedLocations = "Software\Microsoft\Office\14.0\Access\Security\Trusted Locations\"

Private Declare PtrSafe Function RegCreateKeyEx Lib "advapi32.dll" _
                                Alias "RegCreateKeyExA" ( _
                                ByVal hKey As LongPtr, _
                                ByVal lpSubKey As String, _
                                ByVal Reserved As Long, _
                                ByVal lpClass As String, _
                                ByVal dwOptions As Long, _
                                ByVal samDesired As Long, _
                                lpSecurityAttributes As SECURITY_ATTRIBUTES, _
                                phkResult As LongPtr, _
                                lpdwDisposition As Long _
                                ) As Long
  
Private Declare PtrSafe Function RegSetValueEx Lib "advapi32.dll" _
                                Alias "RegSetValueExA" ( _
                                ByVal hKey As LongPtr, _
                                ByVal lpValueName As String, _
                                ByVal Reserved As Long, _
                                ByVal dwType As Long, _
                                lpData As Any, _
                                ByVal cbData As Long _
                                ) As Long
 
Private Declare PtrSafe Function RegCloseKey Lib "advapi32.dll" ( _
                                ByVal hKey As LongPtr _
                                ) As Long

Private Declare PtrSafe Function CoCreateGuid Lib "OLE32.DLL" ( _
                                pGuid As GUID _
                                ) As Long
#Else
Private Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Long
End Type
 
Private Const strTrustedLocations = "Software\Microsoft\Office\12.0\Access\Security\Trusted Locations\"

Private Declare Function RegCreateKeyEx Lib "advapi32.dll" _
                                Alias "RegCreateKeyExA" ( _
                                ByVal hKey As Long, _
                                ByVal lpSubKey As String, _
                                ByVal Reserved As Long, _
                                ByVal lpClass As String, _
                                ByVal dwOptions As Long, _
                                ByVal samDesired As Long, _
                                lpSecurityAttributes As SECURITY_ATTRIBUTES, _
                                phkResult As Long, _
                                lpdwDisposition As Long _
                                ) As Long
  
Private Declare Function RegSetValueEx Lib "advapi32.dll" _
                                Alias "RegSetValueExA" ( _
                                ByVal hKey As Long, _
                                ByVal lpValueName As String, _
                                ByVal Reserved As Long, _
                                ByVal dwType As Long, _
                                lpData As Any, _
                                ByVal cbData As Long _
                                ) As Long
 
Private Declare Function RegCloseKey Lib "advapi32.dll" ( _
                                ByVal hKey As Long _
                                ) As Long

Private Declare Function CoCreateGuid Lib "OLE32.DLL" ( _
                                pGuid As GUID _
                                ) As Long
#End If

Public Function GetNewGUID() As String
    Dim udtGUID As GUID
    If (CoCreateGuid(udtGUID) = 0) Then
        GetNewGUID = "{" & _
        String(8 - Len(Hex$(udtGUID.Data1)), "0") & Hex$(udtGUID.Data1) & "-" & _
        String(4 - Len(Hex$(udtGUID.Data2)), "0") & Hex$(udtGUID.Data2) & "-" & _
        String(4 - Len(Hex$(udtGUID.Data3)), "0") & Hex$(udtGUID.Data3) & "-" & _
        IIf((udtGUID.Data4(0) < &H10), "0", "") & Hex$(udtGUID.Data4(0)) & _
        IIf((udtGUID.Data4(1) < &H10), "0", "") & Hex$(udtGUID.Data4(1)) & "-" & _
        IIf((udtGUID.Data4(2) < &H10), "0", "") & Hex$(udtGUID.Data4(2)) & _
        IIf((udtGUID.Data4(3) < &H10), "0", "") & Hex$(udtGUID.Data4(3)) & _
        IIf((udtGUID.Data4(4) < &H10), "0", "") & Hex$(udtGUID.Data4(4)) & _
        IIf((udtGUID.Data4(5) < &H10), "0", "") & Hex$(udtGUID.Data4(5)) & _
        IIf((udtGUID.Data4(6) < &H10), "0", "") & Hex$(udtGUID.Data4(6)) & _
        IIf((udtGUID.Data4(7) < &H10), "0", "") & Hex$(udtGUID.Data4(7)) & "}"
    End If
End Function

Sub setTrustedLocations()
#If VBA7 Then
    Dim hNewKey As LongPtr
#Else
    Dim hNewKey As Long
#End If
    Dim lngrtn As Long, strSubKey As String
    Dim SA As SECURITY_ATTRIBUTES, rtnDisp As Long
    Dim strValue As String, lngValue As Long
    
    strSubKey = strTrustedLocations & GetNewGUID
    
    lngrtn = RegCreateKeyEx(HKEY_CURRENT_USER, _
                            strSubKey, _
                            0, _
                            vbNullString, _
                            REG_OPTION_NON_VOLATILE, _
                            KEY_ALL_ACCESS, _
                            SA, _
                            hNewKey, _
                            rtnDisp)
    If lngrtn = ERROR_SUCCESS Then
        strValue = CurrentProject.Path & "\"
        RegSetValueEx hNewKey, _
                      "Path", _
                      0, _
                      REG_SZ, _
                      ByVal strValue, _
                      LenB(strValue)
        
        strValue = CurrentProject.Name & "の自炊レジストリ"
        RegSetValueEx hNewKey, _
                      "Description", _
                      0, _
                      REG_SZ, _
                      ByVal strValue, _
                      LenB(strValue)
        
        strValue = Format(Now, "yyyy/mm/dd hh:nn")
        RegSetValueEx hNewKey, _
                      "Date", _
                      0, _
                      REG_SZ, _
                      ByVal strValue, _
                      LenB(strValue)
        
'        lngValue = 1
'        RegSetValueEx hNewKey, _
'                      "AllowSubfolders", _
'                      0, _
'                      REG_DWORD, _
'                      lngValue, _
'                      Len(lngValue)
    End If
    RegCloseKey hNewKey
End Sub

access2010 Quick Access Display（仮）

これの制御方法がわかんない。accessのオプションなんだけど、
Application.SetOption "Size of MRU File List", 0　じゃないんだよな。そもそも、Size of MRU File List　使えてないみたいだし。
[クライアントの設定]→[表示]→[最近使用した...]の設定は、
キー名：HKEY_CURRENT_USER\Software\Microsoft\Office\14.0\Access\File MRU
名前：Max Display
で、backstageから投入するのは、
名前：Max Quick Access Display
に入ってるしな。SetOptionメソッドで設定する方法が不明だから、そのうちにでも。
で、本題のショートカットの件。

キー名：HKEY_CURRENT_USER\Software\Microsoft\Office\14.0\Access\File MRU
名前：Quick Access Display
に情報がある。 レジストリを直接いじればなんとか。

Sub setQuickAccessDisplay()
    Dim kHnd As LongPtr, lngvalue As Long, lngrtn As Long
    lngvalue = 0 '0:非表示　1:表示
    Const strSubKey = "Software\Microsoft\Office\14.0\Access\File MRU"
    Const strName = "Quick Access Display"
    lngrtn = RegOpenKeyEx(HKEY_CURRENT_USER, strSubKey, 0, KEY_SET_VALUE, kHnd)
    If lngrtn = ERROR_SUCCESS Then
        RegSetValueEx kHnd, strName, 0, REG_DWORD, lngvalue, Len(lngvalue)
    End If
    RegCloseKey kHnd
End Sub

もしくは、
[カレントデータベース]→[リボンとツールバーのオプション]→[すべてのメニューを表示する]で非表示にする。だけど、この場合、セパレータが残る。

CustomUI/backstage要素内で制御する方法はなさそう。

office2010 Win32API レジストリ

Option Compare Database
Option Explicit

Private Type SECURITY_ATTRIBUTES
        nLength As Long
        lpSecurityDescriptor As LongPtr
        bInheritHandle As Long
End Type

Private Type FILETIME
        dwLowDateTime As Long
        dwHighDateTime As Long
End Type

Private Const HKEY_CURRENT_USER = &H80000001
Private Const HKEY_LOCAL_MACHINE = &H80000002

Private Const ERROR_SUCCESS = 0

Private Const REG_SZ = 1 ' Unicode nul terminated string
Private Const REG_DWORD = 4 '32-bit number

Private Const REG_OPTION_NON_VOLATILE = 0

Private Const KEY_ALL_ACCESS = &HF003F
Private Const KEY_SET_VALUE = &H2
Private Const KEY_QUERY_VALUE = &H1

Private Declare PtrSafe Function RegCreateKeyEx Lib "advapi32.dll" _
                                Alias "RegCreateKeyExA" ( _
                                ByVal hKey As LongPtr, _
                                ByVal lpSubKey As String, _
                                ByVal Reserved As Long, _
                                ByVal lpClass As String, _
                                ByVal dwOptions As Long, _
                                ByVal samDesired As Long, _
                                lpSecurityAttributes As SECURITY_ATTRIBUTES, _
                                phkResult As LongPtr, _
                                lpdwDisposition As Long _
                                ) As Long

Private Declare PtrSafe Function RegOpenKeyEx Lib "advapi32.dll" _
                                Alias "RegOpenKeyExA" ( _
                                ByVal hKey As LongPtr, _
                                ByVal lpSubKey As String, _
                                ByVal ulOptions As Long, _
                                ByVal samDesired As Long, _
                                phkResult As LongPtr _
                                ) As Long

' Note that if you declare the lpData parameter as String, you must pass it By Value.
' RegQueryValueEx kHnd, strName, 0, 0, ByVal strBuffer, Len(strBuffer)
Private Declare PtrSafe Function RegQueryValueEx Lib "advapi32.dll" _
                                Alias "RegQueryValueExA" ( _
                                ByVal hKey As LongPtr, _
                                ByVal lpValueName As String, _
                                ByVal lpReserved As LongPtr, _
                                lpType As Long, _
                                lpData As Any, _
                                lpcbData As Long _
                                ) As Long

' Note that if you declare the lpData parameter as String, you must pass it By Value.
' RegSetValueEx kHnd, strName, 0, REG_SZ, ByVal strValue, Len(strValue)
Private Declare PtrSafe Function RegSetValueEx Lib "advapi32.dll" _
                                Alias "RegSetValueExA" ( _
                                ByVal hKey As LongPtr, _
                                ByVal lpValueName As String, _
                                ByVal Reserved As Long, _
                                ByVal dwType As Long, _
                                lpData As Any, _
                                ByVal cbData As Long _
                                ) As Long

Private Declare PtrSafe Function RegDeleteKey Lib "advapi32.dll" _
                                Alias "RegDeleteKeyA" ( _
                                ByVal hKey As LongPtr, _
                                ByVal lpSubKey As String _
                                ) As Long

Private Declare PtrSafe Function RegDeleteValue Lib "advapi32.dll" _
                                Alias "RegDeleteValueA" ( _
                                ByVal hKey As LongPtr, _
                                ByVal lpValueName As String _
                                ) As Long

Private Declare PtrSafe Function RegCloseKey Lib "advapi32.dll" ( _
                                ByVal hKey As LongPtr _
                                ) As Long

Private Declare PtrSafe Function RegQueryInfoKey Lib "advapi32.dll" _
                                Alias "RegQueryInfoKeyA" ( _
                                ByVal hKey As LongPtr, _
                                ByVal lpClass As String, _
                                lpcbClass As Long, _
                                ByVal lpReserved As LongPtr, _
                                lpcSubKeys As Long, _
                                lpcbMaxSubKeyLen As Long, _
                                lpcbMaxClassLen As Long, _
                                lpcValues As Long, _
                                lpcbMaxValueNameLen As Long, _
                                lpcbMaxValueLen As Long, _
                                lpcbSecurityDescriptor As Long, _
                                lpftLastWriteTime As FILETIME _
                                ) As Long

Private Declare PtrSafe Function RegEnumKeyEx Lib "advapi32.dll" _
                                Alias "RegEnumKeyExA" ( _
                                ByVal hKey As LongPtr, _
                                ByVal dwIndex As Long, _
                                ByVal lpName As String, _
                                lpcbName As Long, _
                                ByVal lpReserved As LongPtr, _
                                ByVal lpClass As String, _
                                lpcbClass As Long, _
                                lpftLastWriteTime As FILETIME _
                                ) As Long

Private Declare PtrSafe Function RegEnumValue Lib "advapi32.dll" _
                                Alias "RegEnumValueA" ( _
                                ByVal hKey As LongPtr, _
                                ByVal dwIndex As Long, _
                                ByVal lpValueName As String, _
                                lpcbValueName As Long, _
                                ByVal lpReserved As LongPtr, _
                                lpType As Long, lpData As Byte, _
                                lpcbData As Long _
                                ) As Long

office2010 Win32API keybd_event Backstageを表示させない

access2010でファイルタブ押下してもBackstageを表示させない。といっても、onShowでESCキー押下しているだけ。

Option Compare Database
Option Explicit

Private Const VK_ESCAPE = &H1B
Private Const KEYEVENTF_KEYUP = &H2
Private Const KEYEVENTF_EXTENDEDKEY = &H1

'http://msdn.microsoft.com/ja-jp/library/cc364822.aspx
'SendInputを使えとなってるけど、別途x64対応せにゃならんからこっち使う。
Private Declare PtrSafe Sub keybd_event Lib "user32" ( _
                                ByVal bVk As Byte, _
                                ByVal bScan As Byte, _
                                ByVal dwFlags As Long, _
                                ByVal dwExtraInfo As LongPtr)

Sub onShow(cntxt As Object)
    keybd_event VK_ESCAPE, 0, 0, 0
    keybd_event VK_ESCAPE, 0, KEYEVENTF_KEYUP, 0
End Sub

<customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui">
  <backstage onShow="onShow" />
</customUI>

なのだけど、結局ribbonXmlを書かにゃならん。
SendInputを使うよりは、keybd_eventの方が64bit対応がすっきりしてていいかなということだけ。まぁとりあえず作動するし。