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

yg545france

这是老南方高人的高作，有点像photoshop里面得选择功能，但不知道为啥不好用了。请高手指教

AutoCAD VBA函数---选择闭合轻量多段线内的实体

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

Option Explicit
Public objPicked As AcadObject
Public Const VK_ESCAPE = &H1B
Declare Function GetAsyncKeyState Lib "user32" _
(ByVal vKey As Long) As Integer

Function checkkey(lngKey As Long) As Boolean
If GetAsyncKeyState(lngKey) Then
checkkey = True
Else
checkkey = False
End If
End Function

Public 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

没人回复？