檢查 Word 文檔是否已打開 + 錯誤處理

Question

您好，感謝您提前回答。

我正在使用 excel-vba 打開一個 word 文檔並將其保存在一個新名稱下。 這實際上工作正常。

但是如果新名稱的word文檔已經打開就會出現問題！

假設有一個按鈕來運行腳本，用戶第二次運行它，並且創建的文件仍然打開。 用戶可能會在 excel 中更改某些內容，現在想要檢查新的 Word 文檔看起來像后記。 他將再次單擊該按鈕。 它將打開模板（執行所有更改）並嘗試保存它，但不能，因為它已經打開並且它可能會使用舊名稱（模板）而不是新文件保存此文檔。 因此它會覆蓋和破壞模板文件（在測試過程中多次出現）！

因此我需要一些合適的代碼和更好的錯誤處理。 我的第一個想法是檢查具有文件名的文檔是否已經存在。 但它並沒有完全完成它的工作：

Sub CreateWordDocument()
    Dim TemplName, CurrentLocation, DocumentName, Document As String
    Dim WordDoc, WordApp, OutApp As Object

    With table1
        TemplName = table1.Range("A1").Value 'Get selected template name
        CurrentLocation = Application.ActiveWorkbook.Path 'working folder
        Template = CurrentLocation + "\" + TemplName
        DocumentName = .Range("A2").Value
        Document = CurrentLocation + "\" + DocumentName + ".docx"

    'Open Word Template
    On Error Resume Next 'if Word is already running
    Set WordApp = GetObject("Word.Application")
    If Err.Number <> 0 Then
        'Launch a new instance of Word
        Err.Clear
        Set WordApp = CreateObject("Word.Application")
        WordApp.Visible = True 'Make the application visible to the user
    End If

    'if document is already opened in word than close it
    'if its not possible to close it - end application to prevent any damage to the template
    On Error GoTo notOpen
        Set WordDoc = WordApp.Documents(DocumentName + ".docx")
    On Error GoTo closeError
        WordDoc.Close
    notOpen:
        'Open the template
        Set WordDoc = WordApp.Documents.Open(Filename:=Template, ReadOnly:=False) 'Open Template
    'save with new name
    WordDoc.SaveAs Document
    closeError: 
    'open a message box and tell user to close and run again.

在當前階段，它只是從“Set WordDoc = WordApp. ...”跳轉到 notOpened。 任何建議如何解決這個問題？

Answer 1

添加此功能：

Public Function FileIsOpen(FullFilePath As String) As Boolean

    Dim ff As Long

    On Error Resume Next

    ff = FreeFile()
    Open FullFilePath For Input Lock Read As #ff
    Close ff
    FileIsOpen = (Err.Number <> 0)

    On Error GoTo 0

End Function 

然后在您的代碼中使用：

If Not FileIsOpen(DocumentName & ".docx") Then
    Set WordDoc = WordApp.Documents.Open(Filename:=Template, ReadOnly:=False)
Else
    'Do something else because the file is already open.
End If

文檔名稱必須是文檔的完整路徑。

---

其他幾件事：

只有Document是字符串，而OutApp是對象。 所有其他變量均為Variants 。

Dim TemplName, CurrentLocation, DocumentName, Document As String  
Dim WordDoc, WordApp, OutApp As Object

它應該是：

Dim TemplName As String, CurrentLocation As String, DocumentName As String, Document As String
Dim WordDoc As Object, WordApp As Object, OutApp As Object 

---

VBA通常使用+進行加法，使用&進行串聯。

DocumentName + ".docx"  

最好寫成

DocumentName & ".docx"  

---

文檔是Word的保留字。 它不會在代碼中引起太多問題，因為代碼在Excel ，但是要記住一點。

Answer 2

聽起來您需要一種方法來測試Word窗口是否存在。

這是一些應該幫助的代碼。 在嘗試從Excel運行此代碼之前，請確保添加對Microsoft Word Object Library （任何版本）的引用。

Option Explicit

Private Function WordWindowExists(WindowName As String) As Boolean
    WordWindowExists = False
    Dim WordApp     As Word.Application: Set WordApp = GetObject(, "Word.Application")

    If WordApp Is Nothing Then Exit Function

    Dim Windows     As Word.Windows: Set Windows = WordApp.Windows
    Dim Window      As Word.Window

    For Each Window In Windows
        If WindowName = Window.Document.Name Then
            WordWindowExists = True
            Exit Function
        End If
    Next

End Function

Sub FindWindow()
    If WordWindowExists("Document1") Then
        'Do Action when window exists
    Else
        'Do Action when window does not exist
    End If
End Sub