|
|
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") 'Ôö¼óÑ¡Ôñ¼ˉ
Dim FilterType(3) As Integer
Dim FilterData(3) As Variant
FilterType(0) = -4
FilterType(1) = 0
FilterType(2) = 0
FilterType(3) = -4
FilterData(0) = ""
oSset.SelectOnScreen FilterType, FilterData '''ÔúÆáÄ»éϽøDDÑ¡Ôñ
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 |
|
置顶卡
