问题
After spending a fair amount of time looking around, I'm coming up a little stumped, as this is (I'm sure) a pretty common problem.
I run nightly backups of all our office machines, but Outlooks PST files often prevents this form successful completion. I found the solution to this for outlook, but other MS Office apps tend to block backups from successful completion as well.
I've figured out how to save and close Outlook, Word, and Excel. Access I have a solution for, but would like to close that a little more gracefully.
I've found bit's and pieces scattered about, but it seems like there should be one repository for people to find how to close all these programs. (they're not all that different after all, but there are enough differences to have thrown a serious wrench in my gears).
This was one of the most helpful articles I found. The code did not work for me, but I liked the simplistic structure and after a few tweaks I got it working.
I also looked at this StackOverflow thread, but it only addresses part of the issue (not excel..)
Here is the working code to save a document and close Word:
Dim objWord
Dim doc
On Error Resume Next
Set objWord = GetObject(, "Word.Application")
If objWord Is Nothing Then
'No need to do anything, Word is not running
Else
'Open your document and ensure its visible and activate after openning
objWord.Visible = True
objWord.Activate
Set oWS = WScript.CreateObject("WScript.Shell")
' Get the %userprofile% in a variable, or else it won't be recognized
userProfile = oWS.ExpandEnvironmentStrings( "%userprofile%" )
Dim objNetwork
Dim userName
Dim FSO
Dim Folder
Set FSO = CreateObject("Scripting.FileSystemObject")
Set objNetwork = CreateObject("WScript.Network")
userName = objNetwork.userName
If NOT (FSO.FolderExists(userProfile + "\Desktop\Docs-You-Left-Open")) Then
FSO.CreateFolder(userProfile + "\Desktop\Docs-You-Left-Open")
End If
Do while objWord.Documents.Count <> 0
For Each doc in objWord.Documents
doc.SaveAs(userProfile + "\Desktop\Docs-You-Left-Open\" & doc.Name)
doc.Close
Next
Loop
Set doc = Nothing
objWord.quit
End If
Set objWord = Nothing
Here is the working code to gracefully close Outlook:
Dim objOutlook 'As Outlook.Application
Dim olkIns
Set objOutlook = CreateObject("Outlook.Application")
If objOutlook Is Nothing Then
'no need to do anything, Outlook is not running
Else
'Outlook running
Do while objOutlook.Inspectors.Count <> 0
For each olkIns in objOutlook.Inspectors
olkIns.Close olSave
Next
Loop
objOutlook.Session.Logoff
objOutlook.Quit
End If
Set objOutlook = Nothing
Here is the working code to close Access -- Not gracefully -- needs improvment:
strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colProcessList = objWMIService.ExecQuery _
("Select * from Win32_Process Where Name = 'MSACCESS.EXE'")
Set oShell = CreateObject("WScript.Shell")
For Each objProcess in colProcessList
oShell.Run "taskkill /im MSACCESS.EXE", , True
Next
And this is the Excel code that I'm trying to get, but can't seem to break through this one, where it keeps sticking on line 16 objExcel.Application.Visible = True:
Dim objExcel
Dim wkb
On Error Resume Next
Set objExcel = GetObject(, "Excel.Application")
If Err.Number <> 0 Then ExcelWasNotRunning = True
Err.Clear ' Clear Err object in case error occurred.
If ExcelWasNotRunning = True Then
objExcel.Application.Quit
Else
'Open your document and ensure its visible and activate after openning
objExcel.Application.Visible = True
objExcel.Activate
Set oWS = WScript.CreateObject("WScript.Shell")
' Get the %userprofile% in a variable, or else it won't be recognized
userProfile = oWS.ExpandEnvironmentStrings( "%userprofile%" )
Dim objNetwork
Dim userName
Dim FSO
Dim Folder
Set FSO = CreateObject("Scripting.FileSystemObject")
Set objNetwork = CreateObject("WScript.Network")
userName = objNetwork.userName
If NOT (FSO.FolderExists(userProfile + "\Desktop\Docs-You-Left-Open")) Then
FSO.CreateFolder(userProfile + "\Desktop\Docs-You-Left-Open")
End If
Do while objExcel.Workbooks.Count <> 0
For Each wkb in objExcel.Workbooks
wkb.SaveAs(userProfile + "\Desktop\Docs-You-Left-Open\" & wkb.Name)
wkb.Close
Next
Loop
Set wkb = Nothing
objExcel.quit
End If
Set objExcel = Nothing
Any help on the Excel -- and why this would be hanging on:
objExcel.Application.Visible = True or how to go about closing Access gracefully (including handling errors at form closure) would be very much appreciated! And I hope this consolidation of topics helps others, so they don't have to spend an entire day trying to wrap their head around this...
回答1:
OPTION EXPLICIT
DIM strComputer,strProcess, objShell, FSO, userName, objExcel, objWorksheet, objWorkbook, Workbooks, oShell, RunTaskKill, objExcel1, objWorkbook1
SET objShell = CreateObject("Wscript.Shell")
strComputer = objShell.ExpandEnvironmentStrings( "%COMPUTERNAME%" )
strProcess = "excel.exe"
' Function to check if a process is running
FUNCTION isProcessRunning(BYVAL strComputer,BYVAL strProcessName)
DIM objWMIService, strWMIQuery
strWMIQuery = "Select * from Win32_Process where name like '" & strProcessName & "'"
SET objWMIService = GETOBJECT("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" _
& strComputer & "\root\cimv2")
IF objWMIService.ExecQuery(strWMIQuery).Count > 0 THEN
isProcessRunning = TRUE
ELSE
isProcessRunning = FALSE
END IF
END FUNCTION
IF isProcessRunning(strComputer,strProcess) THEN
Set objShell= CreateObject("WScript.Network")
userName = objShell.UserName
Set FSO = CreateObject("Scripting.FileSystemObject")
IF FSO.FolderExists("c:\users\" & userName & "\Desktop\Docs-You-Left-Open") Then
wscript.echo "folder already exists"
wscript.sleep 500
ELSE
FSO.CreateFolder("c:\users\" & userName & "\Desktop\Docs-You-Left-Open")
wscript.sleep 500
END IF
wscript.sleep 1000
Set objExcel = GetObject(, "Excel.Application")
Set objExcel1 = CreateObject("Excel.Application")
objExcel.Application.Visible = True
objExcel1.Application.Visible = True
objExcel.AutoRecover.Enabled = False
objExcel1.AutoRecover.Enabled = False
Set objWorkbook = objExcel.Workbooks
Set objWorkbook1 = objExcel.Workbooks
Set objExcel1 = objExcel
Set objWorkbook1 = objWorkbook
Do while objExcel1.Workbooks.Count <> 0
For Each Workbooks in objExcel1.Workbooks
Workbooks.SaveAs("c:\users\" & userName & "\Desktop\Docs-You-Left-Open\" & Workbooks.Name & Timer() & ".xlsx")
Workbooks.Close
wscript.sleep 100
Next
Loop
wscript.sleep 1000
Set oShell = CreateObject ("WScript.Shell")
oShell.run "taskkill /f /im excel.exe",0,true
Set oShell = Nothing
wscript.quit
ELSE
wscript.echo strProcess & " is NOT running on computer '" & strComputer & "'"
END IF
wscript.quit
来源：https://stackoverflow.com/questions/37603219/saving-and-closing-office-programs-word-excel-access-outlook-with-vbs-for-b