Макрос слова: установка ориентации страницы после разрыва раздела

Question

Этот вопрос о новой проблеме, которая возникла, когда я пытался добавить что-то к работе, я уже задавал вопрос о.

Что я хочу, чтобы мой макрос делал / что он уже делает:

• Добавить заголовок к документу 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

Answer 1

Вот код концепции, основанный на размещении изображений в таблицах.Привычка, которую я приобрел в результате длительного использования Word.

В настоящий момент ключевое слово ParseName не распознается, хотя я добавил ссылку на Microsoft Shell и т. Д. И т. Д.

Не разрыв страницыв поле зрения, поскольку они не нужны.

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