时间戳

首页 > 解决方案 > Word 宏：在分节符后设置页面方向

vba - Word 宏：在分节符后设置页面方向

问题描述

这个问题是关于一个新问题，当我试图增加一些工作时，我已经问过一个问题。

我希望我的宏做什么/它已经在做什么：

为了确保名称不会被推送到下一页（如果图像填满整个页面），我在添加图像和名称之前将底部边距设置为更高的值，然后将边距设置回原始值. 这样图像会小一点，并为名称留出足够的空间。

我的代码（见下文）确实添加了分节符，但似乎它设置了整个文档的方向，而不仅仅是当前部分，所以我最终在所有页面上都具有相同的方向。图像也只添加在最后一个部分，中间没有任何分页/分节符。

我该如何解决？

在另一个问题中，有人已经发布了完整的代码来设置方向，但我更愿意理解为什么我的代码不能按预期工作，而只是复制别人完全不同的代码。

我的代码：

Sub ImportImages(path As String)
    Dim fs As Object
    Dim ff As Variant
    Dim img As Variant
    Dim i As Long
    Dim fsize As Long
    Dim bottomMarginOriginal As Single
    Dim topMarginOriginal As Single
    Dim vertical As Boolean

    Dim objShell As New Shell
    Dim objFolder As Folder
    Dim objFile As ShellFolderItem

    Dim width As Integer
    Dim height As Integer

    Set fs = CreateObject("Scripting.FileSystemObject")
    Set ff = fs.GetFolder(path).Files
    i = 0
    fsize = ff.Count
    vertical = True
    Set objFolder = objShell.NameSpace(path)

    With ActiveDocument
        bottomMarginOriginal = .PageSetup.BottomMargin
        topMarginOriginal = .PageSetup.TopMargin

        For Each img In ff
            Select Case Right(img.name, 4)
                Case ".bmp", ".jpg", ".gif", ".png", "tiff", ".tif"
                    Set objFile = objFolder.ParseName(img.name)
                    width = objFile.ExtendedProperty("{6444048F-4C8B-11D1-8B70-080036B11A03} 3")
                    height = objFile.ExtendedProperty("{6444048F-4C8B-11D1-8B70-080036B11A03} 4")

                    If width > height Then
                        If vertical = False Then 'Already landscape -> just add page break
                            .Characters.Last.InsertBefore Chr(12)
                        Else 'Set to landscape
                            Selection.InsertBreak Type:=wdSectionBreakNextPage
                            .PageSetup.Orientation = wdOrientLandscape
                            .PageSetup.TopMargin = topMarginOriginal 'Adjust margins to new orientation
                            .PageSetup.RightMargin = bottomMarginOriginal
                            .PageSetup.BottomMargin = bottomMarginOriginal
                            .PageSetup.LeftMargin = bottomMarginOriginal
                            .Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = "test " & i 'Set header
                            vertical = False
                        End If
                    ElseIf height > width Then
                        If vertical = True Then 'Already portrait -> just add page break on page 2+
                            If i <> 0 Then
                                .Characters.Last.InsertBefore Chr(12)
                            End If
                        Else 'Set to portrait
                            Selection.InsertBreak Type:=wdSectionBreakNextPage
                            .PageSetup.Orientation = wdOrientPortrait
                            .PageSetup.TopMargin = topMarginOriginal 'Adjust margins to new orientation
                            .PageSetup.RightMargin = bottomMarginOriginal
                            .PageSetup.BottomMargin = bottomMarginOriginal
                            .PageSetup.LeftMargin = bottomMarginOriginal
                            .Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = "test " & i 'Set header
                            vertical = True
                        End If
                    Else
                        If i <> 0 Then
                            .Characters.Last.InsertBefore Chr(12) 
                        End If
                    End If

                    .PageSetup.BottomMargin = bottomMarginOriginal + Application.CentimetersToPoints(1) 'Add 1cm to the bottom margin
                    i = i + 1
                    .Characters.Last.InlineShapes.AddPicture filename:=img
                    .Characters.Last.InsertBefore Chr(11) & img.name
                    .PageSetup.BottomMargin = bottomMarginOriginal 'Reset bottom margin to default
            End Select
        Next
    End With
End Sub

标签： vbams-wordorientation

解决方案

这是基于将图像放入表格的概念代码。我从长期使用 Word 中养成的习惯。

目前，即使我添加了对 Microsoft Shell 等的引用，也无法识别 ParseName 关键字。

因为不需要它们，所以看不到分页符。

Option Explicit

Const PortraitPictureHeight                 As Long = 0 ' change to cm value
Const PortraitTextHeight                    As Long = 0 ' change to a cm value
Const LandscapePictureHeight                As Long = 0 ' change to a cm value
Const LandscapeTextHeight                   As Long = 0 ' change to a cm value
Const HeightOfLineAfterTable                 As Long = 0 ' change to a points


Sub test()

ImportImages "C:\\Users\\slayc\\Pictures"

End Sub
Sub ImportImages(path As String)

    Dim fs                      As Scripting.FileSystemObject
    Dim ff                      As Variant
    Dim img                     As Variant

    Dim objShell                As Shell
    Dim objFolder               As Folder
    Dim objFile                 As ShellFolderItem

    Dim width                   As Long
    Dim height                  As Long


    Set fs = New Scripting.FileSystemObject
    Set ff = fs.GetFolder(path).Files

    Set objShell = New Shell
    Set objFolder = objShell.NameSpace(path)

    ' The assumption is that we are adding sections to the end of the document
    ' so we add the Heder to the last document
    ' this header will be copied to each section we add to the document
    ' when we use Activedocument.sections.add
    ActiveDocument.Sections.Last.Headers(wdHeaderFooterPrimary).Range.Text = "This is your header"

    For Each img In ff

        If InStr(".bmp,.jpg,.gif,.png,.tiff", Right(img.Name, 4)) = 0 Then GoTo Continue_img
        Set objFile = objFolder.ParseName(img.Name)
        width = objFile.ExtendedProperty("{6444048F-4C8B-11D1-8B70-080036B11A03} 3")
        height = objFile.ExtendedProperty("{6444048F-4C8B-11D1-8B70-080036B11A03} 4")

        ' every image gets its own section with its own orientation
        If width > height Then

            InsertLandscapeSection

        Else

            InsertPortraitSection

        End If

        FormatLastTable

        With ActiveDocument.Sections.Last.Range.Tables(1).Range

.Rows(1).Range.Cells(1).Range.Characters.Last.InlineShapes.AddPicture FileName:=img
                .Rows(2).Range.Cells(1).Range.Text = img.Name

        End With

Continue_img:
    Next

End Sub

Public Sub InsertLandscapeSection()

Dim my_range                    As Word.Range

    With ActiveDocument.Sections

        ' Deal with the case where the first section is the last section
        If .Last.Range.Tables.Count > 0 Then

            .Add
            .Last.Range.Previous(unit:=wdParagraph).Font.Size = HeightOfLineAfterTable

        End If

        .Last.PageSetup.Orientation = wdOrientLandscape

        With .Last

            Set my_range = .Range.Duplicate
            my_range.Collapse direction:=wdCollapseStart
            .Range.Tables.Add my_range, 2, 1

            With .Range.Tables(1).Range

                .Rows.HeightRule = wdRowHeightExactly
                .Rows(1).height = CentimetersToPoints(LandscapePictureHeight)
                .Rows(2).height = CentimetersToPoints(LandscapeTextHeight)

            End With

        End With

    End With

End Sub

Public Sub InsertPortraitSection()

Dim my_range                    As Word.Range

    With ActiveDocument.Sections

        If .Last.Range.Tables.Count > 0 Then

            .Add
            .Last.Range.Previous(unit:=wdParagraph).Font.Size = HeightOfLineAfterTable

        End If

        .Last.PageSetup.Orientation = wdOrientPortrait

        With .Last

            Set my_range = .Range.Duplicate
            my_range.Collapse direction:=wdCollapseStart
            .Range.Tables.Add my_range, 2, 1

            With .Range.Tables(1).Range

                .Rows.HeightRule = wdRowHeightExactly
                .Rows(1).height = CentimetersToPoints(PortraitPictureHeight)
                .Rows(2).height = CentimetersToPoints(LandscapeTextHeight)

            End With

        End With

    End With

End Sub

Sub FormatLastTable()

    With ActiveDocument.Sections.Last.Range.Tables(1)

        ' turn off all borders
        .Borders.Enable = False

        'Do any additional formatting of the table that is not related to row height

    End With


End Sub

推荐阅读