像Photoshop一样选择闭合轻量多段线内的实体

yg545france 发表于 2010-2-2 23:39:00

这是老南方高人的高作，有点像photoshop里面得选择功能，但不知道为啥不好用了。请高手指教AutoCAD VBA函数---选择闭合轻量多段线内的实体<div style="PADDING-RIGHT: 0px; MARGIN-TOP: 10px; FONT-SIZE: 9pt; OVERFLOW-X: hidden; WIDTH: 97%; WORD-BREAK: break-all; TEXT-INDENT: 24px; LINE-HEIGHT: normal; HEIGHT: 200px; WORD-WRAP: break-word;">Public Sub mSelectByPolyline() '选择闭合轻量多段线内的实体   Dim sSet As AcadSelectionSet   Dim intCnt As Integer   Dim strInfo As String   Dim objPL As AcadLWPolyline   Dim objEnt As AcadObject   Dim pnt As Variant   Dim objPnt() As Double   Dim i As Integer   On Error Resume Next Redo:   ThisDrawing.Application.ActiveDocument.Utility.GetEntity objPL, pnt, vbCr & "选择闭合的轻量多段线:"   If CheckKey(VK_ESCAPE) = True Then      Exit Sub   End If   If objPL Is Nothing Then      GoTo Redo   End If   If TypeName(objPL) <> "IAcadLWPolyline" Then      GoTo Redo   End If   If objPL.Closed = False Then      GoTo Redo   End If Retry:   strInfo = ThisDrawing.Application.ActiveDocument.Utility.GetString(1, vbCr & vbCr & "是否选择与边线相交的实体(Y/N)?")   If CheckKey(VK_ESCAPE) = True Then      Exit Sub   End If   If strInfo <> "Y" And strInfo <> "N" And strInfo <> "y" And strInfo <> "n" Then      GoTo Retry   End If   ReDim objPnt((UBound(objPL.Coordinates) + 1) * 3 / 2 - 1)   For i = 0 To ((UBound(objPL.Coordinates) + 1) / 2 - 1)       objPnt(3 * i) = objPL.Coordinates(2 * i)       objPnt(3 * i + 1) = objPL.Coordinates(2 * i + 1)       objPnt(3 * i + 2) = 0   Next i   intCnt = ThisDrawing.SelectionSets.count   While (intCnt > 0)       Set sSet = ThisDrawing.SelectionSets.Item(intCnt - 1)       sSet.Delete       intCnt = intCnt - 1   Wend   Set sSet = ThisDrawing.Application.ActiveDocument.SelectionSets.Add("ENT")   If strInfo = "Y" Or strInfo = "y" Then      sSet.SelectByPolygon acSelectionSetCrossingPolygon, objPnt      DelEntFromSSet objPL, sSet   Else     sSet.SelectByPolygon acSelectionSetWindowPolygon, objPnt   End If   If sSet.count > 0 Then     ThisDrawing.Application.ActiveDocument.SendCommand Chr(27) & Chr(27) & "SELECT" & vbCr & axSset2lspEnts(sSet) & vbCr & vbCr   End If End Sub</div>Option Explicit Public objPicked As AcadObject Public Const VK_ESCAPE = &H1B Declare Function GetAsyncKeyState Lib "user32" _ (ByVal vKey As Long) As IntegerFunction checkkey(lngKey As Long) As Boolean If GetAsyncKeyState(lngKey) Then checkkey = True Else checkkey = False End If End FunctionPublic Sub DelEntFromSSet(ByVal ent As AcadEntity, ByVal sSet As AcadSelectionSet) Dim objCollection(0) As AcadEntity Set objCollection(0) = ent sSet.RemoveItems objCollection End Sub'#39; ×ª»»¶à¸öÍ¼ÔªµÄº¯Êý 从vba界面拷贝过来的，汉字乱码了，不知道为啥。 Public Function axSset2lspEnts(ByVal sSet As AcadSelectionSet) As String   Dim enthandle As String   Dim strEnts As String   Dim i As Integer   If sSet.Count = 0 Then Exit Function   enthandle = sSet.Item(0).Handle   strEnts = "(handent" & Chr(34) & enthandle & Chr(34) & ")"   If sSet.Count > 1 Then      For i = 1 To sSet.Count - 1          enthandle = sSet.Item(i).Handle          strEnts = strEnts & vbCr & "(handent" & Chr(34) & enthandle & Chr(34) & ")"      Next i   End If   axSset2lspEnts = strEnts End Function

yg545france 发表于 2010-2-6 19:25:00

没人回复？

页: [1]

明经CAD社区's Archiver

像Photoshop一样选择闭合轻量多段线内的实体