五金模具设计之CAD二次开发用VBA来制做选择集Selection

优胜网络服务

五金模具设计之CAD二次开发用VBA来制做选择集Selection

进行五金模具设计,要想高效率,就离不开软件的智能程度,前面介绍过五金模具设计之在CAD中用VBA来实现多义线的串接,今天我们来学习一下如何在CAD中用VBA来制做选择集.先来看下面的函数.

Function greatSSet() As AcadSelectionSet
On Error Resume Next
ThisDrawing.SelectionSets("PICKFIRST").Delete
Set greatSSet = ThisDrawing.PickfirstSelectionSet
If greatSSet.Count = 0 Then greatSSet.SelectOnScreen
End Function

上面的是一个创建选择集的函数

Public Function CreateSSet(Optional ssName As String = "ss") As AcadSelectionSet
Dim ss As AcadSelectionSet
On Error Resume Next
Set ss = ThisDrawing.SelectionSets(ssName)
If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName)
ss.Clear
Set CreateSSet = ss
End Function
这也是一个创建选择集的函数,和第一个函数效果一样.不过做了错误处理.
下面的函数创建选择集过滤器,这一点非常重要,当你只想选择圆而不想选中其它的元素时,就得进行选择集过滤.

Public Function CreateSSetFilter(ByRef FilterType As Variant, ByRef FilterData As Variant, ParamArray Filter())
If UBound(Filter) Mod 2 = 0 Then
MsgBox "filter参数无效！"
Exit Function
End If
Dim fType() As Integer  ' 过滤器规则
Dim fData() As Variant  ' 过滤器参数
Dim Count As Integer
Count = (UBound(Filter) + 1) / 2
ReDim fType(Count - 1)
ReDim fData(Count - 1)
Dim I As Integer
For I = 0 To Count - 1
fType(I) = Filter(2 * I)
fData(I) = Filter(2 * I + 1)
Next I
FilterType = fType
FilterData = fData
End Function
'删除当前选集
Public Sub delsset()
On Error GoTo ER
Dim I As Integer
For I = 0 To ThisDrawing.SelectionSets.Count - 1
ThisDrawing.SelectionSets.Item(I).Delete
Next I
ER:
Err.Clear
End Sub
Public Function ssExtents(ByVal Sset As AcadSelectionSet) As Variant
Dim ptArr1() As Variant     ' 所有对象的左下角点数组
Dim ptArr2() As Variant     ' 所有对象的右上角点数组
Dim Retval(0 To 1) As Variant
Dim I As Long
Dim Count As Long           ' 当前点数组的维数
Count = Sset.Count - 1
ReDim Preserve ptArr1(Count)
ReDim Preserve ptArr2(Count)
For I = 0 To Sset.Count - 1
Set ent = Sset.Item(I)
ent.GetBoundingBox ptArr1(I), ptArr2(I)
Next I
Dim ptLeftBottom As Variant, ptRightTop As Variant
ptLeftBottom = GetLeftBottomPt(ptArr1)
ptRightTop = GetRightTopPt(ptArr2)
Retval(0) = ptLeftBottom: Retval(1) = ptRightTop
ssExtents = Retval
End Function
' 根据一组对象的左下角点集合获得包围框的左下角点
Public Function GetLeftBottomPt(ByRef ptarr() As Variant) As Variant
Dim ptLeftBottom(0 To 2) As Double      ' 左下角点
Dim I As Long
For I = 0 To UBound(ptarr)
If I = 0 Then
ptLeftBottom(0) = ptarr(I)(0)
ptLeftBottom(1) = ptarr(I)(1)
End If
' 确保ptLeftBottom的X、Y坐标值均为最小
If ptarr(I)(0) < ptLeftBottom(0) Then ptLeftBottom(0) = ptarr(I)(0)
If ptarr(I)(1) < ptLeftBottom(1) Then ptLeftBottom(1) = ptarr(I)(1)
Next I
ptLeftBottom(2) = 0
GetLeftBottomPt = ptLeftBottom
End Function
' 根据一组对象的左下角点集合获得包围框的右上角点
Public Function GetRightTopPt(ByRef ptarr() As Variant) As Variant
Dim ptRightTop(0 To 2) As Double      ' 右上角点
Dim I As Long
For I = 0 To UBound(ptarr)
If I = 0 Then
ptRightTop(0) = ptarr(I)(0)
ptRightTop(1) = ptarr(I)(1)
End If
' 确保ptLeftBottom的X、Y坐标值均为最大
If ptarr(I)(0) > ptRightTop(0) Then ptRightTop(0) = ptarr(I)(0)
If ptarr(I)(1) > ptRightTop(1) Then ptRightTop(1) = ptarr(I)(1)
Next I
ptRightTop(2) = 0
GetRightTopPt = ptRightTop
End Function
Public Sub LayerZoom(ByVal strLayer As String)
Dim ptArr1() As Variant     ' 所有对象的左下角点数组
Dim ptArr2() As Variant     ' 所有对象的右上角点数组
Dim I As Long
Dim Count As Long           ' 当前点数组的维数
Count = -1
For I = 0 To ThisDrawing.ModelSpace.Count - 1
Set ent = ThisDrawing.ModelSpace.Item(I)
If StrComp(ent.LAYER, strLayer, vbTextCompare) = 0 Then
Count = Count + 1
ReDim Preserve ptArr1(Count)
ReDim Preserve ptArr2(Count)
ent.GetBoundingBox ptArr1(Count), ptArr2(Count)
End If
Next I
' 获得图层中所有实体的包围框角点
Dim ptLeftBottom As Variant, ptRightTop As Variant
ptLeftBottom = GetLeftBottomPt(ptArr1)
ptRightTop = GetRightTopPt(ptArr2)

'缩放的操作
ZoomWindow ptLeftBottom, ptRightTop
End Sub