|
|
这是老南方高人的高作，有点像photoshop里面得选择功能，但不知道为啥不好用了。请高手指教
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 SubOption 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
|
|
置顶卡
