■ADOのメモリリーク

開いているExcelBookに対してActiveX Data Objectsを使って読み込みすると、メモリリークが発生する、という話があります。ADOでExcelにアクセスというのがあまりないケースかもしれませんが、一応書いてみました。
[BUG: Memory leak occurs when you query an open Excel worksheet by using ActiveX Data Objects (ADO)]
評判悪い機械翻訳版は こちら 。

まず、テストシート作成です。読み込み元の"data"シート、書込み先の"out"シート、メモリチェック結果を書き出す"chk"シートを作成するコード。

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

　　With Sheets.Add
　　　　.Name = "data"
　　　　With .Range("A1")
　　　　　　.Value = "Field1"
　　　　　　.AutoFill .Resize(, y)
　　　　End With
　　　　ReDim v(1 To x, 1 To y)
　　　　With .Range("A2").Resize(x, y)
　　　　　　For i = 1 To x
　　　　　　　　For j = 1 To y
　　　　　　　　　　v(i, j) = .Cells(i, j).Address(0, 0)
　　　　　　　　Next
　　　　　　Next
　　　　　　.Value = v
　　　　End With
　　End With
　　With Sheets.Add
　　　　.Name = "chk"
　　　　.Range("A1:C1").Value = [{"start","end","leak"}]
　　End With
　　Sheets.Add.Name = "out"
　　ThisWorkbook.Save
End Sub

以下はテストコード。
メモリ使用量のチェックについてはmssupport記事に載っているPDH APIを使いましたが、今回は簡易的に[MemoryUsed プロパティ]にしました。

Option Explicit

Private Sub MEMTEST()
　　Const tx　 As Long = 5 'テスト回数
　　Dim ws　　 As Worksheet
　　Dim wkBook As String
　　Dim wkSQL　As String
　　Dim ret(1 To tx, 1 To 3) As Long
　　Dim i As Long

　　Set ws = Sheets("out")
　　wkBook = ThisWorkbook.FullName
　　wkSQL = "SELECT * FROM [data$]"

　　For i = 1 To tx
　　　　ret(i, 1) = Application.MemoryUsed
　　　　'■TESTプロシージャ
　　　　Call ADOtest(ws, wkBook, wkSQL)
　　　　ret(i, 2) = Application.MemoryUsed
　　　　ret(i, 3) = ret(i, 2) - ret(i, 1)
　　Next

　　Sheets("chk").Range("A65536").End(xlUp).Offset(1).Resize(tx, 3).Value = ret
　　Set ws = Nothing
End Sub
'-------------------------------------------------
'参照設定：Microsoft ActiveX Data Objects 2.x Library
Private Sub ADOtest(ByRef ws As Worksheet, _
　　　　　　　　　　ByVal wkBook As String, _
　　　　　　　　　　ByVal wkSQL As String)
　　Dim wkCon As ADODB.Connection
　　Dim wkRst As ADODB.Recordset

　　On Error GoTo errHandr1
　　ws.UsedRange.ClearContents
　　Set wkCon = New 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 errHandr2
　　Set wkRst = New ADODB.Recordset
　　wkRst.Open wkSQL, wkCon
　　ws.Range("A1").CopyFromRecordset wkRst
　　wkRst.Close
errHandr2:
　　wkCon.Close
errHandr1:
　　Set wkRst = Nothing
　　Set wkCon = Nothing
　　If Err.Number <> 0 Then Debug.Print Err.Number, Err.Description
End Sub
'-------------------------------------------------
'参照設定：Microsoft DAO 3.6 Object Library

Private Sub DAOtest(ByRef ws As Worksheet, _
　　　　　　　　　　ByVal wkBook As String, _
　　　　　　　　　　ByVal wkSQL As String)
　　Dim wkDb As DAO.Database
　　Dim wkRs As DAO.Recordset

　　On Error GoTo errHandr1
　　ws.UsedRange.ClearContents
　　Set wkDb = OpenDatabase(wkBook, False, False, "EXCEL 8.0")
　　On Error GoTo errHandr2
　　Set wkRs = wkDb.OpenRecordset(wkSQL, dbOpenDynaset)
　　ws.Range("A1").CopyFromRecordset wkRs
　　wkRs.Close
errHandr2:
　　wkDb.Close
errHandr1:
　　Set wkRs = Nothing
　　Set wkDb = Nothing
　　If Err.Number <> 0 Then Debug.Print Err.Number, Err.Description
End Sub
'-------------------------------------------------
Private 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
　　If Err.Number <> 0 Then Debug.Print Err.Number, Err.Description
End Sub

結果は以下。
リーク量はデータ量に比例するようです。大量のデータを繰り返し過ぎると、Excel君、帰って来ません。
いずれにしても、あまり多用しない手法だとは思いますが。



ご覧のように、[Data Access Object]や[QueryTable]でも同様です。
（環境）

#（2010.02.09 追記）
#続編あり:D