Word宏:根据图像比例更改页面方向

问题描述 投票:0回答:1

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

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

我现在要添加的内容:

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

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

  • 如何在将图像添加到文档之前获取图像的宽度/高度/比例(Img.Width似乎不存在于Word中)?我不关心它是什么样的信息,只要它告诉我图像是风景还是肖像。
  • 如何添加手动分页符(Chr(12)只是跳转到下一页而不添加实际的分隔符)?
  • 添加手动分页符也意味着我之后不会使用我的标题文本,但如何为新的“Section”设置它?我猜它还不是ActiveDocument.Sections(1),是吗?

我的代码(只是图像导入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

编辑:

这段代码确实添加了分节符,但它似乎设置了整个文档的方向,而不仅仅是当前节,所以我最终在所有页面上都有相同的方向,而且图像只在最后一节中添加而没有任何页/部分介于两者之间。我该如何解决?

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
vba ms-word orientation
1个回答
0
投票

您无需事先获取图像尺寸。尝试以下方面的事情:

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
© www.soinside.com 2019 - 2024. All rights reserved.