IE操作中にオブジェクトのメモリが異常に膨れる場合の対応
Excel VBAで繰り返しIEを操作していると、IEオブジェクトの使っているメモリ領域が異常に膨れることがある。 それも、どういうわけか特定のサイトを操作している時に限ってだ。 原因は不明だが、この状況に陥るとExcelが固まってしまい、タスクマネージャーから強制終了するしかなくなる。
とりあえずの対策として、ブラウザの操作回数をカウントして一定の回数に達したら一度ブラウザを再起動して続きを行うようにしていた。 ずっとそれで対応してきたが、やはり無駄な再起動は控えたいので、プロセスが確保しているメモリ量を取得して、これが一定のサイズに達したら再起動するような方法に変えることにした。
WMIを使ってプロセス情報を取得する。 WMIで取得できる値を確認するため、試しに以下コードを実行してみた。 IEを操作しているので、IEのプロセス情報だけ表示するようにした。
Sub test()
Dim WMI As Object
Set WMI = CreateObject("WbemScripting.SWbemLocator")
Dim oService As Object
Set oService = WMI.ConnectServer
Dim oClassSet As Object
Set oClassSet = oService.ExecQuery("SELECT * FROM Win32_Process")
Dim oClass As Object
DEV_MODE = True
For Each oClass In oClassSet
If oClass.Caption = "iexplore.exe" Then
Debug.Print "Caption：" & oClass.Caption
Debug.Print "CommandLine：" & oClass.commandLine
Debug.Print "Handle：" & oClass.Handle
Debug.Print "PageFaults：" & oClass.PageFaults
Debug.Print "PageFileUsage：" & oClass.PageFileUsage
Debug.Print "PeakPageFileUsage：" & oClass.PeakPageFileUsage
Debug.Print "PrivatePageCount：" & oClass.PrivatePageCount
Debug.Print "ProcessId：" & oClass.ProcessID
Debug.Print "WorkingSetSize：" & oClass.WorkingSetSize
Debug.Print ""
End If
Next
Set oClass = Nothing
Set oClassSet = Nothing
Set oService = Nothing
Set WMI = Nothing
End Sub
実行結果は以下。
Caption：iexplore.exe
CommandLine："C:\Program Files\Internet Explorer\iexplore.exe"
Handle：4908
PageFaults：14549
PageFileUsage：9172
PeakPageFileUsage：11008
PrivatePageCount：9392128
ProcessId：4908
WorkingSetSize：38666240
Caption：iexplore.exe
CommandLine："C:\Program Files (x86)\Internet Explorer\IEXPLORE.EXE" SCODEF:4908 CREDAT:17410 /prefetch:2
Handle：9112
PageFaults：177431
PageFileUsage：95496
PeakPageFileUsage：100440
PrivatePageCount：97787904
ProcessId：9112
WorkingSetSize：133042176この時のタスクマネージャーの表示は以下。
プログラムの出力結果のWorkingSetSizeと、タスクマネージャーのワーキングセット（メモリ）が近い値（ 133042176 ÷ 1024 = 129,924 ）なので、同じ意味と思われる。
上の結果を参考に、IEプロセスの使用メモリを合計してその値を戻す関数を作った。
Function getIEMemSize() as Long
On Error GoTo ErrorHandler
Dim WMI As New WbemScripting.SWbemLocator
Dim oService As Object, oClassSet As Object, oClass As Object
Set oService = WMI.ConnectServer
Set oClassSet = oService.ExecQuery("SELECT * FROM Win32_Process")
Dim ieMemSize: ieMemSize = 0
For Each oClass In oClassSet
If oClass.caption = "iexplore.exe" Then
ieMemSize = ieMemSize + oClass.WorkingSetSize
End If
Next
Set oClass = Nothing
Set oClassSet = Nothing
Set oService = Nothing
Set WMI = Nothing
getIEMemSize = cLng(ieMemSize / 1024 / 1024)
Exit Function
ErrorHandler:
debugPrintFile "getIEMemSize error! Err.Number=[" & err.Number & "], Err.Description=[" & err.description & "]"
getIEMemSize = -1
End Function
あとは、ブラウザ操作側でこの関数を呼び出して、一定の値を超えていればIEプロセスをkillすればよい。 以下のようなプロセスをkillする関数を作って、引数に “iexplore.exe” を渡すようにコールする。
Sub pkill(strProcName As String)
On Error Resume Next
Dim objProcList ' プロセス一覧
Dim objProcess ' プロセス情報
Dim lngKillNum ' 終了したプロセス数
lngKillNum = 0
Set objProcList = GetObject("winmgmts:").InstancesOf("win32_process")
For Each objProcess In objProcList
If LCase(objProcess.Name) = strProcName Then
objProcess.Terminate
If err.Number = 0 Then
lngKillNum = lngKillNum + 1
Else
Debug.Print "エラー: " & err.description
End If
End If
Next
If lngKillNum > 0 Then
Debug.Print strProcName & " を " & lngKillNum & " 個強制終了しました。"
Else
Debug.Print strProcName & " が見つかりませんでした。"
End If
Set objProcList = Nothing
End Sub
参考ページ
https://excel-ubara.com/excelvba4/EXCEL_VBA_438.html