沙漠骆驼工具箱源码-2标注操作

woxing1987

文本操作1，界面和代码如下：
1 界面：


2代码如下：

''''每个click事件的后面注释了当前按钮的名称

Dim filtertype() As Integer '定义选择过滤器类型的dsf组码， 动态数组
Dim filterdata() As Variant '定义过滤器的值，为动态数组
Dim sset1 As AcadSelectionSet




Private Sub CommandButton1_Click() '标注文字替换
    Me.Hide
    On Error Resume Next
    'quxiao '调用取消命令
   
    ReDim filtertype(0)
    ReDim filterdata(0)
    filtertype(0) = 0
    filterdata(0) = "dimension"
    Set sset1 = ThisDrawing.SelectionSets.Add("ss1")
    If Err.Number <> 0 Then
        Err.Clear
        Set sset1 = ThisDrawing.SelectionSets.Item("ss1")
        sset1.Clear
    End If
    ThisDrawing.Utility.prompt ("请拾取标注:")
    sset1.SelectOnScreen filtertype, filterdata
    If sset1.count = 0 Then
        ThisDrawing.Utility.prompt "-------选择失败-------by沙漠骆驼-------" & vbCrLf
        Me.show
        Exit Sub
    End If
    Dim biaozhuoverride As String
    biaozhuoverride = ThisDrawing.Utility.GetString(False, "请输入替换文字:")
    Dim biaozhu As AcadEntity
    For Each biaozhu In sset1
        biaozhu.TextOverride = biaozhuoverride
    Next
    Me.show
End Sub


Private Sub CommandButton13_Click() '取消标注关联
    Me.Hide
    On Error Resume Next
    'quxiao '调用取消命令
    ReDim filtertype(0)
    ReDim filterdata(0)
    filtertype(0) = 0
    filterdata(0) = "dimension"
    Set sset1 = ThisDrawing.SelectionSets.Add("ss1")
    If Err.Number <> 0 Then
        Err.Clear
        Set sset1 = ThisDrawing.SelectionSets.Item("ss1")
        sset1.Clear
    End If
    ThisDrawing.Utility.prompt ("请框选对象以过滤标注:")
    sset1.SelectOnScreen filtertype, filterdata
    If sset1.count = 0 Then
        ThisDrawing.Utility.prompt "-------选择失败-------by沙漠骆驼-------" & vbCrLf
        Me.show
        Exit Sub
    End If
  
    ThisDrawing.SendCommand "move" & vbCr & "SELECT" & vbCr & "p" & vbCr & vbCr & _
                "(command (list 0 0))" & vbCr & "(command (list 5 5))" & vbCr
   
    ThisDrawing.SendCommand "move" & vbCr & "SELECT" & vbCr & "p" & vbCr & vbCr & _
                "(command (list 5 5))" & vbCr & "(command (list 0 0))" & vbCr
    sset1.Clear
    sset1.Delete
    Me.show
End Sub


Private Sub CommandButton3_Click() '刷标注
    Me.Hide
    On Error Resume Next
    'quxiao '调用取消命令
    ReDim filtertype(4)
    ReDim filterdata(4)
    filtertype(0) = -4
    filterdata(0) = "<or"
    filtertype(1) = 0
    filterdata(1) = "text"
    filtertype(2) = 0
    filterdata(2) = "mtext"
    filtertype(3) = 0
    filterdata(3) = "dimension"
    filtertype(4) = -4
    filterdata(4) = "or>"
    Dim wenben1 As AcadEntity
    Dim basepnt As Variant
    ThisDrawing.Utility.GetEntity wenben1, basepnt, "请选择源标注文本:"
    If Err Then
        Me.show
        Exit Sub
    End If
    Dim strtext As String
    If wenben1.ObjectName <> "AcDbText" And wenben1.ObjectName <> "AcDbMText" Then
        If wenben1.TextOverride = "" Then
            strtext = str(wenben1.Measuremen)
        Else
            strtext = wenben1.TextOverride
        End If
    Else
        strtext = wenben1.textstring
    End If
    Set sset1 = ThisDrawing.SelectionSets.Add("ss1")
    If Err.Number <> 0 Then
        Err.Clear
        Set sset1 = ThisDrawing.SelectionSets.Item("ss1")
        sset1.Clear
    End If
    ThisDrawing.Utility.prompt ("请框选要更新的标注:")
    sset1.SelectOnScreen filtertype, filterdata
    If sset1.count = 0 Then
        ThisDrawing.Utility.prompt "-------选择失败-------by沙漠骆驼-------" & vbCrLf
        Me.show
        Exit Sub
    End If
    For Each wenben1 In sset1
        If wenben1.ObjectName <> "AcDbText" And wenben1.ObjectName <> "AcDbMText" Then
            wenben1.TextOverride = strtext
        Else
            wenben1.textstring = strtext
        End If
    Next
    sset1.Delete
    Me.show
End Sub




Private Sub CommandButton2_Click() '标注恢复
'使用用户的字符串来代替计算出的标注值。可以通过设置文本为空字符串("")来恢复计算的标注值。
'用户可使用一对括号(<>)来附加或预先设定文字到主标注值以显示该值。 当字符串显示出来时，
'主标注值将替换括号。例如，当标注值为3.5时，用TextString = "<> mm"，将会显示为"3.5 mm" 。
'可以用方括号( [] )来包含换算标注值。
    Me.Hide
    On Error Resume Next
    'quxiao '调用取消命令
    ReDim filtertype(0)
    ReDim filterdata(0)
    filtertype(0) = 0
    filterdata(0) = "dimension"
    Set sset1 = ThisDrawing.SelectionSets.Add("ss1")
    If Err.Number <> 0 Then
        Err.Clear
        Set sset1 = ThisDrawing.SelectionSets.Item("ss1")
        sset1.Clear
    End If
    ThisDrawing.Utility.prompt ("请框选要恢复原值的标注:")
    sset1.SelectOnScreen filtertype, filterdata
    If sset1.count = 0 Then
        ThisDrawing.Utility.prompt "-------选择失败-------by沙漠骆驼-------" & vbCrLf
        Me.show
        Exit Sub
    End If
    Dim wenben1 As AcadEntity
    For Each wenben1 In sset1
        wenben1.TextOverride = ""
    Next
    Me.show
End Sub


Private Sub CommandButton8_Click() '标注求和
    Me.Hide
    On Error Resume Next
    quxiao '调用取消命令
    ReDim filtertype(0)
    ReDim filterdata(0)
    filtertype(0) = 0
    filterdata(0) = "dimension"
    Set sset1 = ThisDrawing.SelectionSets.Add("ss1")
    If Err.Number <> 0 Then
        Err.Clear
        Set sset1 = ThisDrawing.SelectionSets.Item("ss1")
        sset1.Clear
    End If
    ThisDrawing.Utility.prompt ("请框选要求和的标注文本:")
    sset1.SelectOnScreen filtertype, filterdata
    If sset1.count = 0 Then
        ThisDrawing.Utility.prompt "-------选择失败-------by沙漠骆驼-------" & vbCrLf
        Me.show
        Exit Sub
    End If
    Dim qiuhe As Double
    Dim wenben1 As AcadEntity
    For Each wenben1 In sset1
        qiuhe = qiuhe + wenben1.Measurement
    Next
    Dim qiuhetext As AcadText
    Dim ppt1 As Variant
    ppt1 = ThisDrawing.Utility.GetPoint(, "请拾取插入点:")
    Set qiuhetext = ThisDrawing.ModelSpace.AddText(Format(Trim(str(qiuhe)), "0.000"), ppt1, sset1.Item(0).TextHeight)
    sset1.Delete
    Me.show


End Sub


Private Sub CommandButton9_Click() '标注求积
    Me.Hide
    On Error Resume Next
    quxiao '调用取消命令
    ReDim filtertype(0)
    ReDim filterdata(0)
    filtertype(0) = 0
    filterdata(0) = "dimension"
    Set sset1 = ThisDrawing.SelectionSets.Add("ss1")
    If Err.Number <> 0 Then
        Err.Clear
        Set sset1 = ThisDrawing.SelectionSets.Item("ss1")
        sset1.Clear
    End If
    ThisDrawing.Utility.prompt ("请框选要求积的标注文本:")
    sset1.SelectOnScreen filtertype, filterdata
    If sset1.count = 0 Then
        ThisDrawing.Utility.prompt "-------选择失败-------by沙漠骆驼-------" & vbCrLf
        Me.show
        Exit Sub
    End If
    Dim qiuji As Double
    Dim wenben1 As AcadEntity
    qiuji = 1
    For Each wenben1 In sset1
        qiuji = qiuji * wenben1.Measurement
    Next
    Dim qiujitext As AcadText
    Dim ppt1 As Variant
    ppt1 = ThisDrawing.Utility.GetPoint(, "请拾取插入点:")
    Set qiujitext = ThisDrawing.ModelSpace.AddText(Format(Trim(str(qiuji)), "0.000"), ppt1, sset1.Item(0).TextHeight)
    sset1.Delete
    Me.show


End Sub