分页自动命名保存。

wang80tie

辛苦大神帮忙写一串代码，要求WORD在当前文件夹下自动分页保存，命名为“单位+姓名”（样表中涂红部分），先送上小花花。

wang80tie

找到了一个之前大神写好的代码，但是不会修改成我要的样子，有老师能帮忙修改一下吗？


Sub SaveAsFileByPage()

'分页保存,适用于WORD97及其以上版本
    Dim objShell As Object, objFolder As Object, strNameLenth As Integer
     Dim mySelection As Selection, myFolder As String, myArray() As String
     Dim ThisDoc As Document, myDoc As Document, strName As String, N As Integer
     Dim myRange As Range, PageString As String, pgOrientation As WdOrientation
     Dim sinLeft As Single, sinRight As Single, sinTop As Single, sinBottom As Single
     Dim ErrChar() As Variant, oChar As Variant, sinStart As Single, sinEnd As Single
     Const myMsgTitle As String = "ExcelHome_ShouRou"
     Dim vbYN As VbMsgBoxResult
     sinStart = Timer
     On Error GoTo ErrHandle    '设置错误处理
    '创建一个Shell.Application对象
    Set objShell = CreateObject("Shell.Application")
     '取得文件夹浏览器
    Set objFolder = objShell.BrowseForFolder(0, "请选择一个文件夹", 0, 0)
     If objFolder Is Nothing Then Exit Sub
     myFolder = objFolder.Self.Path & "\"
     Set objFolder = Nothing: Set objShell = Nothing
     Set ThisDoc = ActiveDocument    '定义一个Document对象,以利用本程序作为加载宏
    Set mySelection = ThisDoc.ActiveWindow.Selection
     '文件自动命名时必须规避的字符
    ErrChar = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
     '一些特列字符
    For N = 0 To 31
         ReDim Preserve ErrChar(UBound(ErrChar) + 1)
         ErrChar(UBound(ErrChar)) = Chr(N)
     Next
     strNameLenth = Val(VBA.InputBox(prompt:="请输入您需要设置的文件名长度,0或者取消将自动命名!", Title:=myMsgTitle, Default:=10))
     If strNameLenth > 255 Then strNameLenth = 0
     vbYN = MsgBox("是否需要处理页尾的分隔符(分页符/分节符)?它可能会影响文档结构.", vbYesNo + vbInformation + vbDefaultButton2, myMsgTitle)
     Application.ScreenUpdating = False    '关闭屏幕更新
    '在文档的每页中循环
    For N = 1 To mySelection.Information(wdNumberOfPagesInDocument)
         mySelection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:=N
         Set myRange = ThisDoc.Bookmarks("\PAGE").Range
         If vbYN = vbYes And VBA.Asc(myRange.Characters.Last.Text) = 12 Then _
            myRange.SetRange myRange.Start, myRange.End - 1
         '取得一个以段落标记为分隔符的一维数组
        myArray = VBA.Split(myRange.Text, Chr(13))
         '将所有文本合并为一个字符串
        PageString = VBA.Join(myArray, "")
         '取得文档中每节的页面设置
        With myRange.Sections(1).PageSetup
             sinLeft = .LeftMargin    '左页边距
            sinRight = .RightMargin    '右页边距
            sinTop = .TopMargin    '上边距
            sinBottom = .BottomMargin    '下边距
            pgOrientation = .Orientation    '纸张方向
        End With
         For Each oChar In ErrChar    '进行一系列替换,即删除无效字符
            PageString = VBA.Replace(PageString, oChar, "")
         Next
         If strNameLenth = 0 Then
             strName = ThisDoc.Name
             strName = VBA.Replace(LCase(strName), ".doc", "")
             strName = strName & "_" & N
         Else
             strName = VBA.Left(PageString, strNameLenth)    '取得文件名
        End If
         strName = strName & ".doc"
         myRange.Copy    '复制
        Set myDoc = Documents.Add(Visible:=False)    '新建一个隐藏的空白文档
        With myDoc
             .Content.Paste    '粘贴
            .Content.Paragraphs.Last.Range.Delete    '删除最后一个段落标记
            With .PageSetup    '进行页面设置
                .Orientation = pgOrientation
                 .LeftMargin = sinLeft
                 .RightMargin = sinRight
                 .TopMargin = sinTop
                 .BottomMargin = sinBottom
             End With
             '如果有相同的文档,则自动命名
            If VBA.Dir(myFolder & strName, vbDirectory) <> "" Then strName = "Page_" & N & ".doc"
             .SaveAs myFolder & strName    '另存为
            .Close    '关闭文档
        End With
     Next
     ThisDoc.Characters(1).Copy    '变相清空剪贴板
    Application.ScreenUpdating = True    '恢复屏幕更新
    sinEnd = Timer    '取得代码运行结束的时间
    If MsgBox("分页保存结束,用时:" & sinEnd - sinStart & _
               "秒,是否打开指定文件夹查看分页保存后的文档情况?", vbYesNo, myMsgTitle) = vbYes Then _
        ThisDoc.FollowHyperlink myFolder
     Exit Sub
ErrHandle:
     MsgBox "错误号:" & Err.Number & vbLf & "出错原因:" & Err.Description, myMsgTitle
     Err.Clear
     Application.ScreenUpdating = True    '恢复屏幕更新
End Sub

wang80tie

1. Sub SaveAsFileByPage()
   
2. 
   
3. '分页保存,适用于WORD97及其以上版本
   
4.     Dim objShell As Object, objFolder As Object, strNameLenth As Integer
   
5.      Dim mySelection As Selection, myFolder As String, myArray() As String
   
6.      Dim ThisDoc As Document, myDoc As Document, strName As String, N As Integer
   
7.      Dim myRange As Range, PageString As String, pgOrientation As WdOrientation
   
8.      Dim sinLeft As Single, sinRight As Single, sinTop As Single, sinBottom As Single
   
9.      Dim ErrChar() As Variant, oChar As Variant, sinStart As Single, sinEnd As Single
   
10.      Const myMsgTitle As String = "ExcelHome_ShouRou"
    
11.      Dim vbYN As VbMsgBoxResult
    
12.      sinStart = Timer
    
13.      On Error GoTo ErrHandle    '设置错误处理
    
14.     '创建一个Shell.Application对象
    
15.     Set objShell = CreateObject("Shell.Application")
    
16.      '取得文件夹浏览器
    
17.     Set objFolder = objShell.BrowseForFolder(0, "请选择一个文件夹", 0, 0)
    
18.      If objFolder Is Nothing Then Exit Sub
    
19.      myFolder = objFolder.Self.Path & ""
    
20.      Set objFolder = Nothing: Set objShell = Nothing
    
21.      Set ThisDoc = ActiveDocument    '定义一个Document对象,以利用本程序作为加载宏
    
22.     Set mySelection = ThisDoc.ActiveWindow.Selection
    
23.      '文件自动命名时必须规避的字符
    
24.     ErrChar = Array("", "/", ":", "*", "?", """", "<", ">", "|")
    
25.      '一些特列字符
    
26.     For N = 0 To 31
    
27.          ReDim Preserve ErrChar(UBound(ErrChar) + 1)
    
28.          ErrChar(UBound(ErrChar)) = Chr(N)
    
29.      Next
    
30.      strNameLenth = Val(VBA.InputBox(prompt:="请输入您需要设置的文件名长度,0或者取消将自动命名!", Title:=myMsgTitle, Default:=10))
    
31.      If strNameLenth > 255 Then strNameLenth = 0
    
32.      vbYN = MsgBox("是否需要处理页尾的分隔符(分页符/分节符)?它可能会影响文档结构.", vbYesNo + vbInformation + vbDefaultButton2, myMsgTitle)
    
33.      Application.ScreenUpdating = False    '关闭屏幕更新
    
34.     '在文档的每页中循环
    
35.     For N = 1 To mySelection.Information(wdNumberOfPagesInDocument)
    
36.          mySelection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:=N
    
37.          Set myRange = ThisDoc.Bookmarks("\PAGE").Range
    
38.          If vbYN = vbYes And VBA.Asc(myRange.Characters.Last.Text) = 12 Then _
    
39.             myRange.SetRange myRange.Start, myRange.End - 1
    
40.          '取得一个以段落标记为分隔符的一维数组
    
41.         myArray = VBA.Split(myRange.Text, Chr(13))
    
42.          '将所有文本合并为一个字符串
    
43.         PageString = VBA.Join(myArray, "")
    
44.          '取得文档中每节的页面设置
    
45.         With myRange.Sections(1).PageSetup
    
46.              sinLeft = .LeftMargin    '左页边距
    
47.             sinRight = .RightMargin    '右页边距
    
48.             sinTop = .TopMargin    '上边距
    
49.             sinBottom = .BottomMargin    '下边距
    
50.             pgOrientation = .Orientation    '纸张方向
    
51.         End With
    
52.          For Each oChar In ErrChar    '进行一系列替换,即删除无效字符
    
53.             PageString = VBA.Replace(PageString, oChar, "")
    
54.          Next
    
55.          If strNameLenth = 0 Then
    
56.              strName = ThisDoc.Name
    
57.              strName = VBA.Replace(LCase(strName), ".doc", "")
    
58.              strName = strName & "_" & N
    
59.          Else
    
60.              strName = VBA.Left(PageString, strNameLenth)    '取得文件名
    
61.         End If
    
62.          strName = strName & ".doc"
    
63.          myRange.Copy    '复制
    
64.         Set myDoc = Documents.Add(Visible:=False)    '新建一个隐藏的空白文档
    
65.         With myDoc
    
66.              .Content.Paste    '粘贴
    
67.             .Content.Paragraphs.Last.Range.Delete    '删除最后一个段落标记
    
68.             With .PageSetup    '进行页面设置
    
69.                 .Orientation = pgOrientation
    
70.                  .LeftMargin = sinLeft
    
71.                  .RightMargin = sinRight
    
72.                  .TopMargin = sinTop
    
73.                  .BottomMargin = sinBottom
    
74.              End With
    
75.              '如果有相同的文档,则自动命名
    
76.             If VBA.Dir(myFolder & strName, vbDirectory) <> "" Then strName = "Page_" & N & ".doc"
    
77.              .SaveAs myFolder & strName    '另存为
    
78.             .Close    '关闭文档
    
79.         End With
    
80.      Next
    
81.      ThisDoc.Characters(1).Copy    '变相清空剪贴板
    
82.     Application.ScreenUpdating = True    '恢复屏幕更新
    
83.     sinEnd = Timer    '取得代码运行结束的时间
    
84.     If MsgBox("分页保存结束,用时:" & sinEnd - sinStart & _
    
85.                "秒,是否打开指定文件夹查看分页保存后的文档情况?", vbYesNo, myMsgTitle) = vbYes Then _
    
86.         ThisDoc.FollowHyperlink myFolder
    
87.      Exit Sub
    
88. ErrHandle:
    
89.      MsgBox "错误号:" & Err.Number & vbLf & "出错原因:" & Err.Description, myMsgTitle
    
90.      Err.Clear
    
91.      Application.ScreenUpdating = True    '恢复屏幕更新
    
92. End Sub

复制代码

找到之前大神写的代码，可以运行但是达不到我的要求，请老师帮忙修改一下。

ming0018

请问下，第三页是空白的，需要保存吗？

ming0018

代码在附件中，直接使用。