Excelのブックが常にファイル(またはショートカット)のダブルクリックで開かれて
いる限りは、marbinさんのコード(をVBAにしたもの)で問題ないと思いますが、
既にExcelを起動済みの状態で、
a)Windowsのスタートメニューから、新たにExcelを起動したり、
b)Access等から、CreateObject等によりExcelを起動したり、
といった場合には、Excelアプリケーションが複数立ち上がった形になるため、
一部のファイルは画面に残ることになるかと思います。
・・・と思って触り始めたのですが、エラーから抜け出せず、こんな遅くになって
しまいました(汗)
とりあえず、Subとしてまとめてみましたので、標準モジュールに以下のコードを
貼り付けて、適当な名前をつけて保存して下さい：
'～～～～～～～～～～ここから貼り付け～～～～～～～～～～
Option Compare Database
Option Explicit
'指定した時間(ミリ秒単位)だけ処理を保留するAPI関数
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Sub QuitExcels()
'エラー発生時は「エラー処理」に飛ばす
On Error GoTo エラー処理
Dim Rsl As Boolean
'ループ処理で全てのExcelを終了させる(但しエラー発生時は中断)
Do
'Excelを取得し、配下の全Bookを保存して閉じる
Rsl = CloseBooks()
'Loopで再び同じExcelを取得しないよう、完全に終了するのを待つ
If Rsl Then Sleep 100 '数値は様子をみて適宜調整して下さい
Loop While Rsl
終了処理:
Exit Sub
エラー処理:
'エラー発生時はメッセージを表示
MsgBox Err & "：" & Err.Description, , "QuitExcels"
Resume 終了処理
End Sub
Private Function CloseBooks() As Boolean
On Error GoTo エラー処理
'★こちらの関数は、概ねmarbinさんのコードをVBA化した形になっています★
' (上記a,bのパターンがないなら、これをPublicにして単独使用してもOk)
Dim Xls As Object, Wkb As Object
'Excelへの参照設定をするなら上記一行は以下の一行に差し替え
'Dim Xls As Excel.Application, Wkb As Excel.Workbook
Dim Cncl As Boolean
'Excelへの参照設定をした場合は以下は不要
Const xlMinimized As Long = -4140
'起動中のExcelアプリケーションを取得
Set Xls = GetObject(, "Excel.Application")
'新規ブックでの『ブックの保存』ダイアログの表示に備えてExcelをアクティブ化
AppActivate Xls.Caption
'「名前付きファイルについては確認なしで上書き保存、新規ファイル時のみ
'『ブックの保存』ダイアログを表示して保存」としました
For Each Wkb In Xls.Workbooks
Wkb.Close True
Next
'全ブックが閉じられたかを確認し、本関数の戻り値に反映
CloseBooks = (Xls.Workbooks.Count = 0)
'全ブックを閉じた場合はExcelを終了、そうでない場合は最小化
'(処理終了時のMsgBoxがExcelに隠れるのを回避。Excelと違ってAccess.Application
' にはCaptionプロパティがなく、上と同じAppActivateの適用は面倒なので(汗))
If CloseBooks Then Xls.Quit Else Xls.WindowState = xlMinimized
終了処理:
'メモリを解放して本関数を終了
Set Wkb = Nothing
Set Xls = Nothing
Exit Function
エラー処理:
Select Case Err
Case 429 'GetObject失敗時(→Excel未展開/全て終了済)
'メッセージは不要
Case Else '上記以外のエラー時
MsgBox Err & "：" & Err.Description, vbSystemModal, "CloseBooks"
End Select
'本関数の戻り値を「False」に設定(→呼出元でのLoop処理を終了)
CloseBooks = False
Resume 終了処理
End Function
'～～～～～～～～～～ここまで貼り付け～～～～～～～～～～
あとは、コマンドボタンなどのイベントで、以下のように使用します。
Private Sub コマンド0_Click()
On Error GoTo エラー処理
If MsgBox("すべてのExcelを閉じます。", vbOKCancel, "確認") = vbCancel Then GoTo 終了処理
Call QuitExcels
MsgBox "終了しました。", , "確認"
終了処理:
Exit Sub
エラー処理:
MsgBox Err & "：" & Err.Description, , Me.Name & " コマンド0"
Resume 終了処理
End Sub
・・・長くなりましたが(汗)、以上です。
お礼
有難うございます。大変参考になりました。