ZiGma

【VBA】VBA+正则表达式提取标题快速保存归档

字数统计: 1,661阅读时长: 8 min
2017/08/26 Share

今天快下班了同事找我提了个需求:归档目录太深,每次写完材料归档时需要点很久,且文件夹繁多,保存时要新建文件夹并重命名,Word文档保存时也需要命名。

想了一下,可以靠Word宏配合正则表达式解决。

思路:利用正则表达式提取正文中的案号,并将该案号作为归档文件夹和文件名。而且正好之前在Excel中试验过类似功能,只不过那个是提取案号后将Word另存为。

注:需要在VBA编辑器工具→引用Microsoft VBScript Regular Expressions 5.5

Word代码如下:

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
Sub 快速保存()
Path1 = "E:\" "设置文件夹路径
Set objshell = CreateObject("Shell.Application")
Set objFolder = objshell.browseForFolder(0, "选择文件夹", 0, Path1)
If Not objFolder Is Nothing Then FolderPath = Path1 & objFolder

Dim myExp As RegExp
Dim AllContent
Set myExp = New RegExp
AllContent = ActiveDocument.Content
With myExp '利用正则表达式提取案号以作为文件夹名和文件名'
.Pattern = "((2|\(2).+?号"
.Global = False
Set myMsg = .Execute(AllContent)

For Each m In myMsg
filename_ = m
Next
End With
Set wdApp = Nothing

Path2 = FolderPath & "\" & filename_ "判断是否已经存在文件
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(Path2) = True Then
If (MsgBox("已存在该文件,是否覆盖?", vbYesNo)) = vbNo Then
Cancel = True
GoTo k
Else
GoTo l
End If
Else
MkDir (FolderPath & "\" & filename_) "不存在则创建文件夹
End If
l:
ActiveDocument.SaveAs FileName:=FolderPath & "\" & filename_ & "\" & filename_
k:
End Sub

2018-2-4日更新 进入2018年同事又提出要更改年份文件夹,因此修改了代码,保存到相应案号的年份中。

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
Sub 快速保存()
Dim myExp As RegExp '利用正则表达式提取案号以作为文件夹名和文件名'
Dim AllContent
Set myExp = New RegExp
AllContent = ActiveDocument.Content
With myExp
.Pattern = "((2|\(2).+?号" '正则表达式'
.Global = False
Set myMsg = .Execute(AllContent)

For Each m In myMsg
fileName_ = m
Next
End With

Year_ = Mid(fileName_, 2, 4) & "年案件"

Path1 = "E:\" "设置文件夹路径
Set objshell = CreateObject("Shell.Application") '选择保存路径'
Set objFolder = objshell.browseForFolder(0, "选择文件夹", 0, Path1)
If Not objFolder Is Nothing Then FolderPath = Path1 & objFolder Else Exit Sub

Path2 = FolderPath & "\" & Year_ "定义年份及案号命名的文件夹路径
Path3 = FolderPath & "\" & Year_ & "\" & fileName_
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(Path2) = False Then
MkDir (FolderPath & "\" & Year_) "不存在则创建文件夹
End If

If FSO.FolderExists(Path3) = True Then
If (MsgBox("已存在该文件,是否覆盖?", vbYesNo)) = vbNo Then
Cancel = True
Exit Sub
Else
GoTo l
End If
Else
MkDir (FolderPath & "\" & Year_ & "\" & fileName_)
End If
l:
ActiveDocument.SaveAs FileName:=FolderPath & "\" & Year_ & "\" & fileName_ & "\" & fileName_ "另存为重命名文件
End Sub

2018-2-5日更新

发现每次需要进入宏来修改路径太麻烦,所以又更新了代码,在C盘生成一个保存路径的TXT文件作为配置读取,并且无需再在使用前引用Microsoft VBScript Regular Expressions 5.5。

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
Sub 设置保存路径()
Dim sFile, sFile_, sOpen As Object, Fso As Object
Dim FPath As String
Set Fso = CreateObject("Scripting.FileSystemObject")

If Fso.FileExists("C:\AutoSave\AutoSave.txt") = False Then "判断是否存在设置文件"
MkDir ("C:\AutoSave\") "创建设置文件夹及文件
Set sFile = Fso.CreateTextFile("C:\AutoSave\AutoSave.txt", True)
Set sFile_ = Fso.CreateTextFile("C:\AutoSave\自动保存宏设置文件夹,勿删.txt", True)
Set sFile = Nothing
Set sFile_ = Nothing
End If

Set objshell = CreateObject("Shell.Application") '设置保存路径'
Set objFolder = objshell.browseForFolder(0, "请选择保存路径", 0, 0)
If Not objFolder Is Nothing Then FPath = objFolder.self.Path Else Exit Sub '必要!判断是否取消保存'

Set sOpen = Fso.OpenTextFile("C:\AutoSave\AutoSave.txt", 2, 0) '写入保存的路径'
If len(FPath) <= 3 then '判断是否选取了盘符根目录'
sOpen.Write FPath
Else
sOpen.Write FPath & "\" "写入设置的路径
End if
sOpen.Close

Set Fso = Nothing
Set sOpen = Nothing
Set objshell = Nothing
Set objFolder = Nothing
End Sub

Sub 快速保存()
Dim sFile, sFile_, sOpen As Object, Fso As Object
Dim FPath As String
Dim myExp As RegExp '利用正则表达式提取案号以作为文件夹名和文件名'
Dim AllContent

Set Fso = CreateObject("Scripting.FileSystemObject")
Set objshell = CreateObject("Shell.Application")

If Fso.FileExists("C:\AutoSave\AutoSave.txt") = False Then '判断是否存在设置文件'

If (MsgBox("未设置归档路径,是否设置?", vbYesNo)) = vbNo Then
Cancel = True
Exit Sub
Else
Set objFolder = objshell.browseForFolder(0, "请选择保存路径", 0, 0) '设置保存路径'
If Not objFolder Is Nothing Then FPath = objFolder.self.Path Else Exit Sub '必要!判断是否取消设置'

MkDir ("C:\AutoSave\") "创建设置文件夹及文件
Set sFile = Fso.CreateTextFile("C:\AutoSave\AutoSave.txt", True)
Set sFile_ = Fso.CreateTextFile("C:\AutoSave\自动保存宏设置文件夹,勿删.txt", True)
Set sFile = Nothing
Set sFile_ = Nothing

Set sOpen = Fso.OpenTextFile("C:\AutoSave\AutoSave.txt", 2, 0)
If len(FPath) <= 3 then '判断是否选取了盘符根目录'
sOpen.Write FPath
Else
sOpen.Write FPath & "\" "写入设置的路径
End if
sOpen.Close
End If

Set sOpen = Nothing
Set objFolder = Nothing
End If
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
    Set myExp = New RegExp
AllContent = ActiveDocument.Content
With myExp
.Pattern = "((2|\(2).+?号" '正则表达式'
.Global = False
Set myMsg = .Execute(AllContent)

For Each m In myMsg
fileName_ = m
Next
End With

Year_ = Mid(fileName_, 2, 4) & "年案件" '提取年度,并依据年度分类文件'

Open "C:\AutoSave\AutoSave.txt" For Input As #1
Line Input #1, Path1
Close #1

Set objFolder = objshell.browseForFolder(0, "请选择案件类型文件夹", 0, Path1) '选择保存路径'
If Not objFolder Is Nothing Then FolderPath = objFolder.self.Path Else Exit Sub '必要!判断是否取消保存'

Path2 = FolderPath & "\" & Year_ "定义年份及案号命名的文件夹路径
Path3 = FolderPath & "\" & Year_ & "\" & fileName_
If Fso.FolderExists(Path2) = False Then
MkDir (FolderPath & "\" & Year_) "创建年份的文件夹
End If

If Fso.FolderExists(Path3) = True Then
If (MsgBox("已存在该文件,是否覆盖?", vbYesNo)) = vbNo Then
Cancel = True
Exit Sub
Else
GoTo l
End If
Else
MkDir (FolderPath & "\" & Year_ & "\" & fileName_)
End If
l:
ActiveDocument.SaveAs FileName:=FolderPath & "\" & Year_ & "\" & fileName_ & "\" & fileName_ "另存为重命名文件
End Sub

Excel中则需要调用Word.Application,但是思路还是和Word中一样。

代码如下:

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
Sub test()
Dim wdApp As Word.Application
Dim wddocument As Word.document
Dim myExp As RegExp
Dim AllContent
For k = 2 To Application.CountA(Sheet1.Range("D:D"))
file_ = Sheet1.Range("D" & k)
Set wdApp = New Word.Application
Set wddocument = wdApp.Documents.Open(file_)
With wdApp
Set myExp = New RegExp
AllContent = wddocument.Content
With myExp
.Pattern = Sheet1.Range("B1")
.Global = False
Set myMsg = .Execute(AllContent)

For Each m In myMsg
Sheet1.Range("E" & k) = m
Next
End With
.Documents.Close
.Quit
End With
Set wdApp = Nothing
Next
End Sub
CATALOG
  1. 1. Word代码如下:
  2. 2. 代码如下: