使用 VBA 保存和关闭办公程序（word、excel、access、outlook）以进行备份

Posted 2023-02-19

技术标签:

【中文标题】使用 VBA 保存和关闭办公程序（word、excel、access、outlook）以进行备份【英文标题】：Saving and closing office programs (word, excel, access, outlook) with VBS for backups 【发布时间】：2016-10-02 20:40:25 【问题描述】：

花了相当多的时间环顾四周后，我有点难过，因为（我敢肯定）这是一个很常见的问题。

我每晚都会对我们所有的办公机器进行备份，但 Outlooks PST 文件通常会阻止此表单成功完成。我为 Outlook 找到了解决方案，但其他 MS Office 应用程序也倾向于阻止备份成功完成。

我已经知道如何保存和关闭 Outlook、Word 和 Excel。访问我有一个解决方案，但想更优雅地关闭它。

我发现了一些零散的东西，但似乎应该有一个存储库供人们找到如何关闭所有这些程序。（毕竟它们并没有那么不同，但是有足够的差异在我的齿轮上扔了一个严重的扳手）。

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.

我也看了this *** thread, but it only addresses part of the issue (not excel..)

这是保存文档和关闭 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

这是正常关闭 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

这里是关闭 Access 的工作代码——不优雅——需要改进：

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

这是我想要获取的 Excel 代码，但似乎无法突破这个代码，它一直停留在第 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

有关 Excel 的任何帮助 - 以及为什么会保留此功能：

objExcel.Application.Visible = True 或如何优雅地关闭 Access（包括在表单关闭时处理错误）将不胜感激！我希望这种主题的整合可以帮助其他人，这样他们就不必花一整天的时间来解决这个问题......

【问题讨论】：

将您的Set wkb = Nothing 和objExcel.quit 设置在end if 之外，也可以尝试将objExcel.quit 更改为objExcel.Application.Quit 看看是否有帮助 【参考方案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

【讨论】：

以上是关于使用 VBA 保存和关闭办公程序（word、excel、access、outlook）以进行备份的主要内容，如果未能解决你的问题，请参考以下文章

办公室软件word和excel

为啥每次使用 VBA 保存 word 文档时文件大小都会增加？

[使用vba代码的ms Word文档文本翻译

使用 VBA 将 Word Doc 保存为 2003 XML

Python中办公软件（读取word文件和读出保存别文件）

使用 Excel VBA 创建 Word 应用程序：运行时错误“429”：ActiveX 组件无法创建对象