Word VBA 将图像和文本移动到 Table

Question

我正在尝试检查文档的每个部分是否有图像或分组图像，如果找到它们，则在该部分的开头创建一个包含 1 行 2 列的 table，其中第一列将包含文本（具有原始格式），第二列将包含图像。我已将文档中的所有图像转换为内联形状。

编辑：在文档中，在随机数量的图像之前、之后和之间有随机数量的文本（and/or 其他字符）。有时一个部分没有文字，只有图像。对于每个部分，我希望所有文本（具有原始格式和出现顺序）包含在第一列中，所有图像和分组图像（也按相同顺序）包含在第二个文件夹。理想情况下，如果页面上只有标题和图片，它们将被放入 1x1 table（标题在图片上方）。

我尝试了一些变体，但都没有成功。一般来说，事情开始变得非常混乱，因为我不知道自己在做什么。我在这段代码中省略了文本，因为它只会使事情复杂化，但我也想移动文本。

Sub ToTables()

Dim iShp As InlineShape
Dim oRng As Range
Dim oTbl As Table
Dim i As Integer
Dim a As Integer
Dim b As Integer

a = ActiveDocument.BuiltInDocumentProperties("Number of Sections")
    
For i = 1 To a

Set oRng = ActiveDocument.GoTo(What:=wdGoToSection, Name:=i)
Set oRng = oRng.GoTo(What:=wdGoToBookmark, Name:="\section")

If Right(oRng, 1) = vbCr Then _
        oRng = Left(oRng, Len(oRng) - 1)

b = oRng.InlineShapes.Count
If b >= 1 Then
    oRng.Collapse Direction:=wdCollapseStart
        Set oTbl = oRng.Tables.Add(oRng, 1, 2, AutoFitBehavior:=wdAutoFitContent)
        For Each iShp In oRng.InlineShapes
            iShp.Select
            Selection.Cut
            oTbl.Cell(1, 2).Range.Paste
        Next iShp
End If
Next i
End Sub

谢谢

Answer 1

假设文本位于内联形状之前：

Sub Demo()
Application.ScreenUpdating = False
Dim iShp As InlineShape
For Each iShp In ActiveDocument.InlineShapes
  With iShp.Range
    .Characters.First.Previous = vbTab
    .Start = .Paragraphs.First.Range.Start
    .ConvertToTable vbTab, 1, 2
  End With
Next
Application.ScreenUpdating = True
End Sub

以上代码假定文本和内联图形之间只有一个字符。该字符可以是 space、分段符、换行符，任何东西。

Answer 2

尝试修改后的代码：

Sub Demo()
Application.ScreenUpdating = False
Dim Sctn As Section, Rng As Range, Tbl As Table, s As Long, w As Single
For Each Sctn In ActiveDocument.Sections
  Set Rng = Sctn.Range: w = 0
  Rng.End = Rng.End - 1
  Set Tbl = Rng.ConvertToTable(, NumRows:=1, NumColumns:=1, InitialColumnWidth:=50, AutoFit:=True)
  With Tbl
    .Columns.Add
    For s = .Range.InlineShapes.Count To 1 Step -1
      With .Range.InlineShapes(s)
        If .Width > w Then w = .Width
        .Range.Rows(1).Cells(2).Range.FormattedText = .Range.FormattedText
        .Delete
      End With
    Next
    .Columns(1).Cells.Merge
    .Columns(2).Cells.Merge
    .PreferredWidthType = wdPreferredWidthPercent
    .PreferredWidth = 100
    If w > 0 Then .Columns(2).Width = w + .LeftPadding + .RightPadding
    .Rows.HeightRule = wdRowHeightAuto
  End With
Next
Application.ScreenUpdating = True
End Sub

Word VBA 将图像和文本移动到 Table

Word VBA Move Images and Text into a Table

vba

ms-word