Sub ConnectLine() Dim mySelect As AcadSelectionSet Dim MyVal(0 To 3) As String MyVal(0) = "8": MyVal(1) = "TbRegion": MyVal(2) = "0": MyVal(3) = "REGION" BuildFilter fType, fDate, MyVal Set sss = ThisDrawing.SelectionSets On Error Resume Next ThisDrawing.SelectionSets.Item("mySelects12").Delete On Error GoTo ErrExit Set myss = sss.Add("mySelects12") myss.Select acSelectionSetAll, , , fType, fDate Dim myExplode As Variant, En As AcadEntity For Each En In myss myExplode = En.Explode Set mySelect = sss.Add("sRegions5") mySelect.AddItems myExplode '当前选择集已经添加了对象 '问题:为什么下一句中P提示前一个选择集合不存在 ThisDrawing.SendCommand "_pedit" & vbCr & "M" & vbCr & "P" & vbCr & vbCr & "Y" & vbCr & "J" & vbCr & vbCr & vbCr mySelect.Delete Next Exit Sub ErrExit: MsgBox Err.Description End Sub
'创建选择集的过滤规则 Public Sub BuildFilter(typeArray As Variant, dataArray As Variant, ByVal gCodes As Variant) Dim fType() As Integer, fData() As Variant Dim Index As Long, i As Long Index = LBound(gCodes) - 1 '根据gCodes的内容创建过滤数组 For i = LBound(gCodes) To UBound(gCodes) Step 2 Index = Index + 1 ReDim Preserve fType(0 To Index) ReDim Preserve fData(0 To Index) fType(Index) = CInt(gCodes(i)) fData(Index) = gCodes(i + 1) Next '返回值 typeArray = fType dataArray = fData End Sub |