新入门菜鸟一枚，请教大侠：批量将WORD标题改为文件名

gavino

如何用VBA实现？翻了以前的贴子，总是报错。
情况 是这样的，文件误删以后，恢复成功了，但恢复的WORD文件名字全成了001.docx.  002.docx,所以想用VBA将文件中的标题取出来，然后以标题当做该文件名。请大侠们指教一下。以前有位大侠写的代码
Dim AD1 As String
AD1 = ActiveDocument.FullName

' NO1 Macro
' 宏在 2008-6-9 由 微软用户 录制
   Selection.WholeStory
    Selection.HomeKey Unit:=wdLine
    Selection.Expand wdLine
    Dim myRange As Range
    Set myRange = Selection.Range
    myRange.SetRange myRange.Start, myRange.End - 1
    myRange.Select
    ActiveDocument.SaveAs FileName:=ActiveDocument.Path & "\" & VBA.Trim(myRange.Text) & ".docx"
    On Error Resume Next
    VBA.Kill (AD1)
    Application.Quit
End Sub

运行时报错。、。。。。。。。。。。。。错误在    ActiveDocument.SaveAs FileName:=ActiveDocument.Path & "\" & VBA.Trim(myRange.Text) & ".docx" 。

闻启学

myRange.Text  这个一般包含回车和换行字符

所以出错

试一试

这个换成
  ActiveDocument.SaveAs FileName:=ActiveDocument.Path & "\" & VBA.Trim(mid（myRange.Text，1，len（myRange.Text））) & ".docx"

413191246se

请楼主打包备份文件后应用下面的宏：（2003版通过，不知在2007版中管不管事）
Sub test()
    On Error Resume Next
    Dim fd As FileDialog, i As Long, doc As Document, p As String
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    If fd.Show = -1 Then p = fd.SelectedItems(1) Else Exit Sub
    Set fd = Nothing
    If MsgBox("Are you sure to process the folder " & p & " ?" & vbCr & "是否处理文件夹 " & p & " ？", vbYesNo + vbExclamation, "循环遍历文件夹") = vbNo Then Exit Sub
    With Application.FileSearch
        .LookIn = p
        .SearchSubFolders = True
        .FileName = "*.docx"
        If .Execute > 0 Then
            For i = .FoundFiles.Count To 1 Step -1
                Set doc = Documents.Open(FileName:=.FoundFiles(i))
'''删除段落首尾空格及空行()
                With doc.Content.Find
                    .Execute findtext:="^l", ReplaceWith:="^p", Replace:=wdReplaceAll
                    .Execute findtext:="^13", ReplaceWith:="^p", Replace:=wdReplaceAll
                End With
                Selection.WholeStory
                CommandBars.FindControl(ID:=122).Execute
                CommandBars.FindControl(ID:=123).Execute
                Dim k As Paragraph
                For Each k In doc.Paragraphs
                    If Len(k.Range) = 1 Then k.Range.Delete
                Next
'
                Dim j As String, newName As String, oldName As String
                j = doc.Paragraphs(1).Range.Text
                j = Left(j, Len(j) - 1)
                newName = doc.Path & "\" & j & ".docx"
                oldName = doc.FullName
                doc.Close savechanges:=wdDoNotSaveChanges '关闭文档不保存任何修改
                Name oldName As newName '文件重命名
''''''''''
            Next i
            MsgBox "Complete! There were " & .FoundFiles.Count & " file(s) processed." & vbCr & "处理完毕！共处理 " & .FoundFiles.Count & " 个文件！", vbOKOnly + vbExclamation, "循环遍历文件夹"
        Else
            MsgBox "There were no files found." & vbCr & "未发现文件！", vbOKOnly + vbCritical, "循环遍历文件夹"
        End If
    End With
End Sub

413191246se

不好，预计问题出在《删除段落首尾空格及空行》上面。。。