処理が長くなるFor文で、Excelが固まらないよう、途中で定期的にDoEventsをさせてるのですが、
稀に、DoEventsが暴走し、説明しにくいのですが無限ループ的になってしまいます。
もしどなたか知見をお持ちでしたら、
ご教授頂けますと幸いです。
同じ状況を経験した、という方がいらっしゃれば、
ご連絡頂ければ何か糸口が見つかるかもしれません。
下記がDoEvents用のモジュールで、
For分の途中で「fDoEvents」をCallしており、
「★」の箇所で再帰的に関数が呼ばれるようになってしまいます。。。
処理としては、あるフォルダの容量を知る為に、
フォルダ内のファイルを全て検索し、
各ファイル容量を基にフォルダ容量を計算する、
という処理のファイル検索の途中でfDoEventsを呼び出しています。
どうぞ宜しくお願い致します。
VBA
1Declare Function GetInputState Lib "user32" () As Long 2Private DoTime As Double 3Public Function fDoEvents() 4 5 If GetInputState Then 6 Call prDoEvent 7 Exit Function 8 End If 9 10 '一定時間(1秒)たっていたらDoEvents 11 If Abs(Timer - DoTime) > 1 Then 12 Call prDoEvent 13 Exit Function 14 End If 15 16End Function 17 18Private Function prDoEvent() 19 20 '一定間隔処理用に処理時点の時間を保持 21 DoTime = Timer 22 23 '実行 24 DoEvents '★稀に、DoEvents実行直後に「prDoEvent」が呼ばれ、再帰的に呼ばれ続けてしまう 25 26End Function 27
ファイル検索用の関数を追記いたします(1/30)
VBA
1Public Function fFile_Path_in_Folder(Path_Folder As String, _ 2 Optional Extention As String = "*", _ 3 Optional FileAttribute As VbFileAttribute = vbNormal) As Variant 4 5 6 '- 指定フォルダが無かった場合、終了 7 If FSO.FolderExists(Path_Folder) = False Then Exit Function 8 9 'フォルダパスを格納 10 Dim Path_FD As String 11 Path_FD = Path_Folder 12 If Right$(Path_FD, 1) <> Application.PathSeparator Then 13 Path_FD = Path_FD & Application.PathSeparator 14 End If 15 16 Dim Dic As Scripting.Dictionary 17 Set Dic = New Scripting.Dictionary 18 19 '最初のファイルパスを取得 20 'Dir関数に検索パスを設定 21 Dim FileName As String 22 FileName = Dir(Path_FD & "*" & "." & Extention, FileAttribute) 23 24 Do While FileName <> "" 25 26 Call fDoEvents 27 28 Dim Path_File As String 29 Path_File = Path_FD & FileName 30 31 'ファイルパスを辞書に登録 32 If Directory_IsFolder(Path_File) = False Then 33 Dic.Item(FileName) = Path_File 34 End If 35 36 '次のファイルパスを取得 37 FileName = Dir() 38 39 Loop 40 41 'ファイルロックの開放(念のため) 42 Call Dir(vbNullString) 43 44 If Dic.Count = 0 Then Exit Function 45 46 '- 戻り値 47 fFile_Path_in_Folder = Dic.Items 48 49 Set Dic = Nothing 50 51End Function