Word宏:根据图像比例更改页面方向 [英] Word Macro: Change page orientation depending on image ratio

问题描述

我的宏当前执行以下操作:

My macro currently does the following:

它将标题添加到Word文档，然后从HDD的特定文件夹中读取图像文件，并将它们添加到同一文档中，其名称为图像下方的文件名，并在每个图像后分页.为了确保名称不会被推送到下一页(如果图像占据了整个页面)，我在添加图像和名称之前将底部边距设置为较高的值，然后将边距设置为原始值.这样，图片会更小一些，并为名称留出足够的空间.

It adds a header to a Word document, then reads image files from a specific folder from the HDD and adds them to the same document with the name of the file below the image and a page break after each image. To ensure that the name doesn't get pushed to the next page (if the image fills the whole page), I set the bottom margin to a higher value before adding the image and the name and then set the margin back to the original value. This way the image is a little bit smaller and leaves enough space for the name.

我现在要添加的内容:

根据图像的宽度和高度切换页面方向，并添加手动分页符，因此我可以在同一文档中使用多个方向.

Switch the orientation of the page depending on the images' width and height and add a manual page break, so I can have multiple orientations in the same document.

但是我已经在第一件事上失败了:

But I'm already failing at the first thing:

• 如何在添加图像之前获取图像的宽度/高度/比例 文档(Word中似乎不存在Img.Width)?我不在乎它是什么样的信息，只要它告诉我图像是横向还是纵向即可.
• 如何添加手动分页符(Chr(12)会跳至下一页而不添加实际的分页符)?
• 添加手动分页符还意味着以后不会使用我的标题文本，但是如何为新的"Section"设置标题文本?我猜现在还不是ActiveDocument.Sections(1)，对吗?

• How do I get the width/height/ration of the images before adding them to the document (Img.Width doesn't seem to exist in Word)? I don't care what kind of information it is, as long as it tells me if the image is landscape or portrait.
• How do I add a manual page break (Chr(12) just jumps to the next page without adding an actual break)?
• Adding a manual page break also means that my header text won't be used afterwards but how do I set it for the new "Section"? I'm guessing it's not still ActiveDocument.Sections(1) then, is it?

我的代码(只是图像导入Sub):

My code (just the image import Sub):

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 vertical As Boolean

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

    With ActiveDocument
        bottomMarginOriginal = .PageSetup.BottomMargin
        .PageSetup.BottomMargin = bottomMarginOriginal + Application.CentimetersToPoints(1) 'Add 1cm to margin

        For Each Img In ff
            Select Case Right(Img.name, 4)
                Case ".bmp", ".jpg", ".gif", ".png", "tiff", ".tif"
                    If i <> 0 Then
                        .Characters.Last.InsertBefore Chr(12) 'Add page break before adding the img
                        Debug.Print "Width: " & Img.Width 'Error message: Doesn't exist!
                    Else
                        .Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = "test text"
                        .PageSetup.Orientation = wdOrientLandscape 'TODO: Check the img ratio
                        vertical = False
                    End If

                    i = i + 1
                    .Characters.Last.InlineShapes.AddPicture filename:=Img 'Add the img
                    .Characters.Last.InsertBefore Chr(11) & Img.name 'Add a line break and the img name
            End Select
        Next
    End With
        ActiveDocument.PageSetup.BottomMargin = bottomMarginOriginal
End Sub

此代码确实添加了分节符，但似乎它设置了整个文档的方向，而不仅仅是当前部分，所以我最终在所有页面上都以相同的方向进行操作，并且仅在最后一页添加图像部分之间没有任何页面/部分中断.我该如何解决?

This code does add section breaks but it seems like it sets the orientation for the whole document, not just the current section, so I end up with the same orientation on all pages, plus the images are only added in the very last section without any page/section breaks in between. How do I fix this?

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

推荐答案

您无需事先获取图像尺寸.尝试以下方法:

You don't need to get the image dimensions beforehand. Try something along the lines of:

Sub AddPics()
Application.ScreenUpdating = False
Dim i As Long, StrTxt As String, Rng As Range, vCol
Dim sAspect As Single, sLndWdth As Single, sLndHght As Single
Dim sMgnL As Single, sMgnR As Single, sMgnT As Single, sMgnB As Single, sMgnG As Single
'Select and insert the Pics
With Application.FileDialog(msoFileDialogFilePicker)
  .Title = "Select image files and click OK"
  .Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
  .FilterIndex = 2
  If .Show = -1 Then
    Set vCol = .SelectedItems
  Else
    Exit Sub
  End If
End With
With ActiveDocument
  'Create a paragraph Style with 0 space before/after & centre-aligned
  On Error Resume Next
  .Styles.Add Name:="Pic", Type:=wdStyleTypeParagraph
  With .Styles("Pic").ParagraphFormat
    .Alignment = wdAlignParagraphCenter
    .SpaceAfter = 0
    .SpaceBefore = 0
  End With
  On Error GoTo 0
  With .PageSetup
    sMgnL = .LeftMargin: sMgnR = .RightMargin: sMgnT = .TopMargin: sMgnB = .BottomMargin: sMgnG = .Gutter
  End With
  Set Rng = Selection.Range
  With Rng
    .Paragraphs.Last.Style = "Pic"
    For i = 1 To vCol.Count
      .InsertAfter vbCr
      .Characters.Last.InsertBreak Type:=wdSectionBreakNextPage
      .InlineShapes.AddPicture FileName:=vCol(i), LinkToFile:=False, SaveWithDocument:=True, Range:=.Characters.Last
      'Get the Image name for the Caption
      StrTxt = Split(Split(vCol(i), "\")(UBound(Split(vCol(i), "\"))), ".")(0)
      'Insert the Caption below the picture
      .Characters.Last.InsertBefore Chr(11) & StrTxt
    Next
    .Characters.First.Text = vbNullString
    .Characters.Last.Previous.Text = vbNullString
    For i = 1 To .InlineShapes.Count
      With .InlineShapes(i)
        'Reorient pages for landscape pics
        If .Height / .Width < 1 Then
          With .Range.Sections(1).PageSetup
            .Orientation = wdOrientLandscape
            .LeftMargin = sMgnL: .RightMargin = sMgnR: .TopMargin = sMgnT: .BottomMargin = sMgnB: .Gutter = sMgnG
            sLndWdth = .PageWidth - sMgnL - sMgnR - sMgnG
            sLndHght = .PageHeight - sMgnT - sMgnB
          End With
          .LockAspectRatio = True
          .ScaleHeight = 100
          If .Height > sLndHght Then .Height = sLndHght
          If .Width > sLndWdth Then .Width = sLndWdth
        End If
      End With
    Next
  End With
End With
Application.ScreenUpdating = True
End Sub

这篇关于Word宏:根据图像比例更改页面方向的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！