批量将文档中首次出现的标题或第一行文字设置成文件名

huangyun

因工作需要，从网络和单位内部网络中下载了大量文档（含红头文件），现需要对这些文档进行重命名，规则如下：
1.如果文档是带红头文件的，就取该文档的标题，也就是忽略红头文件和发文字号等信息，直接将标题命名成文件名，注：标题可能是多行（1~3行，且有可能带引号或书名号）
2.如果文档无红头文件的，则以文档中首个段落中的第一句话（前提：第一句话不足一行）或第一行文字作为文件名。
3.以上命名规则若出现文件名相同，则以1，2，3，...后缀加以区分。
搜索了一下，网络上有些类似的代码，但可能并不完全适用我的要求，所以求助论坛网友，能否将代码加以修改，能够适用上述规则，谢谢了。
类似代码链接：http://club.excelhome.net/viewth ... DA%D2%BB&page=1

huangyun

请教3楼，把完整代码复制一下吧，麻烦你了，谢谢。

wj2368

关注，最好能将文号与标题作为文件名

wj2368

你的问题我明白怎么做

wj2368

1. Sub 批量提取标题为文件名()
   
2.     Dim myDialog As FileDialog, oDoc As Variant, myDoc As Document
   
3.     Dim myRange As Range, oldName As String, ErrArray() As Variant
   
4.     Dim oArray As Variant, NewName As String
   
5.     On Error Resume Next    '忽略错误
   
6.     '定义一个导致文件名出错的数组
   
7.     ErrArray = Array("", "/", "*", "?", "<", ">", "|", """", Chr(9), Chr(11), Chr(13))
   
8.     '定义一个文件夹选取对话框
   
9.     Set myDialog = Application.FileDialog(msoFileDialogFilePicker)
   
10.     With myDialog
    
11.         .Filters.Clear    '清除所有文件筛选器中的项目
    
12.         .Filters.Add "所有 WORD 文件", "*.doc", 1    '增加筛选器的项目为所有WORD文件；其中1表示文件筛选器的默认选项(表示为第一项)，以此类推
    
13.         .AllowMultiSelect = True    '允许多项选择
    
14.         If .Show <> -1 Then Exit Sub
    
15.         For Each oDoc In .SelectedItems    '在所有选取项目中循环
    
16.             NewName = ""
    
17.             '以隐藏方式打开Word文档
    
18.             Set myDoc = Word.Documents.Open(FileName:=oDoc, Visible:=False)
    
19.             Set myRange = myDoc.Paragraphs(8).Range '取得第1个段落区域
    
20.              oldName = Application.CleanString(myRange.Text) '清除非打印字符
    
21.               For Each oArray In ErrArray '遍历替换
    
22.              oldName = Replace(oldName, oArray, "")
    
23.             Next
    
24.             myDoc.Close False '关闭文档
    
25.             If Len(oldName) < 1 Then '如果长度小于1不处理
    
26.             Else '进行重命名操作
    
27.                 NewName = .InitialFileName & oldName & ".doc"
    
28.                 '如果当前文件夹中没有此文件名
    
29.                 If Dir(NewName, vbDirectory) = "" Then
    
30.                     Name oDoc As NewName '直接命名
    
31.                 Else '如果存在,则按时间序列数加命名
    
32.                     NewName = Replace(NewName, ".doc", "")
    
33.                     NewName = NewName & Date
    
34.                     NewName = Replace(NewName, ".", "")
    
35.                     NewName = NewName & ".doc"
    
36.                     Name oDoc As NewName
    
37.                 End If
    
38.             End If
    
39.         Next
    
40.     End With
    
41. End Sub
    

复制代码

问题是你的标题应该有固定行，现在是第8行。
请高手指点一下如何取二行、三行为文件名

zyy6356

不对啊。这个。都不能提取。

wh1813

wj2368 发表于 2010-5-14 14:57
问题是你的标题应该有固定行，现在是第8行。
请高手指点一下如何取二行、三行为文件名

请教下，第31行这个，如果不想按照时间序列数加命名，就希望在原文件名后面添加1、2、3、4、这种数字，该如何写？

wj2368

wh1813 发表于 2022-6-27 14:08
请教下，第31行这个，如果不想按照时间序列数加命名，就希望在原文件名后面添加1、2、3、4、这种数字，该 ...

NewName = NewName & Date 更改为：
n=n+1
NewName =n & NewName

wh1813

wj2368 发表于 2022-7-10 07:14
NewName = NewName & Date 更改为：
n=n+1
NewName =n & NewName

报错为定义变量

wj2368

wh1813 发表于 2022-7-12 15:25
报错为定义变量

在最上面dim定义n为数字变量