[更新]-[CAD/VBA]计算选定区域面积 - 石陆软件屋

Dim adText As AcadText
    Dim adSS As AcadSelectionSet
    Dim fType(0 To 1) As Integer, fData(0 To 1)
    Dim i As Integer
        If lstFile.ListCount = 0 Then
        MsgBox "请添加所要操作的图形！"
        Exit Sub
    End If

    '打开图形进行操作
    For i = 0 To lstFile.ListCount
        Application.Documents.Open lstFile.List(i)

        On Error Resume Next
        frmMain.Hide
        '创建新选择集
        Set adSS = ThisDrawing.SelectionSets.Add("adSS")
        If Err Then Set adSS = ThisDrawing.SelectionSets.Add("adSS")
        adSS.Clear

        fType(0) = 0: fData(0) = "TEXT": fType(1) = 8: fData(1) = "*"
        adSS.Select acSelectionSetAll, , , fType, fData
    请高手解释上述代码的选择集如何控制
******************************************************************

Dim adText As AcadText
    Dim adMText As AcadMText
    Dim adSS As AcadSelectionSet
    Dim fType(0 To 1) As Integer, fData(0 To 1)
    Dim i As Integer

    If txtFind.Text = "" Or txtReplace.Text = "" Then
        MsgBox "输入所要替换的字符串内容！"
        Exit Sub
    End If
    If lstFile.ListCount = 0 Then
        MsgBox "请添加所要操作的图形！"
        Exit Sub
    End If

    '获得替换数据
    Dim strFind As String
    Dim strReplace As String
    strFind = txtFind
    strReplace = txtReplace

    '打开图形进行操作
    For i = 0 To lstFile.ListCount
        Application.Documents.Open lstFile.List(i)

        On Error Resume Next
        frmMain.Hide
        '创建新选择集
        Set adSS = ThisDrawing.SelectionSets.Add("adSS")
        If Err Then Set adSS = ThisDrawing.SelectionSets.Add("adSS")
        adSS.Clear

        fType(0) = 0: fData(0) = "TEXT": fType(1) = 8: fData(1) = "*"
        adSS.Select acSelectionSetAll, , , fType, fData
        '对单行文字完成多重文字替换
        For Each adText In adSS
            With adText
                If InStr(.TextString, strFind) Then .TextString = ReplaceStr(.TextString, strFind, strReplace, False)
            End With
        Next adText

        adSS.Clear
        fType(0) = 0: fData(0) = "MTEXT": fType(1) = 8: fData(1) = "*"
        adSS.Select acSelectionSetAll, , , fType, fData
        '对多行文字完成多重文字替换
        For Each adMText In adSS
            With adMText
                If InStr(.TextString, strFind) Then .TextString = ReplaceStr(.TextString, strFind, strReplace, False)
            End With
        Next adMText

        adSS.Delete
        ThisDrawing.Regen acAllViewports

        '关闭图形
        Application.ActiveDocument.Close True, lstFile.List(i)
    Next i

******************************************************************

Dim file As String
file = "e:\experimentation\EV-012.dwg"
Dim tttstr As String
Dim adss As AcadSelectionSe
mycad.Documents.Open file
Set adss = mycad.ActiveDocument.SelectionSets.Add("adss")
If Err Then Set adss = mycad.ActiveDocument.SelectionSets.Add("adss")
adss.Clear
Dim ftype(0 To 1) As Integer
Dim fdata(0 To 1) As Integer
ftype(0) = 0: fdata(0) = "text": ftype(1) = 8: fdata(1) = "*"
adss.Select acSelectionSetAll, , , ftype, fdata
Dim obj
Dim adtext As AcadText
  Dim find As String
  find = "123"
For Each adtext In adss
if adtext= find then
adtext.ScaleFactor = 1#
end if
next

*******************************************************************

Private Sub CommandButton1_Click()
On Error Resume Next
Dim FilterType(0) As Integer
Dim FilterData(0) As Variant
Dim AcadText As AcadEntity
Dim Sep As Integer
Dim Num As Integer
'设定条件
Dim AddText As AcadText
    FilterType(0) = 8
    FilterData(0) = "ZH"
    Dim Sset As AcadSelectionSet
                '安全创建选择集
        Do While ThisDrawing.SelectionSets.Count > 0
            ThisDrawing.SelectionSets.Item(0).Delete
        Loop

        Set Sset = ThisDrawing.SelectionSets.Add("sse1")
        Sset.Select acSelectionSetAll, , , FilterType, FilterData
            For Each AcadText In Sset
                'MsgBox TypeName(AcadText)
                If TypeName(AcadText) = "IAcadText" Then
                    Sep = InStr(AcadText.TextString, "+")
                    If Sep <> 0 Then
                        AcadText.TextString = Left(AcadText.TextString, Sep - 1) & "+" & Format(Mid(AcadText.TextString, Sep + 1), "0")

                        Num = Num + 1
                    Else
                        AcadText.TextString = Format(AcadText.TextString, "0")
                        Num = Num + 1
                    End If
                End If
            Next
            MsgBox "一共修改了" & Num & "个", vbExclamation, "谢谢使用"
        'Sset.Erase
        Sset.Delete

End Sub

[阅读字体大小: 大中小]

引用通告地址 (0)：
复制引用地址

http://www.cnng.net/blog/trackback.asp?tbID=77
复制引用地址

http://www.cnng.net/blog/trackback.asp?tbID=77&CP=GBK