I have difficulty in realize 3d Offset.
I have been doing with my code for three weeks.
Any help would be appreciated.
Thanks in advance.
Imports Autodesk.AutoCAD.Runtime
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.Geometry
Imports System.Math
Public Class GILSclass1
<CommandMethod("TOS")> _
Public Sub TdOffset()
Dim Db As Database = HostApplicationServices.WorkingDatabase
Dim Ed As Editor = Application.DocumentManager.MdiActiveDocument.Editor
Dim Tr As Transaction = Db.TransactionManager.StartTransaction
Try
Dim EntSelOpt As PromptEntityOptions = New PromptEntityOptions("" & Microsoft.VisualBasic.Chr(10) & "Select 3dPolyLine: ")
EntSelOpt.SetRejectMessage("" & Microsoft.VisualBasic.Chr(10) & "Only Selected 3d PolyLine!")
EntSelOpt.AddAllowedClass(GetType(Polyline3d), True)
Dim EntSelRes As PromptEntityResult = Ed.GetEntity(EntSelOpt)
If EntSelRes.Status <> PromptStatus.OK Then Return
Dim DrOpt As PromptPointOptions = New PromptPointOptions("" & Microsoft.VisualBasic.Chr(10) & "Specify Offset Direction: ")
Dim Dres As PromptPointResult = Ed.GetPoint(DrOpt)
Dim DrDst As PromptDoubleOptions = New PromptDoubleOptions("" & Microsoft.VisualBasic.Chr(10) & "Input Offset Distance: ")
Dim Ddst As PromptDoubleResult = Ed.GetDouble(DrDst)
Dim Z_Sig As PromptDoubleOptions = New PromptDoubleOptions("" & Microsoft.VisualBasic.Chr(10) & "Input Z Value: ")
Dim Z_res As PromptDoubleResult = Ed.GetDouble(Z_Sig)
Dim Ent As Polyline3d = CType(Tr.GetObject(EntSelRes.ObjectId, OpenMode.ForRead), Polyline3d)
Dim c As Curve = DirectCast(Ent, Curve)
Dim sp As Double = c.StartParam
Dim ep As Double = c.EndParam
Dim ssp As Point3d = c.GetPointAtParameter(sp)
Dim eep As Point3d = c.GetPointAtParameter(ep)
Dim Vspdr As Double = V(Dres.Value, ssp)
Dim bt As BlockTable = Tr.GetObject(Db.BlockTableId, OpenMode.ForRead)
Dim btr As BlockTableRecord = Tr.GetObject(bt(BlockTableRecord.ModelSpace), OpenMode.ForWrite)
Dim pts As Point3dCollection = New Point3dCollection
Dim FnPt As Point3d
Dim fts As Point3dCollection = New Point3dCollection
Dim qqq As Vector3d = New Vector3d
Dim ppp As Vector3d = New Vector3d
ppp.CrossProduct(qqq)
Dim n As Integer = 0
For p As Double = sp To ep Step 1.0
n = n + 1
Dim pt As Point3d = c.GetPointAtParameter(p)
Dim gt As Point3d = New Point3d(pt.X, pt.Y, pt.Z + Z_res.Value)
Dim Vptnt As Double
Dim nt As Point3d
If p <> ep Then
nt = c.GetPointAtParameter(p + 1.0)
Vptnt = V(nt, pt)
ElseIf p = ep Then
End If
Dim SndPt1 As Point3d
Dim SndPt2 As Point3d
Dim Vfn As Double
Select Case (Vspdr > 0 Or Vspdr = 0) AndAlso Vspdr < Atan(1) * 4
Case True
Vfn = Vptnt + 2 * Atan(1)
SndPt1 = PolarPoint(Dst(pt, nt).Item(0), Vfn, Ddst.Value)
SndPt2 = PolarPoint(Dst(pt, nt).Item(1), Vfn, Ddst.Value)
Case False
Vfn = Vptnt - 2 * Atan(1)
SndPt1 = PolarPoint(Dst(gt, nt).Item(0), Vfn, Ddst.Value)
SndPt2 = PolarPoint(Dst(gt, nt).Item(1), Vfn, Ddst.Value)
End Select
pts.Add(SndPt1)
pts.Add(SndPt2)
If p <> sp AndAlso p <> ep Then
FnPt = API(pts.Item(2 * n - 4), pts.Item(2 * n - 3), pts.Item(2 * n - 2), pts.Item(2 * n - 1))
Dim FnlPt As Point3d = New Point3d(FnPt.X, FnPt.Y, gt.Z)
fts.Add(FnlPt)
ElseIf p = sp Then
FnPt = PolarPoint(pt, Vfn, Ddst.Value)
Dim fnlpt As Point3d = New Point3d(SndPt1.X, SndPt1.Y, gt.Z)
fts.Add(fnlpt)
ElseIf p = ep Then
Select Case (Vspdr > 0 Or Vspdr = 0) AndAlso Vspdr < Atan(1) * 4
Case True
Vfn = Vptnt + 2 * Atan(1)
Case False
Vfn = Vptnt - 2 * Atan(1)
End Select
FnPt = PolarPoint(pt, Vfn, Ddst.Value)
Dim fnlpt As Point3d = New Point3d(SndPt1.X, SndPt1.Y, gt.Z)
fts.Add(fnlpt)
End If
Next
Dim my3dpoly As Polyline3d = New Polyline3d(Poly3dType.SimplePoly, fts, False)
btr.AppendEntity(my3dpoly)
Tr.AddNewlyCreatedDBObject(my3dpoly, True)
Tr.Commit()
Catch
Finally
Tr.Dispose()
End Try
End Sub
Friend Function PolarPoint(ByVal BasePoint As Point3d, ByVal angle As Double, ByVal distance As Double) As Point3d
Dim x As Double = distance * Cos(angle)
Dim y As Double = distance * Sin(angle)
Return New Point3d(BasePoint.X + x, BasePoint.Y + y, BasePoint.Z)
End Function
Friend Function API(ByVal p1 As Point3d, ByVal p2 As Point3d, ByVal p3 As Point3d, ByVal p4 As Point3d) As Point3d
Dim angAp As Double = Atan((p2.Y - p1.Y) / (p2.X - p1.X))
Dim angBt As Double = Atan((p4.Y - p3.Y) / (p4.X - p3.X))
Dim ar1 As Double = (((p3.Y - p1.Y) * Cos(angBt) - (p3.X - p1.X) * Sin(angBt)) / Sin(angAp - angBt))
Dim ar2 As Double = (((p3.Y - p1.Y) * Cos(angAp) - (p3.X - p1.X) * Sin(angAp)) / Sin(angAp - angBt))
Dim x As Double = p1.X + ar1 * Cos(angAp)
Dim y As Double = p1.Y + ar1 * Sin(angAp)
Return New Point3d(x, y, 0)
End Function
Friend Function BPI(ByVal p1 As Point3d, ByVal p2 As Point3d, ByVal p3 As Point3d, ByVal p4 As Point3d) As Point3d
Dim angAp As Double = Atan((p2.Y - p1.Y) / (p2.X - p1.X))
Dim angBt As Double = Atan((p4.Y - p3.Y) / (p4.X - p3.X))
Dim ar1 As Double = (((p3.Y - p1.Y) * Cos(angBt) - (p3.X - p1.X) * Sin(angBt)) / Sin(angAp - angBt))
Dim ar2 As Double = (((p3.Y - p1.Y) * Cos(angAp) - (p3.X - p1.X) * Sin(angAp)) / Sin(angAp - angBt))
Dim x As Double = p1.X + ar1 * Cos(angAp)
Dim y As Double = p1.Y + ar1 * Sin(angAp)
Return New Point3d(x, y, 0)
End Function
Friend Function V(ByVal p1 As Point3d, ByVal p2 As Point3d) As Double
Dim ang As Double = Atan((p2.Y - p1.Y) / (p2.X - p1.X))
Return ang
End Function
Friend Function Dst(ByVal p1 As Point3d, ByVal p2 As Point3d) As Point3dCollection
Dim ds As Double = Sqrt((p2.X - p1.X) ^ 2 + (p2.Y - p1.Y) ^ 2)
Dim va As Double = V(p1, p2)
Dim s1 As Point3d = PolarPoint(p1, va, ds / 3)
Dim s2 As Point3d = PolarPoint(p1, va, ds * 2 / 3)
Dim ggc As Point3dCollection = New Point3dCollection
ggc.Add(s1)
ggc.Add(s2)
Return ggc
End Function
End Class
