愚者の経験

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

カテゴリーアーカイブ: クラス

[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]サブフォームを読み込む前に処理したい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することなく
結果を出すことができます。これでまた可能性が広がった気がします。

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


コレクションをいろいろ自作してみる(機能考察編)

Dictionaryだと値の登録が直に行えます。
これがなかなかどうして便利です。

        Dim dic As New Dictionary
        dic("Key") = 1

コレクションを自作してみるからにはここまで
実装したいものです。

しかも確かDictionaryだとKeyは文字列じゃなくても
良かったはずです。数値とかでもいけます。
この機能は…諦めましょう。

実はAccess2007以降になりますがグローバルオブジェクトの
「TempVars」がかなりDictionaryに近いです。
なのでこれを使ってみるのも手ですが、
Countとかに影響してきますので却下します。

ここでも紹介したように若干危険な香りがしますが
Collection単体でKeyも一応取れますので次回はこれを使ってクラスを作って見ます。

コレクションをいろいろ自作してみる(ADODB.Recordset編)

VBA.Collectionは痒いとこに手が届かない感が強いので
クラスを作るんですが結局Dictionaryに落ち着くのを繰り返して
ますが添え字でもアクセスしたいことだってあります。
もちろんKeyでもアクセスしたいです。
Keyも取得したいです。

というわけで色々作ったボツネタです。

Option Compare Database
Option Explicit

Private rst As ADODB.Recordset

Private Sub Class_Initialize()
    Set rst = New ADODB.Recordset

    With rst
        ' もちろんクライアントカーソル
        .CursorLocation = adUseClient

        ' KeyとValueのフィールド作成
        With .Fields
            .Append "Key", adVarWChar, 50
            .Append "Value", adVariant, , adFldIsNullable
        End With

        .Open
        ' ↓必須(Findを利用する場合は無い方がよい)
        .Fields("Key").Properties("Optimize").Value = True
    End With
End Sub

Private Sub Class_Terminate()
    Set rst = Nothing
End Sub

Public Sub Add(Value As Variant, ByVal Key As String)
    ' upsertしたい
    If (Exists(Key) = False) Then
        rst.AddNew Array("Key", "Value"), Array(Key, Value)
    Else
        rst.Update Array("Key", "Value"), Array(Key, Value)
    End If
End Sub

Public Sub Remove(Index As Variant)
    If (Exists(Index) = True) Then
        rst.Delete
    End If
End Sub
Public Function Item(Index As Variant) As Variant
    If (Exists(Index) = True) Then
        Item = rst.Fields(1).Value
    End If
End Function
Public Function Key(Index As Variant) As Variant
    If (Exists(Index) = True) Then
        Key = rst.Fields(0).Value
    End If
End Function
Public Function Count() As Long
On Error Resume Next
 If (rst.RecordCount > 0) Then
 Count = rst.RecordCount
 End If
End Function

Public Function Exists(Index As Variant) As Boolean
On Error GoTo Failure
 If (VarType(Index) = vbString) Then
 ' Filter利用
 ' Findの方が若干早い?
 With rst.Clone
 .Filter = "Key='" & Index & "'"
 If (.EOF = False) Then
 Exists = True
 End If
 End With
 Else
 rst.AbsolutePosition = Index
 Exists = True
 End If
Failure:
End Function

スタンドアロンのADODB.Recordsetならいけるんじゃない?
と思って作りました。

Add→AddNew
Remove→Delete
Item→KeyのFilterまたはAbsolutePositionで移動
Count→RecordCount

でそれぞれシミュレートできます…が速度的な問題で
Dictionaryにかなり劣ります。
ADODB.Recordsetのメソッドが使えるので拡張性は高め?
KeyでSortしたりファイル保存したり、GetStringやGetRowsが
利用できるのでその配列からFor Eachもおそらく可能。
またAccessのフォームにセット出来る。利用するシーンは不明。

かなり適当に作ってますのでそのまま使わないように。

以上。

EvtSummarizer改

サンプルダウンロード

前回の機能に加え以下の機能追加

・フォームとレポートもAddできるように変更
・フォームとレポートのみにあるイベントの追加
(Close,Current,Load,Unload,Resize,Activate,Deactivate追加、Closeイベントのみ確認)
・グループ化機能追加(Addの引数にGroup(String)を指定する)
・グループ名からコントロールコレクションを取得するGroupメソッド追加
・グループ名を指定し、該当するコントロールのプロパティを一斉に変更、取得する
Propertiesプロパティ追加(グループ名をNullで指定するとAddしたすべてが対象)
・KeyかIndexからKeyを取得するGetKeyメソッド追加
・KeyかIndexからGroupを取得するGetGroupメソッド追加
・Addしたコントロールをすべて消すClearメソッド追加

これで開発が楽になればいいんですが…速度が大丈夫か気になるところ。
まあよほど大量のコントロールを操作しなければUI的に遅延を感じることはほとんどないです。

追記:フォーム、レポート系のイベントを使う場合は「コード保持」プロパティを
[はい]に設定しないと使えません。

Accessでコントロールプロパティのデータバインドがしたい

Accessに足りないのはこれだと思います。プロパティのバインドが出来れば、
かなりのコードを減らすことができると思います。

バインド出来ればいいなと思うプロパティは
Visible「可視」
Enabled「使用可能」
これが筆頭だと思います。これを切り替えるために書くコードの量は馬鹿にならないと思います。

といっても前回、前々回に紹介した「EvtSummerizer」クラスを使えばさほど苦ではないのですが…一応やってみます。

Accessでコントロール配列を再現するクラス(EvtSummarizer)の使い方

EvtSummarizerで利用するとこんな感じのコードになります。 複数のコマンドボタンのダブルクリックイベントをKey付きの引数で取得します。 フォームのコード

Option Compare Database
Option Explicit

Private WithEvents btns As EvtSummarizer

Private Sub btns_EvtOnDblClick(Key As String, Cancel As Integer)
        MsgBox Key & "ダブルクリックしました。"
End Sub

Private Sub Form_Load()
        Set btns = New EvtSummarizer

        With btns
                .Add Me.コマンド0, , ehDblClick
                .Add Me.コマンド1, , ehDblClick
                .Add Me.コマンド2, , ehDblClick
                .Add Me.コマンド3, , ehDblClick

                .Remove 3

                '        
                'コントロールへのアクセス
                Debug.Print .Item(0).Name
                Debug.Print .Item(1).Name
                Debug.Print .Item(2).Name
                Debug.Print .Item(0).Caption
                Debug.Print .Item(1).Caption
                .Item(2).Tag = "test"

                Debug.Print .Item("コマンド2").Tag
        End With
End Sub

工夫している箇所 見ての通りCollectionオブジェクトと同じメソッドしか「見えません」。 コントロールのイベントを取得するEvtObjectクラスから親のEvtSummarizerクラスを参照し 親クラスの「パブリックメソッド」をCallしてRaiseEventさせるわけですが、 親クラスの「パブリックメソッド」は実際に使う際に見えてしまいます。 そこでEvtSummarizerはEvtObjectをImplementsしています。 各EvtObjectクラスは親をEvtObjectクラスにキャストして参照をもつことで「メソッドの隠蔽」を実現しています。 実際EvtObjectが「ダブルクリック」を検知し、EvtSummarizerの「ダブルクリック通知メソッド」を呼ぶ、というような仕組みでイベントと通知メソッドは基本的に一対一であるのでImplementsしても全然問題なくむしろ好都合です。 また取得したいイベントを追加する際には のようにプラス記号でずらずらと追加できます。 ちょっと.NetのAddHandlerみたいなのを意識してますw(実際はほとんどしらないです。) 内部では列挙型定数とビット計算っぽいのでいろいろやってます。CallByNameで実装しましたがフツーに場合分けで良かった気もします。 他にもEvtSummarizerのNothing時に持っているEvtObjectクラスがNothingされるようになっています。 これを実現するのが最後のクラスであるParentGuideクラスです。 参考URL:mougのクラス研究室…だったんですが削除されてます。 2013-04-19追記:kumatti様からアナウンスがありました。インターネットアーカイブで閲覧出来ます。 http://web.archive.org/web/20120512005124/http://moug.net/faq/viewtopic.php?t=62306 http://web.archive.org/web/20120512005112/http://moug.net/faq/viewtopic.php?t=62566 http://web.archive.org/web/20130115194304/http://moug.net/faq/viewtopic.php?t=62720 2番目のところに「親オブジェクトへの参照を保持せずに親オブジェクトへの参照を得る方法2」のくだりがあります。 早い話RaiseEvent-WithEvents経由でオブジェクトを伝える様にすれば、参照を持っていてもNothingされる動きになります。 それとKey文字列を持つことにしました。なのでコントロールの参照はIndex(数値)かKey(文字列)でコントロールにアクセスできます。 エラートラップしてないです…まあいいでしょう。なおKeyを入れない場合は自動的にコントロール名がKeyになります。 Indexはさり気なく0スタートです。 ぱっと思いつく要望としてはFor Eachでしょうか…あとグループ化もあるといいですね。 Itemメソッドの戻り値はObjectにしていますがControlでも良かったかなあ。でも後々FormやReportのCloseイベントとかも… コントロール配列というには少し趣旨がずれたものが完成しましたが結構快適に使えます。 「データシートのどこかのセルをダブルクリックして単票を開く」など各コントロールに同じイベントで共通メソッドを呼ぶような 場合はかなりあっさり書くことができます。また結果として同じイベントであればコントロールの種類に関係なくなっており 「テキストボックスのダブルクリック」と「ボタンのダブルクリック」なども一つのイベントでキャッチできます。(そんな機会あるかな) またサブフォームのコントロールをAddすることで処理をすべてメインフォーム側に持ってくることも可能かもしれません。 改変自由、自己責任ですが多くの方の役に立てば幸いです。試しに使ってみた方は感想いただけると嬉しいです。