请高手指点一下本人编的小程序

h289990416 · 发表于 2009-5-15 17:42:00

帮忙看一下我这个程序，刚一运行，就显示“当前范围内的声明重复”，这是在
中加载VBA的
谢谢了！


 
Option Explicit
Public Sub MtextToText()
    On Error Resume Next
    
    Dim ptInsert As Variant
    Dim txtStr As String
    Dim height As Double
    Dim width As Double
    
    '选择多行文字*********************************************
    '安全创建选择集
    Dim SSet As AcadSelectionSet
    If Not IsNull(ThisDrawing.SelectionSets.Item("this")) Then
        Set SSet = ThisDrawing.SelectionSets.Item("this")
        SSet.Delete
    End If
    Set SSet = ThisDrawing.SelectionSets.Add("this")
    
    '定义过滤规则
    Dim filterType(0) As Integer
    Dim filterData(0) As Variant
    filterType(0) = 0
    filterData(0) = "Mtext"
    
    SSet.SelectOnScreen filterType, filterData
    
    '创建单行文字***************************************************************
    Dim ptMin As Variant, ptMax As Variant
    Dim objText As AcadText
    Dim objMtext As AcadMText
    
    Dim i, j As Integer
    Dim quantity As Integer            'quantity为Mtext的行数
    Dim TextIndex() As Integer         'TextIndex()记录每行所在的位置
    Dim tmpStr As String
    
    Dim ptMin As Variant, ptMax As Variant    '获得多行文字的位置
    
    For Each objMtext In SSet
        '获得文字的主要参数
      objMtext.GetBoundingBox ptMin, ptMax
        txtStr = objMtext.TextString
        height = objMtext.height
        '找出Mtext共有几行
        quantity = 1
        For i = 1 To Len(Mtext)
           If Mid(Mtext, i, 1) = "\p" Then quantity = quantity + 1
        Next i
    
        '找出每行行首在Mtext的位置
        ReDim TextIndex(quantity)
        TextIndex(0) = 0
        For j = 1 To quantity
            For i = 1 To Len(Mtext)
                If Mid(Mtext, i, 1) = "\p" Then TextIndex(j) = i
            Next i
        Next j
        TextIndex(j) = i
        
        '将Mtext转换为多行Text文字
        For j = 0 To quantity - 1
            tmpStr = Mid(txtStr, TextIndex(j) + 1, TextIndex(i + 1) - TextIndex(i) - 1)
            ptInsert(0) = ptMin(0)
            ptInsert(1) = ptMin(1) + (i + 1) * (ptMax(1) - ptMin(1)) / quantity
            ptInsert(2) = ptMin(2)
            
            Set objText = ThisDrawing.ModelSpace.AddText(tmpStr, ptInsert, height)
       
        '调整单行文字的对齐方式
        objText.InsertionPoint = ptInsert
        objMtext.Delete  '删除文字
    Next
    
    SSet.Delete
End Sub

雪山飞狐_lzh · 发表于 2009-5-15 17:50:00

Dim ptMin As Variant, ptMax As Variant
Dim objText As AcadText
Dim objMtext As AcadMText

Dim i, j As Integer
Dim quantity As Integer 'quantity为Mtext的行数
Dim TextIndex() As Integer 'TextIndex()记录每行所在的位置
Dim tmpStr As String

Dim ptMin As Variant, ptMax As Variant '获得多行文字的位置

h289990416 · 发表于 2009-5-15 17:54:00

这点问题是解决了，谢谢，虽然还是有问题，自己再找找

syk070205 · 发表于 2010-8-3 15:14:00

你的创建选择集可能有问题，您可以看考下面的程序！

''''''安全创建选择集
On Error Resume Next
Dim SSet As AcadSelectionSet
If Not IsNull(docObj.SelectionSets.Item("Example")) Then
Set SSet = docObj.SelectionSets.Item("Example")
SSet.Delete '及时删除不用的选择集非常重要
End If
Set SSet = docObj.SelectionSets.Add("Example")
''''''向选择集中添加实体
SSet.Select acSelectionSetCrossing, ptMin, ptMax
''''''将选择集中的实体添加到数组中
Dim objCollection() As Object
ReDim objCollection(SSet.Count - 1)
Dim i As Integer
For i = 0 To SSet.Count - 1
Set objCollection(i) = SSet.Item(i)
Next i

luna125 · 发表于 2010-12-31 10:20:00

Dim ptMin As Variant, ptMax As Variant
Dim objText As AcadText
Dim objMtext As AcadMText

Dim i, j As Integer
Dim quantity As Integer 'quantity为Mtext的行数
Dim TextIndex() As Integer 'TextIndex()记录每行所在的位置
Dim tmpStr As String

Dim ptMin As Variant, ptMax As Variant '获得多行文字的位置
这个地方重复定义了嘛，
Dim ptMin As Variant, ptMax As Variant
Dim ptMin As Variant, ptMax As Variant '获得多行文字的位置

chmenf087 · 发表于 2010-12-31 17:16:00

提醒一点，Mtext的textstring函数返回值包括格式符号你这样有些Mtext无法转成Text

请高手指点一下本人编的小程序

发表回复

精选推荐