■続々）ADOのメモリリーク

そう言えばずっと気になってて検証せねばと思いつつ忘れてた。
リンクを貼って頂いてた『守破離でいこう!!』様の記事にMicrosoft.ACE.OLEDB.12.0プロバイダを使うとメモリリークしないというコメントがあったのだった。
WinXP/Excel2003の環境に、[2007 Office system ドライバ: データ接続コンポーネント]をダウンロードして試してみた。
（Office2007インストール済み環境では不要）
手順は
・新規Book作成、名前をつけて保存。
・過去記事の Private Sub test_PRE()を新規Bookにコピーして実行。
・以下コードコピーして Sub memLeaktest() 実行。
・■TESTプロシージャ 箇所で ADOtest1 と ADOtest2 をそれぞれ試行してみる。

Option Explicit
'Performance monitor functions for Visual Basic from PDH.DLL
Private Declare Function PdhVbOpenQuery _
　　　　　　　　　　　　　Lib "pdh.dll" ( _
　　　　　　　　　　　　　　　ByRef QueryHandle As Long) As Long
Private Declare Function PdhCloseQuery _
　　　　　　　　　　　　　Lib "pdh.dll" ( _
　　　　　　　　　　　　　　　ByVal QueryHandle As Long) As Long
Private Declare Function PdhVbAddCounter _
　　　　　　　　　　　　　Lib "pdh.dll" ( _
　　　　　　　　　　　　　　　ByVal QueryHandle As Long, _
　　　　　　　　　　　　　　　ByVal CounterPath As String, _
　　　　　　　　　　　　　　　ByRef CounterHandle As Long) As Long
Private Declare Function PdhRemoveCounter _
　　　　　　　　　　　　　Lib "pdh.dll" ( _
　　　　　　　　　　　　　　　ByVal CounterHandle As Long) As Long
Private Declare Function PdhCollectQueryData _
　　　　　　　　　　　　　Lib "pdh.dll" ( _
　　　　　　　　　　　　　　　ByVal QueryHandle As Long) As Long
Private Declare Function PdhVbGetDoubleCounterValue _
　　　　　　　　　　　　　Lib "pdh.dll" ( _
　　　　　　　　　　　　　　　ByVal CounterHandle As Long, _
　　　　　　　　　　　　　　　ByRef CounterStatus As Long) As Double
'-------------------------------------------------
Sub memLeaktest()
　　Const tx As Long = 30 'テスト回数
　　Const wkSQL = "SELECT * FROM [data$]"
　　Const cPath = "¥Process(Excel)¥Private Bytes"
　　Dim ws　　　As Worksheet
　　Dim rng　　 As Range
　　Dim wkBook　As String
　　Dim hPDHQry As Long　 'Handle to performance monitor query
　　Dim hPDHCnt As Long　 'Handle to performance monitor counter
　　Dim cStat　 As Long　 'Status of counter when checked
　　Dim pByts　 As Double 'Value of counter when checked
　　Dim x　　　 As Long
　　Dim i　　　 As Long
　　Dim ret(0 To tx)

　　With ThisWorkbook
　　　　Set ws = .Sheets("out")
　　　　Set rng = .Sheets("data").Range("A2")
　　　　wkBook = .FullName
　　End With
　　x = PdhVbOpenQuery(hPDHQry)
　　x = PdhVbAddCounter(hPDHQry, cPath, hPDHCnt)
　　x = PdhCollectQueryData(hPDHQry)
　　pByts = PdhVbGetDoubleCounterValue(hPDHCnt, cStat)
　　If cStat = 0 Then
　　　　ret(0) = CLng(pByts) ¥ 1024
　　End If

　　For i = 1 To tx
　　　　rng.Value = "'" & i

　　　　'■TESTプロシージャ
　　　　Call ADOtest1(ws, wkBook, wkSQL)

　　　　x = PdhCollectQueryData(hPDHQry)
　　　　pByts = PdhVbGetDoubleCounterValue(hPDHCnt, cStat)
　　　　If cStat = 0 Then
　　　　　　ret(i) = CLng(pByts) ¥ 1024
　　　　End If
　　　　'念のため更新されている事の確認用
　　　　'Debug.Print ws.Cells(1).Value
　　Next

　　x = PdhRemoveCounter(hPDHCnt)
　　x = PdhCloseQuery(hPDHQry)
　　ThisWorkbook.Sheets("chk").Range("IV2").End(xlToLeft) _
　　　　　　　　.Offset(, 1).Resize(tx + 1).Value _
　　　　　　　　= Application.Transpose(ret)

　　Set rng = Nothing
　　Set ws = Nothing
End Sub
'-------------------------------------------------
Sub ADOtest1(ByRef ws As Worksheet, _
　　　　　　ByVal wkBook As String, _
　　　　　　ByVal wkSQL As String)
　　Dim wkCon As Object 'ADODB.Connection
　　Dim wkRst As Object 'ADODB.Recordset

　　On Error GoTo conErr
　　ws.UsedRange.ClearContents
　　Set wkCon = CreateObject("ADODB.Connection")
　　With wkCon
　　　　.Provider = "Microsoft.Jet.OLEDB.4.0"
　　　　.Properties("Extended Properties") = "Excel 8.0"
　　　　.Properties("Data Source") = wkBook
　　　　.Open
　　End With
　　On Error GoTo rsErr
　　Set wkRst = CreateObject("ADODB.Recordset")
　　wkRst.Open wkSQL, wkCon
　　ws.Range("A1").CopyFromRecordset wkRst
　　wkRst.Close
rsErr:
　　wkCon.Close
conErr:
　　Set wkRst = Nothing
　　Set wkCon = Nothing
　　With Err()
　　　　If .Number <> 0 Then
　　　　　　Debug.Print .Number, .Description
　　　　End If
　　End With
End Sub
'-------------------------------------------------
Sub ADOtest2(ByRef ws As Worksheet, _
　　　　　　 ByVal wkBook As String, _
　　　　　　 ByVal wkSQL As String)
　　Dim wkCon As Object 'ADODB.Connection
　　Dim wkRst As Object 'ADODB.Recordset

　　On Error GoTo conErr
　　ws.UsedRange.ClearContents
　　Set wkCon = CreateObject("ADODB.Connection")
　　With wkCon
　　　　.Provider = "Microsoft.ACE.OLEDB.12.0"
　　　　.Properties("Extended Properties") = "Excel 12.0"
　　　　.Properties("Data Source") = wkBook
　　　　.Open
　　End With
　　On Error GoTo rsErr
　　Set wkRst = CreateObject("ADODB.Recordset")
　　wkRst.Open wkSQL, wkCon
　　ws.Range("A1").CopyFromRecordset wkRst
　　wkRst.Close
rsErr:
　　wkCon.Close
conErr:
　　Set wkRst = Nothing
　　Set wkCon = Nothing
　　With Err()
　　　　If .Number <> 0 Then
　　　　　　Debug.Print .Number, .Description
　　　　End If
　　End With
End Sub

結果です。（テスト間はExcel再起動）

確かにメモリリークは解消されてるようです。