愚者の経験

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

月別アーカイブ: 10月 2011

クイックソートと挿入ソートのハイブリッド

前回の投稿:配列をソート(並び替え)で挙げていた改善案の
「2.ある程度並べ替えできたら挿入ソートに移行」
を適用したクイックソートです。

実行時間が6割ほどになりました。

Public Sub QuickSort2(Data As Variant)
‘クイックソートと挿入ソートのハイブリッド
    Dim Stack As Dictionary
    Set Stack = New Dictionary
‘    Dim Stack As Object
‘    Set Stack = CreateObject(“Scripting.Dictionary”)
‘    Dim Stack As Collection
‘    Set Stack = New Collection
   
    Dim LeftIdx As Long
    Dim RightIdx As Long
    Dim Pivot As Variant
    Dim tPivot(2) As Variant
    Dim Temp As Variant
   
    Dim i As Long
    Dim j As Long
    Stack.Add Stack.Count + 1, LBound(Data)
    Stack.Add Stack.Count + 1, UBound(Data)
‘    Stack.Add LBound(Data), CStr(Stack.Count + 1)
‘    Stack.Add UBound(Data), CStr(Stack.Count + 1)
    Do While Stack.Count > 0
               
        LeftIdx = Stack(Stack.Count – 1)
        RightIdx = Stack(Stack.Count)
‘        LeftIdx = Stack(CStr(Stack.Count – 1))
‘        RightIdx = Stack(CStr(Stack.Count))
       
        Stack.Remove Stack.Count
        Stack.Remove Stack.Count
        ‘クイックソート
        If LeftIdx < RightIdx Then
       
            Pivot = Data((LeftIdx + RightIdx) / 2)
           
            i = LeftIdx
            j = RightIdx
           
            Do While i <= j
           
                Do While Data(i) < Pivot
                    i = i + 1
                Loop
           
                Do While Data(j) > Pivot
                    j = j – 1
                Loop
           
                If i <= j Then
                    Temp = Data(i)
                    Data(i) = Data(j)
                    Data(j) = Temp
                   
                    i = i + 1
                    j = j – 1
                End If
           
            Loop
           
            If RightIdx – i >= 0 Then
                If RightIdx – i <= 10 Then '分割した要素の数によって挿入ソートに移行
                    ComboInsertionSort Data, i, RightIdx
                Else
                    Stack.Add Stack.Count + 1, i
                    Stack.Add Stack.Count + 1, RightIdx
        ‘            Stack.Add i, CStr(Stack.Count + 1)
        ‘            Stack.Add RightIdx, CStr(Stack.Count + 1)
                End If
            End If
           
            If j – LeftIdx >= 0 Then
                If j – LeftIdx <= 10 Then '分割した要素の数によって挿入ソートに移行
                    ComboInsertionSort Data, LeftIdx, j
                Else
                    Stack.Add Stack.Count + 1, LeftIdx
                    Stack.Add Stack.Count + 1, j
        ‘            Stack.Add LeftIdx, CStr(Stack.Count + 1)
        ‘            Stack.Add j, CStr(Stack.Count + 1)
                End If
            End If
        End If
   
    Loop
   
‘    ArrayTest Data
End Sub

Public Sub ComboInsertionSort(Data As Variant, MinIdx As Long, MaxIdx As Long)
‘挿入ソート(別のソートとセットで利用)
    Dim i As Long, j As Long
    Dim Temp As Variant
    j = 1
    For j = MinIdx To MaxIdx
        i = j – 1
        Do While i >= 0
            If Data(i + 1) < Data(i) Then
                Temp = Data(i + 1)
                Data(i + 1) = Data(i)
                Data(i) = Temp
            Else
                Exit Do
            End If
            i = i – 1
        Loop
    Next
   
End Sub

配列をソート(並び替え) 非再帰クイックソート

現在作成中のプログラムで、配列を並び替える必要が出てきました。
簡単に出来るかと思いきや意外と難しく奥深いです。

今回は配列に要素を追加するたびに並び替えを行うために「シェルソート」というアルゴリズムを
採用しましたが、最も高速と言われる「クイックソート」なるアルゴリズムもついでに勉強しました。

参考URL:http://ameblo.jp/blueskyame/entry-10244296193.html

最終的には常用できるようにしたかったので、非再帰処理版のクイックソートを作成することにしました。
参考URLの方のコードを拝見し、クラスモジュールを直接Dictionary(またはCollection)オブジェクトで
置き換えました。(1次配列のみ対応)

本コードは「Microsoft Scripting Runtime」を参照設定しています。
これができない場合は、DictionaryオブジェクトをCreateObjectするかCollectionオブジェクトで
代用してください。
速度の観点ではDictionaryオブジェクトを事前バインディングしたものが最も高速です。
私のノートパソコンでは1000000個の整数配列で約6秒ほどで処理できます。
これはおそらく純粋なクイックソートなので改善案として
1.Pivotの選択の仕方
2.ある程度並べ替えできたら挿入ソートに移行
などまだまだ高速化出来ると思います。
高速なソートを知っている方はぜひ連絡を(^_-)-☆

Public Sub QuickSort(Data As Variant)
‘クイックソート非再帰版
‘スタックをDictionary(またはCollection)オブジェクトで再現する
‘コメントアウトした行はCollectionオブジェクトを使用した場合のコードです。
    Dim Stack As Dictionary
    Set Stack = New Dictionary
‘    Dim Stack As Object
‘    Set Stack = CreateObject(“Scripting.Dictionary”)
‘    Dim Stack As Collection
‘    Set Stack = New Collection
   
    Dim LeftIdx As Long
    Dim RightIdx As Long
    Dim Pivot As Variant
    Dim Temp As Variant
   
    Dim i As Long
    Dim j As Long

    Stack.Add Stack.Count + 1, LBound(Data)
    Stack.Add Stack.Count + 1, UBound(Data)
‘    Stack.Add LBound(Data), CStr(Stack.Count + 1)
‘    Stack.Add UBound(Data), CStr(Stack.Count + 1)

    Do While Stack.Count > 0
               
        LeftIdx = Stack(Stack.Count – 1)
        RightIdx = Stack(Stack.Count)
‘        LeftIdx = Stack(CStr(Stack.Count – 1))
‘        RightIdx = Stack(CStr(Stack.Count))
       
        Stack.Remove Stack.Count
        Stack.Remove Stack.Count
        ‘クイックソート
        If LeftIdx < RightIdx Then
           
            If (RightIdx – LeftIdx) < 1 Then
                InsertionSort Data
                Exit Sub
            End If
            Pivot = Data((LeftIdx + RightIdx) / 2)
           
            i = LeftIdx
            j = RightIdx
           
            Do While i <= j
           
                Do While Data(i) < Pivot
                    i = i + 1
                Loop
           
                Do While Data(j) > Pivot
                    j = j – 1
                Loop
           
                If i <= j Then
                    Temp = Data(i)
                    Data(i) = Data(j)
                    Data(j) = Temp
                   
                    i = i + 1
                    j = j – 1
                End If
           
            Loop

            Stack.Add Stack.Count + 1, i
            Stack.Add Stack.Count + 1, RightIdx
‘            Stack.Add i, CStr(Stack.Count + 1)
‘            Stack.Add RightIdx, CStr(Stack.Count + 1)

            Stack.Add Stack.Count + 1, LeftIdx
            Stack.Add Stack.Count + 1, j
‘            Stack.Add LeftIdx, CStr(Stack.Count + 1)
‘            Stack.Add j, CStr(Stack.Count + 1)
        End If
   
    Loop
   
‘    ArrayTest Data
End Sub

追記:続きの記事クイックソートと挿入ソートのハイブリッドで若干の高速化が見込めます。

ADOのRecordsetをフォームに利用4

以前の投稿
ADOのRecordsetをフォームに利用1
ADOのRecordsetをフォームに利用2
ADOのRecordsetをフォームに利用3
長かったですがようやく解決しました。これでようやく
「ADOのRecordsetをフォームに利用し、FilterとSortを自由に行ない、更に編集が出来る」
が完成しました。

結局ADOのRecordsetをフォームに利用2のコードを少し改良したものになります。

参考URL:http://msdn.microsoft.com/ja-jp/library/cc408271.aspx

↑これによると
「Recordset.Openを使用して永続化ファイルを開く」のくだりに

OpenメソッドのActiveConnection引数に”Provider=MSPersist”と書いてあります。
これで解決です。

Dim strm as ADODB.Stream
Set strm = New ADODB.Stream
strm.Open

rst1.Save strm, adPersistADTG

Set rst2 = New ADODB.Recordset
rst2.Open strm,”Provider=MSPersist”

ActiveConnection引数に”Provider=MSPersist”を追加しただけです。
しかしこれはエラーになります。

なぜかといいますと、ADODB.StreamオブジェクトをADODB.RecordsetのOpen メソッドで
利用する場合に指定できる引数は第一引数のSourceのみだからです。

なので最終的には

Dim strm as ADODB.Stream
Set strm = New ADODB.Stream
strm.Open

———————ここでrst1にFilterをかける—————–

rst1.Save strm, adPersistADTG           ‘FilterのかかったRecordsetを保存

Set rst2 = New ADODB.Recordset
rst2.ActiveConnection = “Provider=MSPersist”
rst2.Open strm

———————ここでrst2にSortをかける
Set Me.Form1.Recordset = rst2

これで完成です。やっとFilterとSortの併用で100件を超えられます。

2011/11/05追記:フォームに追加するまでのコードを追加

ADOのRecordsetをフォームに利用3

以前の投稿
ADOのRecordsetをフォームに利用1
ADOのRecordsetをフォームに利用2

上の続きでADOのRecordsetをフォームに表示する際に
「FilterとSortを併用すると結果が100件までしか出ない」現象について。

ここでフォームコントロールの機能に注目し

「フォームのOrderByとFilter(フォームフィルタ)を使えばいいのでは?」
と思ったのでやってみた。

Set Me.Recordset = rst

Me.OrderBy = “test desc”
Me.OrderByOn = True

並び替えは…できた!(^_^)v
次はフィルタ機能を試す。

Set Me.Recordset = rst

Me.Filter = “test = ‘テスト'”
Me.FilterOn = True

結果は…できないorz
データシートでみると確かにフィルタ適用になっているが絞り込みはされない。
ならば
「フィルターはRecordsetのFilterで、
並べ替えはFormのOrderByでそれぞれ適用すればいい」
と思った。

rst.Filter = “test = ‘テスト'”

Set Me.Recordset = rst

Me.OrderBy = “test desc”
Me.OrderByOn = True

これでどうだ!ってFilterかかってない(^_^;)
並べ替えが実行されるとRecordsetが初期化されるようだ。(つまりFilter解除)
つまりこの方法だと
フィルターをかけると並び替えが解除され、
並び替えをかけるとフィルターが解除される(泣)

う~ん、どうしようか…併用難しい。

2011/10/28 追記ADOのRecordsetをフォームに利用4にて解決しました。

ADOのRecordsetをフォームに利用2

ADOのRecordsetをフォームに利用1の問題に関して
一つアイデアが浮かんだ。それは

「絞り込んだ(Filter)したRecordsetを別のRecordsetして
それに対してSortをかければいいのではないか?」
Recordset1(テーブル全体)

Filterをかける

Recordset1(Filterがかかっている)

Recordset2にRecordset1の内容をコピー

Recordset2(Filterなしの絞り込みしたデータ)

Recordset2にSort

併用回避ヽ(^o^)丿

という具合でできるんじゃないかと思った。
が、これもなかなか難しい。
Recordsetの内容をなかなかコピーできない。

Set rst2=rst1

はダメ。rst2にSortすると結局同じです。

Set rst2=rst1.Clone

これもダメ。いけるかと思われたがFilterが無視されるみたいですね。

Dim strm as ADODB.Stream
Set strm = New ADODB.Stream
strm.Open

rst1.Save strm, adPersistADTG

Set rst2 = New ADODB.Recordset
rst2.Open strm

Filter後のRecordsetが作れました!
当然この後にSortしても併用にはならないので、100以上表示できます!

だが喜んだのもつかの間、後になって重大な事実に気づく。

このレコードセット更新できないです。
レコードセット自体は更新できるけど、元のデータベースに反映してくれないようです。

結局振り出しに戻る。

2011/10/28 追記:ADOのRecordsetをフォームに利用4にて解決しました。

ADOのRecordsetをフォームに利用1

参考URL:http://blogs.msdn.com/b/nakama/archive/2008/10/16/ado.aspx

Access側にテーブルを作らずにリンクテーブルもなしで

Set Me.Recordset=rst

のようにレコードセットをフォームに代入する手法を勉強中。そこで大変やっかいな問題が!

rst.Filter = “A=1”
rst.Sort = “A”

Set Me.Recordset=rst

のようにFilterとSortを併用するとフォームに100件しか表示されません。
どちらか一方だけだと問題ありません。
参考URL:http://www.accessclub.jp/bbs3/0366/superbeg109983.html

Debug.Print rst.RecordCount

でみても100件以上あることが確認できます。
しかし表示は100件!なぜ!?

2011/10/28 追記:ADOのRecordsetをフォームに利用4にて解決しました。

自作?クラス3

参考URL:http://hatenachips.blog34.fc2.com/blog-entry-166.html

今回はSplitterコントロールに挑戦です。比較的簡単。
Accessでサブフォームを複数配置する画面があったとしたら使いたくなるかもしれませんね(^_^;)
設計、使用法はこんな感じ。
・四角形をSplitterとしてにセット
・縦のSplitterクラスと横のSplitterクラスに別にする。
(コードはほとんど一緒になるがわかりやすさ重視で。)
・連動するコントロール(複数)を「上か下」または「右か左」に分けて登録する。
(コントロールの位置によってTop、Leftだけ変更すればいい場合と、併せてHeight、Widthを変更する場合に分かれるため。)
おまけ
・Max値とMin値を設定可能にする
・Splitterのマウスホバー時にカーソルを上下矢印または左右矢印に変更する。
課題
・タブ付ドキュメントのアンカーがある場合コントロールがずれる。
高さ幅の変更前にそれらを「0」にすることで解決。

追記:クラスモジュールを公開します。改変、利用はいつものように構いませんが自己責任でお願いします。

‘Splitterの列挙体(縦Splitterと横Splitter)
Public Enum SplitterModeEnum
    VSPLITTER
    HSPLITTER
End Enum

‘カーソルを変更するAPI
Private Declare Function LoadCursor Lib “user32” Alias “LoadCursorA” _
    (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
Private Declare Function SetCursor Lib “user32” _
    (ByVal hCursor As Long) As Long
   
‘カーソルの値(上下の矢印と左右の矢印)
Private Const IDC_SIZENS = 32645
Private Const IDC_SIZEWE = 32644

‘Splitterとなる四角形コントロール
Private WithEvents Rct As Rectangle
‘連動するコントロールを格納するコレクション
Private Ctls As Collection
Private Ctls2 As Collection

‘ドラッグ中かどうかを判定するために使用する変数
Private IsClick As Boolean

‘LoadCursorの返り値を格納する変数
Private Cursor As Long

‘移動した長さ
Private d As Long

‘MouseDown時の座標
Private pP As Long

‘MouseMove後の座標
Private nP As Long

‘Splitterの最大座標と最小座標
Private MaxP As Long
Private MinP As Long

‘縦Splitterか横Splitterかの保存用
Private Mode As SplitterModeEnum

‘コンストラクタ
Private Sub Class_Initialize()
    Set Ctls = New Collection
    Set Ctls2 = New Collection
    MaxP = 64800
    MinP = 0
End Sub

‘デストラクタ
Private Sub Class_Terminate()
    Set Ctls = Nothing
    Set Ctls2 = Nothing
End Sub

‘Splitterとして四角形コントロールをセットする
Public Sub SetSplitter(Ctl As Rectangle, SplitterMode As SplitterModeEnum)
    Set Rct = Ctl
    Rct.OnMouseDown = “[イベント プロシージャ]”
    Rct.OnMouseMove = “[イベント プロシージャ]”
    Rct.OnMouseUp = “[イベント プロシージャ]”
    Mode = SplitterMode
   
    If Mode = HSPLITTER Then
        Cursor = LoadCursor(0, IDC_SIZENS)
    Else
        Cursor = LoadCursor(0, IDC_SIZEWE)
    End If
End Sub

‘連動するコントロールの追加
‘四角形コントロールよりも上又は左にあるコントロール
Public Sub Add(Ctl As Control)
    Ctls.Add Ctl
End Sub

‘連動するコントロールの追加
‘四角形コントロールよりも下又は右にあるコントロール
Public Sub Add2(Ctl As Control)
    Ctls2.Add Ctl
End Sub

‘Splitterの最大座標の設定、取得
Public Property Let Max(SetMax As Long)
    MaxP = SetMax
End Property

Public Property Get Max() As Long
    Max = MaxP
End Property

‘Splitterの最小座標の設定、取得
Public Property Let Min(SetMin As Long)
    MinP = SetMin
End Property

Public Property Get Min() As Long
    Min = MinP
End Property

‘マウスダウン時
Private Sub Rct_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Mode = HSPLITTER Then
        pP = Y
    Else
        pP = X
    End If
    IsClick = True
    SetCursor Cursor
End Sub

‘マウスムーブ時
Private Sub Rct_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error Resume Next
    SetCursor Cursor
    If IsClick = False Then Exit Sub
   
    If Mode = HSPLITTER Then
        d = pP – Y
        nP = Rct.Top – d
        If MaxP < nP Then Exit Sub
        If MinP > nP Then Exit Sub
        Rct.Top = nP
    Else
        d = pP – X
        nP = Rct.Left – d
        If MaxP < nP Then Exit Sub
        If MinP > nP Then Exit Sub
        Rct.Left = nP
    End If
       
    Ctls_Move
End Sub

‘マウスアップ時
Private Sub Rct_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    IsClick = False
End Sub

‘連動コントロールの幅、高さの変更
Private Sub Ctls_Move()
    Dim pHW As Long
    Dim Ctl As Control
    If Mode = HSPLITTER Then
        For Each Ctl In Ctls
            Ctl.Height = Ctl.Height – d
        Next
       
        For Each Ctl In Ctls2
            pHW = Ctl.Height + d
            Ctl.Height = 0
            Ctl.Top = Ctl.Top – d
            Ctl.Height = pHW
        Next
    Else
        For Each Ctl In Ctls
            Ctl.Width = Ctl.Width – d
        Next
       
        For Each Ctl In Ctls2
            pHW = Ctl.Width + d
            Ctl.Width = 0
            Ctl.Left = Ctl.Left – d
            Ctl.Width = pHW
        Next
    End If
End Sub

Accessでメールクライアント1

参考URL1:http://www.ynsk.co.jp/nsk/knowhow/sendmail/sendmail5.htm
参考URL2:http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_800_080.html

上記URLは非常に参考になります。
Accessでメールをする需要はそれほど高くないと思われますがあったら便利ですね。

1.csv等のデータを添付しメールを送信
2.メールを受信し、添付ファイルをテーブルに取り込み
の2つがメール関係で大体必要となる機能です。(かなり大雑把ですが)

Outlookを使っていれば参照設定やCreateObjectでメール(機能)にアクセスできますが、
「Outlookを使ってください!」はかなり使いにくいなと思っていたのです。

なんとか自力(標準機能)でメールできないかと探していたところ上記URLに当たりました。
これらを参考にし自分流にメールクライアントを作成中です。

追記:POP3サーバーがSSLで構成されている場合詰むかもしれない…