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

# 1 の続き...

Sub ADOtest(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 DAOtest(ByRef ws As Worksheet, _
　　　　　　ByVal wkBook As String, _
　　　　　　ByVal wkSQL As String)
　　Const dbOpenDynaset As Long = 2
　　Dim wkDb As Object 'DAO.Database
　　Dim wkRs As Object 'DAO.Recordset

　　On Error GoTo conErr
　　ws.UsedRange.ClearContents
　　Set wkDb = CreateObject("DAO.DBEngine.36") _
　　　　　　　 .OpenDatabase(wkBook, False, False, "EXCEL 8.0")
　　On Error GoTo rsErr
　　Set wkRs = wkDb.OpenRecordset(wkSQL, dbOpenDynaset)
　　ws.Range("A1").CopyFromRecordset wkRs
　　wkRs.Close
rsErr:
　　wkDb.Close
conErr:
　　Set wkRs = Nothing
　　Set wkDb = Nothing
　　With Err()
　　　　If .Number <> 0 Then
　　　　　　Debug.Print .Number, .Description
　　　　End If
　　End With
End Sub
'-------------------------------------------------
Sub QRYtest(ByRef ws As Worksheet, _
　　　　　　ByVal wkBook As String, _
　　　　　　ByVal wkSQL As String)
　　Dim wkQRY As QueryTable

　　On Error Resume Next
　　ws.UsedRange.ClearContents
　　Set wkQRY = ws.QueryTables.Add( _
　　　　　　　　　 Connection:="ODBC;DSN=Excel Files;" & _
　　　　　　　　　　　　　　　 "DBQ=" & wkBook & ";", _
　　　　　　　　　 Destination:=ws.Range("A1"), _
　　　　　　　　　 Sql:=wkSQL)
　　With wkQRY
　　　　.FieldNames = False
　　　　.RefreshStyle = xlOverwriteCells
　　　　.AdjustColumnWidth = False
　　　　.Refresh BackgroundQuery:=False
　　　　ws.Names(.Name).Delete
　　　　.Delete
　　End With
　　Set wkQRY = Nothing
　　With Err()
　　　　If .Number <> 0 Then
　　　　　　Debug.Print .Number, .Description
　　　　End If
　　End With
End Sub

メモリ計測は[BUG: Memory leak occurs when you query an open Excel worksheet by using ActiveX Data Objects (ADO)]に載っているPDH.DLLを使用。
新規Book標準モジュールにコードを置いて、名前をつけて保存した後、Private Sub test_PRE()を実行。（テストデータを作成して上書き保存します）

Private Sub test_PRE()
　　Const x As Long = 2000 'データ行数
　　Const y As Long = 10　 'データ列数
　　Dim i　 As Long
　　Dim j　 As Long
　　Dim v() As String

　　ReDim v(1 To x, 1 To y)
　　With ThisWorkbook
　　　　With .Sheets.Add
　　　　　　.Name = "data"
　　　　　　With .Range("A1").Resize(x, y)
　　　　　　　　For i = 1 To x
　　　　　　　　　　For j = 1 To y
　　　　　　　　　　　　v(i, j) = .Cells(i, j).Address
　　　　　　　　　　Next
　　　　　　　　Next
　　　　　　　　.Value = v
　　　　　　End With
　　　　End With
　　　　.Sheets.Add.Name = "out"
　　　　.Sheets.Add.Name = "chk"
　　　　.Save
　　End With
End Sub

その後 Sub test() を実行。（InputBoxに文字列を入力する事でテストプロシージャを分岐）

テストは実行するごとにExcelを再起動して実行しました。
以下は結果データ。

---

【環境１】

[Windows]
XP pro 5.1.2600 SP3

[EXCEL]
2000 9.0.8968 SP3
2003 11.8316.8221 SP3
2007 12.0.6514.5000 SP2

---

【環境２】

[Windows]
VISTA ultimate 6.0 6022 SP2

[EXCEL]
2000 9.0.8968 SP3
2007 12.0.6514.5000 SP2

---