愚者の経験

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

月別アーカイブ: 6月 2012

マルチインスタンス利用時のOpenArgs-無理っぽい

前回の投稿

マルチインスタンス利用時のOpenArgsの実装について仕様をまとめます。
1.フォームのOpen時イベントで利用できる。
2.別のフォームが開いていても各々OpenArgsが利用できる。
3.フォーム内の変数でOpenArgsを保持しない。
4.マルチインスタンス利用時でも各々OpenArgsが利用できる。

これらを妥協することなく実現する方法を考えていきます。
まず1ですがこれは以下のようなコードのことです。

'標準モジュール
Public Argument As Variant
Private frm As Form
Public Function Test() As Long
    Set frm = New Form_フォーム1
    Argument = Array(1, 2, 3)
    frm.Visible = True
End Function

Testプロシージャの2行目でフォーム1のOpenイベントが始まるため、これは却下です。
ではこれはどうでしょう。

'標準モジュール
Public Argument As Variant
Private frm As Form
Public Function Test() As Long
    Argument = Array(1, 2, 3)
    Set frm = New Form_フォーム1
    frm.Visible = True
End Function

'フォーム1のコード
Private Sub Form_Open(Cancel As Integer)
    If (IsArray(Argument) = True) Then
    End If
End Sub

これもだめです。2に抵触します。
後から別のフォームが開いた時、OpenArgsの代わりのグローバル変数「Argument」の
内容が上書きされるので、Open時はOKですがその後がダメです。
かと言ってフォーム内に変数を持つのは3に抵触することになります。

これらの要求を満たすにはまずグローバル変数「Argument」はコレクションである
必要があるということになります。

というわけで標準モジュールに宣言したグローバル変数「Argument」は
「Arguments」コレクションに直します。

'標準モジュール
Public Arguments As New Collection
Private frm As Form
Public Function Test() As Long
    Arguments.Add Array(1, 2, 3), "フォーム1"
    Set frm = New Form_フォーム1
    frm.Visible = True
End Function

'フォーム1のコード
Private Sub Form_Open(Cancel As Integer)
    If (IsArray(Arguments(Me.Name)) = True) Then
    End If
End Sub

だいぶ良くなりました。これでフォーム側の変数が不要になりました。
別のフォームを開いても各々「Arguments(Me.Name)」でそれぞれの値が
取得できます。

しかし更に問題がありました。4つめの実現です。
マルチインスタンスを利用すると「同じフォームが複数」開けます。
つまりフォーム名をキーに出来ないのです。

では何をキーにするか…オブジェクトポインタでもキーにするかってあれ?
Objptrは「Newしたオブジェクト」に有効です。しかしNewした瞬間にOpenイベントが
入ります。ウィンドウハンドルも同様です。

「Newする前にNewした後に取得できる値をキーにする」必要がありそうです。詰みましたorz

広告

マルチインスタンス利用時のOpenArgs-プロローグ

「Accessクラスオブジェクト」をNewしてオブジェクト変数に格納することで
同じフォームやレポートを複数開く「マルチインスタンス」という小技があります。

Private frm As Form
Public Function Test() As Long
    Set frm = New Form_フォーム1
    frm.Visible = True
End Function

フォーム1の「コード保持」プロパティを「はい」に設定していれば
このコードでフォーム1が開きます。オブジェクト変数を複数にして、それぞれNewしてやると
フォーム1が複数開きます。これが「マルチインスタンス」です。

Private frm() As Form
Public Function Test() As Long
    ReDim frm(1)
    Set frm(0) = New Form_フォーム1
    Set frm(1) = New Form_フォーム1
    frm(0).Visible = True
    frm(1).Visible = True
End Function

「Docmd.OpenForm」と違う点は当然複数開けることが大きな違いになるわけですが、
ここで疑問がありました。それが「OpenArgsは?」です。
「OpenArgs」は読み取り専用であるため、Newした後で代入できません。
フォーム側のPublic変数に代入しようにもNewした時点でフォームのOpenイベントやLoadイベントが始まりますので
Open時のイベントでOpenArgsを使っている場合はダメになります。そしてこのパターンはかなり多いです。

一番簡単なのがグローバル変数に代入することなのですが、各フォームのOpenイベントで
グローバル変数に値を退避する必要があり結構面倒くさいです。

フォーム側のイベントに何も書かずに統一的な参照方法でそのフォーム固有の変数にアクセスしたいですね。
どうしようかな…。

VBAのWithステートメントは便利

Withステートメントは主に修飾パスが長い場合に省略するために用いられることが多いような気がします。
しかし場合によってWithステートメントで「オブジェクト変数の宣言を省略できる」ことがあります。

前の投稿などでも利用した使い方です。Object変数を用意せず「With New ADODB.Command ~ End With」とします。
今までのコードの書き方はこんな感じでした。

Public Function Test() As Long
    Dim i As Long
    Dim int1 As Long,int2 As Long

    Dim cnn As ADODB.Connection
    Set cnn = New ADODB.Connection
    cnn.ConnectionString = _
            "Provider=Microsoft.ACE.OLEDB.12.0;" & _ 
            "Data Source=C:\test.accdb;"
    cnn.Open

    Dim cmd As ADODB.Command
    Dim rst As ADODB.Recordset
    Set cmd = New ADODB.Command
    Set rst = New ADODB.Recordset

    With cmd
        Set .ActiveConnection = cnn
        .CommandText = "select * from test1"
        .CommandType = adCmdText
        .CommandTimeout = 0
        Set rst = .Execute
    End With

    With rst
        If (.RecordCount > 0) Then
            int1 = .Fields("int1").Value
            int2 = .Fields("int2").Value
        End If
    End With

    Set rst = Nothing
    Set cmd = Nothing

    Test = int1 + int2
End Function

こんな感じのコードが短くできます。

Public Function Test() As Long
    Dim i As Long
    Dim int1 As Long,int2 As Long

    Dim cnn As ADODB.Connection
    Set cnn = New ADODB.Connection
    cnn.ConnectionString = _
            "Provider=Microsoft.ACE.OLEDB.12.0;" & _ 
            "Data Source=C:\test.accdb;"
    cnn.Open

    With New ADODB.Command
        Set .ActiveConnection = cnn
        .CommandText = "select * from test1"
        .CommandType = adCmdText
        .CommandTimeout = 0
        With .Execute
            If (.RecordCount > 0) Then
                int1 = .Fields("int1").Value
                int2 = .Fields("int2").Value
            End If
        End With
    End With

    Test = int1 + int2
End Function

本来Newしたオブジェクトは即変数に代入するのがもはや定番の書き方になっているようですが、
With New~とすることでほぼ同等のコードにできます。明らかなデメリットといえば
ほかのオブジェクト変数に代入できないこととぐらいでしょうか…。またWithで指定するオブジェクトが
明示的な型指定を受けていない場合は「.」を入れてもヒントが出ません。例えばフォームのレコードセットで見ると

    Dim rst As DAO.Recordset
    
    Set rst = Me.Recordset
    With rst
        .AddNew
    End With

この「With rst」はヒントが出ます。ですが変数を省略して

    With Me.Recordset
        .AddNew
    End With

のようにしてもヒントは出ません。(もちろん実行はできます。)

このようにWithステートメントは.NetでいうところのUsingと似たような使い方ができます。
With~End Withまでの一時的なオブジェクトという感じですね。

FaceBookをようやくタイムライン化できた

FaceBookをタイムラインにするにはhttps://www.facebook.com/about/timelineにアクセスし、
「タイムラインの利用を開始」みたいなボタンが出てくるのそれをクリックでOK。

みたいなことが言われていますが、そもそもボタンが出ずにタイムラインにできないユーザーの方々がいるようです。
私もそのひとりでしたがやっとタイムライン化できました。

私の場合はおもむろにタイムライン化している友達のページを見たら画面上部に「タイムラインに切り替える」みたいな
ボタンが表示され、クリックすることで切り替えができました。

その時の私のFaceBookはまだFaceBook自体を始めたばかりなので
友達6人
いいね!10個
写真8枚
でした。他の方の参考になれば幸いです。

Accessでaccdbを使わずに他のDBを使ってみる – SQL Server CE編

SQL Server Compact Editionも実験してみます。Versionは3.5のsp2を利用します。

Public Sub sqlceTest2()
    Dim i As Long
    Dim tm As Single

    Dim cnn As ADODB.Connection
    Set cnn = New ADODB.Connection
    cnn.ConnectionString = _
            "Provider=Microsoft.SQLSERVER.CE.OLEDB.3.5;" & _
            "Data Source=C:\test.sdf;"
    cnn.Open

    With New ADODB.Command
        Set .ActiveConnection = cnn
        cnn.BeginTrans
        .CommandText = "insert into " & _
            "test1 (int1,int2,int3,int4,int5,text1,text2,text3,text4,text5) " & _
            "values (1,2,3,4,5,'a','b','c','d','e')"
        .CommandType = adCmdText
        .CommandTimeout = 0

        tm = Timer
        For i = 0 To 30000
            .Execute
        Next

        Debug.Print Timer - tm
        cnn.CommitTrans
    End With
End Sub

実行結果 6.2秒

Public Sub sqlceTest3()
    Dim i As Long
    Dim tm As Single

    Dim cnn As ADODB.Connection
    Set cnn = New ADODB.Connection
    cnn.ConnectionString = _
            "Provider=Microsoft.SQLSERVER.CE.OLEDB.3.5;" & _
            "Data Source=C:\test.sdf;"
    cnn.Open

    With New ADODB.Recordset
        Set .ActiveConnection = cnn
        .CursorLocation = adUseClient

        tm = Timer

        For i = 0 To 10
            .Open "select * from test1", , adOpenStatic, adLockReadOnly
            .Close
        Next

        Debug.Print Timer - tm
    End With
End Sub

実行結果 3.5秒

Public Sub sqlceTest4()
    Dim i As Long
    Dim tm As Single

    Dim cnn As ADODB.Connection
    Set cnn = New ADODB.Connection
    cnn.ConnectionString = _
            "Provider=Microsoft.SQLSERVER.CE.OLEDB.3.5;" & _
            "Data Source=C:\test.sdf;"
    cnn.Open

    With New ADODB.Command
        Set .ActiveConnection = cnn
        cnn.BeginTrans
        .CommandText = "update test1 set int1=10"
        .CommandType = adCmdText
        .CommandTimeout = 0

        tm = Timer
        For i = 0 To 100
            .Execute
        Next

        Debug.Print Timer - tm
        cnn.CommitTrans
    End With
End Sub

実行結果 8.8秒

早い…SQLCEは一応uniqueidentifier(guid)やrowversion(timestamp)も使えるので
案外Accessで使ってもいいのかもしれません。

Accessでaccdbを使わずに他のDBを使ってみる – SQLite編4

次にupdateしてみます。30001件の全行に対しint1=10に更新します。


Public Sub SQLiteTest4()
    Dim i As Long
    Dim tm As Single
    
    Dim cnn As ADODB.Connection
    Set cnn = New ADODB.Connection
    cnn.ConnectionString = _
            "Provider=OleSQLite.SQLiteSource.1;" & _
            "Data Source=C:\test.sqlite;"
    cnn.Open
    
    With New ADODB.Command
        Set .ActiveConnection = cnn
        cnn.BeginTrans
        .CommandText = "update test1 set int1=10"
        .CommandType = adCmdText
        .CommandTimeout = 0
        
        tm = Timer
        For i = 0 To 100
            .Execute
        Next
        
        Debug.Print Timer - tm
        cnn.CommitTrans
    End With
End Sub

Public Sub accdbTest4()
    Dim i As Long
    Dim tm As Single
    
    
    Dim cnn As ADODB.Connection
    Set cnn = New ADODB.Connection
    cnn.ConnectionString = _
            "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;" & _
            "Data Source=C:\test.accdb;"
    cnn.Open
    
    With New ADODB.Command
        Set .ActiveConnection = cnn
        cnn.BeginTrans
        .CommandText = "update test1 set int1=10"
        .CommandType = adCmdText
        .CommandTimeout = 0
        
        tm = Timer
        For i = 0 To 100
            .Execute
        Next
        
        Debug.Print Timer - tm
        cnn.CommitTrans
    End With
End Sub

実行結果 SQLite :18.5秒 Access:40.1秒
Deleteは確認してませんがSQLiteはSelect以外で高速です。Selectもインデックスを利用して計測すれば
結果が違ってくるかもしれません。

Accessでaccdbを使わずに他のDBを使ってみる – SQLite編3

30001件のデータが追加されたので今度はSelectしてみます。

Public Sub SQLiteTest3()
    Dim i As Long
    Dim tm As Single
    
    Dim cnn As ADODB.Connection
    Set cnn = New ADODB.Connection
    cnn.ConnectionString = _
            "Provider=OleSQLite.SQLiteSource.1;" & _
            "Data Source=C:\test.sqlite;"
    cnn.Open
    
    With New ADODB.Recordset
        Set .ActiveConnection = cnn
        .CursorLocation = adUseClient
                
        tm = Timer

        For i = 0 To 10
            .Open "select * from test1", , adOpenStatic, adLockReadOnly
            .Close
        Next
        
        Debug.Print Timer - tm
    End With
End Sub

Public Sub accdbTest3()
    Dim i As Long
    Dim tm As Single
    
    Dim cnn As ADODB.Connection
    Set cnn = New ADODB.Connection
    cnn.ConnectionString = _
            "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;" & _
            "Data Source=C:\test.accdb;"
    cnn.Open
    
    With New ADODB.Recordset
        Set .ActiveConnection = cnn
        .CursorLocation = adUseClient
        
        tm = Timer

        For i = 0 To 10
            .Open "select * from test1", , adOpenStatic, adLockReadOnly
            .Close
        Next
        
        Debug.Print Timer - tm
    End With
End Sub

実行結果 SQLite :8.8秒 Access:2.2秒
おかしいです…SQLiteに早くなって欲しいのに笑selectは完敗ですかね。

WaterMarkクラス

Ajax Toolkit にあった「WaterMark」エクステンド。空白のテキストボックスの上にテキストを出し
入力時に消えるというこの動作はフォームのレイアウト的に魅力です。

これと同じような動作をするクラスを作成してみます。

Option Explicit

Private Type RECT
    rtLeft As Long
    rtTop As Long
    rtRight As Long
    rtBottom As Long
End Type

Private Declare Function GetWindowDC Lib "user32" ( _
                ByVal Hwnd As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetWindowRect Lib "user32" ( _
                ByVal Hwnd As Long, _
                ByRef lpRect As RECT) As Long

Private Declare Function DrawText Lib "user32" _
                Alias "DrawTextA" ( _
                ByVal hDC As Long, _
                ByVal lpString As String, _
                ByVal nCount As Long, _
                ByRef lpRect As RECT, _
                ByVal uFormat As Long) As Long

Private Declare Function SetTextColor Lib "gdi32" ( _
                ByVal hDC As Long, _
                ByVal crColor As Long) As Long
Private Declare Function CreateBrushIndirect Lib "gdi32" ( _
                ByRef lpLogBrush As LOGBRUSH) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" _
                Alias "CreateFontIndirectA" ( _
                ByRef lpLogFont As LOGFONT) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
                ByVal hDC As Long, _
                ByVal nIndex As Long) As Long
Private Declare Function SelectObject Lib "gdi32" ( _
                ByVal hDC As Long, _
                ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" ( _
                ByVal hObject As Long) As Long
Private Declare Function FillRect Lib "user32" ( _
                ByVal hDC As Long, _
                lpRect As RECT, _
                ByVal hBrush As Long) As Long

Private Const LF_FACESIZE = 32
Private Const FW_NORMAL = 400
Private Type LOGFONT
    lfHeight          As Long
    lfWidth           As Long
    lfEscapement      As Long
    lfOrientation     As Long
    lfWeight          As Long
    lfItalic          As Byte
    lfUnderline       As Byte
    lfStrikeOut       As Byte
    lfExpressionSet   As Byte
    lfOutPrecision    As Byte
    lfClipPrecision   As Byte
    lfQuality         As Byte
    lfPitchAndFamily As Byte
    lfFaceName(LF_FACESIZE) As Byte
End Type

Private Type LOGBRUSH
    lbStyle As Long
    lbColor As Long
    lbHatch As Long
End Type

Private Const DT_SINGLELINE = &H20
Private Const DT_NOCLIP = &H100
Private Const DT_LEFT = &H0
Private Const DT_CENTER = &H1
Private Const DT_RIGHT = &H2
Private Const DT_VCENTER = &H4 Or DT_SINGLELINE
Private Const DT_TOP = &H0
Private Const DT_BOTTOM = &H8 Or DT_SINGLELINE

Private Const POINT_PER_INCH = 72
Private Const LOGPIXELSY = 90

Private pTarget As Control
Private WithEvents txt As TextBox
Private WithEvents cbo As ComboBox
Private WithEvents Parent As Form
Private html As Object

Private TargetRECT As RECT
Private MarkFont As LOGFONT
Private MarkBrush As LOGBRUSH
Private MarkText As String
Private IsMark As Boolean
Private fColor As Long
Private bColor As Long
Private fName()  As Byte
Private hFont As Long
Private hBrush As Long
Private TextFormat As Long

Private Sub Class_Initialize()
    IsMark = False
    MarkText = ""
    Set html = CreateObject("htmlfile")
    Set html.parentWindow.onhelp = Me
End Sub

Private Sub Class_Terminate()
    Set pTarget = Nothing
    Set Parent = Nothing
    Set html.parentWindow.onhelp = Nothing
    Set html = Nothing
    Set cbo = Nothing
    Set txt = Nothing
    DeleteObject hFont
    DeleteObject hBrush
End Sub

Public Sub Bind(Target As Control, WaterText As String, _
                Optional FontSize As Variant, _
                Optional FontName As Variant, _
                Optional hTextAlign As Byte = 1, _
                Optional vTextAlign As Byte = 1, _
                Optional FontColor As Long = 10197915)
    Dim hAlign As Long
    Dim vAlign As Long

    Set pTarget = Target

    If (pTarget.ControlType = acTextBox) Then
        Set txt = pTarget
    Else
        Set cbo = pTarget
    End If

    With pTarget
        Set Parent = CodeContextObject
        GetWindowRect Parent.Hwnd, TargetRECT

        Parent.OnCurrent = "[イベント プロシージャ]"
        Parent.OnResize = "[イベント プロシージャ]"
        .OnExit = "[イベント プロシージャ]"
        .OnEnter = "[イベント プロシージャ]"

        fColor = FontColor

        If (IsMissing(FontName) = True) Then
            FontName = .FontName
        End If

        If (IsMissing(FontSize) = True) Then
            FontSize = .FontSize
        End If

        If (Parent.RecordSelectors = False) Then
            TargetRECT.rtLeft = .Left / 15
        Else
            TargetRECT.rtLeft = .Left / 15 + 20
        End If

        If (Parent.PopUp = True) Then
            TargetRECT.rtTop = .Top / 15 + 25
            TargetRECT.rtLeft = TargetRECT.rtLeft + 4
        Else
            TargetRECT.rtTop = .Top / 15
        End If
        TargetRECT.rtRight = TargetRECT.rtLeft + .Width / 15 - 4
        TargetRECT.rtBottom = TargetRECT.rtTop + .Height / 15 - 2

    End With

    MarkText = WaterText

    Dim i As Long
    With MarkFont
        fName() = StrConv(FontName, vbFromUnicode)
        For i = 0 To UBound(fName)
            .lfFaceName(i) = fName(i)
        Next
        .lfWeight = FW_NORMAL
        .lfExpressionSet = 1
        .lfHeight = FontSize * _
                        (GetDeviceCaps(GetWindowDC(Parent.Hwnd), LOGPIXELSY) / POINT_PER_INCH)
        .lfItalic = 0
        .lfStrikeOut = 0
        .lfUnderline = 0
    End With
    hFont = CreateFontIndirect(MarkFont)

    Select Case hTextAlign
        Case 0
            hAlign = DT_CENTER
        Case 1
            hAlign = DT_LEFT
        Case 2
            hAlign = DT_RIGHT
        Case Else
            hAlign = DT_CENTER
    End Select

    Select Case vTextAlign
        Case 0
            vAlign = DT_VCENTER
        Case 1
            vAlign = DT_TOP
        Case 2
            vAlign = DT_BOTTOM
        Case Else
            vAlign = DT_VCENTER
    End Select
    TextFormat = hAlign Or vAlign Or DT_NOCLIP

    Appearance
End Sub

Private Sub Parent_Current()
    Appearance
End Sub

Private Sub Parent_Resize()
    LazyAppearance
End Sub

Public Sub Appearance()
On Error Resume Next
    Dim hDC As Long
    With pTarget
        hDC = GetWindowDC(Parent.Hwnd)
        SetTextColor hDC, fColor
        SelectObject hDC, hFont

        If (Nz(.Value, "") = "") Then
            DrawText hDC, MarkText, -1, TargetRECT, TextFormat
        End If
    End With
End Sub

Private Sub LazyAppearance()
    html.parentWindow.setTimeout "onhelp.Appearance", 0, "VBScript"
End Sub

Private Sub txt_Enter()
    If (Nz(pTarget.Value, "") = "") Then
        DoEvents
    End If
End Sub

Private Sub txt_Exit(Cancel As Integer)
    LazyAppearance
End Sub

Private Sub cbo_Enter()
    If (Nz(pTarget.Value, "") = "") Then
        DoEvents
    End If
End Sub

Private Sub cbo_Exit(Cancel As Integer)
    LazyAppearance
End Sub

最初ExitとEnterイベントでテキストボックス等に直接文字を入れて表示しようとしたら
コントロールソースが数値型の場合に弾かれました…当たり前ですよね。

結局APIのDrowText関数でコントロールの矩形に描画しています。
コントロール内にフォーカスが入った時に再描画がかかるお陰で描画したテキストは
フォーカス時に消えてくれます。

本当は背景色も設定できればいいと思うんですがわかりません…
文字列の透過方法もわかりませんでしたm(__)m
また最小化した後に表示したイベントも順当な方法でつかむことができませんでした。

こんな感じで使います。

Option Explicit

Private WaterMarks() As c_WaterMark

Private Sub Form_Load()
    ReDim WaterMarks(1)

    Set WaterMarks(0) = New c_WaterMark
    Set WaterMarks(1) = New c_WaterMark

    WaterMarks(0).Bind Me.text1, "ID入力"
    WaterMarks(1).Bind Me.text2, "IDなし"

End Sub

WaterMarkのテスト

Accessでaccdbを使わずに他のDBを使ってみる – SQLite編2

前回の記事でSQLiteのInsertがやたら遅かった件ですが情報がありました。
参考URL:http://d.hatena.ne.jp/ytRino/20100915/1284519761

SQLiteはトランザクションを自動でつけるので遅くなる…ということでしょうか?
前後にトランザクションを明示してやると早くなるらしいです。なのでテストプロシージャを変更してみます。


Public Sub SQLiteTest2()
    Dim i As Long
    Dim tm As Single
    
    Dim cnn As ADODB.Connection
    Set cnn = New ADODB.Connection
    cnn.ConnectionString = _
            "Provider=OleSQLite.SQLiteSource.1;" & _
            "Data Source=C:\test.sqlite;"
    cnn.Open
    
    With New ADODB.Command
        Set .ActiveConnection = cnn
        cnn.BeginTrans
        .CommandText = "insert into " & _
            "test1 (int1,int2,int3,int4,int5,text1,text2,text3,text4,text5) " & _
            "values (1,2,3,4,5,'a','b','c','d','e')"
        .CommandType = adCmdText
        .CommandTimeout = 0
        
        tm = Timer
        For i = 0 To 30000
            .Execute
        Next
        
        Debug.Print Timer - tm
        cnn.CommitTrans
    End With
End Sub

Public Sub accdbTest2()
    Dim i As Long
    Dim tm As Single
    
    
    Dim cnn As ADODB.Connection
    Set cnn = New ADODB.Connection
    cnn.ConnectionString = _
            "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;" & _
            "Data Source=C:\test.accdb;"
    cnn.Open
    
    With New ADODB.Command
        Set .ActiveConnection = cnn
        cnn.BeginTrans
        .CommandText = "insert into " & _
            "test1 (int1,int2,int3,int4,int5,text1,text2,text3,text4,text5) " & _
            "values (1,2,3,4,5,'a','b','c','d','e')"
        .CommandType = adCmdText
        .CommandTimeout = 0
        
        tm = Timer
        For i = 0 To 30000
            .Execute
        Next
        
        Debug.Print Timer - tm
        cnn.CommitTrans
    End With
End Sub

実行結果 SQLite :8.44秒 Access:13.65秒
SQLiteはとても早くなりました。

Accessでaccdbを使わずに他のDBを使ってみる – SQLite編1

Accessと同じくファイルDBで、しかもAndroidなどにも広く使われている「SQLite」を
バックエンドに置きAccessのaccdbと比べて利点があるのかを調べてみます。

まず接続からいきます。

どうやら「SQLite」用のOLEDBプロバイダは本家で開発しておらず、サードパーティ製を使うしかないようです。ODBCドライバもサードパーティならあるようです。ここではOLEDBプロバイダを利用して実験します。

SQLite OLE DB Provider:http://cherrycitysoftware.com/ccs/providers/provsqlite.aspx

SQLiteのテーブル等を作成するために管理ツールも準備します。「tkSQLite」を使いました。
tkSQLite:http://reddog.s35.xrea.com/wiki/TkSQLite.html

早速実験してみます。以下のテーブルを使います。

[test1]テーブル

  • id integer 主キー インクリメント
  • int1 integer
  • int2 integer
  • int3 integer
  • int4 integer
  • int5 integer
  • text1 text
  • text2 text
  • text3 text
  • text4 text
  • text5 text

このテーブルに3万回Insertします。
実行方法はADODB.CommandオブジェクトでExecuteを3万回実行して速度を見ます。

“Insert into test1
(int1,int2,int3,int4,int5,text1,text2,text3,text4,text5)
values(1,2,3,4,5,’a’,’b’,’c’,’d’,’e’)”

Public Sub SQLiteTest()
    Dim i As Long
    Dim tm As Single

    With New ADODB.Command
        .ActiveConnection = _
            "Provider=OleSQLite.SQLiteSource.1;" & _
            "Data Source=C:\test.sqlite;"

        .CommandText = "insert into " & _
            "test1 (int1,int2,int3,int4,int5,text1,text2,text3,text4,text5) " & _
            "values (1,2,3,4,5,'a','b','c','d','e')"
        .CommandType = adCmdText
        .CommandTimeout = 0

        tm = Timer
        For i = 0 To 30000
            .Execute
        Next

        Debug.Print Timer - tm
    End With
End Sub

Public Sub accdbTest()
    Dim i As Long
    Dim tm As Single

    With New ADODB.Command
        .ActiveConnection = _
            "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;" & _
            "Data Source=C:\test.accdb;"

        .CommandText = "insert into " & _
            "test1 (int1,int2,int3,int4,int5,text1,text2,text3,text4,text5) " & _
            "values (1,2,3,4,5,'a','b','c','d','e')"
        .CommandType = adCmdText
        .CommandTimeout = 0

        tm = Timer
        For i = 0 To 30000
            .Execute
        Next

        Debug.Print Timer - tm
    End With
End Sub

実行結果        SQLite :280秒         Access:18秒
SQLite遅い…これはプロバイダのせいなのかわかりませんが。
ファイルサイズ SQLite :1,171kb Access:2,436kb
同じ行数でもSQLiteのほうが断然ファイルサイズが小さいです。