愚者の経験

「また今度」はほとんどこない

カテゴリーアーカイブ: モジュール

[Access]EvtSummarizerがAccess2013だと落ちる

前回の投稿で作ったイベント統合クラスはAccess2013で実行すると落ちてしまいます。
なんでだろう…どうも子オブジェクトのTerminateイベントは発生しているがその後に落ちる。

フォーム側で予めNothingしておくと大丈夫。なんだこれ?

[Access][VBA]Openイベントを統合して取得する(コントロール配列クラス改良)

サンプルダウンロード:http://www.mediafire.com/download/mfem6mcgdsq95r3/ex.zip※Access2010で確認

以前の投稿
「Accessでコントロール配列を再現するクラス(EvtSummerizer)作成」で作ったクラスを改良して
フォームのOpenイベントも統合可能にしましたので公開します。
※グループは若干気に入らなかったので外しました。

レポートのOpenイベントも統合したかったのですが、「Docmd.OpenReport acViewNormal」した場合は
ウィンドウが作成されないのでそもそもフックできず。
なので常にacViewPreviewで開き、即印刷したい場合はEchoをFalseした後に
acHiddenでPreviewを開きDoCmd.RunCommand acCmdPrintし、Closeする流れをとることにしました。
(もちろんDocmd.OpenReportをもう一度送っても可ですが、なんとなくです(笑))

Openイベントが統合できることでアプリケーション側の排他機能が書きやすくなるかもしれません。

お決まりですが、使用する場合は自己責任でお願いします。
もしお使いいただけたら、ご利用後に感想等もいただけると嬉しいです。m(__)m

[Access]Openイベントより前にForm参照を取得する

前回の投稿

よくよく見るとこのコードだと対象のフォームにサブフォームかリストボックス
またはタブを配置していないと正常に動作しなかった
のでフックの種類を
変更したところ、うまくいきました。

Option Compare Database
Option Explicit

Private Declare Function UnhookWindowsHookEx Lib "user32" ( _
                ByVal hHook As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function SetWindowsHookEx Lib "user32" _
                Alias "SetWindowsHookExA" ( _
                ByVal idHook As Long, _
                ByVal lpfn As Long, _
                ByVal hmod As Long, _
                ByVal dwThreadId As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" ( _
                ByVal hHook As Long, _
                ByVal nCode As Long, _
                ByVal wParam As Long, _
                ByRef lParam As Any) As Long
                
Private Const WH_CALLWNDPROC = 4
Private Const HC_ACTION = 0

Private hHook As Long
Private hName As String
Private hOk As Boolean

Public Sub OpenFormEx(FormName As String)
    If (CurrentProject.AllForms(FormName).IsLoaded) Then
        DoCmd.SelectObject acForm, FormName
        Exit Sub
    End If
    hHook = SetWindowsHookEx(WH_CALLWNDPROC, AddressOf CallWndProc, 0, GetCurrentThreadId)
    hName = FormName
    hOk = False
    DoCmd.OpenForm FormName
    UnhookWindowsHookEx hHook
End Sub
      
      
Public Function CallWndProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
On Error GoTo Finally
    Dim Target As IFormEx

    If ((nCode = HC_ACTION) And Not hOk) Then
        Set Target = Forms(hName)
        Target.PreOpen
        hOk = True
        UnhookWindowsHookEx hHook
        Set Target = Nothing
    End If
Finally:
    CallWndProc = CallNextHookEx(hHook, nCode, wParam, lParam)
End Function

これでクラスモジュールでFormのオープンイベントをフックできそうです。
かなり制御に幅が広がり、面白いことになりそうです。

[Access]サブフォームを読み込む前に処理したい2

[Access]サブフォームを読み込む前に処理したい1の続き

「いやフック使ってもサブフォームから先に開くんだし、どうやっても無理なんじゃ…」
と思うかもしれませんが、実際は
・サブフォームのクエリ内でメインフォームのコントロールを参照してもパラメータとして聞いてこない
・サブフォームのオープン時にメインフォームのプロパティは操作可能
という点からオープンイベントはサブ→メインの順で発生するが、フォームが作成される順番はメイン→サブである
の仮説がある程度成り立つのではと思っています。実際はもっと違う仕組みかもしれませんが。

というわけである程度の期待を込めてフックしてみます。

フック時にフォーム側へCallするメソッドは固定したいので
私の中でそろそろおなじみとなりつつあるインターフェイスクラスを作成します。
FormExインターフェイスクラス

Option Compare Database
Option Explicit

Public Sub PreOpen()
    'PreOpenメソッド
End Sub

標準モジュール

Option Compare Database
Option Explicit

Private Declare Function UnhookWindowsHookEx Lib "user32" ( _
                ByVal hHook As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function SetWindowsHookEx Lib "user32" _
                Alias "SetWindowsHookExA" ( _
                ByVal idHook As Long, _
                ByVal lpfn As Long, _
                ByVal hmod As Long, _
                ByVal dwThreadId As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" ( _
                ByVal hHook As Long, _
                ByVal nCode As Long, _
                ByVal wParam As Long, _
                ByRef lParam As Any) As Long
                
Private Const HCBT_ACTIVATE = 5
Private Const HCBT_CREATEWND = 3
Private Const WH_CBT = 5

Private hHook As Long
Private hName As String
' Docmd.Openメソッドの代わりにこちらを使う
Public Sub OpenFormEx(FormName As String)
    If (CurrentProject.AllForms(FormName).IsLoaded) Then
        DoCmd.SelectObject acForm, Name
        Exit Sub
    End If
    hHook = SetWindowsHookEx(WH_CBT, AddressOf CBTHook, 0, GetCurrentThreadId)
    hName = FormName
    DoCmd.OpenForm FormName
    UnhookWindowsHookEx hHook
End Sub
'フックプロシージャ
Private Function CBTHook(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
On Error GoTo Finally
    Static Target As FormEx
    
    'ウィンドウ作成時に割り込み、FormExのPreOpenをCallする
    '※対象のフォームはFormExクラスをImprementsすること
    If nCode = HCBT_CREATEWND Then
        Set Target = Forms(hName)
        Target.PreOpen
        UnhookWindowsHookEx hHook
        Set Target = Nothing
    End If
Finally:
    CBTHook = CallNextHookEx(hHook, nCode, wParam, lParam)
End Function

フォーム1

Option Compare Database
Option Explicit

'FormExクラス継承
Implements FormEx

Private Sub FormEx_PreOpen()
On Error Resume Next
    'Open前に実行されるプロシージャ
    Debug.Print "Test"
End Sub

結論としましてはビンゴでした。
FormEx_PreOpenメソッドで値を代入するとサブフォームをRequeryすることなく
結果を出すことができます。これでまた可能性が広がった気がします。

[VBA]作っておくと若干便利な関数

1.Application.Echoの改良

Public Sub DisplayLock(ByVal OnOff As Boolean)
    Static cnt As Long
    
    cnt = cnt + IIf(OnOff, 1, -1)
    
    If ((cnt = 1) And (OnOff)) Then
        Application.Echo False
    End If
    
    If ((cnt = 0) And (Not OnOff)) Then
        Application.Echo True
    End If
    
    If (cnt < 0) Then
        cnt = 0
    End If
End Sub

Echoは入れ子にすると解除のタイミングが早まってしまうので
ものぐさな私はこんなことしてます。

2.VBAでInみたいな比較をしたい。Orは書きにくい

Public Function Exists(Source As Variant, ParamArray Params() As Variant) As Boolean
    Exists = Eval(CStr(Source) & " in(" & Join(Params, ",") & ")")
End Function

速度は度外視でぐうたらに使います。

3.色の指定がめんどくさい。

Public Function StrRGB(ByVal Color As String) As Long
    StrRGB = RGB( _
        val("&H" & Right$("00" & Mid$(Color, 1, 2), 2)), _
        val("&H" & Right$("00" & Mid$(Color, 3, 2), 2)), _
        val("&H" & Right$("00" & Mid$(Color, 5, 2), 2)))
End Function

この方が私はわかりやすいです。

Fix関数落とし穴[Access][VBA]

小数部を切り取る関数の2大筆頭です。もう一つは「int関数」
さて私のパソコンだとイミディエイトウィンドウで以下を実行すると

?fix(113)/100
?fix(1.13*100)/100
?fix(1.13*10^2)/100

次のようになりました。
?fix(113)/100
1.13
?fix(1.13*100)/100
1.12
?fix(1.13*10^2)/100
1.12

はい、ずれました~orz
「Fix関数」は小数部を切ってくれますが第一引数の時点で丸められて
しまうとどうしようもないですので多分こんなことになります。

?1.13*100=113
False

?1.13*100<113
True

上記のように出ますので1.13*100は整数部112なわけです。
浮動小数点型で誤差が発生するのが分かります。

端数処理関数を作ってみました。
「切り上げ」は絶対値基準で行なっています。

Option Compare Database
Option Explicit

Public Enum RoundOperationEnum
    RoundUp             '切り上げ
    RoundDown           '切り捨て
    RoundOff            '四捨五入
End Enum

'端数処理
Public Function Round(Value As Variant, ByVal Digits As Long, Operation As RoundOperationEnum) As Variant
On Error GoTo exit1
    Dim dec As Variant
    dec = CDec(Value)
    
    Select Case Operation
        Case RoundOff
            Round = Fix(dec * (10 ^ Digits) + 0.5 * Sgn(dec)) / (10 ^ Digits)
        Case RoundDown
            Round = Fix(dec * (10 ^ Digits)) / (10 ^ Digits)
        Case RoundUp
            Round = -Int(-Abs(dec) * (10 ^ Digits)) * Sgn(dec) / (10 ^ Digits)
    End Select
    Exit Function
exit1:
    Round = 0
End Function

CurrencyやDoubleでデメリット背負うよりはDecimal型かむしろString型のほうが
計算そのものには適しているんじゃないかとさえ思います。

コレクション改(?)

かなり結構やっつけです。
Index⇔Keyをお互いにできる…ハズ。
なんの検証もしてませんので参考程度に。

Option Compare Database
Option Explicit
 
Private Declare Sub RtlMoveMemory Lib "kernel32" ( _
                ByRef Destination As Any, _
                ByRef Source As Any, _
                Optional ByVal Length As Long = 4)
                
Public List As Collection
 
Public Function Key(ByVal Index As Long) As String
  
    Dim i     As Long
    Dim Ptr   As Long
    Dim sKey  As String
 
    Select Case Index
        Case Is <= List.Count / 2
            RtlMoveMemory Ptr, ByVal ObjPtr(List) + 24
            For i = 2 To Index
                RtlMoveMemory Ptr, ByVal Ptr + 24
            Next i
        Case Else
            RtlMoveMemory Ptr, ByVal ObjPtr(List) + 28
            For i = List.Count - 1 To Index Step -1
                RtlMoveMemory Ptr, ByVal Ptr + 20
            Next i
    End Select
    i = StrPtr(sKey)
    RtlMoveMemory ByVal VarPtr(sKey), ByVal Ptr + 16
    Key = sKey
    RtlMoveMemory ByVal VarPtr(sKey), i
 
End Function
 
Public Function Index(ByVal Key As String, _
                Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As Long
  
     Dim Ptr   As Long
     Dim sKey  As String
     Dim aKey  As Long
    
    If List.Count Then
        aKey = StrPtr(sKey)
        RtlMoveMemory Ptr, ByVal ObjPtr(List) + 24
        Index = 1
        Do
            RtlMoveMemory ByVal VarPtr(sKey), ByVal Ptr + 16
            If StrComp(Key, sKey, Compare) = 0 Then
                Exit Do
            End If
            Index = Index + 1
            RtlMoveMemory Ptr, ByVal Ptr + 24
        Loop Until Ptr = 0
        RtlMoveMemory ByVal VarPtr(sKey), aKey
    End If
    If Ptr = 0 Then
        Index = -1
    End If
 
End Function

Public Function Exists(IndexOrKey As Variant) As Boolean
On Error GoTo NotExists
    List.Item IndexOrKey
    Exists = True
    Exit Function
NotExists:
    Exists = False
End Function

Private Sub Class_Initialize()
    Set List = New Collection
End Sub

Private Sub Class_Terminate()
    Set List = Nothing
End Sub


コレクションに配列をAddすると…

以下のように配列をAddするとどうなるでしょうか。
値の授受はできるでしょうか。

Public Function test1()
    Dim c As New Collection
    Dim ary(0) As Variant
        
    c.Add ary
    
    c.Item(1)(0) = "test"
    
    MsgBox c.Item(1)(0)
End Function

エラーにもならず、授受もできません。不思議。
VBAの仕様を垣間見た…気がします。
誰か教えてくださいm(__)m

API宣言の書き方は「今後」どうすればいいか

旧バージョンとの互換性、アーキテクチャ(86/64bit)の互換性を意識して
APIを記述するには何が一番良いか考えてみます。

先に結論を書きますと
64bit版が登場したOffice2010以上とそれ未満では互換性のとりようがない」です。

64bit版が登場したOffice2010からVBAのバージョンが[7]にアップし
API宣言が変化しました。(元の宣言が出来ないわけではありませんが64bit版ではコンパイルエラー)

        Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)

ここで言うと「PtrSafe」と「LongPtr」です。64bit版専用に「LongLong」という型も存在するようですが
「LongPtr」が自動判別(32bitならLong型、64bit型ならLongLong型)してくれるため別にいいのです。

Office2010以上であれば上記の書き方で32bitでも64bitでも動作します。
ですが2007以下も入ってくるとVBAのバージョンは6になるので
残念ながら2通り記述する必要があります。

#If VBA7 Then 
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

上記のようにすればにしてもコンパイルは確かに通りますし、両方で動作します。
しかしVBA6側では文字が赤くなってしまいます。なのでVBA6側からAPIを直そうとする場合
コンパイルエラー「修正候補:Sub または Function」と戦い続けるはめになります(笑)

ポップアップしたフォームにApplication.Echoは無効

ヘルプにも書いてありますが、フォーム[ポップアップ]プロパティが「はい」の時
そのフォームに対して「Application.Echo False」しても無効です。
もちろん「Docmd.Echo False」でも同じです。

その場合どうするかといいますとやっぱりAPIを使います。

    Private Declare Function LockWindowUpdate Lib "user32" (ByVal Hwnd As Long) As Long

でもこれは他のアプリケーションとか重ねるとその画面でまた固まってしまいます。
なにかいい方法はないものか…