|
请参运行以下二个代码，推荐使用第二个代码： '* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* Created By I Love You_Word!@ExcelHome 2005-8-10 09:28:06
'仅测试于System: Windows NT Word: 10.0 Language: 2052
'№ 0004^The Code CopyIn [ThisDocument-ThisDocument]^'
'* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Option Explicit
Sub FileNewName()
Dim FSO As Object, FDR As Object, F As Object, i As Variant, OldName As String, NewName As String
Dim MyDoc As Object, MyFolder As String, A As Byte
On Error Resume Next '忽略错误
MyFolder = "D:\2005881677775\8-8\" '此处修改你的文件夹名
Set FSO = CreateObject("Scripting.FileSystemObject") '创建计算机文件系统以向其访问
Set FDR = FSO.GetFolder(MyFolder) '指定其中访问的文件夹对象
Set F = FDR.Files '定义该文件夹中的所有文件集合
For Each i In F '在指定文件下的文件中循环
'创建一个后期绑定的DOC文件
Set MyDoc = CreateObject(MyFolder & i.Name)
NewName = ""
For A = 1 To 10
If Len(MyDoc.Paragraphs(A).Range.Text) > 1 Then Exit For
Next
If MyDoc.Paragraphs(A).Range.Information(wdWithInTable) Then
NewName = Mid(MyDoc.Paragraphs(A).Range.Text, 1, Len(MyDoc.Paragraphs(A).Range.Text) - 2)
Else
NewName = Mid(MyDoc.Paragraphs(A).Range.Text, 1, Len(MyDoc.Paragraphs(A).Range.Text) - 1)
End If
MyDoc.Close False '关闭文件
Set MyDoc = Nothing
NewName = VBA.Trim(NewName)
NewName = MyFolder & NewName
If Dir(NewName & ".Doc", vbDirectory) <> "" Then
NewName = NewName & Timer
End If
NewName = NewName & ".Doc"
'取得原有文件名
OldName = MyFolder & i.Name
'取得新文件名
Name OldName As NewName
Next i
End Sub
'----------------------
Sub Example2() '此代码功能为列出重命令指定文件夹中所有选取的WORD文件
Dim MyDialog As FileDialog, vrtSelectedItem As Variant, A As Byte, MyDoc As Document
Dim OldName As String, NewName As String, MyRange As Range
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 '确定
For Each vrtSelectedItem In .SelectedItems '在所有选取项目中循环
Set MyDoc = Documents.Open(FileName:=vrtSelectedItem, Visible:=False)
OldName = vrtSelectedItem '取得原文件名
Debug.Print OldName
For A = 1 To 10 '循环
Set MyRange = MyDoc.Paragraphs(A).Range
If Len(MyRange.Text) > 1 Then Exit For '如果该段落文本长度大小于(非空白段落),则退出循环
Next
If MyRange.Information(wdWithInTable) Then
'如果在表格中,则去除最后两个字符
NewName = Mid(MyRange.Text, 1, Len(MyRange.Text) - 2)
Else
'如果为正常段落不在表格中,则去除最后一个段落标记
NewName = Mid(MyRange.Text, 1, Len(MyRange.Text) - 1)
End If
MyDoc.Close False '关闭文件
'去除空格
NewName = VBA.Trim(NewName)
'重新定义新的文件名
NewName = .InitialFileName & NewName
'如果已经存在该文件名,则加上时间数,加以区别
If Dir(NewName & ".Doc", vbDirectory) <> "" Then NewName = NewName & Timer
'重命名该文件
Name OldName As NewName & ".Doc"
Next
End If
End With
End Sub
'----------------------
[此贴子已经被作者于2005-8-10 9:29:50编辑过] | 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2005-8-2 09:18
楼主