[求助]如何批量为指定文件夹下的指定文件重命名？

tangqingfu

有500多个WORD文件，文件是试卷，文件名无规律，所有文件的第1段为考试省份和考试性质，第2段为考试科目。
求助：如何用VBA提取指定文件夹的WORD文档的中的第1段的前10个字符和2段落的文字作为并被提取文档的“另存为”文件的文件名？
例：
文档第1段为：2008年常德市初中毕业学业考试试卷
　　第2段为：语文
需要另存为的文件名为：2008年常德市初中＿语文
谢谢

zhenyin321

在DOS下这个东西非常容易

tangqingfu

感谢sylun兄的代码：
Sub mySaveAs()
'
    Dim i As Long, st As Single, mypath As String, fs As FileSearch
    Dim myDoc As Document, n As Integer
    Dim strpara1 As String, strpara2 As String, docname As String, a
   
    On Error GoTo hd
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "请指定目标文件夹"
        If .Show <> -1 Then Exit Sub
        st = Timer
        mypath = .InitialFileName
    End With
   
    Application.ScreenUpdating = False
    If Dir(mypath & "另存为", vbDirectory) = "" Then MkDir mypath & "另存为"  '另存为文档的保存位置
    Set fs = Application.FileSearch
    With fs
        .NewSearch
        .LookIn = mypath
        .FileType = msoFileTypeWordDocuments
        If .Execute(msoSortByFileName) > 0 Then
            For i = 1 To .FoundFiles.Count
                If InStr(fs.FoundFiles(i), "~$") = 0 Then
                    Set myDoc = Documents.Open(.FoundFiles(i), Visible:=False)
                    With myDoc
                        strpara1 = Replace(.Paragraphs(1).Range.Text, Chr(13), "")
                        strpara1 = Left(strpara1, 10)
                        strpara2 = Replace(.Paragraphs(2).Range.Text, Chr(13), "")
                        If Len(strpara1) < 2 Or Len(strpara2) < 2 Then GoTo hd
                        docname = strpara1 & "_" & strpara2
                        docname = CleanString(docname)
                        For Each a In Array("\", "/", ":", "*", "?", """ ", "<", " >", "|")
                            docname = Replace(docname, a, "")
                        Next
                        .SaveAs mypath & "另存为\" & docname & ".doc"
                        n = n + 1
                        .Close
                    End With
                End If
            Next
        End If
    End With
    MsgBox "共处理了" & fs.FoundFiles.Count & "个文档，保存于目标文件夹的名称为“另存为”的下一级文件夹中。" _
        & vbCrLf & "处理时间：" & Format(Timer - st, "0") & "秒。"
    Application.ScreenUpdating = True
    Exit Sub
   
hd:
    '出错原因基本上是第一、二段内容不符合要求
    MsgBox "运行出现意外，程序终止！" & vbCrLf & "已处理文档数：" & n _
        & vbCrLf & "出错文档：" & vbCrLf & fs.FoundFiles(i)
    If Not myDoc Is Nothing Then myDoc.Close
End Sub

szqhb

来做个记号啊，又时会有用的

坠叶飘香

{:soso_e136:}你光发的代码。原文件有木有。

02761752696

谢谢      分享