[求助]为何下面的VBA代码不能完全达到我的要求?

ssq1109

Ku74HEt9.rar (33.34 KB, 下载次数: 9)

2006-11-16 15:32 上传

点击文件名下载附件
[求助]为何下面的VBA代码不能完全达到我的要求?

我本想将文档中的单一文本框（即没有和其他文本框或别的对象组合）中的内容：

①在前后加标记后提取出来（注意：不只是提取其中的文本，是要提取除文本框线内的全部内容，包括字体、字号、上下标、字符颜色等属性，如有插图也要一起提出来）；

②提取后放到该文本框所在段落的那一行；

③提取后删除该单一文本框；

④不要对组合文本框或其他对象起作用（既不提取其中的内容，也不删除它们）

我用下面的代码试了一下，发现下列要解决的问题：

（1）上述①要求达到，但奇怪的是得到多个相同的结果（好像是与文档中文本框数目相同）；

（2）提取出来的内容所放置的位置不准，都到了文首；

（3）程序会同时删除组合文本框、艺术字、文本框和WORD中绘制的插图的组合等，但不会删除插入的点阵图（当然我也不希望删除它）；

（4）如果将代码中的下面一行删除的话，就不能删除想删除的单一文本框

         i.Delete            '删除文本框

我试过几个条件语句，都未达到目的，请高手指点。谢谢！

Sub GetText()

Dim i As Shape
On Error Resume Next
   With ActiveDocument
      For Each i In .Shapes
         i.TextFrame.TextRange.InsertBefore "(Text"  '前插标记
         i.TextFrame.TextRange.InsertAfter "Text)"   '后插标记
         i.TextFrame.TextRange.Cut    '剪切文本框中内容
         i.Delete            '删除文本框
         Selection.Paste     '粘贴文本框中内容
      Next
    End With
End Sub

ssq1109

得到多个相同结果的原因应是For Each i In .Shapes的原因，对每一个i都会Paste一次，但怎样解决这些问题呢？

konggs

SSQ1109兄。看看下面代码行否？

Sub GetText()

Dim i As Shape
Dim arange As Range

On Error Resume Next
Application.ScreenUpdating = False

   With ActiveDocument
      For Each i In .Shapes
        If i.Type = msoTextBox Then
            i.TextFrame.TextRange.InsertBefore "(Text"  '前插标记
            i.TextFrame.TextRange.InsertAfter "Text)"   '后插标记
            i.TextFrame.TextRange.Cut    '剪切文本框中内容
            Set arange = i.Anchor

            i.Delete            '删除文本框
            arange.Paste     '粘贴文本框中内容
        End If
      Next
    End With
Application.ScreenUpdating = True
End Sub

[此贴子已经被作者于2006-11-17 12:23:58编辑过]

ssq1109

非常谢谢孔兄！我要好好学习您的限定条件的方法和锁定段落的方法。

第一次测试时我还以为提取后文本所置位置不准，因总是还在文首。后查看附件中的第一个文本框的嵌入方式为“浮于文字上方”，将其改为别的方式后正确。