Hi,
welcome on board
This code will draw an arc inside your
lines chain at distance 0.12 from these lines
Is there what you want?
Let me know how it will works
~'J'~
Option Explicit
Public Function Get_Distance(fPoint As Variant, sPoint As Variant) As Double
Dim x1 As Double, x2 As Double
Dim y1 As Double, y2 As Double
Dim z1 As Double, z2 As Double
Dim cDist As Double
x1 = fPoint(0): y1 = fPoint(1): z1 = fPoint(2)
x2 = sPoint(0): y2 = sPoint(1): z2 = sPoint(2)
cDist = Sqr(((x2 - x1) ^ 2) + ((y2 - y1) ^ 2) + ((z2 - z1) ^ 2))
Get_Distance = cDist
End Function
Public Function Get_MidPoint(fPoint As Variant, sPoint As Variant) As Variant
Dim mpoint(2) As Double
mpoint(0) = (CDbl(sPoint(0)) + CDbl(fPoint(0))) / 2
mpoint(1) = (CDbl(sPoint(1)) + CDbl(fPoint(1))) / 2
mpoint(2) = (CDbl(sPoint(2)) + CDbl(fPoint(2))) / 2
Get_MidPoint = mpoint
End Function
Sub OffsetLinesToArc()
Dim pt1 As Variant
Dim pt2 As Variant
Dim pt3 As Variant
Dim pt4 As Variant
Dim pt5 As Variant
Dim pt6 As Variant
Dim pt7 As Variant
Dim pt8 As Variant
Dim ang1 As Double
Dim ang2 As Double
Dim stAng As Double
Dim endAng As Double
Dim oEnt As AcadEntity
Dim oLine As AcadLine
Dim osm As Integer, varpt As Variant
Dim Pi As Double
Pi = Atn(1#) * 4
osm = ThisDrawing.GetVariable("OSMODE")
ThisDrawing.SetVariable "OSMODE", 1
MsgBox "First select line then" & vbCr & _
"Pick points in" & vbCr & _
"clockwise order only!"
On Error GoTo Err_Control
With ThisDrawing.Utility
.GetEntity oEnt, varpt, vbCr & "Select any of lines from the chain"
If TypeOf oEnt Is AcadLine Then
Set oLine = oEnt
Else
Exit Sub
End If
pt1 = .GetPoint(, vbCr & "Specify the starting point of an arc in clockwise order")
pt2 = .GetPoint(pt1, vbCr & "Specify the point near to middle of the chain of lines")
pt3 = .GetPoint(pt2, vbCr & "Specify the ending point")
ang1 = .AngleFromXAxis(pt1, pt2) + (Pi / 2)
ang2 = .AngleFromXAxis(pt2, pt3) + (Pi / 2)
pt4 = Get_MidPoint(pt1, pt2)
pt5 = Get_MidPoint(pt2, pt3)
pt6 = .PolarPoint(pt4, ang1, 1#)
pt7 = .PolarPoint(pt5, ang2, 1#)
End With
ThisDrawing.SetVariable "OSMODE", 0
Dim oXline1 As AcadXline, oXline2 As AcadXline
Set oXline1 = ThisDrawing.ModelSpace.AddXline(pt4, pt6)
Set oXline2 = ThisDrawing.ModelSpace.AddXline(pt5, pt7)
Dim intPt As Variant
intPt = oXline1.IntersectWith(oXline2, acExtendNone)
Dim oArc As AcadArc
Dim dblRad As Double
dblRad = Get_Distance(intPt, pt1) - 0.12
With ThisDrawing.Utility
stAng = .AngleFromXAxis(intPt, pt3)
endAng = .AngleFromXAxis(intPt, pt1)
End With
Set oArc = ThisDrawing.ModelSpace.AddArc(intPt, dblRad, stAng, endAng)
oArc.Layer = oLine.Layer
oArc.Linetype = oLine.Linetype
oArc.LinetypeScale = oLine.LinetypeScale
oArc.Lineweight = oLine.Lineweight
oArc.TrueColor = oLine.TrueColor
oArc.Update
Exit_Here:
oXline1.Delete
oXline2.Delete
ThisDrawing.SetVariable "OSMODE", osm
Exit Sub
Err_Control:
MsgBox Err.Description
Resume Exit_Here
End Sub
Reply With Quote
Originally Posted by Fatty
....where in the world did you learn to write code like that!? Very nice indeed.
