在实际应用中，有可能同时选择多个文字对象，进行增量复制
先发个多选的子程序
Private Sub SelectLots(ByVal Ssetname As String, _
ByVal objName As String, _
Optional strPrompt As String = "请选择单行文本，可以框选" & vbCrLf)
'Ssetname 新建选择集的名
'objName 要选择对象的名，可以文字对象，也可以是直线或其它任何acad实体
'strPrompt 选择时提示的文字
Dim sSetObj As AcadSelectionSet, flag As Boolean
For Each sSetObj In ThisDrawing.SelectionSets
If sSetObj.name = Ssetname Then
flag = True
Exit For
End If
Next
If flag Then sSetObj.Delete '创建集合，如集存在，则删除，新建
Set sSetObj = ThisDrawing.SelectionSets.Add(Ssetname)
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
gpCode(0) = 0
dataValue(0) = objName
Dim groupCode As Variant, dataCode As Variant
groupCode = gpCode
dataCode = dataValue
ThisDrawing.Utility.Prompt strPrompt
sSetObj.SelectOnScreen groupCode, dataCode
End Sub
没有太多变化，直接发代码：
Public Sub CopyTextIncrement2() '增量复制,多选模式
Dim strSsetname As String, objTextArr() As AcadText, i As Long
strSsetname = "MEA~CopyTextIncrement2"
SelectLots strSsetname, "TEXT"
If ThisDrawing.SelectionSets(strSsetname).Count = 0 Then Exit Sub
On Error GoTo Err2
ReDim objTextArr(ThisDrawing.SelectionSets(strSsetname).Count - 1)
For i = 0 To ThisDrawing.SelectionSets(strSsetname).Count - 1
Set objTextArr(i) = ThisDrawing.SelectionSets(strSsetname).Item(i)
Next i
Dim IncreaseNum As Double
IncreaseNum = ThisDrawing.Utility.GetReal("请输入增加量（可以为负,默认为1）：")
If IncreaseNum = 0 Then IncreaseNum = 1
On Error GoTo err1
Dim copyObj As AcadText, pt1, pt2
Dim dx As Double, dy As Double, InsPt(2) As Double
pt1 = ThisDrawing.Utility.GetPoint(, "请指定复制基点：")
Do
pt2 = ThisDrawing.Utility.GetPoint(pt1, "请指定复制到点：")
For i = 0 To UBound(objTextArr)
dx = pt2(0) - pt1(0)
dy = pt2(1) - pt1(1)
Set copyObj = objTextArr(i).Copy()
Dim strText As String, iPos As Integer, iDotPos As Integer, strFormat As String
strText = RTrim(copyObj.TextString)
iPos = Len(strText)
Do While IsNumeric(Mid(strText, iPos))
iPos = iPos - 1
If iPos = 0 Then Exit Do
Loop
If iPos = Len(strText) Then '末尾没有数字
strText = strText & CStr(IncreaseNum)
Else
iDotPos = InStr(iPos + 1, strText, ".", vbTextCompare) '取小数点位置
If iDotPos0 Then '有小数点
strFormat = "#." & String(Len(strText) - iDotPos, "0")
strText = Mid(strText, 1, iPos) & Format(Val((Mid(strText, iPos + 1)) + _
IncreaseNum), strFormat)
Else '无小数点
strText = Mid(strText, 1, iPos) & CStr(Val((Mid(strText, iPos + 1)) + _
IncreaseNum))
End If
End If
InsPt(0) = copyObj.InsertionPoint(0) + dx
InsPt(1) = copyObj.InsertionPoint(1) + dy
copyObj.TextString = strText
copyObj.Move copyObj.InsertionPoint, InsPt
copyObj.Highlight False
Set objTextArr(i) = copyObj
copyObj.Highlight True
Next i
pt1 = pt2
Loop
Exit Sub
err1:
If Not (copyObj Is Nothing) Then copyObj.Highlight False
Debug.Print Err.Description
Err.Clear
Exit Sub
Err2:
Err.Clear
Resume Next
End Sub
3、先选择对象再执行命令
在vb中可不可以先选择对象再执行命令呢？当然是可以的，AcadDocument对象有一个PickfirstSelectionSet属性，可以实现这个目的。看代码：
Private Function getPickFirstSel(Optional strObjName As String = "AcDbText") As _
AcadSelectionSet '选当前选择的text
On Error GoTo err1
Dim objSset As AcadSelectionSet
Dim obj1 As AcadObject, objRemove(0) As AcadObject, i As Integer
Dim iNum As Integer
iNum = 0
Set objSset = ThisDrawing.PickfirstSelectionSet
If objSset.Count > 0 Then
For i = objSset.Count - 1 To 0 Step -1
Set obj1 = objSset.Item(i)
If StrComp(obj1.ObjectName, strObjName, vbTextCompare) = 0 Then
iNum = iNum + 1
Else
Set objRemove(0) = obj1 '如果不是文字，就从选集中删除
objSset.RemoveItems objRemove '这里必须是数组(变体)
End If
Next i
End If
If iNum > 0 Then
Set getPickFirstSel = objSset
Else
Set getPickFirstSel = Nothing
End If
Exit Function
err1:
Set getPickFirstSel = Nothing
‘Debug.Print Err.Number, Err.Description
Err.Clear
End Function 另外说一点Autocad的小知识，知道的同志请忽略，对于不支持先选择后执行命令的命令，也可以先选择后执行，方法是：（1），选择你要选择的对象
（2），执行命令，选择对象之前按p键，回车就可以了 很好很强大 学习学习
页:
1
[2]