★VBA如何控制word自动用学生姓名当文件名保存？

it_hunter

现在手头有一个word文档，是一个关于很多学生的成绩通知书，其中每一页对应一个学生，目前已用VBA代码将每一页提出来单独保存。但是文件名是“通知书-1.DOC"、”通知书-2.DOC“。。。。等等。
因为每一页中学生的姓名位置是固定的(如下图），所以希望通过vba编程将姓名（每个学生不同）字符提取出来，以便作为文件名自动保存。

（姓名字符在文档中的特点：前面有”学生“两个字，后面是”已“字，且姓名都是自动添加了下划线的。）。

不知道在vba中如何读取这个特定位置的文字出来。特求助解决，谢谢！

附：目前实现将该文件自动按每一页自动保存为”通知书-1.DOC“"通知书-2.doc“……的VBA代码（该代码在文档的thisdocument模块中，能够正确执行)如下：

--------------------------------------------
Sub SaveAsPage()

Dim PageCount As Integer, StartRange As Long, EndRange As Long, MyRange As Range, Fn As String, MyDoc As Document
On Error Resume Next
If Dir("D:\通知书", vbDirectory) <> "" Then                           '判断文件夹是否存在
        MsgBox "文件夹存在", , "提示"            '提示
Else
     MsgBox "文件夹不存在!在D盘创建一个名为“通知书”的文件夹", , "提示"         '文件夹不存在的提示
     MkDir "D:\通知书"                                            
End If
ChangeFileOpenDirectory "D:\通知书"
PageCount = Selection.Information(wdNumberOfPagesInDocument)
Range(0, 0).Select '将光标移至文档起点
For I = 1 To PageCount '设置循环次数
    StartRange = Selection.Start '取得该页的第一个字符位置
    Selection.EndKey Unit:=wdLine '将光标移动到该页首行的最后位置
     Fn = "FILE" & I&".DOC"
       If I = PageCount Then '如果循环到达最后一页
        EndRange = ActiveDocument.Content.End '将文档最后位置赋值于EndRange
      Else
        Selection.GoToNext (wdGoToPage) '否则,将下一页的起始位置赋值于EndRange(等同于本页的最后位置)
        EndRange = Selection.Start
     End If
    Set MyRange = Range(StartRange, EndRange) '将本页中的内容进行复制
    MyRange.Copy
    Set MyDoc = Documents.Add '新建一空白文档
    MyDoc.Range(0, 0).Paste '在文档开始处粘贴
    MyDoc.SaveAs FileName:=Fn '保存文档名
    MyDoc.Close '关闭文档
Next
End Sub


----------------------

413191246se

楼主，我是在2003中测试的，不敢保证在2007或以上正确。请先备份原文件后再测试，测试完毕与原文件对照一下以保正确。

1. Sub SaveAsPage_New()
   
2.     Dim PageCount As Integer, StartRange As Long, EndRange As Long, MyRange As Range, Fn As String, MyDoc As Document, i As Long
   
3.     On Error Resume Next
   
4.     If Dir("D:\通知书", vbDirectory) <> "" Then                           '判断文件夹是否存在
   
5.             MsgBox "文件夹存在", , "提示"            '提示
   
6.     Else
   
7.          MsgBox "文件夹不存在!在D盘创建一个名为“通知书”的文件夹", , "提示"         '文件夹不存在的提示
   
8.          MkDir "D:\通知书"
   
9.     End If
   
10.     ChangeFileOpenDirectory "D:\通知书"
    
11.     PageCount = Selection.Information(wdNumberOfPagesInDocument)
    
12. '    Range(0, 0).Select '将光标移至文档起点
    
13.     Selection.HomeKey unit:=wdStory
    
14.     For i = 1 To PageCount '设置循环次数
    
15.         StartRange = Selection.Start '取得该页的第一个字符位置
    
16.         Selection.EndKey unit:=wdLine '将光标移动到该页首行的最后位置
    
17. '        Fn = "FILE" & i & ".DOC"
    
18.         If i = PageCount Then '如果循环到达最后一页
    
19.             EndRange = ActiveDocument.Content.End '将文档最后位置赋值于EndRange
    
20.         Else
    
21.             Selection.GoToNext (wdGoToPage) '否则,将下一页的起始位置赋值于EndRange(等同于本页的最后位置)
    
22.             EndRange = Selection.Start
    
23.         End If
    
24.         Set MyRange = ActiveDocument.Range(StartRange, EndRange) '将本页中的内容进行复制
    
25.         MyRange.Copy
    
26.         Set MyDoc = Documents.Add '新建一空白文档
    
27.         MyDoc.Range(0, 0).Paste '在文档开始处粘贴
    
28.         
    
29. '取得学生名字
    
30.         Selection.HomeKey unit:=wdStory
    
31.         Selection.ClearFormatting
    
32.         Selection.Find.Execute findtext:="学生", Forward:=True, Wrap:=wdFindStop
    
33.         If Selection.Find.Found = True Then
    
34.             Do
    
35.                 Selection.MoveEnd unit:=wdCharacter, Count:=1
    
36.             Loop Until Selection Like "*已于"
    
37.             Selection.MoveStart unit:=wdCharacter, Count:=2
    
38.             Selection.MoveEnd unit:=wdCharacter, Count:=-2
    
39.         End If
    
40.         
    
41.         Fn = Selection.Text
    
42.         Fn = Fn & ".doc"
    
43. '
    
44.         ActiveDocument.Paragraphs.Last.Previous.Range.Delete
    
45.         ActiveDocument.Paragraphs.Last.Range.Select
    
46. '最后一段，设置为1磅
    
47.         With Selection.Font
    
48.             .Size = 1
    
49.             .Kerning = 0
    
50.             .DisableCharacterSpaceGrid = True
    
51.         End With
    
52.         With Selection.ParagraphFormat
    
53.             .LineSpacing = LinesToPoints(0.25)
    
54.             .AutoAdjustRightIndent = False
    
55.             .DisableLineHeightGrid = True
    
56.         End With
    
57. '''
    
58.         MyDoc.SaveAs FileName:=Fn '保存文档名
    
59.         MyDoc.Close '关闭文档
    
60.     Next
    
61. End Sub

复制代码

it_hunter

很好，在word2013中测试通过了，非常感谢啊！

ww0000

太好了,如何改成第一行呢?

daibao88

提取姓名可以用正则表达式或两个split