九月, 2018 | ExcelOffice【微信公众号：水星Excel】

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

1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

23

24

25

26

27

28

29

30

31

32

33

34

35

36

37

38

39

40

41

42

43

44

45

46

47

48

49

50

51

52

53

54

55

56

57

58

59

60

61

62

63

64

65

66

67

68

69

70

71

72

73

74

75

76

77

78

79

80

81

82

83

84

85

86

87

88

89

90

91

92

93

94

95

96

97

98

99

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

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)

Set oSubFolders = Nothing

End If

Set oFile = Nothing

Set oFolder = Nothing

Set oFso = Nothing

End Sub

[……]

阅读全文>>>

如何在vba中使用Word Application对象的邮件合并事件？

2018年9月10日作者：水星Excel

834 次浏览暂无评论

在word中内置了许多与邮件合并相关的事件，这些邮件合并的事件都是由Application对象触发的，具体如下图所示：

灵活地使用这些事件，可以极大地增强邮件合并的功能。

比如希望在邮件合[……]

阅读全文>>>

如何在ppt中用vba实现图形的布尔运算？

2018年9月9日作者：水星Excel

969 次浏览暂无评论

布尔运算是数字符号化的逻辑推演法，包括联合、相交、相减。

在图形处理操作中引用了这种逻辑运算方法以使简单的基本图形组合产生新的形体，并由二维布尔运算发展到三维图形的布尔运算。

在PPT幻灯片中，当[……]

阅读全文>>>

如何用vba在excel工作表中插入同心不同半径的圆或者半圆？

2018年9月7日作者：水星Excel

793 次浏览暂无评论

如下图所示：

如果要在工作表中插入两个同心半圆或者圆，根据如何用vba在excel工作表中插入圆？和如何用vba在excel工作表中插入半圆？中介绍的。

当用vba在工作表中插入圆或者[……]

阅读全文>>>

如何用vba实现中文汉字转拼音，并且带声调？

如何在vba中使用QueryTable对象的刷新事件？

如何用vba给单元格的部分字符添加下划线？

如何用vba批量将文件夹下的文本文件的内容逐行导入excel？

如何用vba批量删除文件夹下文件大小为0的空文件？

如何在word中使用DocVariable域显示文档变量的值？

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

如何在vba中使用Word Application对象的邮件合并事件？

如何在ppt中用vba实现图形的布尔运算？

如何用vba在excel工作表中插入同心不同半径的圆或者半圆？

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

热门文章

最近文章

微信公众号