change tapered polyline to line segments

Call me lazy...

Does anyone have code to change a polyline with tapered segments to lines? I
have some drawings where someone used a polyline to create leaders for
notes. The arrowhead at the end of the polyline tapered from 0 to some
width. I'm trying to export these drawings to dxf for a legacy VAX
application. I have to explode all polylines and much other stuff. I've
handled all the other problem entities except this one. I need the polyline
segment or "arrowhead" converted into lines tracing the outline of the
former. I handled solids used as arrowheads this same way. But they are easy
to find with a filtered selection set. Perhaps code to trace the entire
polyline making them double lines if any segments have width greater than 0
would be cool.

thanks
LJB

 

Here's a quick solution. I think it does what you want

Public Sub OutlineArrowHeads()   Dim Angle_A As Double   Dim Angle_B As Double   Dim Angle_C As Double   Dim Angle_D As Double   Dim DeleteOriginal As Byte   Dim EndPoint(0 To 1) As Double   Dim EndWidth As Double   Dim Entity As AcadEntity   Dim Length_A As Double   Dim Length_B As Double   Dim Length_C As Double   Dim Outline As AcadLWPolyline   Dim Polyline As AcadLWPolyline   Dim StartPoint(0 To 1) As Double   Dim StartWidth As Double   Dim Vertices(0 To 7) As Double

DeleteOriginal = MsgBox("Delete original arrowheads?", vbYesNo)

For Each Entity In ThisDrawing.ModelSpace     If TypeOf Entity Is AcadLWPolyline Then       Set Polyline = Entity       ' Only process polylines with one segement.       If UBound(Polyline.Coordinates) = 3 Then         ' Only process polylines with a starting width of zero and         ' and ending width greater than zero.         Polyline.GetWidth 0, StartWidth, EndWidth         If (StartWidth = 0) And (EndWidth > 0) Then           StartPoint(0) = Polyline.Coordinates(0)           StartPoint(1) = Polyline.Coordinates(1)           EndPoint(0) = Polyline.Coordinates(2)           EndPoint(1) = Polyline.Coordinates(3)

Length_A = CalcLength(StartPoint, EndPoint)           Length_B = EndWidth / 2#           Length_C = (Length_A ^ 2 + Length_B ^ 2) ^ 0.5

Angle_A = DegreesToRadians(CalcAngle(StartPoint, EndPoint))           Angle_B = Atn(Length_B / Length_A)           Angle_C = Angle_A - Angle_B           Angle_D = Angle_A + Angle_B

Vertices(0) = Polyline.Coordinates(0)           Vertices(1) = Polyline.Coordinates(1)           Vertices(2) = Length_C * Cos(Angle_C)           Vertices(3) = Length_C * Sin(Angle_C)           Vertices(4) = Length_C * Cos(Angle_D)           Vertices(5) = Length_C * Sin(Angle_D)           Vertices(6) = Polyline.Coordinates(0)           Vertices(7) = Polyline.Coordinates(1)

Set Outline = ThisDrawing.ModelSpace.AddLightWeightPolyline(Vertices)           Outline.Layer = Polyline.Layer           If DeleteOriginal = vbYes Then             Polyline.Delete           End If         End If       End If     End If   Next Entity End Sub

'-------------------------------------------------------------------------------

Public Function CalcAngle( ByRef StartPoint() As Double, _   ByRef EndPoint() As Double) As Double   Dim DeltaX As Double   Dim DeltaY As Double

DeltaX = EndPoint(X) - StartPoint(X)   DeltaY = EndPoint(Y) - StartPoint(Y)

If DeltaX = 0# And DeltaY > 0 Then     CalcAngle = 90#   ElseIf DeltaX = 0# And DeltaY < 0 Then     CalcAngle = 270#   ElseIf DeltaX > 0 And DeltaY < 0 Then     CalcAngle = (Atn(DeltaY / DeltaX) * 180# / PI) + 360#   ElseIf DeltaX < 0 And DeltaY > 0 Then     CalcAngle = (Atn(DeltaY / DeltaX) * 180# / PI) + 180#   ElseIf DeltaX < 0 And DeltaY < 0 Then     CalcAngle = (Atn(DeltaY / DeltaX) * 180# / PI) + 180#   ElseIf DeltaX < 0 And DeltaY = 0# Then     CalcAngle = 180#   ElseIf DeltaX = 0 And DeltaY = 0 Then     CalcAngle = 0   Else     CalcAngle = Atn(DeltaY / DeltaX) * 180# / PI   End If End Function

'-------------------------------------------------------------------------------

Public Function CalcLength(ByRef Point1() As Double, _   ByRef Point2() As Double) As Double   Dim DeltaX As Double   Dim DeltaY As Double

DeltaX = Point1(X) - Point2(X)   DeltaY = Point1(Y) - Point2(Y)   CalcLength = (DeltaX ^ 2 + DeltaY ^ 2) ^ 0.5 End Function

 

Oops - should have tested it before posting :-(

Try this instead:

Public Sub OutlineArrowHeads()   Dim Angle_A As Double   Dim Angle_B As Double   Dim Angle_C As Double   Dim Angle_D As Double   Dim DeleteOriginal As Byte   Dim EndPoint(0 To 1) As Double   Dim EndWidth As Double   Dim Entity As AcadEntity   Dim Length_A As Double   Dim Length_B As Double   Dim Length_C As Double   Dim Outline As AcadLWPolyline   Dim Polyline As AcadLWPolyline   Dim StartPoint(0 To 1) As Double   Dim StartWidth As Double   Dim Vertices(0 To 7) As Double

DeleteOriginal = MsgBox("Delete original arrowheads?", vbYesNo)

For Each Entity In ThisDrawing.ModelSpace     If TypeOf Entity Is AcadLWPolyline Then       Set Polyline = Entity       ' Only process polylines with one segement.       If UBound(Polyline.Coordinates) = 3 Then         ' Only process polylines with a starting width of zero and         ' and ending width greater than zero.         Polyline.GetWidth 0, StartWidth, EndWidth         If (StartWidth = 0) And (EndWidth > 0) Then           StartPoint(0) = Polyline.Coordinates(0)           StartPoint(1) = Polyline.Coordinates(1)           EndPoint(0) = Polyline.Coordinates(2)           EndPoint(1) = Polyline.Coordinates(3)

Length_A = CalcLength(StartPoint, EndPoint)           Length_B = EndWidth / 2#           Length_C = (Length_A ^ 2 + Length_B ^ 2) ^ 0.5

Angle_A = DegreesToRadians(CalcAngle(StartPoint, EndPoint))           Angle_B = Atn(Length_B / Length_A)           Angle_C = Angle_A - Angle_B           Angle_D = Angle_A + Angle_B

Vertices(0) = Polyline.Coordinates(0)           Vertices(1) = Polyline.Coordinates(1)           Vertices(2) = Polyline.Coordinates(0) + (Length_C * Cos(Angle_C))           Vertices(3) = Polyline.Coordinates(1) + (Length_C * Sin(Angle_C))           Vertices(4) = Polyline.Coordinates(0) + (Length_C * Cos(Angle_D))           Vertices(5) = Polyline.Coordinates(1) + (Length_C * Sin(Angle_D))           Vertices(6) = Polyline.Coordinates(0)           Vertices(7) = Polyline.Coordinates(1)

Set Outline = ThisDrawing.ModelSpace.AddLightWeightPolyline(Vertices)           Outline.Layer = Polyline.Layer           If DeleteOriginal = vbYes Then             Polyline.Delete           End If         End If       End If     End If   Next Entity End Sub

 

Thanks for the code. It certainly does trace a tapered single segment polyline. In my case however the arrowhead is one segment of a many segment polyline. The code for calculating the angles to trace the item will be handy.



 



thanks



LJB

 

Having a little problem with lines running right to left. Does your CalculateAngle function return degrees? Mine only returns radians and evidently does not detect the right to left condition properly.



 



thanks



LJB

 

Mr. B,

Mark's CalcAngle function and a Length function are at the bottom of his
first post... I'm guessing you missed it since his corrected post only had
his main sub...

Hope this takes care of it for you...

James

 

Thanks for the code Mark. I have changed it slightly to outline quadrilateral as well as triangular polyline segments. I also removed the need for converting angles to degrees and back again. This should run without any ancillary functions. The code works by pretending the line segment is always horizontal, calculate the associated coordinates for each end and rotate them to match the segments actual angle. A little bit like creating a UCS at each end of the line so its possible to ignore the angle.



 



Public Sub OutlinePlineSegment()
   Dim Entity As AcadEntity
   Dim Polyline As AcadLWPolyline
   Dim Outline As AcadLWPolyline
   Dim StartPoint(0 To 1) As Double
   Dim EndPoint(0 To 1) As Double
   Dim StartWidth As Double
   Dim EndWidth As Double
   Dim SegLength As Double
   Dim CosSeg As Double
   Dim SinSeg As Double
   Dim Vertices() As Double
 
   For Each Entity In ThisDrawing.ModelSpace
      If TypeOf Entity Is AcadLWPolyline Then
         Set Polyline = Entity
         ' Only process polylines with one segement.
         If UBound(Polyline.Coordinates) = 3 Then
            Polyline.GetWidth 0, StartWidth, EndWidth
            
            StartPoint(0) = Polyline.Coordinates(0)
            StartPoint(1) = Polyline.Coordinates(1)
            EndPoint(0) = Polyline.Coordinates(2)
            EndPoint(1) = Polyline.Coordinates(3)
           
            SegLength = Sqr((StartPoint(0) - EndPoint(0)) ^ 2 + _
                            (StartPoint(1) - EndPoint(1)) ^ 2)
            CosSeg = (EndPoint(0) - StartPoint(0)) / SegLength
            SinSeg = (EndPoint(1) - StartPoint(1)) / SegLength
           
            If StartWidth > 0 And EndWidth > 0 Then
               'Segment is quadrilateral
               ReDim Vertices(0 To 9)
               Vertices(0) = -SinSeg * StartWidth / 2 + StartPoint(0)
               Vertices(1) = CosSeg * StartWidth / 2 + StartPoint(1)
               Vertices(2) = -SinSeg * EndWidth / 2 + EndPoint(0)
               Vertices(3) = CosSeg * EndWidth / 2 + EndPoint(1)
               Vertices(4) = SinSeg * EndWidth / 2 + EndPoint(0)
               Vertices(5) = -CosSeg * EndWidth / 2 + EndPoint(1)
               Vertices(6) = SinSeg * StartWidth / 2 + StartPoint(0)
               Vertices(7) = -CosSeg * StartWidth / 2 + StartPoint(1)
               Vertices(8) = Vertices(0)
               Vertices(9) = Vertices(1)
            Else
               'Segment is triangular
               ReDim Vertices(0 To 7)
               If EndWidth > 0 Then
                  'Start Width must have been 0. So to symplify
                  'code just swap points and width.
                  Dim TempPoint(0 To 1) As Double
                  TempPoint(0) = StartPoint(0)
                  TempPoint(1) = StartPoint(1)
                  StartPoint(0) = EndPoint(0)
                  StartPoint(1) = EndPoint(1)
                  EndPoint(0) = TempPoint(0)
                  EndPoint(1) = TempPoint(1)
                  StartWidth = EndWidth
               End If
               Vertices(0) = -SinSeg * StartWidth / 2 + StartPoint(0)
               Vertices(1) = CosSeg * StartWidth / 2 + StartPoint(1)
               Vertices(2) = EndPoint(0)
               Vertices(3) = EndPoint(1)
               Vertices(4) = SinSeg * StartWidth / 2 + StartPoint(0)
               Vertices(5) = -CosSeg * StartWidth / 2 + StartPoint(1)
               Vertices(6) = Vertices(0)
               Vertices(7) = Vertices(1)
            End If
           
            Set Outline = ThisDrawing.ModelSpace.AddLightWeightPolyline(Vertices)
            Outline.Layer = Polyline.Layer
           
            If MsgBox("Delete original arrowheads?", vbYesNo) = vbYes Then
               'Polyline.Explode
               Polyline.Delete
            End If
      End If
    End If
  Next Entity
End Sub

 

You are right! I won't be using the message box in my program but stuck it back in before I posted the code since yours had it. I never gave its location any thought.



"Mark_Abercrombie" <> wrote in message news:...

You're welcome. Glad it helped.

BTW: You might want to move your message box call outside of the loop. Your users may get irritated when they have to answer the same question a few hundred times ;O