如何修复正在遍历图片3次的循环

Question

基本上，我想做的是遍历文档中的所有inlineshapes，将它们转换为图形，选择形状之后的第一段并将其用作标题。

我不知道为什么我的代码在每个inlineshape中循环3次并创建3个不同的标题。

它也从创建第一个标题到最后一个形状的段落开始。

我只尝试过图片，但是如果您有任何建议，我也会在表格中添加代码。

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