用VB6进行Autocad的二次开发(原创)

zzyong00 · 发表于 2014-10-20 21:44:00

2、多选增量复制
在实际应用中，有可能同时选择多个文字对象，进行增量复制

31mpcdkrwa2.gif

先发个多选的子程序

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

没有太多变化，直接发代码：

copy

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 iDotPos  0 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

zzyong00 · 发表于 2014-10-20 21:54:00

3、先选择对象再执行命令
在vb中可不可以先选择对象再执行命令呢？当然是可以的，AcadDocument对象有一个PickfirstSelectionSet属性，可以实现这个目的。看代码：

copy

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