VBA操作WORD（六）另存为不含宏的文档

Sub 另存为不含宏的文档()Application.DisplayAlerts = False	Application.ScreenUpdating = FalseDim oDoc As DocumentSet oDoc = Word.ActiveDocumentDim oRng As RangeSet oRng = oDoc.ContentDim sPath As String'默认存储路径，当前用户桌面，注释掉的是当前文档路径sPath = Environ("userprofile") & "\Desktop\" 'Word.ActiveDocument.Path & "\"'处理文件名Dim strDocName As StringstrDocName =ActiveDocument.Paragraphs(1).Range.Text '包含一个回车符strDocName = Replace(strDocName, Chr(13), "") 'chr(10)'删除句末回车符，没有trim空格'采用复制内容到新文档的形式，避免将宏代码带到新文档oRng.SelectoRng.CopyDim oDocTemp As DocumentSet oDocTemp = Word.Documents.AddWith oDocTemp.Application.Selection.PasteEnd With'Dim vrtSelectedItem As VariantDim fDialog As FileDialogSet fDialog = Application.FileDialog(msoFileDialogSaveAs)With fDialog.AllowMultiSelect = False.Filters.Clear '不清空会造成多次添加.Filters.Add "Word文件", "*.doc;*.docx;*.docm", 1.InitialFileName = sPath '& strDocName 'Left(vrtSelectedItem, Len(vrtSelectedItem) - 5)'返回值-1表示按下确认按钮。如果没有判断，那么无论点击哪个按钮，均会保存文件到磁盘。If .Show = -1 Then'Set oDocTemp = Application.Documents.Save(vrtSelectedItem, ReadOnly:=True)'vrtSelectedItem为空'.Execute'execute是SaveAs对话框配套的保存命令，执行的是直接另存为操作，会把宏代码带到新文档。改为调用SaveAs2方法完成存储操作'.SelectedItems.Item(1)是对话框文件名修改后的名字。SelectedItems(1)为nulloDocTemp.SaveAs2 filename:=.SelectedItems.Item(1), FileFormat:=wdFormatDocumentDefaultoDocTemp.Close FalseEnd IfEnd WithSet fDialog = NothingApplication.ScreenUpdating = TrueApplication.DisplayAlerts = True
End Sub

上面代码需要注意地方两点，也是浪费我很多时间的地方，一是如果采用标题之类作为文件名，因为包括了回车符（换行符）导致代码一直报错，需要先删掉才能保存成功。

第二点，微软官方文档SaveAs2例子的人机交互有点不是很友好，直接用InputBox让用户输入文件名（见中间注释掉的代码）。所以考虑用dialog弹出另存的对话框，由用户选择文件类型和修改文件名（默认默认为文件内容的第一行（标题），减少手工劳动），但又有新的问题，dialog的.execute命令会直接将当前文档另存为新文档，导致VBA宏代码等也跟着到新文档，徒增文件体积。而我希望不要把宏代码带到新文档，采用声明一个新的文档对象，并且把当前文档的内容复制过去的形式，再使用了SaveAs2方法另存为新生成的文档对象。

上面的代码很好的结合了两方的优点，解决了缺点，完美！上面的处理方法是原创，反正我没看到过类似的解决方案。

中间注释掉对文件名处理部分，留给有需要的人参考。

'摘抄自微软官方文档的一个例子Dim intPos As IntegerintPos = InStrRev(strDocName, ".")'此处删除后缀名，后续另存为对话框中选择文件类型后再加上后缀名If intPos = 0 Then' 如果文档还未保存，问用户输入文件名strDocName = InputBox("请输入要保存的文件名：")Else'删除原来的后缀名并添加新的后缀名strDocName = Left(strDocName, intPos - 1)strDocName = strDocName & ".docx"End If