在文本框中提取文本

问题描述

我对VBA编码还很陌生，我正尝试在文本框中提取文本，并将文本框文本插入范围段之前。

这是我到目前为止想到的：

Private Sub Document_New()
   Dim shp As Shape
   Dim oRngAnchor As Range
   Dim sstring As String
   For Each shp In ActiveDocument.Shapes
       If shp.Type = msoTextBox Then
            shp.Select
            Selection.ShapeRange.TextFrame.TextRange.Select
           sstring = Left(shp.TextFrame.TextRange.Text,_
             shp.TextFrame.TextRange.Characters.Count - 1)
           If Len(sstring) > 0 Then
               Set oRngAnchor = shp.Anchor.Paragraphs(1).Range
               oRngAnchor.InsertBefore _
                 "*" & sstring & "*"
           End If
           shp.Delete
       End If
   Next shp
End Sub

但是它会跳过此处和此处的某些文本框，请检查并让我知道是否可以从所有文本框中提取文本。

我们非常感谢您的协助。

谢谢。

解决方法

请尝试下一个代码。当在形状之间进行迭代并在迭代过程中删除其中之一时，形状参考将丢失。形状必须在末尾删除。除此之外，无需选择：

Sub takeTextFromTextBoxes()
   Dim shp As Shape,oRngAnchor As Range,sString As String
   Dim shpR As ShapeRange,arrShp As Variant,k As Long,i As Long 'new declarations
   
   ReDim arrShp(ActiveDocument.Shapes.Count)
   For Each shp In ActiveDocument.Shapes
       i = i + 1
       If shp.Type = msoTextBox Then
           sString = Left(shp.TextFrame.TextRange.Text,_
             shp.TextFrame.TextRange.Characters.Count - 1)
           If Len(sString) > 0 Then
               Set oRngAnchor = shp.Anchor.Paragraphs(1).Range
               oRngAnchor.InsertBefore "*" & sString & "*"
           End If
           arrShp(k) = i: k = k + 1
       End If
   Next shp
   ReDim Preserve arrShp(k - 1)
   Set shpR = ActiveDocument.Shapes.Range(arrShp)
   shpR.Delete
End Sub