删除文字和标注和创建面域并移动

dogingate

CAD的VBA正在学习中，写了几个小插件
1、AddMenu增加菜单
2、deleteTextAndDimension删除选中的文字和标注
3、readSectionProperties
创建面域并将面域的形心移动到整体坐标系0点

具体代码如下：

Sub AddMenu()
' On Error Resume Next
' ¶¨òåμ±Ç°2Ëμ￥×éμıäá¿
Dim oMenus As AcadPopupMenus
Dim oMyMenu As AcadPopupMenu
Dim strMenuName As String
Dim oMyMenuItem As AcadPopupMenuItem

Set oMenus = ThisDrawing.Application.MenuGroups.Item(0).Menus

On Error Resume Next
Set oMyMenu = oMenus.Item("Wolf")
If oMyMenu Is Nothing Then
    Set oMyMenu = oMenus.Add("Wolf")
End If

If Not oMyMenu.OnMenuBar Then
    oMyMenu.InsertInMenuBar ThisDrawing.Application.MenuBar.count
End If

Set oMyMenuItem = oMyMenu.AddMenuItem(0, "é¾3yÎÄ×Öoí±ê×￠", "-vbarun deleteTextAndDimension ")
Set oMyMenuItem = oMyMenu.AddMenuItem(0, "¸Öêø¶áè¡", "-vbarun deleteTextAndDimension ")
Set oMyMenuItem = oMyMenu.AddMenuItem(0, "½ØÃæìØDÔ", "-vbarun readSectionProperties ")
End Sub


Sub deleteTextAndDimension()
Dim oDrawing As Object: Set oDrawing = ThisDrawing
Dim oUtil As Object: Set oUtil = oDrawing.Utility
Dim oSset As Object

If oDrawing.SelectionSets.count <> 0 Then
    For i = oDrawing.SelectionSets.count - 1 To 0 Step -1
        oDrawing.SelectionSets(i).Delete
    Next i
End If
    Set oSset = ThisDrawing.SelectionSets.Add("TEST_SSET") '&#212;&#246;&#188;ó&#209;&#161;&#212;&#241;&#188;ˉ

Dim FilterType(3) As Integer
Dim FilterData(3) As Variant
FilterType(0) = -4
FilterType(1) = 0
FilterType(2) = 0
FilterType(3) = -4
FilterData(0) = "<OR"
FilterData(1) = "TEXT"
FilterData(2) = "DIMENSION"
FilterData(3) = "OR>"

oSset.SelectOnScreen FilterType, FilterData '''&#212;ú&#198;á&#196;&#187;é&#207;&#189;&#248;DD&#209;&#161;&#212;&#241;
oSset.Highlight ture
oSset.Erase


End Sub

Sub readSectionProperties()
Dim oDraw As ThisDrawing
Dim oSset As AcadSelectionSet
Dim bool As Boolean: bool = False
For Each oSset In ThisDrawing.SelectionSets
    If oSset.Name = "wolf" Then
        bool = True
    End If
Next
If bool Then
    Set oSset = ThisDrawing.SelectionSets.Item("wolf")
    oSset.Delete
End If
Set oSset = ThisDrawing.SelectionSets.Add("wolf")

oSset.SelectOnScreen

Dim ents() As AcadEntity: ReDim ents(oSset.count - 1)
For i = 0 To oSset.count - 1
    Set ents(i) = oSset(i)
Next i

'oSset.Delete

Dim varRegions As Variant

varRegions = ThisDrawing.ModelSpace.AddRegion(ents)

temp = 0
k = 0
For i = LBound(varRegions) To UBound(varRegions)
    If varRegions(i).Area > temp Then
        k = i
        temp = varRegions(i).Area
    End If
Next i

Dim oReg As Object
For i = LBound(varRegions) To UBound(varRegions)
    If i <> k Then
        varRegions(k).Boolean acSubtraction, varRegions(i)
    End If
Next i

Dim varCentroid As Variant
varCentroid = varRegions(k).Centroid

Set oReg = varRegions(k)
Dim pt1(0 To 2) As Double
Dim pt2(0 To 2) As Double
pt1(0) = varCentroid(0): pt1(1) = varCentroid(1): pt1(2) = 0
pt2(0) = 0: pt2(1) = 0: pt2(2) = 0


'Dim varPt1 As Variant
'Dim varPt2 As Variant
'
'varPt1 = ThisDrawing.Utility.GetPoint(, vbCrLf & "Base point: ")
'varPt2 = ThisDrawing.Utility.GetPoint(varPt1, vbCrLf & "Second point: ")
'oReg.Move varPt1, varPt2

oReg.Move pt1, pt2
oReg.Update

End Sub