这个问题是关于一个新问题的，当我试图添加一些我已经问过question的工作内容时。
我希望宏执行的操作/已经在执行的操作：
为确保名称不会被推送到下一页（如果图像占据了整个页面），我在添加图像和名称之前将底部边距设置为较高的值，然后将边距设置为原始值。这样，图片会更小，并为名称留出足够的空间。
我的代码（请参阅下文）确实添加了分节符，但似乎它设置了整个文档的方向，而不仅是当前节，因此我在所有页面上都使用相同的方向。图像也仅添加在最后一部分中，而中间没有任何页面/部分中断。
我该如何解决？
在另一个问题中，有人已经发布了完整的代码来设置方向，但是我更愿意理解为什么我的代码不能像复制别人完全不同的代码那样工作。
我的代码：
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
答案 0 :(得分：0)
这里是基于将图像放入表格中的概念代码。我长期使用Word已经养成了习惯。
即使我添加了对Microsoft Shell等的引用，目前ParseName关键字也无法识别。
因为不需要它们，所以看不到分页符。
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