如何用VBA实现纵横排版页码在相同位置对齐？

sdgxzxh

最近在制作文档时，经常出现纵向和横向页面交错出现的情况，用手动方法将页码调整到同一位置对齐效率较低，请问用VBA 如何实现？

sdgxzxh

经过奋战，有了初步的答案，不知道是否存在错误，请版主指点
Sub 调整横向页码()
'**************************************************
'本过程调整文档中所有横向页面的页码调整
'调整后，横向页码与纵向页码在同一位置对齐
'过程假设首节页面为纵向设置
'过程假设页脚只有一个图文框用于页码
'过程假设页码显示在图文框中
'**************************************************
    Application.ScreenUpdating = False '关闭屏幕刷新
    On Error Resume Next  '设置错误处理
    Dim 节 As Section
    Dim 总节数  As Long, 计数器 As Long
   
    If Documents.Count <> 0 Then
            总节数 = ActiveDocument.Sections.Count
    Else
            Exit Sub '如果没有打开文档直接退出
    End If
        
    If 总节数 = 1 Then
        Exit Sub    '如果只有一节，直接退出
    End If
      
   
    For 计数器 = 2 To 总节数
        With ActiveDocument
                If .Sections(计数器).PageSetup.Orientation <> .Sections(计数器 - 1).PageSetup.Orientation Then
                    .Sections(计数器).Footers(wdHeaderFooterPrimary).LinkToPrevious = False
                    '如果本节页面方向和前节页面方向不同，则关闭本节同前开关设置
                End If
        End With
    Next 计数器  '取消所有节的同前开关设置
   
    For 计数器 = 2 To 总节数
    If ActiveDocument.Sections(计数器).PageSetup.Orientation = wdOrientLandscape Then
    '如果是横向页面，则进行调整
        With ActiveDocument.Sections(计数器).Footers(wdHeaderFooterPrimary).Range.Frames(1)
            .TextWrap = True
            .WidthRule = wdFrameAuto
            .HeightRule = wdFrameAuto
            .HorizontalPosition = MillimetersToPoints(17.5)                                '页码距短边17.5毫米，居中
            .RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
            .VerticalPosition = wdFrameCenter
            .RelativeVerticalPosition = wdRelativeVerticalPositionPage
            .HorizontalDistanceFromText = MillimetersToPoints(0)
            .VerticalDistanceFromText = MillimetersToPoints(0)
            .LockAnchor = False
            .Range.Orientation = wdTextOrientationDownward  '调整页码文字方向
        End With
    End If
  
    ActiveDocument.Sections(计数器).Headers(wdHeaderFooterPrimary) _
            .Range.ParagraphFormat.Borders(wdBorderBottom).LineStyle = wdLineStyleNone     '用于防止页眉出现横线
    Next 计数器

    Application.ScreenUpdating = True  '恢复屏幕刷新
End Sub

xkqtdzj

关注，很实际的需求，还不太完善，谢谢提供思路。

13032383987

好帖，持续关注中，你这个代码是把横向页面的页码插在居中位置，请问如何把页码插在外侧

13032383987

xkqtdzj 发表于 2019-12-3 21:56
关注，很实际的需求，还不太完善，谢谢提供思路。

大侠能把这个横向页码居中改成外侧吗？居中的语句换成外侧该怎么写？

xkqtdzj

先运行楼主调整横向页码()，然后到横排的节，切换页眉页脚状态，复制页码框，返回本页页面状态，粘贴页码框，（该节每面页码都这样处理）。单码移动到下侧，双码移动到上侧，本节处理完再删除本节的先前生成的页码。直至处理完所有的横排的节。
现在这些手动的过程，哪位大能可实现全VBA执行就好了。请大能出手

19820713chen

感谢sdgxzxh提供的思路，自已按楼主的代码写了页码外侧的代码。

Sub 调整横向页码_外侧()
'**************************************************
'本过程调整文档中所有横向页面的页码调整
'调整后，横向页码与纵向页码在同一位置对齐
'过程假设首节页面为纵向设置
'过程假设页脚只有一个图文框用于页码
'过程假设页码显示在图文框中
'**************************************************
    Application.ScreenUpdating = False '关闭屏幕刷新
    On Error Resume Next  '设置错误处理
    Dim 节 As Section
    Dim 总节数  As Long, 计数器 As Long
   
    If Documents.Count <> 0 Then
            总节数 = ActiveDocument.Sections.Count
    Else
            Exit Sub '如果没有打开文档直接退出
    End If
        
    If 总节数 = 1 Then
        Exit Sub    '如果只有一节，直接退出
    End If

    For 计数器 = 2 To 总节数
        With ActiveDocument
                If .Sections(计数器).PageSetup.Orientation <> .Sections(计数器 - 1).PageSetup.Orientation Then
                  
                    .Sections(计数器).Footers(wdHeaderFooterPrimary).LinkToPrevious = False
                    .Sections(计数器).Footers(wdHeaderFooterEvenPages).LinkToPrevious = False
                    
                    '如果本节页面方向和前节页面方向不同，则关闭本节同前开关设置
                End If
        End With
    Next 计数器  '取消所有节的同前开关设置
   
    For 计数器 = 2 To 总节数
    ActiveDocument.Sections(计数器).PageSetup.OddAndEvenPagesHeaderFooter = True
    If ActiveDocument.Sections(计数器).PageSetup.Orientation = wdOrientLandscape Then
    '如果是横向页面，则进行调整
        With ActiveDocument.Sections(计数器).Footers(wdHeaderFooterPrimary).Range.Frames(1)
            .TextWrap = True
            .WidthRule = wdFrameAuto
            .HeightRule = wdFrameAuto
            .HorizontalPosition = MillimetersToPoints(15)                                '页码距短边15毫米，左下位置
            .RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
            .VerticalPosition = MillimetersToPoints(188)
            .RelativeVerticalPosition = wdRelativeVerticalPositionPage
            .HorizontalDistanceFromText = MillimetersToPoints(0)
            .VerticalDistanceFromText = MillimetersToPoints(0)
            .LockAnchor = False
            .Range.Orientation = wdTextOrientationDownward  '调整页码文字方向
        End With
        
        With ActiveDocument.Sections(计数器).Footers(wdHeaderFooterEvenPages).Range.Frames(1)
            .TextWrap = True
            .WidthRule = wdFrameAuto
            .HeightRule = wdFrameAuto
            .HorizontalPosition = MillimetersToPoints(15)                                '页码距短边15毫米，右下位置
            .RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
            .VerticalPosition = MillimetersToPoints(15)
            .RelativeVerticalPosition = wdRelativeVerticalPositionPage
            .HorizontalDistanceFromText = MillimetersToPoints(0)
            .VerticalDistanceFromText = MillimetersToPoints(0)
            .LockAnchor = False
            .Range.Orientation = wdTextOrientationDownward  '调整页码文字方向
        End With
    End If
  
    ActiveDocument.Sections(计数器).Headers(wdHeaderFooterPrimary) _
    .Range.ParagraphFormat.Borders(wdBorderBottom).LineStyle = wdLineStyleNone     '用于防止页眉出现横线
      
    ActiveDocument.Sections(计数器).Headers(wdHeaderFooterEvenPages) _
    .Range.ParagraphFormat.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
   
    Next 计数器

    Application.ScreenUpdating = True  '恢复屏幕刷新
End Sub

希望帮到有需要的人。

xkqtdzj

19820713chen 发表于 2019-12-15 16:50
感谢sdgxzxh提供的思路，自已按楼主的代码写了页码外侧的代码。

Sub 调整横向页码_外侧()

19820713chen的代码解决了公文排版中的一类问题。很实用。

这段代码在WORD2007中运行很好，在WORD2003中只能单步运行，直接执行结果就不是预期。不是有没有解法？

19820713chen

xkqtdzj 发表于 2019-12-19 14:19
19820713chen的代码解决了公文排版中的一类问题。很实用。

这段代码在WORD2007中运行很好，在WORD2003 ...

我在测试过程中发现一些问师。我也重新写了一下代码，都是在word2010下运行，没在word2003测试过。
请看下面代码有没有效果 。

19820713chen

Sub 插入页码_外侧2()
    Dim S As Section
    Dim n As String
    Dim asection As Section
   
   Application.ScreenUpdating = False '关闭屏幕刷新
    On Error Resume Next  '设置错误处理
    Dim 节 As Section
    Dim 总节数  As Long, 计数器 As Long
   
    If Documents.Count <> 0 Then
            总节数 = ActiveDocument.Sections.Count
    Else
            Exit Sub '如果没有打开文档直接退出
    End If

    For 计数器 = 2 To 总节数
        With ActiveDocument
                If .Sections(计数器).PageSetup.Orientation <> .Sections(计数器 - 1).PageSetup.Orientation Or wdOrientLandscape Then
                  
                    .Sections(计数器).Footers(wdHeaderFooterPrimary).LinkToPrevious = False
                    .Sections(计数器).Footers(wdHeaderFooterEvenPages).LinkToPrevious = False
                    
                    '如果本节页面方向和前节页面方向不同，则关闭本节同前开关设置
                End If
        End With
    Next 计数器  '取消所有节的同前开关设置
   
    For Each asection In ActiveDocument.Sections

       With asection.Headers(wdHeaderFooterPrimary)
            .Range.Delete
            .Range.ParagraphFormat.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
       End With
    Next

'删除页脚
For Each asection In ActiveDocument.Sections
   
   With asection.Footers(wdHeaderFooterPrimary)
        .Range.Delete
        .Range.ParagraphFormat.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
   End With
   With asection.Footers(wdHeaderFooterEvenPages)
        .Range.Delete
        .Range.ParagraphFormat.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
   End With
Next


   
    For Each S In ActiveDocument.Sections
        S.Footers(1).Range.Delete
        With S.Footers(1).Range.Sections(1).Headers(1).PageNumbers
            .NumberStyle = wdPageNumberStyleArabic
            .HeadingLevelForChapter = 0
            .IncludeChapterNumber = False
            .ChapterPageSeparator = wdSeparatorHyphen
            .RestartNumberingAtSection = False
            .StartingNumber = 0
        End With
      
        S.Footers(1).PageNumbers.Add 4, True
      
         With S.Footers(wdHeaderFooterPrimary).Range.Frames(1).Range
            .Select
            With Selection
        
                With .Font
                    .Name = "宋体"
                    .Name = "Times New Roman"
                    .Size = 9
                End With
                .ParagraphFormat.CharacterUnitRightIndent = 1.5
            End With
        End With
        With S.Footers(wdHeaderFooterEvenPages).Range.Frames(1).Range
            .Select
            With Selection
           
            .InsertBefore n
                With .Font
                    .Name = "宋体"
                    .Name = "Times New Roman"
                    .Size = 9
                End With
                .ParagraphFormat.CharacterUnitRightIndent = 1.5
            End With
        End With

    Next
    ActiveWindow.ActivePane.Close
    ActiveWindow.View.Type = wdPrintView
   
    For 计数器 = 2 To 总节数
       ActiveDocument.Sections(计数器).PageSetup.OddAndEvenPagesHeaderFooter = True
    If ActiveDocument.Sections(计数器).PageSetup.Orientation = wdOrientLandscape Then
    '如果是横向页面，则进行调整
        With ActiveDocument.Sections(计数器).Footers(wdHeaderFooterPrimary).Range.Frames(1)
            
            .Width = CentimetersToPoints(0.42)
            .HeightRule = wdFrameAtLeast
            .Height = CentimetersToPoints(1.05)
           
            .HorizontalPosition = MillimetersToPoints(16)                                '页码距短边15毫米，左下位置
            .RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
            .VerticalPosition = MillimetersToPoints(188)
            .RelativeVerticalPosition = wdRelativeVerticalPositionPage
            .HorizontalDistanceFromText = MillimetersToPoints(0)
            .VerticalDistanceFromText = MillimetersToPoints(0)

            .Range.Orientation = wdTextOrientationDownward  '调整页码文字方向
        End With
        
        With ActiveDocument.Sections(计数器).Footers(wdHeaderFooterEvenPages).Range.Frames(1)
            
            .Width = CentimetersToPoints(0.42)
            .HeightRule = wdFrameAtLeast
            .Height = CentimetersToPoints(1.05)
         
            .HorizontalPosition = MillimetersToPoints(16)                                '页码距短边15毫米，右下位置
            .RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
            .VerticalPosition = MillimetersToPoints(15)
            .RelativeVerticalPosition = wdRelativeVerticalPositionPage
            .HorizontalDistanceFromText = MillimetersToPoints(0)
            .VerticalDistanceFromText = MillimetersToPoints(0)
            
            .Range.Orientation = wdTextOrientationDownward  '调整页码文字方向
        End With
    End If
  
        ActiveDocument.Sections(计数器).Headers(wdHeaderFooterPrimary) _
        .Range.ParagraphFormat.Borders(wdBorderBottom).LineStyle = wdLineStyleNone     '用于防止页眉出现横线
           
        ActiveDocument.Sections(计数器).Headers(wdHeaderFooterEvenPages) _
        .Range.ParagraphFormat.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
        
        With ActiveDocument.Sections(计数器).Footers(wdHeaderFooterEvenPages).Range.Font
            .Name = "Times New Roman"
            .Size = 9
        End With
   
    Next 计数器

    Application.ScreenUpdating = True  '恢复屏幕刷新
End Sub