Как исправить петлю, которая проходит через картинки 3 раза - PullRequest
Новая
       5

Как исправить петлю, которая проходит через картинки 3 раза

0 голосов
/ 14 февраля 2019

По сути, я пытаюсь перебрать все встроенные формы в документе, преобразовать их в рисунки, выбрать первый абзац после формы и использовать его в качестве заголовка.

Я не могувыяснить, почему мой код перебирает каждую строчку 3 раза и создает 3 разных заголовка.

Он также начинается с создания первого заголовка с абзацем из последней фигуры.

У меня есть толькопопробовал с картинками, но я дам код для таблиц, если у вас есть какие-либо предложения.

Screenshot of what is happening

Sub ApplyCaptions()
Application.ScreenUpdating = True
Dim oCap As CaptionLabel, bCap As Boolean, iShp As InlineShape, oTbl As Table, TmpRng As Range, strCaption As String, i As Integer, Rng As Range
  With ActiveDocument
  For Each iShp In .InlineShapes
    Set TmpRng = iShp.Range.Paragraphs.First.Range
    With TmpRng
       If .Style = "Caption" Then bCap = ChkCaption(TmpRng)
       If .Paragraphs.Last.Next.Range.Style = "Caption" And bCap = False Then
            bCap = ChkCaption(TmpRng)
       End If
       If bCap = False Then
        With ActiveDocument.InlineShapes
            For i = 1 To .Count
                With .Item(i)
                    If .Type = wdInlineShapePicture Then
                        Set Rng = .Range.Paragraphs(1).Range
                        With Rng
                        Do
                            .Collapse wdCollapseEnd
                            .MoveEnd wdParagraph
                        Loop While Len(Trim(.Text)) = 1 And .End < .Document.Content.End
                            strCaption = Rng.Text
                        End With
                        iShp.Range.InsertCaption Label:="Figure", TitleAutoText:="", _
                        Title:=strCaption, Position:=wdCaptionPositionBelow, ExcludeLabel:=0
                    End If
                        strCaption = ""
                End With
            Next i
        End With
    End If
  End With
  Next
  For Each oTbl In .Tables
        Set TmpRng = oTbl.Range.Paragraphs.Last.Range
        With TmpRng
          If .Style = "Caption" Then bCap = ChkCaption(TmpRng)
          If .Paragraphs.Last.Next.Range.Style = "Caption" And bCap = False Then
            bCap = ChkCaption(TmpRng)
          End If
          If bCap = False Then
            oTbl.Range.InsertCaption Label:="Table", TitleAutoText:="", _
              Title:="", Position:=wdCaptionPositionBelow, ExcludeLabel:=0
          End If
        End With
  Next
  End With
  Set TmpRng = Nothing
  Application.ScreenUpdating = False
End Sub

Function ChkCaption(TmpRng As Range) As Boolean
Dim oCap As CaptionLabel
ChkCaption = False
For Each oCap In CaptionLabels
  If InStr(TmpRng.Text, CaptionLabels(oCap)) > 0 Then
ChkCaption = True
Exit For
  End If
Next
End Function
...