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

■ADOのメモリリーク の続編。
前回、開いているBookに対してADO、DAO、QueryTable を用いてデータを読み込んだ時、全ての手法でメモリリークが発生する...ような結論になっていました。
今回追加検証をやってみたら、どうも改善されているようです。

結果を先にまとめると。
『Excel2003sp3以降、QueryTableを使った読み込みではメモリリーク問題は解消されているようである』
『OS:WindowsVistaでは、ADO、DAOに関してもメモリリーク問題は解消されているようである』

テストコード内容。

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 test()
　　Dim x As String

　　x = InputBox("ado or dao or qry")
　　If Len(x) = 0 Then Exit Sub
　　Call memLeaktest(x)
End Sub
'-------------------------------------------------
Sub memLeaktest(prc As String)
　　Const tx As Long = 20　　'テスト回数
　　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 + 1)

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

　　For i = 1 To tx
　　　　rng.Value = "'" & i
　　　　'■TESTプロシージャ
　　　　Select Case prc
　　　　Case "ado"
　　　　　　Call ADOtest(ws, wkBook, wkSQL)
　　　　Case "dao"
　　　　　　Call DAOtest(ws, wkBook, wkSQL)
　　　　Case "qry"
　　　　　　Call QRYtest(ws, wkBook, wkSQL)
　　　　End Select
　　　　x = PdhCollectQueryData(hPDHQry)
　　　　pByts = PdhVbGetDoubleCounterValue(hPDHCnt, cStat)
　　　　If cStat = 0 Then
　　　　　　ret(i + 1) = CLng(pByts) ¥ 1024
　　　　End If
　　　　Debug.Print ws.Cells(1).Value
　　Next

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

　　Set rng = Nothing
　　Set ws = Nothing
End Sub

# 2 へ続く