Word宏:根据图像比例更改页面方向
Posted
tags:
篇首语:本文由小常识网(cha138.com)小编为大家整理,主要介绍了Word宏:根据图像比例更改页面方向相关的知识,希望对你有一定的参考价值。
我的宏目前执行以下操作:
它为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
答案
您无需事先获取图像尺寸。尝试以下方面的事情:
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宏:根据图像比例更改页面方向的主要内容,如果未能解决你的问题,请参考以下文章