从Excel打开Word文档并将其保存到新文件位置

Question

我正在尝试从excel打开word文档，然后使用对话框将其另存为新文件位置。

问题在于它保存的是excel文件，而不是已打开的Word文件。

Option Explicit
Sub SaveWordDoc()
    Dim WordApp As Object, WordDoc As Object, path As String
    Dim dlgSaveAs As FileDialog

    ' Allows word document to be selected and opened
    With Application.FileDialog(msoFileDialogOpen)
    .Show
    If .SelectedItems.Count = 1 Then
        path = .SelectedItems(1)
    End If
    End With

    If path = "" Then
        Exit Sub
    End If


    Set WordApp = CreateObject("Word.Application")
    Set WordDoc = WordApp.Documents.Open(path)
    WordApp.Visible = False

    'Opens Save As dialog box
    Set dlgSaveAs = Application.FileDialog( _
    FileDialogType:=msoFileDialogSaveAs)
    dlgSaveAs.Show

    WordApp.ActiveDocument.Close
    WordApp.Quit
    Set WordApp = Nothing
    Set WordDoc = Nothing
End Sub

Answer 1

谢谢BigBen，只要选择了Word文档格式，您的建议就可以很好地发挥作用。

Option Explicit
Sub Test()
    Dim WordApp As Object, WordDoc As Object, path As String
    Dim dlgSaveAs As FileDialog, fileSaveName As Variant

    ' To get the code to function I had to include the Microsoft Word 16 Object
    'Library.

    'From the excel VBA editor window. Tools > References then ensure Microsoft Word
    '16.0 Object Library is checked.

    ' Allows word document to be selected and opened
    With Application.FileDialog(msoFileDialogOpen)
    .Show
    If .SelectedItems.Count = 1 Then
        path = .SelectedItems(1)
    End If
    End With

    If path = "" Then
        Exit Sub
    End If


    Set WordApp = CreateObject("Word.Application")
    Set WordDoc = WordApp.Documents.Open(path)
    WordApp.Visible = False

    ' Allows word document to be saved under a different file location and name
    fileSaveName = Application.GetSaveAsFilename( _
    fileFilter:="Word Documents (*.docx), *.docx")
    WordApp.ActiveDocument.SaveAs2 Filename:=fileSaveName, _
        FileFormat:=wdFormatDocumentDefault

    WordApp.ActiveDocument.Close
    WordApp.Quit

    Set WordApp = Nothing
    Set WordDoc = Nothing
End Sub