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

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

帮忙看一下我这个程序，刚一运行，就显示“当前范围内的声明重复”，这是在
AutoCAD中加载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:32

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:30

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

页: [1]

明经CAD社区's Archiver

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