ODBCリンクテーブルの一問一答

そもそもODBCつながらない…
→64bitだったらこれをやってみる。
なにかがおかしい…
→定義変更後にリンクテーブルの更新をした?
Viewのリンクテーブルでデータの追加ってどうするの?新規行がないよ?
→「CREATE INDEX <インデックス名> ON <テーブル名> (<列名(カンマ区切り)>) with primary」
を実行して擬似インデックスを作成。
更新、削除しようとすると競合エラーが出てできない…
→Null値が入ったbit型の列がない?
データがすべて#Deletedなんだけど…
→bigint型使ってたらdecimalとかmoneyとかに変更する。
値を消して移動しようとしたら「Variant型でない変数にNull値を代入しようとしました」と出る。保存前なのに…。
→NOT NULLの付く列はNULLにして移動しようとした瞬間に上記のエラーが発生します。
厄介なことに「どのイベントの発生よりも早い」ので回避出来ません。

とりあえず、エラーメッセージを見ても内容がわかりにくいものを厳選。

広告

コレクション改(?)

かなり結構やっつけです。
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

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

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

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

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

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

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

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

DSNが見つからない?

はい。知っていたのに忘れていました。

64bitの場合は「コントロールパネル」→「管理ツール」→「データソース(ODBC)」で
登録してもダメです…(システムドライブ)\sysWow64\odbcad32.exeからODBCを作成しましょう。

前者の操作で有効な場合もあります。
「登録したのに接続できない！」という場合に疑ってみてください。

SQL ServerへのCSVファイルinsert高速化

クライアントでテキストファイル(csv)を処理してテーブルに
取り込む操作があったのですがそれが遅いとの事。

普通に「insert into xxxxx values(zzzzzzz,zzzz,zzzz)」系の
文字列にして、ADODB.Commandにセットしていたんですが
良かれと思ってあることをしていたのです…

    Dim InsertSQL As String
    Dim ValuesSQL As String
    Dim Row As String
    Dim rCount As Long
    Dim fNO As Long
    
    fNO = FreeFile
    InsertSQL = "insert into xxx(xxxx,xxx,xx,x)"
    
    Open filePath For Input As #fNO
    Do Until EOF(fNO)
        rCount = rCount + 1
        Line Input #fNO, Row
        
        ValuesSQL = ValuesSQL & ",(" & Row & ")"
        
        If (rCount Mod 1000 = 0) Then
            With New ADODB.Command
                .ActiveConnection = "xxxxxx"
                .CommandText = InsertSQL & " values" & Mid$(ValuesSQL, 2)
                .CommandType = adCmdText
                .CommandTimeout = 0
                .Execute , , adExecuteNoRecords
            End With
            ValuesSQL = ""
        End If
    Loop
    
    Close #fNO

大雑把に書くとこんな感じです。適当に書いてるのであしからず。
SQL Server2008から(確か)可能になった「insert into~~ valuesでの複数行追加」
をやっていました。「valus(a1,b1),(a2,b2)」のような書き方で複数行がinsertできる機能ですが
既定で一度に1000行までしかinsertできない制約を除けば一度の実行の手間が省ける！
と思っていたんです。

しかしExecute前後でTimer計測すると1000行入れるのにも4-5秒ほどの時間がかかっていました。
インデックスを除去したりトランザクションで括っても結果は変わらず…「早くならない!これが限界か?」
おもむろに1000行カウントを外して1行ずつExecuteするように変更してみました。
するとなんと5000行を10秒で回りました。めちゃくちゃSpeedup。

さらに

insert into xxx(xxxx,xxx,xx,x) values('a1','b1','c1','d1');
insert into xxx(xxxx,xxx,xx,x) values('a2','b2','c2','d2');
insert into xxx(xxxx,xxx,xx,x) values('a3','b3','c3','d3');
insert into xxx(xxxx,xxx,xx,x) values('a4','b4','c4','d4');
…
insert into xxx(xxxx,xxx,xx,x) values('a1000','b1000','c1000','d1000');

上記のような全体を文字列にして実行回数自体を減らすと更に早くなりました。
これならトランザクションで効果が出そうだと思いましたがやはりあまり変わらず。

いづれにしても複数行insertで遅い時は敢えて1行ずつ実行することも
試してみる価値はあると思います。必ずしも新機能が高速だというわけではなく
当然ケースバイケースだということだと思います。でもちょっと驚き。

ちなみに1行30列ほどだったと思います。
また1行ずつExecuteするなら、「insert into xxx(xxxx,xxx,xx,x) values(?,?,?,?);」
このような形でCommandTextをセットし、PreparedをTrueにして実行すれば
こっちのほうが早いかもしれません。やったことないですが。

    Dim Row As String
    Dim rCount As Long
    Dim fNO As Long
    fNO = FreeFile

    With New ADODB.Command
        .ActiveConnection = "xxxx"
        .CommandText = "insert into xxx(xxxx,xxx,xx,x) values(?,?,?,?);"
        .CommandType = adCmdText
        .CommandTimeout = 0
        .Prepared = True
        ' Parameters.Apprend .CreateParameter*4が必要かも
    
        Open filePath For Input As #fNO
        Do Until EOF(fNO)
            rCount = rCount + 1
            Line Input #fNO, Row
            .Execute , Split(Row, ",", , vbBinaryCompare), adExecuteNoRecords
        Loop
        Close #fNO
    End With

超すっきりしますね(笑)繰り返しますが未検証なのであしからず。
パラメータの配列渡しはSplitじゃダメかも知れません。

そもそもBULK使えば?と言われそうですが、これはこれで共有フォルダの
設定とか考えなくていいので全く見込みがないわけじゃないと思うのです。

コレクションをいろいろ自作してみる(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のフォームにセット出来る。利用するシーンは不明。

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

以上。

DBにファイルを保存したいのに

データベースにエクセルファイルを保存したいという需要も
全くないというわけではないと思います。

データに画像ファイルやエクセルファイルを紐付け出来れば
それはまた便利な機能かと思います。
その際「ファイルのパスを保存する」という手段が一般的ですが
バックアップが面倒などの理由からDBのレコードに保存することも
可能です。以下のようなコードでファイルをBinaryReadして
Accessの場合はメモ型かOLEオブジェクト型に代入することで
実現出来ます。(フィールド名[memo]がメモ型)

Private Function 読込(ByVal Path As String)
    Dim buff() As Byte
    Dim fileNo As Long
    If Path <> "" Then
        fileNo = FreeFile
        
        Open Path For Binary As fileNo
        ReDim buff(LOF(fileNo) - 1)
        
        Get fileNo, , buff
        Close fileNo
        
        読込 = buff
    End If
End Function

Private Function 復元(ByVal Path As String)
    Dim buff() As Byte
    Dim fileNo As Long
    Dim rst As DAO.Recordset
    If Path <> "" Then
        Set rst = Me.Recordset
        
        ReDim buff(rst.Fields("memo").FieldSize - 1)
        fileNo = FreeFile
        buff = rst.Fields("memo").Value
        
        Open Path For Binary As fileNo
        Put fileNo, , buff
        Close fileNo
        
        MsgBox "復元しました"
    End If
End Function

Private Sub btn読込_Click()
    Me.memo.Value = 読込(InputBox$("パスを指定"))
End Sub

Private Sub btn復元_Click()
    復元 InputBox$("パスを指定")
End Sub

ですがこれでは問題があります。
それはOffice2007以降にでた新形式のOpenXML形式のファイルです。
上記のようなBinaryReadするコードで「xlsx」などのファイルを
読み込んでファイルの復元を行うとファイルが破損します。

一応「修復」が可能ですがカッコ悪い…どうすればいいかなぁ。
zip→BinaryReadで保存した場合はOKなんですが…

Access2013に乗り換える意味

Accessがバージョンアップするに伴い機能が増えて来ました。
仮に現行のシステムが既にAccessでもバージョンをあげることで
開発を楽に、ユーザビリティをよく出来る面もありました。

2003→2007ではアンカー機能で幅広いディスプレイでは情報を多く表示でき
2007→2010では条件付き書式の設定数制限が青天井になり
2010→2013では…タッチ用にリボンのボタンを大きくできるくらい?でもタッチで開発なんてしない。

既存の使い方(デスクトップアプリとして)でAccess2013は
前バージョンと比べて何か違いはあるのでしょうか?
・adpが使えない
・xpに使えない(Windows 8 には2010はインストール可(サポート有))
大きなデメリットを背負っている割に2010の下位互換でしかないような…。

製品の紹介ページにはSharepointServer前提のWebServiceの新機能しか
書いてないように見えます。

なにやら挙動不審ですし…結構頻繁に落ちるかフリーズします。
・Officeのバージョン切り替え後にAccess2013起動してフリーズ
・再起動後にフォームをデザインで新規作成しようとしてフリーズ
・テンプレートから新規作成しようとして無言で落ちる

あまり悪く言いたくはありませんがテンプレートどれもほとんど同じです。
テンプレートのテンプレートがあるのではと疑いたくなります。
Access2010でも大差ないテンプレートですがオブジェクトの数が結構違います。
2010の方がフォームとかクエリとか多いです。パターンも3つほどあったと思いますが
2013は1つです。「さっきと同じテンプレート間違えて選択したかな?」と思いますよ(笑)

もうデスクトップアプリとしては成長をやめたような感じがひしひしと伝わってきます。
同じ「Access」ですが2013はSharepointの一部だという側面がかなりあります。