アクセスからエクセルファイルを全て閉じたい

アクセスからエクセルファイルを全て閉じるにはどうすればいいでしょう？（保存して閉じたいです）


エクセルファイルは名前やファイル数はランダムです。

アクセスの標準モジュールに
Sub Test1()
Dim ExcelApp As Object
Set ExcelApp = CreateObject("Excel.Application")
ExcelApp.Application.Visible = False

Set ExcelApp = Nothing
End Sub

と書きました。
このあいだにコードをいれるのですが
思いつきません。

まず数を取得して
一つ一つ保存→閉じるかな？と思い
MsgBox ExcelApp.Worksheet.Count
を入れてみましたが
エラーになりました。

オフィスのバージョンは2003です。

ご教授よろしくお願い致します。

No.2 ベストアンサー 回答者： DexMachina 回答日時： 2010/01/14 22:27

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


・・・長くなりましたが(汗)、以上です。

この回答へのお礼

有難うございます。大変参考になりました。

お礼日時：2010/01/24 15:49

No.1 回答者： marbin 回答日時： 2010/01/06 22:41

アクセスVBAではないですが、VBSでのコードです。

少し改造すればアクセスVBAに応用できます。

Dim objxl
Dim objwb
On Error Resume Next
Err.Clear
Set objxl = GetObject(,"Excel.Application")
If Err.number = 429 Then Wscript.Quit
For Each objwb In objxl.WorkBooks
'ブックが編集されていて上書き保存されていなかったら上書き保存
If objwb.Saved = False Then objwb.Save
objwb.Close
Next
If objxl.Workbooks.Count = 0 Then objxl.Quit
Set objxl = Nothing

なお、
>MsgBox ExcelApp.Worksheet.Count
ブックオブジェクトにはワークシートがありますが、エクセルアプリケーション
直下にはにはワークシートは存在しません。
エクセルアプリケーション
→ブック
→ワークシート
になります。

この回答へのお礼

難しそうですが試してみます。
ご回答ありがとうございます。

お礼日時：2010/01/09 22:55