[编程交流] VBA通过创建多段线

Sub PerimeterLine()
   'To create Regions with the objects
   Dim DifRegs() As AcadObject
   Dim ObjtoConv As AcadEntity
   Dim ActRegion As Variant
   Dim FstRegs As AcadSelectionSet
   Dim FstRegCount As Integer
   Dim FstRegT(1) As Integer
   Dim FstRegV(1) As Variant
   FstRegT(0) = 8: FstRegV(0) = "0"
   FstRegT(1) = 0: FstRegV(1) = "Region"
   ' to combine all regions
   On Error Resume Next
   ThisDrawing.SelectionSets("FstRegs_0").Delete
   On Error GoTo 0
   Set FstRegs = ThisDrawing.SelectionSets.Add("FstRegs_0")
   FstRegs.Select acSelectionSetAll, , , FstRegT, FstRegV
   FstRegCount = FstRegs.Count
   ReDim DifRegs(FstRegCount - 1)
   Dim Thefirst As AcadRegion
   Dim Thesecond As AcadRegion
   For FstObjL = 0 To FstRegCount - 1
       Set DifRegs(FstObjL) = FstRegs.Item(FstObjL)
       If FstObjL <> 0 Then
           Set Thefirst = DifRegs(0)
           Set Thesecond = DifRegs(FstObjL)
           Thefirst.Boolean acUnion, Thesecond
       End If
   Next FstObjL
   Thefirst.Update
   ThisDrawing.Regen acAllViewports
   'explode region in to lines
   Dim ExplodedRegion As Variant
   Dim ExplRegCount As Integer
   ExplodedRegion = Thefirst.Explode
   ExplRegCount = UBound(ExplodedRegion)
   'retrieve coords to make perimeter line
   Dim ExRegL As Integer
   Dim ExRegNumCoords As Integer
   ExRegNumCoords = ((ExplRegCount + 1) * 2) + 1
   Dim ExRegCoords() As Double
   Dim RegLine As AcadLine
   ReDim ExRegCoords(ExRegNumCoords)
   For ExRegL = 0 To ExplRegCount
       Set RegLine = ExplodedRegion(ExRegL)
       ExRegCoords(ExRegL * 2) = RegLine.StartPoint(0)
       ExRegCoords(ExRegL * 2 + 1) = RegLine.StartPoint(1)
       If ExRegL = ExplRegCount Then
           ExRegCoords(ExRegL * 2 + 2) = RegLine.EndPoint(0)
           ExRegCoords(ExRegL * 2 + 3) = RegLine.EndPoint(1)
       End If
   Next ExRegL
   'Make the perimeter line
   Dim PerLine As AcadLWPolyline
   Set PerLine = ThisDrawing.ModelSpace.AddLightWeightPolyline(ExRegCoords)
   PerLine.color = acYellow
End Sub