2010/12/30

access2010 Webブラウザーコントロール その3

Webブラウザーコントロールのobjectプロパティ
Webブラウザーコントロールのメソッドでは、実体であるIEを直接操作することができない。
イベントはひと通り揃ってるからよいのだけれど、GoBackとかリロードさせるメソッドがないということ。なので、objectプロパティで オブジェクトを参照しメソッドを呼び出す。

Option Compare Database
Option Explicit
'エラー処理してない

Private wbObj As WebBrowser

Const BaseUrl = "http://www.google.co.jp/"

Private Sub cmdBack_Click()
    wbObj.GoBack
End Sub

Private Sub cmdForword_Click()
    wbObj.GoForward
End Sub

Private Sub cmdReload_Click()
    wbObj.Refresh
End Sub

Private Sub Form_Load()
    Set wbObj = Me.Webブラウザー0.Object
    Me.Webブラウザー0.ControlSource = URLstring(BaseUrl)
End Sub

Private Function URLstring(x As String)
    URLstring = Chr(61) & Chr(34) & x & Chr(34)
End Function

2010/12/29

access2010 access2007 メッセージバー(読み取り専用)の制御

Option Compare Database
Option Explicit
'*********************************************
'引用及び参考:http://www.ka-net.org/
'参照設定:oleacc.dll
'*********************************************
Private Const CHILDID_SELF = 0&
Private Const OBJID_CLIENT = &HFFFFFFFC
Private Const ROLE_SYSTEM_PUSHBUTTON = &H2B

#If VBA7 Then
Private 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
 
Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "oleacc" ( _
                                ByVal hWnd As LongPtr, _
                                ByVal dwId As Long, _
                                riid As Any, _
                                ByRef ppvObject As IAccessible _
                                ) As Long
 
Private Declare PtrSafe Function IIDFromString Lib "ole32" ( _
                                ByVal lpsz As LongPtr, _
                                lpiid As Any _
                                ) As Long

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 Function MsgBarHwnd() As LongPtr
    Dim hndl As LongPtr
    hndl = FindWindowEx(hWndAccessApp, 0, _
                       "MsoCommandBarDock", "MsoDockTop")
    hndl = FindWindowEx(hndl, 0, "MsoCommandBar", " ") '決め打ちしてるところ
    hndl = FindWindowEx(hndl, 0, "MsoWorkPane", vbNullString)
    hndl = FindWindowEx(hndl, 0, "NUIPane", vbNullString)
    hndl = FindWindowEx(hndl, 0, "NetUIHWND", vbNullString)
    MsgBarHwnd = hndl
End Function
#Else
Private Declare 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
 
Private Declare Function AccessibleObjectFromWindow Lib "oleacc" ( _
                                ByVal hwnd As Long, _
                                ByVal dwId As Long, _
                                riid As Any, _
                                ByRef ppvObject As IAccessible _
                                ) As Long
 
Private Declare Function IIDFromString Lib "ole32" ( _
                                ByVal lpsz As Long, _
                                lpiid As Any _
                                ) As Long

Private Declare Function FindWindowEx Lib "user32" _
                                Alias "FindWindowExA" ( _
                                ByVal hWnd1 As Long, _
                                ByVal hWnd2 As Long, _
                                ByVal lpsz1 As String, _
                                ByVal lpsz2 As String _
                                ) As Long

Private Function MsgBarHwnd() As Long
    Dim hndl As Long
    hndl = FindWindowEx(hWndAccessApp, 0, _
                       "MsoCommandBarDock", "MsoDockTop")
    hndl = FindWindowEx(hndl, 0, "MsoCommandBar", " ") '決め打ちしてるところ
    hndl = FindWindowEx(hndl, 0, "MsoWorkPane", vbNullString)
    hndl = FindWindowEx(hndl, 0, "NUIPane", vbNullString)
    hndl = FindWindowEx(hndl, 0, "NetUIHWND", vbNullString)
    MsgBarHwnd = hndl
End Function
#End If
Private 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

Function MsgBarClose()
    If CurrentDb.Updatable Then Exit Function
    Do Until MsgBarHwnd <> 0
        DoEvents
    Loop
    Dim accApp As IAccessible, acc As IAccessible, accChild As IAccessible
    Dim IID(0 To 3) As Long, strName As String
#If VBA7 Then
    strName = "このメッセージを閉じる"
#Else
    strName = "閉じる"
#End If
    IIDFromString StrPtr("{618736E0-3C3D-11CF-810C-00AA00389B71}"), IID(0)
    If AccessibleObjectFromWindow(MsgBarHwnd, _
                                  OBJID_CLIENT, _
                                  IID(0), _
                                  acc) _
                                  <> 0 Then Exit Function

    Set accChild = GetAcc(acc, strName, ROLE_SYSTEM_PUSHBUTTON)
    accChild.accDoDefaultAction CHILDID_SELF
End Function
ちょっと安定した
振り返ると、メッセージバーを表示しないメニューコマンドの実行/DoCmd.RunCommand acCmdHideMessageBar で制御できるし。

2010/12/27

access2010 ナビゲーションフォーム その5

移動ボタン(NavigationButton)と移動コントロール(NavigationControl)の件。
移動ボタンにはParentTab、移動コントロールにはTabs、っつープロパティがあったのね。
ちょっと遠回りしたか?
Dim NavCtr As NavigationControl
Dim NavBtn As NavigationButton
Set NavCtr = Me.移動コントロール5 '最上位ではない

For Each NavBtn In NavCtr.Tabs
    Debug.Print NavBtn.Name, NavBtn.ParentTab.Name
Next
'ここまでとここからの出力はちょっとだけ違うけど
For Each NavBtn In NavCtr.Controls
    Debug.Print NavBtn.Name, NavBtn.Properties("NavigationParentButton")
Next
ヘルプを見ると、最上位レベルとある。英語版でもTop-Levelとなっているが、最上位ということではなく、親。ひとつ上位レベルの移動ボタン(NavigationButton)を参照できる。
そして、最上位レベルである時ParentTabを参照すると、強制終了する。
If NavCtr.Properties("NavigationParent") <> "" Then
    For Each NavBtn In NavCtr.Tabs
        Debug.Print NavBtn.Name, NavBtn.ParentTab.Name
    Next
End If
単純に選択されている移動ボタン(NavigationButton)を参照するだけなら、移動コントロール(NavigationControl)のSelectedTabプロパティでいい。

2010/12/26

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

2010/12/24

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

2010/12/22

access2010 access2007 Application.ProductCode

Application.ProductCodeで何を見るか。

{BRMMmmmm-PPPP-LLLL-p000-D000000FF1CE}

MMがメジャーバージョンだから、12だとOffice2007,14だとOffice2010
PPPPが製品IDで、001CがAccess Runtime
pはx86/x64で、x86だと 0、x64なら 1

Office 2010 における製品コード GUID の番号付けのしくみ

2007 Office スイートおよび 2007 Office プログラムにおける製品コード GUID の番号付けのしくみについて

Office2003以前だとちょっと違う
Office 2003 における製品コード GUID の番号付けのしくみ

2010/12/20

年末だから、チラシの裏

だらだらと自分用メモとして始めてみたのだけれども、なんだか面白かったなぁと。
Bloggerの統計をみて思ってしまった。

多い順で。
1.日本
日本語なのだから当たり前、全体の95%。自分のアクセスも含まれちゃってんだろうから。
2.アメリカ合衆国
特に印象なし。なんだっけ
3.ルクセンブルグ
ルクセンブルグの人には悪いんだけど、どこにあるのかすら知らんかった。どうやらいい国っぽいな。行ってみたい国1番手。
4.ブラジル
遠いよね、日本から。船旅でなら行ってみたい。
5.カナダ
来日した台湾系米国人が、カナダはいいぜぇ、一緒に行こうぜなんて言ってたけど行きません。
6.南アフリカ
これまた遠いなぁ。google.co.zaからだったかな
7.オランダ
王国なんだよね。飾り窓とかあっちの方しか思い浮かばないのは、申し訳ない。
8.ラトビア
バルト3国って行ってみたい地域。だって、美人が多いって言うじゃないの。
9.ハンガリー
共産党時代があった国や地域ってなんか好き。
10.中国
ニーハオ。グレートファイアウォールはどうなっているのだろうか。

その他、いろんな国からのアクセスがあったみたいなんだけど、google.co.jpだったりするんよね。
いろんなところに日本人がいるのだろうなぁと。行ってみたいなよその国。

1.access2010 不具合
まぁ、当然だな。こればっかりは仕方がない。どえらく機能が追加されてるわけだし、早いとこSP1出してほしいものだ。それ以前に、Win7SP1でどうなるかが気になるが。
2.access 2007 runtime ショートカットメニューが出ない
えぇ、出ませんとも。自前で作るか、Application.Commandbars(hoge).ShowPopupでどうぞ。
3.access2010 backstage ビュー 非表示
ribbonXml書いて好きなだけ非表示にしちゃいなよ。
4.access2010 webデータベース
取っ掛かりは面白い。だが、Sharepointがないとダメなんで今後どうなっていくのかな。office365で使用できるのだけれども、これは広がっていくのだろうか。office15でどうなるかな。フォームがWebページに変換されるのは、スゲーなと思う。ちょっとだけ思い入れ。
5.access2010 互換性
何との互換性だけど、互換性はないと思うべき。JetからAce、VBA7、64bitとかいろいろあるし。access2010x64でaccde/mde/ade作ると、それ以外で開くことできないんだよ。ファイルを開くことができないってことね。
6.access2010 idmso
ribbonに関する情報が少ないんだな、きっと。2010の情報探しても2007の情報を見てください的なこと多い気がする。
7.access 2007 vba 分割フォーム
多分一番ダメな子だと思う。2010でもあるのだけれども、表舞台にはいないし。TempVars使え。
8.access2010 配布
お好きなだけどうぞ。Runtime版は無償で使用できますからね。
9.access2010ランタイムのリボン
ribbonxml書いて。慣れたら簡単。
10.class_initialize mysql
記憶にございません。

なんだかなぁと思いつつ思い入れもある検索キーワード
76件てどうなのよと。
9件てね。きっと、どうでもいいことなんだな。いつか役に立つ日がくるかな。

チラシの裏終わり


access2010 パッケージソリューションウィザード その12

だらだらメモし続けて、その12
access2010 パッケージソリューション 表示されない のキーワードでの検索が定期的にあるようなので書いておく。

1.インストールしないとだめですよ。

2.COMアドインから削除してしまったとき
インストールオプションの再インストールしてもだめみたいなので、インストール済みであることを確認の上、表示されないユーザでログイン後、レジストリの追加
------reg File start ----
Windows Registry Editor Version 5.00

[HKEY_CURRENT_USER\Software\Microsoft\Office\Access\Addins\AccessPW.14]
"CommandLineSafe"=dword:00000000
"Description"="Microsoft Access Package Solution Wizard 2010 COM Addin"
"FriendlyName"="Microsoft Access Package Solution Wizard 2010 COM Addin"
"LoadBehavior"=dword:00000003
------reg File end ----

3. COMアドインのチェックを外して以降、なにしてもアクティブになってくれない時
LoadBehaviorの値を2から3に更新

Package Solution Wizard まとめはこちら

2010/12/17

access2010 Ribbon comboBoxの不具合

invalidateControlで再キャッシュ後getTextで取得した値を中の人が忘れてしまう。

フォームを閉じるとき、invalidatecontrolを実行。開く時では、リボンがキャッシュされていないことがあるからと普通に考えた。要はフォームを開いたときは初期化しておきたかっただけ。
で、どうなるかというと、
comboBoxのItemを選択もしくは同じ文字列を投入し、フォームを閉じる。この時、comboBoxの値の初期化が成功するのは目視できる。だけど、フォームを再び開いたときには最後に投入したItemが選択された状態に戻っている。
<customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui" 
               onLoad="onLoad">
  <ribbon startFromScratch="false">
    <tabs>
      <tab id="tab01" label="タブ01">
        <group id="g01" label="グループ01">
          <comboBox id="cb01" label="コンボボックス" getText="getText">
            <item id="i01" label="item01" imageMso="Info" />
            <item id="i02" label="item02" imageMso="HappyFace" />
            <item id="i03" label="item03" imageMso="PanningHand" />
          </comboBox>
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>
Option Compare Database
Option Explicit

Private rbn As IRibbonUI

Sub onLoad(ribbon As IRibbonUI)
    Set rbn = ribbon
End Sub

Sub getText(ctr As IRibbonControl, rtn)
    rtn = "(未選択)"
End Sub

Sub Invalidate_cb01()
    rbn.InvalidateControl "cb01"
End Sub
Option Compare Database
Option Explicit

Private Sub Form_Close()
    Module1.Invalidate_cb01
End Sub

で、現時点での対策その1。但し、該当comboBoxが配置されているタブがアクティブになること
Option Compare Database
Option Explicit

Private rbn As IRibbonUI

Sub onLoad(ribbon As IRibbonUI)
    Set rbn = ribbon
End Sub

Sub getText(ctr As IRibbonControl, rtn)
    rtn = "(未選択)"
    DoEvents
End Sub

Sub Invalidate_cb01()
    rbn.InvalidateControl "cb01"
End Sub
Option Compare Database
Option Explicit

Private Sub Form_Load()
On Error Resume Next '初回のエラーだけ処理したい
    Module1.Invalidate_cb01
End Sub

対策その2。初期化なんて考えない。

access2010 Ribbon RibbonXmlが読み込まれるのはいつだ

RibbonXmlが読み込まれるタイミングの話。
CutomUI要素のonLoadはリボンが初めて使用される時のことでキャッシュされる時。どっちかっていうとonCacheって感じで違う話。

USysRibbonsに登録したRibbonXmlは自動的に全て読み込まれるのだが、これはAutoExecより先。
AutoExecでLoadCustomUIメソッドを同一RibbonNameで実行してみると明白。
で、BackstageをカスタマイズするRibbonXmlは、AutoExecでのLoadCustomUIメソッド実行が読み込みの最終期限。コマンドラインスイッチ /x マクロ実行では間に合わない。

Backstageに配置したコントロールを実行時に操作にする場合は、USysRibbonsで自動読み込むのではなく、AutoExecでCurrentProject.IsTrusted検査後、LoadCustomUIメソッドで読み込むことが大事なポイント。

Backstage以外をカスタマイズするRibbonXmlは、実際に使う時、つまりキャッシュされる直前までに読み込まれていればいい。

たぶんa2007も同じ。

2010/12/16

access2010 パッケージソリューションウィザード その11 不具合修正

HotFixが公開されていたので、一応確認。
Description of the Access 2010 hotfix package (accessde-x-none.msp): December 14, 2010
サブフォルダにファイルを追加しようとした場合、「予期しないエラーが発生しました。」でパッケージが作成できないことに対する修正。一応SP1リリースということになっている。

a2010(x64)とa2007用はまだみたい。そのうちでるでしょって。
でもってOrcaで確認
SUBFOLDER1が追加されている。フォルダ名pict
ファイルも無事同梱されている
残念なことにレジストリがa2007用
もうね、なんで一緒に直さないのかと。
念のためインストールさせてみたけど、レジストリ以外は無事に処理が進む。

いまのところレジストリはウィザード途中でa2010用レジストリを追加もしくはmsiの修正が必要。そして、サブフォルダにaccessファイルを同梱してパッケージを作る時、必要に応じてAllowSubfoldersも追加しなければならない。

http://social.answers.microsoft.com/Forums/en-US/addbuz/thread/d009265c-6e87-432a-8515-9265b372836f 
Kathyのコメントがちょっと気になる。

Package Solution Wizard まとめはこちら

access2010 Ribbon contextualTabs TabSetFormReportExtensibility

ユーザ定義ができる組み込みtabSet。idMsoは、TabSetFormReportExtensibility
通常のタブと違うのはタブの表示とオブジェクトが開いたときタブがアクティブになる。
そして、一番右に表示される。

<customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui">
  <ribbon>
    <contextualTabs>
      <tabSet idMso="TabSetFormReportExtensibility">
        <tab id="tab02" label="オブジェクトが開かれたときアクティブになる">
          <group id="g02" label="グループ02">
            <labelControl id="lbl01" label="contextualTabs" />
          </group>
        </tab>
        <tab id="tab03" label="タブ03">
          <group id="g03" label="グループ03">
            <button id="btn02" label="ボタン02" imageMso="Info" />
          </group>
        </tab>
      </tabSet>
    </contextualTabs>
    <tabs>
      <tab id="tab01" label="タブ01" insertAfterMso="TabHomeAccess">
        <group id="g01" label="グループ01">
          <button idMso="ApplicationOptionsDialog" visible="true" />
          <button idMso="FileCloseDatabase" />
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>

2010/12/13

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対応がすっきりしてていいかなということだけ。まぁとりあえず作動するし。

2010/12/09

Access2010 フォームイベントのメモ

通常 レコードが0件で
AllowAdditions=False
Load時
レコードソース設定
Open時
レコードソース設定
1:Form_Open1 1:Form_Open1 1:Form_Open1 1:Form_Open1
2:Form_Open2 2:Form_Open2 2:Form_Open2 2:Form_Load1
3:Form_Load1 3:Form_Load1 3:Form_Load1 3:Form_Load2
4:Form_Load2 4:Form_Load2 4:Form_Activate 4:Form_Resize
5:Form_Resize 5:Form_Resize 5:Form_Current 5:Form_Activate
6:Form_Activate 6:Form_Activate 6:Form_Load2 6:Form_GotFocus
7:Form_Current
7:Form_Resize 7:Form_Current


8:Form_Deactivate 8:Form_Open2


9:Form_Activate


10:Form_Current




8:Form_Unload 7:Form_Unload 11:Form_Unload 9:Form_Unload
9:Form_Deactivate 8:Form_Deactivate 12:Form_Deactivate 10:Form_Deactivate
10:Form_Close 9:Form_Close 13:Form_Close 11:Form_Close

フォームにEnabled=Trueの
コントロールがない
詳細セクションに
Enabled=Trueの
コントロールがない
PopUp/ダイアログ
1:Form_Open1 1:Form_Open1 1:Form_Open1
2:Form_Open2 2:Form_Open2 2:Form_Open2
3:Form_Load1 3:Form_Load1 3:Form_Load1
4:Form_Load2 4:Form_Load2 4:Form_Load2
5:Form_Resize 5:Form_Resize 5:Form_Resize
6:Form_Activate 6:Form_Activate 6:Form_Current
7:Form_GotFocus 7:Form_GotFocus
8:Form_Current 8:Form_Current



9:Form_Unload 9:Form_Unload 7:Form_Unload
10:Form_LostFocus 10:Form_GotFocus 8:Form_Close
11:Form_Deactivate 11:Form_LostFocus
12:Form_Close 12:Form_Deactivate

13:Form_Close
Option Compare Database
Option Explicit
'access2010調べ
Private i As Integer

Private Sub Form_GotFocus()
    EventLog "Form_GotFocus"
End Sub

Private Sub Form_LostFocus()
    EventLog "Form_LostFocus"
End Sub

Private Sub Form_Open(Cancel As Integer)
    EventLog "Form_Open1"
'    Me.RecordSource = "テーブル1"
    EventLog "Form_Open2"
End Sub

Private Sub Form_Load()
    EventLog "Form_Load1"
'    Me.RecordSource = "テーブル1"
    EventLog "Form_Load2"
End Sub

Private Sub Form_Resize()
    EventLog "Form_Resize"
End Sub

Private Sub Form_Activate()
    EventLog "Form_Activate"
End Sub

Private Sub Form_Current()
    EventLog "Form_Current"
End Sub

Private Sub Form_Deactivate()
    EventLog "Form_Deactivate"
End Sub

Private Sub Form_Unload(Cancel As Integer)
    EventLog "Form_Unload"
End Sub

Private Sub Form_Close()
    EventLog "Form_Close"
End Sub

Private Sub EventLog(str As String)
    i = i + 1
    Debug.Print i & ":" & str
End Sub

access2010 Webデータベース その6 accdwとはなんぞや

これだけかよ。ははは。
<?xml version="1.0" encoding="utf-8"?>
<ApplicationReference xmlns="http://schemas.microsoft.com/office/accessservices/2009/04/accdw">
  <URL>http://r2datafull01/sample01</URL>
</ApplicationReference>

2010/12/08

syntaxhighlighter xml表示

あーやっとできた。でもIEだと1行でないな。もういいや。
<?xml version="1.0" encoding="utf-8"?>
<Wix xmlns="http://schemas.microsoft.com/wix/2006/wi">
  <Product Id="__GUID__" Name="Accessテストアプリケーション" Language="1041" Version="0.0.0.1" Manufacturer="MukkuMuku Div." UpgradeCode="__GUID__" Codepage="932">
    <Package Description="Accessアプリケーション配布テスト" Comments="Wix+WixEditでやってみた" InstallerVersion="200" Compressed="yes" />
    <Media Id="1" Cabinet="simple.cab" EmbedCab="yes" />
    <Directory Id="TARGETDIR" Name="SourceDir">
      <Directory Id="WINDOWSVOLUME" Name="sample01">
        <!--WindowsVolumeだとエラーって言ってくるんだわ-->
        <Directory Name="app01" Id="app01">
          <Component Id="db01" DiskId="1" Guid="__GUID__">
            <File Id="maindb.accdb" Name="maindb.accdb" Source="__source path__" KeyPath="yes">
              <Shortcut Id="desktopShortcut" Directory="DesktopFolder" Name="Accessテストアプリケーション" WorkingDirectory="INSTALLDIR" Advertise="yes" Icon="AppIcon.ico" IconIndex="0" />
              <Shortcut Id="ExeShortcut" Directory="ProgramMenuDir" Name="Accessテストアプリケーション" Advertise="yes" Icon="AppIcon.ico" IconIndex="0" />
            </File>
            <CreateFolder>
              <!--フォルダapp01に必要なパーミッションはここ-->
              <Permission User="Users" GenericExecute="yes" GenericRead="yes" GenericWrite="yes" />
              <Permission User="Administrators" GenericAll="yes" />
            </CreateFolder>
            <!--Access Trusted Location用のレジストリ-->
            <RegistryValue Key="Software\Microsoft\Office\14.0\Access\Security\Trusted Locations\[ProductCode]" Root="HKLM" Type="string" Value="[app01]" Name="Path" />
          </Component>
        </Directory>
      </Directory>
      <Directory Id="DesktopFolder"></Directory>
      <Directory Id="ProgramMenuFolder">
        <Directory Id="ProgramMenuDir" Name="MukkuMuku Div.">
          <Component Id="StartMenuShortcuts" Guid="__GUID__">
            <RemoveFolder Id="ProgramMenuDir" On="uninstall" />
            <RegistryValue Root="HKCU" Key="Software\[Manufacturer]\[ProductName]" Type="string" Value="" />
            <Shortcut Id="UninstallProduct" Name="Uninstall" Description="Uninstalls the application" Target="[System64Folder]msiexec.exe" Arguments="/x [ProductCode]" />
          </Component>
        </Directory>
      </Directory>
    </Directory>
    <Feature Id="DefaultFeature" Title="Main Feature" Level="1">
      <ComponentRef Id="db01" />
      <ComponentRef Id="StartMenuShortcuts" />
    </Feature>
    <UI />
    <Icon Id="AppIcon.ico" SourceFile="__icon_source_path__" />
    <!--すべてのユーザで使えるようにするProperty-->
    <Property Id="ALLUSERS" Value="2" />
  </Product>
</Wix> 

2010/12/07

access2010 Webデータベース その5 SharePoint上のユーザー権限

ACCDE’s are not supported in Access Services on SharePoint 2010
AccessTeamBlogに投稿されていたので、久しぶりにWebデータベースについて。
accdeはAccess Serviceに対応しないってことなんだけど、発行できなくはない。でも、あんまり意味ないし、不都合だらけだし。

以下、権限の話。
全てのユーザは、accdw経由でaccdbをダウンロードしファイルを開くことができる。そして、ローカル上ではオブジェクトの作成編集自体は可能。だが、権限がなければ新規や編集済みオブジェクトをSharepoint上のオブジェクトと同期させることができないというだけ。なので、事実上変更できないということ。
ローカルへダウンロードさせたくないとする場合は、Sharepointユーザ権限だけでは対応できないのではないかと思う。Access Serviceのサイトテンプレートをごにょごにょしないとならんような気がする。ドロップダウンメニューをいじるのはどっかで見た。

SharePoint
Permission Level
Access Services Actions
Read Data
Open in Access (rehydrate) / Take Offline
Modify/ Add Data
Create/ Modify Objects & Sync
Create/ Edit Schema
Publish
フルコントロール
デザイン
投稿
×
×
×
閲覧
×
×
×
×
制限付きアクセス
×
×
×
×

Sharepoint アクセス許可ダイアログ
権限が足りない場合 投稿
権限が足りない場合 閲覧

権限が足りない場合 閲覧
権限が足りない場合
ログ

access2010 アプリケーションパーツ その8 -accde-

accdeで運用している場合で、アプリケーションパーツを使用できる状態にしていると、削除できないフォームとレポートが氾濫することになる。と、いうことで、リボンでのコマンド制御などは必須になった。プリインストールのアプリケーションパーツを削除しておいたとしても、ユーザ定義のものも存在するからどうにもならね。

オブジェクトのインポートUIからだと、テーブル/クエリ以外は選択できないようになっているからよいのだけれど、アプリケーションパーツからだとオブジェクトががっつりとインポートされてしまうので要注意。
コードが含まれるアプリケーションパーツの場合、モジュール以外のオブジェクトがインポートされる。インスタンス化したフォームだとしてもVBAは実行されることはないから大きな影響はなさそうだけれども、なんだかなぁ。 可能性は低いだろうけど、モーダル+ショートカットメニューを表示しない+コントロールボックスがないフォームを開いてしまうともうどうにもならなくなるってことか。

特段の要件がない限り、Runtime/Runtimeモードでの展開をしておくべきなんだろうな、きっと。

2010/12/06

access2010 アプリケーションアイコンの設定

Option Compare Database
Option Explicit

Sub SetAppIcon()
On Error GoTo ErrHnd
    Dim curPath As String
    Dim iconName As String, iconFullPath As String
    Dim rs As DAO.Recordset, rsPct As DAO.Recordset
    
    curPath = Application.CurrentProject.Path
    iconName = "logo"
    iconFullPath = curPath & "\" & iconName & ".ico"
    
    If Len(Dir(iconFullPath)) = 0 Then
        Set rs = CurrentDb.OpenRecordset( _
                "select Data from MSysResources where Name='" & _
                iconName & "';")
                'a2007なら添付ファイルありのテーブル使うべな
        Set rsPct = rs("Data").Value
        rsPct("FileData").SaveToFile iconFullPath
    End If
    
    ChangeProperty "AppIcon", dbText, iconFullPath
    ChangeProperty "UseAppIconForFrmRpt", dbBoolean, True
    Application.RefreshTitleBar
Exit Sub
ErrHnd:
    MsgBox Error$
End Sub

Function ChangeProperty(strPropName As String, _
    varPropType As Variant, _
    varPropValue As Variant) As Integer

    Dim dbs As Object, prp As Variant
    Const conPropNotFoundError = 3270

    Set dbs = CurrentDb
    On Error GoTo Change_Err
    dbs.Properties(strPropName) = varPropValue
    ChangeProperty = True

Change_Bye:
    Exit Function

Change_Err:
    If Err = conPropNotFoundError Then
        Set prp = dbs.CreateProperty(strPropName, _
            varPropType, varPropValue)
        dbs.Properties.Append prp
        Resume Next
    Else
        ChangeProperty = False
        Resume Change_Bye
    End If
End Function

2010/12/02

access2010 ピボットテーブルのVBAコーディング

とりあえず、単純なところまで。
Option Compare Database
Option Explicit
'参照設定:Microsoft Office XP Web Components
'C:\Program Files\Microsoft Office\Office14\OFFOWC.DLL

Private Sub inipvt()
    Dim fst As OWC10.PivotFieldSet

    With Me.PivotTable.activeview
        Do Until .RowAxis.FieldSets.Count = 0
            Set fst = .RowAxis.FieldSets(0)
            .RowAxis.RemoveFieldSet fst
        Loop

        Do Until .ColumnAxis.FieldSets.Count = 0
            Set fst = .ColumnAxis.FieldSets(0)
            .ColumnAxis.RemoveFieldSet fst
        Loop

        Do Until .FilterAxis.FieldSets.Count = 0
            Set fst = .FilterAxis.FieldSets(0)
            .FilterAxis.RemoveFieldSet fst
        Loop

        Do Until .DataAxis.Totals.Count = 0
            .DataAxis.RemoveTotal .DataAxis.Totals(0)
        Loop
        
        Do Until .Totals.Count = 0
            .DeleteTotal .Totals(0).Name
        Loop
    End With
End Sub

Private Sub Form_Load()

    Call inipvt
    
    Dim Fst1 As OWC10.PivotFieldSet
    Dim fld As OWC10.PivotField
    Dim ttl As OWC10.PivotTotal

    With Me.PivotTable.activeview
        Set Fst1 = .FieldSets("F_num1")
        .DataAxis.InsertFieldSet Fst1
        Set Fst1 = .FieldSets("F_num2")
        .DataAxis.InsertFieldSet Fst1
        
        Set Fst1 = .FieldSets("F_date")
        .RowAxis.InsertFieldSet Fst1
        
'        .FilterAxis.InsertFieldSet Fst1

        Set fld = .FieldSets("F_num1").Fields("F_num1")
        .AddTotal "合計:F_num1", fld, plFunctionSum
        Set ttl = .Totals("合計:F_num1")
        .DataAxis.InsertTotal ttl
        Set fld = .FieldSets("F_num2").Fields("F_num2")
        .AddTotal "合計:F_num2", fld, plFunctionSum
        Set ttl = .Totals("合計:F_num2")
        .DataAxis.InsertTotal ttl
    End With
End Sub

2010/11/23

office2010 Win32API WaitForSingleObject/OpenProcess/CloseHandle

Option Compare Database
Option Explicit

Const PROCESS_ALL_ACCESS = &H1F0FFF
Const SYNCHRONIZE = &H100000

Const INFINITE = &HFFFFFFFF      '  Infinite timeout

#If VBA7 Then
'http://msdn.microsoft.com/ja-jp/library/cc429427.aspx
Declare PtrSafe Function WaitForSingleObject Lib "kernel32" ( _
                                ByVal hHandle As LongPtr, _
                                ByVal dwMilliseconds As Long _
                                ) As Long

'http://msdn.microsoft.com/ja-jp/library/cc429278.aspx
Declare PtrSafe Function OpenProcess Lib "kernel32" ( _
                                ByVal dwDesiredAccess As Long, _
                                ByVal bInheritHandle As Long, _
                                ByVal dwProcessId As Long _
                                ) As LongPtr

'http://msdn.microsoft.com/ja-jp/library/cc429605.aspx
Declare PtrSafe Function CloseHandle Lib "kernel32" ( _
                                ByVal hObject As LongPtr _
                                ) As Long

#Else
Declare Function WaitForSingleObject Lib "kernel32" ( _
                                ByVal hHandle As Long, _
                                ByVal dwMilliseconds As Long _
                                ) As Long

Declare Function OpenProcess Lib "kernel32" ( _
                                ByVal dwDesiredAccess As Long, _
                                ByVal bInheritHandle As Long, _
                                ByVal dwProcessId As Long _
                                ) As Long

Declare Function CloseHandle Lib "kernel32" ( _
                                ByVal hObject As Long _
                                ) As Long
#End If

Sub test()
    Dim taskID
#If vba7 Then
    Dim pHwnd As LongPtr
#Else
    Dim pHwnd As Long
#End If
    taskID = Shell("calc.exe")
    pHwnd = OpenProcess(SYNCHRONIZE, False, taskID)
    WaitForSingleObject pHwnd, INFINITE
    CloseHandle pHwnd
    Debug.Print "Process End"
End Sub

2010/11/22

WiX WiXEditを使ってみたメモ

UIはまだまだ先になりそうだけど、Accessアプリケーションの配布って感じでどんな感じになるのかとやってみた。
<?xml version="1.0" encoding="utf-8"?>
<Wix xmlns="http://schemas.microsoft.com/wix/2006/wi">
  <Product Id="__GUID__" Name="Accessテストアプリケーション" Language="1041" Version="0.0.0.1" Manufacturer="MukkuMuku Div." UpgradeCode="__GUID__" Codepage="932">
    <Package Description="Accessアプリケーション配布テスト" Comments="Wix+WixEditでやってみた" InstallerVersion="200" Compressed="yes" />
    <Media Id="1" Cabinet="simple.cab" EmbedCab="yes" />
    <Directory Id="TARGETDIR" Name="SourceDir">
      <Directory Id="WINDOWSVOLUME" Name="sample01">
        <!--WindowsVolumeだとエラーって言ってくるんだわ-->
        <Directory Name="app01" Id="app01">
          <Component Id="db01" DiskId="1" Guid="__GUID__">
            <File Id="maindb.accdb" Name="maindb.accdb" Source="__source path__" KeyPath="yes">
              <Shortcut Id="desktopShortcut" Directory="DesktopFolder" Name="Accessテストアプリケーション" WorkingDirectory="INSTALLDIR" Advertise="yes" Icon="
AppIcon.ico" IconIndex="0" />
              <Shortcut Id="ExeShortcut" Directory="ProgramMenuDir" Name="Accessテストアプリケーション" Advertise="yes" Icon="
AppIcon.ico" IconIndex="0" />
            </File>
            <CreateFolder>
              <!--フォルダapp01に必要なパーミッションはここ-->
              <Permission User="Users" GenericExecute="yes" GenericRead="yes" GenericWrite="yes" />
              <Permission User="Administrators" GenericAll="yes" />
            </CreateFolder>
            <!--Access Trusted Location用のレジストリ-->
            <RegistryValue Key="Software\Microsoft\Office\14.0\Access\Security\Trusted Locations\[ProductCode]" Root="HKLM" Type="string" Value="[app01]" Name="Path" />
          </Component>
        </Directory>
      </Directory>
      <Directory Id="DesktopFolder"></Directory>
      <Directory Id="ProgramMenuFolder">
        <Directory Id="ProgramMenuDir" Name="MukkuMuku Div.">
          <Component Id="StartMenuShortcuts" Guid="__GUID__">
            <RemoveFolder Id="ProgramMenuDir" On="uninstall" />
            <RegistryValue Root="HKCU" Key="Software\[Manufacturer]\[ProductName]" Type="string" Value="" />
            <Shortcut Id="UninstallProduct" Name="Uninstall" Description="Uninstalls the application" Target="[System64Folder]msiexec.exe" Arguments="/x [ProductCode]" />
          </Component>
        </Directory>
      </Directory>
    </Directory>
    <Feature Id="DefaultFeature" Title="Main Feature" Level="1">
      <ComponentRef Id="db01" />
      <ComponentRef Id="StartMenuShortcuts" />
    </Feature>
    <UI />
    <Icon Id="AppIcon.ico" SourceFile="__icon_source_path__" />
    <!--すべてのユーザで使えるようにするProperty-->
    <Property Id="ALLUSERS" Value="2" />
  </Product>
</Wix>

Toolを使いつつも何とかできたのが不思議でならない。日本語情報が少ないのがちとつらいな。

2010/11/21

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

access2010 runtime サイレントインストール

参考情報


<Configuration Product="AccessRT">
    <Display Level="none" CompletionNotice="no" SuppressModal="yes" AcceptEula="yes" />
</Configuration>

2010/11/19

access2010 access2007 パッケージソリューションウィザード その10 ChainedInstall

配布用セットアップファイルに、同時にインストールしたいドライバなどを追加してみる。
編集するのは生成されたパッケージ内の/Files/Setup/setup.ini。これにChainedInstall_nセクションを追加する。詳細の情報はここ

MySQL ODBCドライバを同時に配布しインストール。 msi/exeはPathに指定したフォルダに配置。
[ChainedInstall_1]
TaskName=MySQL ODBC Connecter 5.1.8 win32
TaskType=msi
Path=\Files\mysql-connector-odbc-5.1.8-win32.msi
IgnoreReturnValue=0
;cmdline=

runtimeパッケージインストールファイルを含めていれば、[ChainedInstall_1]を使っているだろうから、[ChainedInstall_2]ってことになるかな。
5.1.6がインストールされていたんだけど、5.1.8に更新されて、まぁいいんじゃないか。
配布アプリケーションのアップグレードコード元のプロダクトコードとアップグレードコードを使って、本体も更新しつつドライバーも更新だ。

Package Solution Wizard まとめはこちら

access2010 データマクロでテーブルを読み取り専用にする

BackEndのデータマクロ(1)

BackEndのデータマクロ(2)

'FrontEnd
Function IsTableReadOnly() As Boolean
    IsTableReadOnly = False
End Function
FE/BE等の構成で、共通のユーザ定義関数を使用した。FEからの接続の場合、CRUDすべて可能で、直接BEをアクセスしていたり、IsTableReadOnlyを定義していないFEから接続するとエラーで戻ってくる。ADOだろうがDAOだろうとも。

2010/11/18

office2010 Win32API SendMessage

Option Compare Database
Option Explicit

Const WM_CHAR = &H102
Const BM_CLICK = &HF5
Const SW_HIDE = 0
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

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

Sub OpenaccdrWithPassword()
    Dim pHwnd As LongPtr, cHwnd As LongPtr, btnHwnd As LongPtr
    Dim taskID As Double
    Dim targetDBName As String
    Dim targetDBFullName As String
    Dim dialogName As String
    Dim strDBPassword As String
    
    
    strDBPassword = "p@ssw0rd"
    
    dialogName = "データベース パスワードの入力"
    
    targetDBName = "targetAppName"
    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
    
    taskID = Shell("msaccess.exe /runtime " & _
                    targetDBFullName, vbNormalFocus)
    If taskID = 0 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

2010/11/17

office2010 Win32API FindWindow/FindWindowEx/PostMessage

Option Compare Database
Option Explicit

Const WM_CHAR = &H102
Const BM_CLICK = &HF5
Const SW_HIDE = 0

'FindWindow
'http://msdn.microsoft.com/ja-jp/library/cc364634.aspx
Declare PtrSafe Function FindWindow Lib "user32" _
                                Alias "FindWindowA" ( _
                                ByVal lpClassName As String, _
                                ByVal lpWindowName As String _
                                ) As LongPtr

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

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


Sub OpenaccdrWithPassword()
    Dim pHwnd As LongPtr, cHwnd As LongPtr, btnHwnd As LongPtr
    Dim targetDBName As String
    Dim targetDBFullName As String
    Dim dialogName As String
    
    dialogName = "データベース パスワードの入力"
    
    targetDBName = "targetAppName"
    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
    
    Shell "msaccess.exe /runtime" & targetDBFullName, vbNormalFocus
    
    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
        
    PostMessage cHwnd, WM_CHAR, Asc("p"), 0
    PostMessage cHwnd, WM_CHAR, Asc("@"), 0
    PostMessage cHwnd, WM_CHAR, Asc("s"), 0
    PostMessage cHwnd, WM_CHAR, Asc("S"), 0
    
    PostMessage btnHwnd, BM_CLICK, 0, 0
    
    Application.Quit
End Sub

2010/11/15

office2010 Win32API GetWindowLongPtr/SetWindowLongPtr

access2010でフォームウインドウをWindowsタスクバーに表示しようとしてみたコネタ。PopUp=Trueじゃないとダメだし。ShowWindowsInTaskbarみたいなもんだろうか。
アクティブ時/非アクティブ時とかで切り替えるんならSetWindowPosが必要かも知れんね。
Option Compare Database
Option Explicit

'GetWindowLongPtr
'http://msdn.microsoft.com/ja-jp/library/cc364762.aspx

'SetWindowLongPtr
'http://msdn.microsoft.com/ja-jp/library/cc411204.aspx

'GetWindowLong
'http://msdn.microsoft.com/ja-jp/library/cc364760.aspx

'SetWindowLong
'http://msdn.microsoft.com/ja-jp/library/cc411203.aspx

Const GWL_EXSTYLE = -20
Const GWLP_HINSTANCE = -6
Const GWLP_ID = -12
Const GWL_STYLE = -16
Const GWLP_USERDATA = -21
Const GWLP_WNDPROC = -4
'GWL_EXSTYLE 新しい拡張ウィンドウスタイルを設定します。
'GWL_STYLE 新しいを設定します。
'GWLP_WNDPROC ウィンドウプロシージャへの新しいアドレスを設定します。
'GWLP_HINSTANCE 新しいアプリケーションインスタンスハンドルを設定します。
'GWLP_ID 新しいウィンドウ ID を設定します。
'GWLP_USERDATA   ウィンドウに関連付けられた値を設定します。この 32 ビット値は、ウィンドウを作成したアプリケーションで使用する目的で各ウィンドウが持っているものです。この値の初期値は 0 です。

Const WS_EX_APPWINDOW = &H40000

#If Win64 Then
Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" _
            Alias "GetWindowLongPtrA" ( _
                ByVal hwnd As LongPtr, _
                ByVal nIndex As Long _
                ) As LongPtr
Private Declare PtrSafe Function SetWindowLongPtr Lib "user32" _
            Alias "SetWindowLongPtrA" ( _
                ByVal hwnd As LongPtr, _
                ByVal nIndex As Long, _
                ByVal dwNewLong As LongPtr _
                ) As LongPtr
#Else
Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" _
            Alias "GetWindowLongA" ( _
                ByVal hwnd As LongPtr, _
                ByVal nIndex As Long _
                ) As LongPtr
Private Declare PtrSafe Function SetWindowLongPtr Lib "user32" _
            Alias "SetWindowLongA" ( _
                ByVal hwnd As LongPtr, _
                ByVal nIndex As Long, _
                ByVal dwNewLong As LongPtr _
                ) As LongPtr
#End If

Sub AddTaskBarlist()
    Dim Ws As LongPtr
    Dim pHwnd As LongPtr
    pHwnd = CodeContextObject.hwnd
    Ws = GetWindowLongPtr(pHwnd, GWL_EXSTYLE)
    Ws = Ws Or WS_EX_APPWINDOW
    SetWindowLongPtr pHwnd, GWL_EXSTYLE, Ws
End Sub

2010/11/14

access2010 access2007 パッケージソリューションウィザード その9

ウィザードで発行した配布ファイルでインストールする時、インストールの途中、ユーザ操作でインストール先フォルダの変更ができてしまうことはあまり望ましくない。なので、それをできないようにしてみる。
ウィザードで発行されたファイルが置かれるフォルダは、ユーザドキュメントフォルダ以下、
\Install Packages\database_nameなんだけど、
\Install Packages\database_name\Files\Setup\setup.iniを編集すればよい。

 [Display]
; The diplay section is used for overriding the default UI
;       Value           Default         Description
;       Display         full            Option to override the default UI
;                                       [none, quiet, basic, reduced, full]
;       CompletionNotice Yes            Option to display a setup completion
;                                       notice for otherwise quiet setup
Display=full
CompletionNotice=Yes

Display=fullになってるから、Display=basic にする。quietとか他は適当に試しながらで。

Package Solution Wizard まとめはこちら

2010/11/13

office2010 Win32API SetWindowPos 最前面化

Option Compare Database
Option Explicit

'SetWindowPos
'http://msdn.microsoft.com/ja-jp/library/cc411206.aspx
'戻り値
'関数が成功すると、0 以外の値が返ります。
'関数が失敗すると、0 が返ります。拡張エラー情報を取得するには、 関数を使います。

' SetWindowPos Flags
Const SWP_NOSIZE = &H1
Const SWP_NOMOVE = &H2
Const SWP_NOZORDER = &H4
Const SWP_NOREDRAW = &H8
Const SWP_NOACTIVATE = &H10
Const SWP_FRAMECHANGED = &H20
Const SWP_SHOWWINDOW = &H40
Const SWP_HIDEWINDOW = &H80
Const SWP_NOCOPYBITS = &H100
Const SWP_NOOWNERZORDER = &H200
Const SWP_NOSENDCHANGING = &H400
Const SWP_DEFERERASE = &H2000
Const SWP_ASYNCWINDOWPOS = &H4000
Const SWP_DRAWFRAME = SWP_FRAMECHANGED
Const SWP_NOREPOSITION = SWP_NOOWNERZORDER

'SWP_ASYNCWINDOWPOS この関数を呼び出したスレッドとウィンドウを所有するスレッドが異なる入力キューに関連付けられている場合、ウィンドウを所有するスレッドへ要求が送られます。こうすると、要求を受け取ったスレッドが要求を処理している間も、関数を呼び出したスレッドの実行が止まってしまうことはありません。
'SWP_DEFERERASE WM_SYNCPAINT メッセージが生成されないようにします。
'SWP_DRAWFRAME  ウィンドウを囲む枠( ウィンドウクラスの記述部分で定義されている)を描画します。
'SWP_FRAMECHANGED   SetWindowLong 関数を使って新しいフレームスタイルの設定を適用します。ウィンドウサイズが変更されない場合にも、ウィンドウにWM_NCCALCSIZE メッセージを送ります。このフラグを指定しなかった場合、ウィンドウサイズが変更される場合にしか WM_NCCALCSIZE メッセージは送られません。
'SWP_HIDEWINDOW ウィンドウを非表示にします。
'SWP_NOACTIVATE ウィンドウをアクティブ化しません。このフラグをセットしなかった場合、ウィンドウはアクティブ化され、最前面ウィンドウまたは非最前面ウィンドウのどちらか(hWndInsertAfter パラメータの設定による)のグループの最上位に移動します。
'SWP_NOCOPYBITS クライアント領域の内容全体を破棄します。このフラグをセットしなかった場合は、クライアント領域の有効な内容が保存され、再配置後のウィンドウのクライアント領域にコピーし直されます。
'SWP_NOMOVE 現在の位置を維持します(X パラメータと Y パラメータを無視します)。
'SWP_NOOWNERZORDER  オーナーウィンドウの Z オーダーを変更しません。
'SWP_NOREDRAW   変更結果を再描画しません。このフラグを指定すると、再描画は一切行われません。このフラグは、クライアント領域、非クライアント領域( タイトルバーおよびスクロールバーを含む)、および親ウィンドウの、このウィンドウが移動した???果現れた部分のすべてに適用されます。このフラグをセットした場合、ウィンドウや親ウィンドウの再描画の必要な部分は、アプリケーションで明示的に無効化または再描画しなければなりません。
'SWP_NOREPOSITION   SWP_NOOWNERZORDER フラグと同じです。
'SWP_NOSENDCHANGING ウィンドウに WM_WINDOWPOSCHANGING メッセージが送られないようにします。
'SWP_NOSIZE 現在のサイズを維持します(cx パラメータと cy パラメータを無視します)。
'SWP_NOZORDER   現在の Z オーダーを維持します(hWndInsertAfter パラメータを無視します)。
'SWP_SHOWWINDOW ウィンドウを表示します。

' SetWindowPos() hwndInsertAfter values
Const HWND_TOP = 0
Const HWND_BOTTOM = 1
Const HWND_TOPMOST = -1
Const HWND_NOTOPMOST = -2

'HWND_BOTTOM    ウィンドウを Z オーダーの最後に置きます。hWnd パラメータで指定したウィンドウが最前面ウィンドウだった場合、このウィンドウは最前面ウィンドウではなくなり、ほかのすべてのウィンドウの下に置かれます。
'HWND_NOTOPMOST ウィンドウを最前面ウィンドウ以外のすべてのウィンドウの前( つまり、すべての最前面ウィンドウの後ろ)に挿入します。hWnd パラメータで指定したウィンドウが既に最前面ウィンドウではなかった場合、このフラグは意味を持ちません。
'HWND_TOP   ウィンドウを Z オーダーの先頭に置きます。
'HWND_TOPMOST   ウィンドウを最前面ウィンドウではないすべてのウィンドウの前に挿入します。このウィンドウは、アクティブでないときにも最前面に表示されます。

#If VBA7 = 1 Then
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

#Else
Declare Function SetWindowPos Lib "user32" _
                            (ByVal hwnd As Long, _
                             ByVal hWndInsertAfter As Long, _
                             ByVal x As Long, _
                             ByVal y As Long, _
                             ByVal cx As Long, _
                             ByVal cy As Long, _
                             ByVal wFlags As Long _
                             ) As Long

#End If

'SetWindowPos FormObject.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE + SWP_NOSIZE
'SetWindowPos FormObject.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE + SWP_NOSIZE