Community
style="PADDING-RIGHT: 0px; PADDING-LEFT: 5px; MARGIN-LEFT: 5px; BORDER-LEFT: #000000 2px solid; MARGIN-RIGHT: 0px">
<alteru> a écrit dans le message de news:I
href="mailto:6109859@discussion.autodesk.com">6109859@discussion.autodesk.com...
am wanting to create a lisp routine that will set points at even elevations
(ie: 100.00', 101.00', 102.00' etc.) between 2 selected aecc cogo points. I
know civil3d can interpolate between selected points with "create points -
interpolate", "incremental elevation" command but it wont do it to the even
elevations if the picked points are not also to even elevations (ie: i want to
select points with elevation of 98.07' and 103.57', and have it automatically
set points at 99.00', 100.00', 101.00' 102.00' and 103.00' using the grade
between selected points.)
I can do simple lisp routines but this one is
way out of my league LOL, any help would be
appreciated.
Option Explicit
Type Type_Data
Elevation As Double
FirstDistance As Double
UnitDistance As Double
Direction As Double
End Type
Public Const scMsgHeader = "Point creation"
Public Const icIncrement = 1
Public ogCivilApp As AeccApplication
Public ogCivilDoc As AeccDocument
Public ogCivilDb As AeccDatabase
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Start Civil 3D and create Civil 3D document and database objects.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetCivilObjects() As Boolean
On Error GoTo ErrorHandler
Dim sAppName As String
Select Case Val(ThisDrawing.Application.Version)
Case 17.2 ' v2009
sAppName = "AeccXUiLand.AeccApplication.6.0"
Case 17.1 ' v2008
sAppName = "AeccXUiLand.AeccApplication.5.0"
Case 17# ' v2007
sAppName = "AeccXUiLand.AeccApplication.4.0"
Case Else
MsgBox "'GetCivilObjects' only provides for Civil 3D R2007, 2008
and 2009", vbInformation, "Laurie"
GetCivilObjects = False
Exit Function
End Select
Set ogCivilApp = ThisDrawing.Application.GetInterfaceObject(sAppName)
If ogCivilApp Is Nothing Then
MsgBox "Error creating " & sAppName & ", exit."
GetCivilObjects = False
Exit Function
End If
Set ogCivilDoc = ogCivilApp.ActiveDocument
Set ogCivilDb = ogCivilDoc.Database
GetCivilObjects = True
Exit Function
ErrorHandler:
MsgBox "Problem creating Civil objects with 'GetCivilObjects'" & vbCrLf _
& "due to: " & vbCrLf & Err.Description & vbCrLf & vbCrLf _
& "You may need to repair your Civil 3D Application",
vbCritical, "Laurie"
Err.Clear
GetCivilObjects = False
End Function ' GetCivilObjects
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function CloseCivil() As Boolean
On Error GoTo ErrorHandler
Set ogCivilDoc = Nothing
Set ogCivilDb = Nothing
Set ogCivilApp = Nothing
CloseCivil = True
Exit Function
ErrorHandler:
MsgBox "Unable to process data in Function 'CloseCivil' due to:" &
vbCrLf & Err.Description, vbCritical, scMsgHeader
Err.Clear
CloseCivil = False
End Function ' CloseCivil
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Select the points and draw points on the integer elevations
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub CreatePoints()
Dim PtStart(0 To 2) As Double
Dim v As Variant
Dim Pt1 As AeccPoint
Dim Pt2 As AeccPoint
Dim daDistances(0 To 2) As Double
Dim tData As Type_Data
On Error GoTo ErrorHandler
GetCivilObjects
Set Pt1 = GetPoint("Select the first Civil 3D point")
If Pt1 Is Nothing Then Exit Sub
Set Pt2 = GetPoint("Select the second Civil 3D point")
If Pt2 Is Nothing Then Exit Sub
If GetData(Pt1, Pt2, tData) = False Then Exit Sub
PtStart(0) = Pt1.Easting
PtStart(1) = Pt1.Northing
v = ThisDrawing.Utility.PolarPoint(PtStart, tData.Direction,
tData.FirstDistance)
PtStart(0) = v(0)
PtStart(1) = v(1)
PtStart(2) = tData.Elevation
Set Pt1 = ogCivilDoc.Points.Add(PtStart)
Pt1.Description = "Added by Program"
tData.Elevation = tData.Elevation + icIncrement
Do While tData.Elevation < Pt2.Elevation
v = ThisDrawing.Utility.PolarPoint(PtStart, tData.Direction,
tData.UnitDistance)
PtStart(0) = v(0)
PtStart(1) = v(1)
PtStart(2) = tData.Elevation
Set Pt1 = ogCivilDoc.Points.Add(PtStart)
Pt1.Description = "Added by Program"
tData.Elevation = tData.Elevation + icIncrement
Loop
CloseCivil
Exit Sub
ErrorHandler:
MsgBox "Unable to process data in Sub 'CreatePoints' due to:" &
vbCrLf & Err.Description, vbCritical, scMsgHeader
Err.Clear
End Sub ' CreatePoints
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Add the data needed for point creation to the data type tData
' Called from: CreatePoints
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetData(Pt1 As AeccPoint, Pt2 As AeccPoint, tData As Type_Data)
As Boolean
On Error GoTo ErrorHandler
Dim dTmp As Double
Dim PtStart(0 To 2) As Double
Dim PtEnd(0 To 2) As Double
Dim dTotalDist As Double
Dim dHeightIncrement As Double
dTotalDist = Sqr((Pt1.Easting - Pt2.Easting) ^ 2 + (Pt1.Northing -
Pt2.Northing) ^ 2)
dHeightIncrement = Pt2.Elevation - Pt1.Elevation
If dHeightIncrement < 0 Then
Dim Pt As AeccPoint
Set Pt = Pt1
Set Pt1 = Pt2
Set Pt2 = Pt
dHeightIncrement = -dHeightIncrement
Else
End If '
tData.Elevation = icIncrement + Int(Pt1.Elevation / icIncrement) *
icIncrement
If tData.Elevation > Pt2.Elevation Then
GetData = False
Exit Function
Else
End If '
tData.FirstDistance = (tData.Elevation - Pt1.Elevation) * dTotalDist
/ dHeightIncrement
tData.UnitDistance = icIncrement * dTotalDist / dHeightIncrement
PtStart(0) = Pt1.Easting
PtStart(1) = Pt1.Northing
PtEnd(0) = Pt2.Easting
PtEnd(1) = Pt2.Northing
tData.Direction = ThisDrawing.Utility.AngleFromXAxis(PtStart, PtEnd)
GetData = True
Exit Function
ErrorHandler:
MsgBox "Unable to process data in Function 'GetData' due to:" &
vbCrLf & Err.Description, vbCritical, scMsgHeader
Err.Clear
GetData = False
End Function ' GetData
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Called from:
' Calls:
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetPoint(spPrompt As String) As AeccPoint
On Error GoTo ErrorHandler
Dim oEnt As AcadEntity
Dim Pt(0 To 2) As Double
On Error Resume Next
ThisDrawing.Utility.GetEntity oEnt, Pt, "Select first Civil 3D point
object"
If Err <> 0 Then
Err.Clear
If MsgBox("No object was selected" & vbCrLf & "Do you wish to try
again ?", vbYesNo, scMsgHeader) = vbYes Then
GetPoint spPrompt
Else
Set GetPoint = Nothing
Exit Function
End If
Else
End If '
On Error GoTo ErrorHandler
If TypeOf oEnt Is AeccPoint Then
Set GetPoint = oEnt
Exit Function
End If
If MsgBox("The selected object was not a Civil 3D point" & vbCrLf &
"Do you wish to try again ?", vbYesNo, scMsgHeader) = vbYes Then
GetPoint spPrompt
Else
Set GetPoint = Nothing
End If
Exit Function
ErrorHandler:
MsgBox "Unable to process data in Function 'GetPoint' due to:" &
vbCrLf & Err.Description, vbCritical, scMsgHeader
Err.Clear
Set GetPoint = Nothing
End Function ' GetPoint