[编程交流] 在e处创建垂直线

Sub Inters2Perp() 'Main sub
Dim SOS As AcadSelectionSet
Dim objSS As AcadSelectionSet
Dim intCode(1) As Integer
Dim varData(1) As Variant
Dim objEnt As AcadEntity
Dim entBaseLine As AcadLine
Dim colPt As New Collection
Dim ent As AcadEntity
Dim varPt As Variant
With ThisDrawing
  On Error Resume Next
  .Utility.GetEntity ent, varPt, "Select the line to which perpendiculars will land: "
  If Err <> 0 Or Not TypeOf ent Is AcadLine Then
     .Utility.Prompt "Operation aborted!" & vbCr
     Exit Sub
  End If
  On Error GoTo 0
  Set entBaseLine = ent
  
  For Each SOS In .SelectionSets
     If SOS.Name = "MySS" Then
        .SelectionSets("MySS").Delete
     Exit For
     End If
  Next
  
  intCode(0) = 0: varData(0) = "LINE"
  intCode(1) = 8: varData(1) = "*" 'replace * with layer name of crossing lines
  .SelectionSets.Add ("MySS")
  Set objSS = ThisDrawing.SelectionSets("MySS")
  objSS.SelectOnScreen intCode, varData
  
  
  If objSS.Count < 1 Then
     MsgBox "No lines and polylines selected!"
     Exit Sub
  End If
  
  Set colPt = GenCollection(objSS)
  GenLines colPt, entBaseLine
  
End With
End Sub
Function GenCollection(objSS As AcadSelectionSet) As Collection
Dim colPt As New Collection
Dim entPrimary As AcadLine
Dim entSecondary As AcadLine
Dim varPt As Variant
Dim i As Integer
Dim entObj(0) As AcadEntity
  Do While objSS.Count > 1
     Set entPrimary = objSS.Item(0)
     For i = 1 To objSS.Count - 1
        Set entSecondary = objSS.Item(i)
        varPt = entPrimary.IntersectWith(entSecondary, acExtendNone)
        If UBound(varPt) > 1 Then colPt.Add (varPt)
     Next
     Set entObj(0) = entPrimary
     objSS.RemoveItems entObj
  Loop
  Set GenCollection = colPt
End Function
Private Sub GenLines(colPt As Collection, entBaseLine As AcadLine)
Dim dblAngle As Double
Dim varPt As Variant
Dim dblEndPt() As Double
Dim entLine As AcadLine
dblAngle = ThisDrawing.Utility.AngleFromXAxis(entBaseLine.StartPoint, entBaseLine.EndPoint) + 1.5707963268
For Each varPt In colPt
  dblEndPt = ThisDrawing.Utility.PolarPoint(varPt, dblAngle, 1#)
  Set entLine = ThisDrawing.ModelSpace.AddLine(varPt, dblEndPt)
  On Error Resume Next
  entLine.EndPoint = entLine.IntersectWith(entBaseLine, acExtendThisEntity)
  If Err <> 0 Then entLine.Delete
  Err.Clear
Next
End Sub