[求助] 如何批量把第一行的字更改word的文件名

     在一个文件夹下，有四五百个文件，从网上下载的，所有文件名都是编号，不是真正的文件名，大都是word，ppt文档

少量rar。只要改word的就可以，其它的能改也不反对。有的word文档中只有图片，没有文字，这类的可以不改。

1、现在把文件名改为第一行文字的名字。只要实现第一种可能就可以，当然，要是能第二种可能更好

2、文件名可能出现重复，如果出现重复，则按照后面加上编号。

help!help!help!

我开发的灵感百宝箱（新版，未发布）中有个合并文档和拆散保存的功能，可能能解决你的问题。有兴趣可以直接与我联系。

Sub Word文件改名()
    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:="C:\" & Selection & ".doc"
    ActiveWindow.Close
End Sub

这个宏用于选中文档的第一行的文字，并以之重命名。"C:\" & Selection & ".doc"为保存路径

http://club.excelhome.net/viewthread.php?tid=270732&replyID=&skin=0

感谢守柔版主提供的部分代码

这个只能是一个一个的改，但是也比较快，500个文件7、8分钟吧，word可以最多打开60个左右的文件。如果想全自动的话那就要再加入一部分代码。我就不会了。

热烈期待 守柔版主 解决。

请参考：

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* Created By SHOUROU@ExcelHome 2007-11-5 6:38:14
'仅测试于System: Windows NT Word: 11.0 Language: 2052
'№ 0269^The Code CopyIn [ThisDocument-ThisDocument]^'
'* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Option Explicit
Sub NewNameWithDocuments()
    Dim MyDialog As FileDialog, oDoc As Variant, myDoc As Document
    Dim myRange As Range, oldName As String, ErrArray() As Variant
    Dim oArray As Variant, newName As String
    On Error Resume Next    '忽略错误
    '定义一个导致文件名出错的数组
    ErrArray = Array("\", "/", "*", "?", "<", ">", "|", """", Chr(9), Chr(11), Chr(13))
    '定义一个文件夹选取对话框
    Set MyDialog = Application.FileDialog(msoFileDialogFilePicker)
    With MyDialog
        .Filters.Clear    '清除所有文件筛选器中的项目
        .Filters.Add "所有 WORD 文件", "*.doc", 1    '增加筛选器的项目为所有WORD文件
        .AllowMultiSelect = True    '允许多项选择
        If .Show <> -1 Then Exit Sub
        For Each oDoc In .SelectedItems    '在所有选取项目中循环
            newName = ""
            '以隐藏方式打开Word文档
            Set myDoc = Word.Documents.Open(FileName:=oDoc, Visible:=False)
            Set myRange = myDoc.Paragraphs.First.Range '取得第1个段落区域
            oldName = Application.CleanString(myRange.Text) '清除非打印字符

            For Each oArray In ErrArray '遍历替换
                oldName = Replace(oldName, oArray, "")
            Next
            myDoc.Close False '关闭文档
            If Len(oldName) < 1 Then '如果长度小于1不处理
            Else '进行重命名操作
                newName = .InitialFileName & oldName & ".doc"
                '如果当前文件夹中没有此文件名
                If Dir(newName, vbDirectory) = "" Then
                    Name oDoc As newName '直接命名
                Else '如果存在,则按时间序列数加命名
                    newName = Replace(newName, ".doc", "")
                    newName = newName & Timer
                    newName = Replace(newName, ".", "")
                    newName = newName & ".doc"
                    Name oDoc As newName
                End If
            End If
        Next
    End With
End Sub
'----------------------

单击附件中的“开始重命名Word文件“（常用工具栏中）即可。

oa7vHEoh.rar (7.27 KB, 下载次数: 569)

请参考:

请参考：
Option Explicit

Sub Example()
    Dim MyDialog As FileDialog, vrtSelectedItem As Variant
    Dim myArray() As String, OldName As String, thisPath As String
    Dim NewName As String
    '    On Error Resume Next
    '定义一个文件夹选取对话框
    Set MyDialog = Application.FileDialog(msoFileDialogFilePicker)
    With MyDialog
        .Filters.Clear    '清除所有文件筛选器中的项目
        .Filters.Add "所有 WORD 文件", "*.doc", 1    '增加筛选器的项目为所有WORD文件
        .AllowMultiSelect = True    '允许多项选择
        If .Show = -1 Then    '确定
            thisPath = .InitialFileName
            For Each vrtSelectedItem In .SelectedItems    '在所有选取项目中循环
                NewName = GetFileTitle(thisPath, vrtSelectedItem)
                If NewName <> "" Then
                    Name vrtSelectedItem As thisPath & NewName & ".doc"
                End If
            Next vrtSelectedItem
        End If
    End With
End Sub
Function GetFileTitle(apath, strFl) As String
'请在VBE/工具/引用中勾选对于MICROSOFT SHELL CONTROLS AND AUTOMATION
    Dim shl As Shell32.Shell
    Dim shfd As Shell32.Folder
    Dim Flname As String
    Set shl = New Shell
    Set shfd = shl.NameSpace(apath)
    Flname = VBA.Replace(strFl, apath, "")
    GetFileTitle = shfd.GetDetailsOf(shfd.Items.Item(Flname), 10)
End Function
'MsgBox ActiveDocument.BuiltInDocumentProperties(wdPropertyTitle) '返回活动文档属性值

守兄,有的文件是无法用name重命名的(如中文乱码的文件),不知能不能解决,以前我也做过一个解决方法类同,但这个问题没有解决