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

access2010 access2007 アプリケーションウインドウ/タスクバーの非表示 その2

ナビゲーションフォームだったらどうなるのかなと、a2010だけど。これはこれで便利
当たり前だけど、MainForm以外はサブフォームだから何もしないでいい。ダイアログモードで別フォーム開くのも問題ないし。複数フォーム表示なら、都度、フォームのhwndつかんでShowWindowかな。

 アプリケーションウィンドウを非表示にしてるから、他Accessアプリケーションを実行しててもタスクバーに表示されない。
 タスクバーからすべてのウィンドウを閉じるとしても、一緒に閉じられない。

a2007以降、ShowWindowsInTaskbarがないのだからこんな使い方もあり。

access2010 access2007 ナビゲーションウィンドウ Navigate to Category

ナビゲーションウィンドウ/Navigation Paneのタイトルバードロップダウンリストの設定
ナビゲーションウィンドウのカテゴリドロップダウン
 これを、DoCmd.SetDisplayedCategoriesメソッド/表示されるカテゴリの設定マクロアクションで調整する。コードなら、
Sub SetNaviCategory()
    DoCmd.SetDisplayedCategories 0, "acNavigationCategoryObjectType"
    DoCmd.SetDisplayedCategories 0, "acNavigationCategoryTablesAndViews"
    DoCmd.SetDisplayedCategories 0, "acNavigationCategoryModifiedDate"
    DoCmd.SetDisplayedCategories 0, "acNavigationCategoryCreatedDate"
    DoCmd.SetDisplayedCategories 0, "ユーザー設定"
End Sub

で、ここまでできて、残りはナビゲーションオプションで指定以外のチェックを外して完成。
DoCmd.LockNavigationPane True を仕上げにセット

access2010 Ribbon dynamicMenu


そのまんまで、dynamicなMenuということ。
dynamicMenu要素には、getContent属性が必須で、このコールバックでメニュー表示に必要なRibbonXmlを取得する。子要素はmenuと同じで、

<menu xmlns="http://schemas.microsoft.com/office/2009/07/customui">
   <!--menu子要素-->
</menu>

のXmlを用意してあげないとならない。
invalidateContentOnDrop属性をtrueにすることでメニュー展開時にコールバックを要求してくる。
どんな方法でもいいからRibbonXmlを返せばいい。
<customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui">
  <ribbon>
    <tabs>
      <tab id="tab01" label="タブ01">
        <group id="g01" label="グループ01">
          <dynamicMenu id="dm01" 
                       getContent="getContent" 
                       size="large" 
                       imageMso="CreateForm"
                       label="ダイナミックメニュー" 
                       invalidateContentOnDrop="true" />
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>
Option Compare Database
Option Explicit

Sub getContent(ctr As IRibbonControl, rtnXml)
    rtnXml = CreateContents
End Sub

Sub onAction(ctr As IRibbonControl)
    MsgBox ctr.id & vbTab & ctr.Tag
End Sub

Private Function CreateContents()
    Dim xdoc As New DOMDocument
    Dim xelem(1) As IXMLDOMElement
    Dim objCount As Integer, i As Integer
    Dim dbs As Database, accdoc As Document
    
    Set dbs = CurrentDb
    
    Set xelem(0) = xdoc.createElement("menu")
    xelem(0).setAttribute "xmlns", "http://schemas.microsoft.com/office/2009/07/customui"
    xelem(0).setAttribute "itemSize", "large"
    xdoc.appendChild xelem(0)
    
    objCount = dbs.Containers("Forms").Documents.Count
    
    If objCount > 0 Then
        Set xelem(1) = xdoc.createElement("menuSeparator")
        xelem(1).setAttribute "id", "sep01"
        xelem(1).setAttribute "title", "フォーム"
        xelem(0).appendChild xelem(1)
        For i = 0 To objCount - 1
            Set accdoc = dbs.Containers("Forms").Documents(i)
            Set xelem(1) = xdoc.createElement("button")
            With xelem(1)
                .setAttribute "id", "form" & Format(i, "00")
                .setAttribute "label", accdoc.Name
                .setAttribute "tag", accdoc.Name
                .setAttribute "imageMso", "CreateForm"
                .setAttribute "onAction", "onAction"
                .setAttribute "description", docDescription(accdoc)
            End With
            xelem(0).appendChild xelem(1)
        Next
    End If
    
    CreateContents = xdoc.XML
'    Debug.Print xdoc.XML
    
    Set xdoc = Nothing
    Set dbs = Nothing
End Function

Private Function docDescription(doc As Document) As String
On Error GoTo ErrHnd
    docDescription = Nz(doc.Properties("Description"), " ")
Exit Function
ErrHnd:
    docDescription = " "
End Function
<menu xmlns="http://schemas.microsoft.com/office/2009/07/customui" itemSize="large"><menuSeparator id="sep01" title="フォーム"/>
<button id="form00" label="フォーム1" tag="フォーム1" imageMso="CreateForm" onAction="onAction" description="DescriptionDescription"/>
<button id="form01" label="フォーム2" tag="フォーム2" imageMso="CreateForm" onAction="onAction" description=" "/>
<button id="form02" label="フォーム3" tag="フォーム3" imageMso="CreateForm" onAction="onAction" description="DescriptionDescription"/>
<button id="form03" label="フォーム4" tag="フォーム4" imageMso="CreateForm" onAction="onAction" description="DescriptionDescription"/>
<button id="form04" label="フォーム5" tag="フォーム5" imageMso="CreateForm" onAction="onAction" description=" "/>
</menu>

access2010 access2007 無効モードとマクロとVBAマクロ

セキュリティの警告が表示されている状態が無効モード。この時、マクロとVBAマクロの動作は異なる。
Command0押下時、マクロは開始され、マクロアクションは実行される。
Command1押下時、マクロは開始されるが、Unsafe Actionを実行しようとした時点で中止される。
Command2押下時、イベントプロシージャは実行されない。エラーも出ない。
埋め込みマクロじゃなくても同じ。

無効モードについて、アプリケーション配布時にどうなるか理解をしておかないと、思わぬトラブルが発生することがある。Runtimeモード/Runtime環境への配布であれば、無効モードで実行されることはないからよいのだけれど、製品版環境へaccdb/accdeでの配布の場合、セキュリティ設定が要求を満たしていない場合仕込んだコードが実行されないということが発生する。

別件、なんで埋め込みマクロなのかを考えると、accdeの場合を想像するとわかりやすい。単体のマクロは編集できるが、埋め込みマクロは編集できない。a2010からデータマクロが使えるけれども、これも考えに入れておかないとだめね。マクロだからaccdeでも編集できる。重要なロジックが含まれているならなおさら要注意。なんだかんだ考えるとRuntimeで実行させるのが比較的安全なのかも知れない。ケースバイケースでいくしかないかな。

2010/11/12

office 2010 Help Files: Win32API_PtrSafe with 64-bit Support

APIはあんまり使わないけど、どうしても使うことがある。
Office2010(64bit)の時、はて?Longなの?LongPtrなの?どっち?って時に見る資料。

Office 2010 Help Files: Win32API_PtrSafe with 64-bit Support

access2010 ナビゲーションウィンドウを非表示に

データベースウィンドウ/Navigation Paneを実行時に非表示とするプロシージャ2通り。

Sub NavigationPaneHide01()
    DoCmd.NavigateTo "acNavigationCategoryObjectType", ""
    DoCmd.RunCommand acCmdWindowHide
End Sub

Sub NavigationPaneHide02()
    DoCmd.SelectObject acForm, "", True
    DoCmd.RunCommand acCmdWindowHide
End Sub

office2010 Win32API ShowWindow アプリケーションウインドウ/タスクバーの非表示

Option Compare Database
Option Explicit

'ShowWindow
'http://msdn.microsoft.com/ja-jp/library/cc411211.aspx

Public Const SW_HIDE = 0
Public Const SW_SHOWNORMAL = 1
Public Const SW_NORMAL = 1
Public Const SW_SHOWMINIMIZED = 2
Public Const SW_SHOWMAXIMIZED = 3
Public Const SW_MAXIMIZE = 3
Public Const SW_SHOWNOACTIVATE = 4
Public Const SW_SHOW = 5
Public Const SW_MINIMIZE = 6
Public Const SW_SHOWMINNOACTIVE = 7
Public Const SW_SHOWNA = 8
Public Const SW_RESTORE = 9
Public Const SW_SHOWDEFAULT = 10
Public Const SW_MAX = 10
'SW_HIDE ウィンドウを非表示にし、他のウィンドウをアクティブにします。
'SW_MAXIMIZE ウィンドウを最大化します。
'SW_MINIMIZE ウィンドウを最小化し、Z オーダーが次のトップレベルウィンドウをアクティブにします。
'SW_RESTORE ウィンドウをアクティブにして表示します。最小化または最大化されていたウィンドウは、元の位置とサイズに戻ります。最小化されているウィンドウを元に戻す場合は、このフラグをセットします。
'SW_SHOW ウィンドウをアクティブにして、現在の位置とサイズで表示します。
'SW_SHOWDEFAULT  アプリケーションを起動したプログラムが 関数に渡した 構造体で指定された SW_ フラグに従って表示状態を設定します。
'SW_SHOWMAXIMIZED ウィンドウをアクティブにして、最大化します。
'SW_SHOWMINIMIZED ウィンドウをアクティブにして、最小化します。
'SW_SHOWMINNOACTIVE ウィンドウを最小化します。
'SW_SHOWMINIMIZED と似ていますが、この値を指定した場合は、ウィンドウはアクティブ化されません。
'SW_SHOWNA ウィンドウを現在のサイズと位置で表示します。
'SW_SHOW と似ていますが、この値を指定した場合は、ウィンドウはアクティブ化されません。
'SW_SHOWNOACTIVATE ウィンドウを直前の位置とサイズで表示します。
'SW_SHOWNORMAL と似ていますが、この値を指定した場合は、ウィンドウはアクティブ化されません。
'SW_SHOWNORMAL ウィンドウをアクティブにして表示します。ウィンドウが最小化または最大化されていた場合は、その位置とサイズを元に戻します。初めてウィンドウを表示するときには、このフラグを指定してください。

#If VBA7 Then
Public Declare PtrSafe Function ShowWindow Lib "user32" _
                                (ByVal hwnd As LongPtr, _
                                 ByVal nCmdShow As Long _
                                ) As Long
#Else
Public Declare Function ShowWindow Lib "user32" _
                           (ByVal hwnd As Long, _
                            ByVal nCmdShow As Long _
                           ) As Long
#End If
Option Compare Database
Option Explicit

'*** 必要条件 ***
'Me.PopUp = Trueであること。
'
Private Sub Form_Open(Cancel As Integer)
    If Not Me.PopUp Then Exit Sub
    Dim rc As Long
    rc = ShowWindow(Application.hWndAccessApp, SW_HIDE)
    rc = ShowWindow(Me.hwnd, SW_SHOW)
End Sub

Private Sub Form_Close()
    Dim rc As Long
    rc = ShowWindow(Application.hWndAccessApp, SW_SHOW)
End Sub


動作確認:win7(64/32)/XPSP3/access2010(64/32)/access2007/Runtime

access2010 access2007 Windows7 SP1(RC)でこうなった

"Type Mismatch" error message when you run a VBA macro in a 64-bit version of an Office 2010 application
で、ADODB.RecordSet.RecoudCountは、Longが返るようになってこれはよし。
他には、a2010(64bit)でモジュールがたくさんになるとコンパイルエラー/メモリ不足なってしまうとこともどうやら改善する模様。excel2010(64bit)で大量にシートコピーしてるとCopyメソッドが失敗し始めるというところもなくなっているような気配。
ただ、残念なことに、a2010/a2007/Win7SP1RC/32bit/64bit全ての可能な組み合わせでピボットグラフ/ピボットテーブルが動作しない。USのForumにも同様な投稿がされていて、a2003でも同じ現象にあるらしいことが見受けられた。
なんとなくだけれども、最終的にはSP1にofficeもしくはaccessが対応しなければならないこともあるんじゃないかなと。a2003でも発生しているならば、その逆もありか.、、、。このままいくと機能不全だし、それはないかなと楽観的に。

2010/11/11

access2010 access2007 Runtimeモード/Runtime環境だけ実行

現在、RuntimeモードもしくはRuntime環境で作動しているかは、SysCmd(acSysCmdRuntime) で情報を得ることができるから、これを起動時に確認すればよいということ。だけど、SysCmd関数はマクロ内で直接使用できない場合がほとんどなので、これをユーザ関数化しておく。
Option Compare Database
Option Explicit

Function IsRuntime() As Boolean
    IsRuntime = SysCmd(acSysCmdRuntime)
End Function
ここで、考えるシナリオが2つ、いずれも、信頼できる場所に無いなどセキュリティ関係。
  • Runtime版での実行
  • 製品版での実行
  1. Runtime版の場合、セキュリティに関する通知が出現しても、OK押下でVBAコードの実行が許可されるから問題はなさそう。
  2. 製品版の場合、セキュリティの警告が表示されつつもファイルは開いてしまう。その状態ではVBAコードが実行されない。これは、ちょっと困る。
これについては、起動時にCurrentProject.IsTruetedプロパティを参照し、ユーザ定義関数IsRuntimeが実行できる状態にあるかを確認する。

リボンカスタマイズとチョイ悪社員対策(AllowBypasskeyやaccde化/各種オプションの設定)は必要に応じて。

2010/11/09

access2010 Ribbon control


control要素は、sharedControls(qat)/documentContorls(qat)/group(tab)の子要素として使用できる。
groupの子要素である場合、id属性は使用できないから、組み込みコントロールのクローンとしてのみ使用可能。 sharedControls/documentContorlsの場合は、id属性を使用できて、指定したid属性値をもつコントロールをクローンする。だから、qatでbutton以外のカスタムコントロール(menuとかgalleryとか)をcontrol要素を使って配置することが可能。qatでクローンを使う場合、当然元になるコントロールがキャッシュされていないとだから、必要な場合は起動時にキャッシュさせておくなど整えておくことが必要かもね。qatにcheckBoxやtoggleButtonを配置することも可能なんだけど、group子要素に配置されているクローン元をは同期しない。ステータスを持たせるコントロールはあんまり使わないと思うけど。

2010/11/08

access2010 Ribbon menu


menuの子要素には、button/checkBox/gallery/menu/menuSeparator/splitButton/toggleButton、確認してないけど、control/dynamicMenu が使える。子要素にmenuが配置できるからmenuの入れ子で展開されるUIが作れる。
子要素に配置されるコントロールのサイズは、menuのitemSize属性値が適用される。配置コントロールがsize属性値を持っているとUIエラーになる。
itemSize="large"である場合、配置コントロールのdescription属性値が展開アイテムに表示される。

menuの子要素としてsplitButtonを配置した場合、splitButtonがgetLabelコールバックを実行してくる現象が発生している。

access2010 Ribbon splitButton


splitButtonの子要素は、button+menu/toggleButton+menuのいずれかの組み合わせで、子要素先頭のbutton/toggleButtonがsplitButtonの親表示コントロールになる。子要素menuが展開後に表示されれるコントロールになる。
splitButtonにsize属性はないから、表示コントロールのsize属性を使う。子要素menuについては、menuの属性itemSizeが適用される。

要素:splitButton
子要素:button/toggleButton/menu
属性:size

2010/11/04

access2010 Ribbon gallery


galleryコントロールの子要素は、item/buttonのみ。itemの後だけにbutton配置が可能。
gallery要素内のitemのitemHeight/itemWidth属性はアイテムサイズではなくて、itemのイメージが配置されるエリアのサイズ。itemここのサイズはitemのラベルによって伸縮する。
dropDown/comboBox同様、getItemCount/getItemID/getItemLabel/getItemImageコールバックでgallery子要素を構成できる。buttonはだめよ。
コントロールからの情報取得はonActionで、要素内buttonはそれぞれにonActionを。
rows/columns属性はお好みで。

invalidateContentOnDrop属性は、office2007でも使える。

要素:gallery
子要素:item/button
コールバック:onAction/getItemHeight/getItemWidth/getItemCount/getItemID/getItemLabel/getItemImage
属性:rows/columns/showItemLabel/showItemImage/invalidateContentOnDrop

2010/11/02

access2010 Ribbon dropDown comboBox


まずは、コントロールからの情報を取得
dropDownはonActionコールバックプロシージャで、comboBoxはonChangeで。
dropDownからは、itemID(String)/itemIndex(Integer)が取得できる。いずれかを使用するかは自由、どちらとも使うのも自由。コレクションからitemを作っているならindexが手早いかもと思うくらい。
selectedItemIndexまたはselectedItemIDで選択された状態にすることはできるが、このときonActionは発生しない。まぁ当たり前だけど、何が起こるか分からないし。
comboBoxは、editBoxも同じなんだけど、コントロール内の文字列が取得できる。
動画終盤でcomboBoxの挙動がちょっとあやしいと感じた。意図的にInvalidateしても、いったんは更新されるが、フォームを閉じ再び開いたときには更新される前の状態に戻っている。この状態が発生するのは、itemを選択時/itemLabelと同じ手投入をした時。デグレとは思えないので、調査中。

getItemCount
コントロール内のアイテム数を通知。アイテムの数だけgetItem○○が実行される。
0 → (itemCount - 1)
getItemID/getItemLabel
コールバックで通知してくるindexを基にitemID(String)を渡す
getItemImage
indexを基にイメージを渡していけばいいのだけど、2つの手段がある。imageMsoで使われる名前か画像データを渡してあげる。pngとか透過を使ったデータがすんなり渡せればいいのだけど、GDI+とか使わないとダメことがあるので、基本的にはやらない方向で検討する。

invalidateContentOnDrop
office2010から使用できる属性
その名の通り、ドロップしたときにコンテンツを無効化にするということだが、comboBoxドロップした時アイテムが更新されるということ。特段のInvalidateを必要としない。trueで発生。

要素:dropDown/comboBox
コールバック:onAction/onChange/getItemCount/getItemID/getItemLabel/getItemImage/getSelectedItemIndex/getSelectedItemID/getText
属性:invalidateContentOnDrop