Word Macro：根据图像比例更改页面方向答案

【问题标题】：Word Macro: Change page orientation depending on image ratioWord Macro：根据图像比例更改页面方向
【发布时间】：2019-03-12 12:34:11
【问题描述】：

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

它会在 Word 文档中添加页眉，然后从 HDD 中的特定文件夹中读取图像文件，并将它们添加到同一个文档中，文件名位于图像下方，每个图像后都有一个分页符。为了确保名称不会被推送到下一页（如果图像填满整个页面），我在添加图像和名称之前将底部边距设置为更高的值，然后将边距设置回原始值.这样图像会更小一些，并为名称留出足够的空间。

我现在要添加的内容：

根据图像的宽度和高度切换页面方向并添加手动分页符，这样我就可以在同一个文档中拥有多个方向。

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

如何在添加图片之前获取图片的宽度/高度/比例到文档（Img.Width 在 Word 中似乎不存在）？我不在乎它是什么信息，只要它告诉我图像是横向还是纵向。
如何添加手动分页符（Chr(12) 只是跳转到下一页而不添加实际分页符）？
添加手动分页符也意味着以后不会使用我的标题文本，但是如何为新的“节”设置它？我猜它还不是ActiveDocument.Sections(1)，是吗？

我的代码（只是图片导入子）：

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

编辑：

此代码确实添加了分节符，但似乎它设置了整个文档的方向，而不仅仅是当前部分，所以我最终在所有页面上都具有相同的方向，而且图像只添加到最后节之间没有任何分页/分节符。我该如何解决这个问题？

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

【问题讨论】：

Img 是一个File object，没有理由让它有一个 Width 属性。不过ShellForlderItem可能有一个扩展属性“Dimensions”，你可以试试看。
@VincentG 哦，抱歉，我对 VBA 还是很陌生。我像 this 一样尝试过，但第一行 (Dim objShell As New Shell) 已经引发了 user-defined type not defined 错误。 Shell 是 VBA for Word 的一部分吗？我知道有些 VBA 类仅适用于 Access，但不适用于 Word。
如果要使用早期绑定，需要在vba编辑器中添加对“Microsoft Shell Controls and Automation”的引用。
@VincentG 啊，谢谢。它现在正在工作，但它返回类似“？1024 x 682？”的东西。（与链接中的问题相同：没有“分辨率”、“垂直分辨率”和“水平分辨率”的信息），我必须为每张图像解析。是否有更快的方法来获取尺寸？我在我的问题中对其进行了编辑：我不在乎我得到了什么（宽度/高度、比例、方向......），只要它以某种方式告诉我图像是横向还是纵向。
您尝试过 SCID 吗？像水平尺寸的“{6444048F-4C8B-11D1-8B70-080036B11A03} 3”或水平分辨率的“{6444048F-4C8B-11D1-8B70-080036B11A03} 5”？

标签： vba ms-word orientation

【解决方案1】：

您无需事先获取图像尺寸。尝试以下方式：

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

【讨论】：

我之前打开了一个 FileDialog 来选择文件夹，然后将路径传递给我的“ImportImages”子。 ;) 我明白你在做什么（我想），所以感谢你的代码！但是，老实说，我宁愿在添加图像之前检查比率，因为之后不会再经历所有事情来调整图像大小（如果我定位页面，然后添加图像，Word 会正确调整它的大小它自己的）需要更长的时间，如果有 20 多张图像（这很有可能），这一点尤其明显？
@Neph 我建议你试试看。时间上的差异几乎不可能是显着的，特别是因为我的代码不必经历为每个页面计算方向的过程。我在笔记本电脑上用 50 张 jpg 图像（大多数是全页横向格式）在 20 秒内进行了测试。
它不需要外壳来检查，这是真的（不确定这如何影响它的性能）但调整图像大小可能会再次平衡它。我可以给你的vCol 我从fs.GetFolder(path).Files 得到的列表吗（我想使用一个文件夹，因为无论如何我必须阅读它来做其他事情）？您的代码如何确保 img 名称不会被推到带有高图像的下一页？我将尝试它，但我也想找出为什么我编辑的代码不能按预期工作以及如何修复它。如果我只是复制你的，我不会从中学到任何东西。