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

sdgxzxh · 发表于 2012-10-20 17:39

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

sdgxzxh · 发表于 2012-10-28 21:12

经过奋战，有了初步的答案，不知道是否存在错误，请版主指点
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 · 发表于 2019-12-3 21:56

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

13032383987 · 发表于 2019-12-4 19:06

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

13032383987 · 发表于 2019-12-4 19:31

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

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

xkqtdzj · 发表于 2019-12-12 11:59

本帖最后由 xkqtdzj 于 2019-12-12 12:00 编辑

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

19820713chen · 发表于 2019-12-15 16:50

感谢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 · 发表于 2019-12-19 14:19

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

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

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

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

19820713chen · 发表于 2019-12-19 18:43

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

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

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

19820713chen · 发表于 2019-12-19 18:45

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

		自动登录	找回密码
密码			免费注册

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

评分