另存为 | ExcelOffice【微信公众号：水星Excel】

如果要将03版本的word转换为最新的word版本，可以使用Document对象的SaveAs2方法。

代码如下：

Dim oWord As Object
Dim oDic As Object
Const wdExportFormatPDF = 17
Sub QQ1722187970()
   Set oWord = VBA.CreateObject("word.application")
    Dim sPath As String
    '获取文件或者文件夹的路径
    sPath = GetPath()
    If Len(sPath) Then
        EnuAllFiles (sPath)
        MsgBox "处理完成!!!"
    End If
    oWord.Quit
    Set oWord = Nothing
End Sub
Function GetPath() As String
    '声明一个FileDialog对象变量
    Dim oFD As FileDialog
'    '创建一个选择文件对话框
'    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    '创建一个选择文件夹对话框
    Set oFD = Application.FileDialog(msoFileDialogFolderPicker)
    '声明一个变量用来存储选择的文件名
    Dim vrtSelectedItem As Variant
    With oFD
        '允许选择多个文件
        .AllowMultiSelect = True
        '使用Show方法显示对话框，如果单击了确定按钮则返回-1。
        If .Show = -1 Then
            '遍历所有选择的文件
            For Each vrtSelectedItem In .SelectedItems
                '获取所有选择的文件的完整路径,用于各种操作
                GetPath = vrtSelectedItem
            Next
            '如果单击了取消按钮则返回0
        Else
        End If
    End With
    '释放对象变量
    Set oFD = Nothing
End Function
Function GetFileName(ByVal sName As String)
    '获取纯文件名的自定义函数
    'QQ1722187970
    Dim sTemp As String
    sTemp = sName
    '判断后缀名分隔符.的位置
    iPos = Len(sTemp) - VBA.InStr(1, VBA.StrReverse(sTemp), ".")
    If iPos <> 0 Then
        sTemp = Mid(sTemp, 1, iPos)
    End If
    '判断路径分隔符\的位置
    iPos = VBA.InStr(1, sTemp, "\")
    If iPos <> 0 Then
        '反转后好取字符
        iPos = VBA.InStr(1, VBA.StrReverse(sTemp), "\")
        sTemp = Mid(VBA.StrReverse(sTemp), 1, iPos - 1)
        sTemp = VBA.StrReverse(sTemp)
    End If
    GetFileName = sTemp
End Function

Sub EnuAllFiles(ByVal sPath As String, Optional bEnuSub As Boolean = False)
    '定义文件系统对象
    Dim oFso As Object
    Set oFso = CreateObject("Scripting.FileSystemObject")
    '定义文件夹对象
    Dim oFolder As Object
    Set oFolder = oFso.GetFolder(sPath)
    '定义文件对象
    Dim oFile As Object
    '如果指定的文件夹含有文件
    If oFolder.Files.Count Then
        For Each oFile In oFolder.Files
            With oFile
                '输出文件所在的盘符
                Dim sDrive As String
                sDrive = .Drive
                '输出文件的类型
                Dim sType As String
                sType = .Type
                '输出含后缀名的文件名称
                Dim sName As String
                sName = .Name
                '输出含文件名的完整路径
                Dim sFilePath As String
                sFilePath = .Path
                '如果文件是Word文件且不是隐藏文件
                If sType Like "*ord*2003*" And Not (sName Like "*~$*") Then
                    Const wdFormatDocumentDefault = 16
                    Const wdFormatXMLDocument = 12
                    Const wdWord2013 = 15
                    Set oDoc = oWord.documents.Open(sFilePath)
                    With oDoc
                        Dim sFPath As String
                        sFPath = .Path
                        sName = .Name
                        sName = GetFileName(sName)
                        sName = sFPath & "\" & sName & ".docx"
                        .SaveAs2 Filename:=sName, FileFormat:=wdFormatDocumentDefault, CompatibilityMode:=wdWord2013
                        .Close
                    End With
                End If
            End With
        Next
    '如果指定的文件夹不含有文件
    Else
    End If
    '如果要遍历子文件夹
    If bEnuSub = True Then
        '定义子文件夹集合对象
        Dim oSubFolders As Object
        Set oSubFolders = oFolder.SubFolders
        If oSubFolders.Count > 0 Then
            For Each oTempFolder In oSubFolders
                sTempPath = oTempFolder.Path
                Call EnuAllFiles(sTempPath, True)
            Next
        End If
        Set oSubFolders = Nothing
    End If
    Set oFile = Nothing
    Set oFolder = Nothing
    Set oFso = Nothing
End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

Dim oWord As Object

Dim oDic As Object

Const wdExportFormatPDF = 17

Sub QQ1722187970()

Set oWord = VBA.CreateObject("word.application")

Dim sPath As String

'获取文件或者文件夹的路径

sPath = GetPath()

If Len(sPath) Then

EnuAllFiles (sPath)

MsgBox "处理完成!!!"

End If

oWord.Quit

Set oWord = Nothing

End Sub

Function GetPath() As String

'声明一个FileDialog对象变量

Dim oFD As FileDialog

' '创建一个选择文件对话框

' Set oFD = Application.FileDialog(msoFileDialogFilePicker)

'创建一个选择文件夹对话框

Set oFD = Application.FileDialog(msoFileDialogFolderPicker)

'声明一个变量用来存储选择的文件名

Dim vrtSelectedItem As Variant

With oFD

'允许选择多个文件

.AllowMultiSelect = True

'使用Show方法显示对话框，如果单击了确定按钮则返回-1。

If .Show = -1 Then

'遍历所有选择的文件

For Each vrtSelectedItem In .SelectedItems

'获取所有选择的文件的完整路径,用于各种操作

GetPath = vrtSelectedItem

'如果单击了取消按钮则返回0

Else

End If

End With

'释放对象变量

Set oFD = Nothing

End Function

Function GetFileName(ByVal sName As String)

'获取纯文件名的自定义函数

'QQ1722187970

Dim sTemp As String

sTemp = sName

'判断后缀名分隔符.的位置

iPos = Len(sTemp) - VBA.InStr(1, VBA.StrReverse(sTemp), ".")

If iPos <> 0 Then

sTemp = Mid(sTemp, 1, iPos)

End If

'判断路径分隔符\的位置

iPos = VBA.InStr(1, sTemp, "\")

If iPos <> 0 Then

'反转后好取字符

iPos = VBA.InStr(1, VBA.StrReverse(sTemp), "\")

sTemp = Mid(VBA.StrReverse(sTemp), 1, iPos - 1)

sTemp = VBA.StrReverse(sTemp)

End If

GetFileName = sTemp

End Function

Sub EnuAllFiles(ByVal sPath As String, Optional bEnuSub As Boolean = False)

'定义文件系统对象

Dim oFso As Object

Set oFso = CreateObject("Scripting.FileSystemObject")

'定义文件夹对象

Dim oFolder As Object

Set oFolder = oFso.GetFolder(sPath)

'定义文件对象

Dim oFile As Object

'如果指定的文件夹含有文件

If oFolder.Files.Count Then

For Each oFile In oFolder.Files

With oFile

'输出文件所在的盘符

Dim sDrive As String

sDrive = .Drive

'输出文件的类型

Dim sType As String

sType = .Type

'输出含后缀名的文件名称

Dim sName As String

sName = .Name

'输出含文件名的完整路径

Dim sFilePath As String

sFilePath = .Path

'如果文件是Word文件且不是隐藏文件

If sType Like "*ord*2003*" And Not (sName Like "*~$*") Then

Const wdFormatDocumentDefault = 16

Const wdFormatXMLDocument = 12

Const wdWord2013 = 15

Set oDoc = oWord.documents.Open(sFilePath)

With oDoc

Dim sFPath As String

sFPath = .Path

sName = .Name

sName = GetFileName(sName)

sName = sFPath & "\" & sName & ".docx"

.SaveAs2 Filename:=sName, FileFormat:=wdFormatDocumentDefault, CompatibilityMode:=wdWord2013

.Close

End With

End If

End With

'如果指定的文件夹不含有文件

Else

End If

'如果要遍历子文件夹

If bEnuSub = True Then

'定义子文件夹集合对象

Dim oSubFolders As Object

Set oSubFolders = oFolder.SubFolders

If oSubFolders.Count > 0 Then

For Each oTempFolder In oSubFolders

sTempPath = oTempFolder.Path

Call EnuAllFiles(sTempPath, True)

End If

Set oSubFolders = Nothing

End If

Set oFile = Nothing

Set oFolder = Nothing

Set oFso = Nothing

End Sub

[……]

阅读全文>>>

如何将ListView控件中的数据导出到Excel中？

如何将Excel数据导入到ListView控件中？

如何用vba批量把固定分隔符或者固定宽度的文本文档另存为excel文件?

如何用vba将同一文件下的所有03版本的word转换为最新版本？

感谢你的支持，我将持续地写出更好的文章。

热门文章

最近文章

微信公众号