TheSwamp
CAD Forums => Vertically Challenged => Land Lubber / Geographically Positioned => Topic started by: sinc on August 21, 2004, 03:12:11 PM
-
Here's a simple routine that will datum-adjust existing points based on the centerline FG profile of the current alignment. It's useful if you have existing points you want to change the elevation of, or if you don't want/need to go to the overhead of creating a cross-section template and setting points that way.
It will calc the grade for the point based on the profile, then applies two additional datum adjustments: a flat datum adjustment, and another calculated by multiplying a grade percentage you specify by the offset distance of the point from the alignment. (Set these to 0 for no adjustment.)
It could use some improvements, for example: a dialogue box that pops up and asks you to select a FG profile (currently it always uses the centerline one, although you can change this in the code easily enough).
; pt2align.lsp v1.00
; Datum-adjust selected cogo points to the current FG profile.
; Can also apply another flat datum adjustment to profile grade,
; as well as an additional datum adjustment calculated from a grade
; percentage multiplied by the point's offset distance from the alignment.
; Richard Sincovec AUG-21-2004
(vl-load-com)
(if (null vll-kCurve)
(vlax-import-type-library
:tlb-filename "landauto.tlb"
:methods-prefix "vll-"
:properties-prefix "vll-"
:constants-prefix "vll-"
) ;_ vlax-import-type-library
) ;_ if
(defun c:pt2align (/ acadObj aeccApp aeccProj
cogoPoints alignments curAlign ss
pt pt_num curAlignName
err fgProfiles sta ofs
dir elev
)
(if (null *ZYZ_DATUMADJ*)
(setq *ZYZ_DATUMADJ* 0.0)
) ;_ if
(setq *ZYZ_DATUMADJ*
(cond
((getreal
(strcat
"\nDatum adjustment to apply <"
(rtos *ZYZ_DATUMADJ*)
">: "
) ;_ strcat
) ;_ getdist
)
(*ZYZ_DATUMADJ*)
) ;_ cond
) ;_ setq
(if (null *ZYZ_GRADEADJ*)
(setq *ZYZ_GRADEADJ* 0.0)
) ;_ if
(setq *ZYZ_GRADEADJ*
(cond
((getreal
(strcat
"\nGrade adjustment to apply <"
(rtos *ZYZ_GRADEADJ*)
"%>: "
) ;_ strcat
) ;_ getdist
)
(*ZYZ_GRADEADJ*)
) ;_ cond
) ;_ setq
; should probably add more elaborate error detection...
(setq
err (vl-catch-all-apply
(function
(lambda ()
(setq acadObj (vlax-get-acad-object)
aeccApp (vla-getInterfaceObject
acadObj
"Aecc.Application"
) ;_ vla-getInterfaceObject
aeccProj (vll-get-activeProject aeccApp)
cogoPoints (vll-get-cogoPoints aeccProj)
alignments (vll-get-alignments aeccProj)
curAlignName (vll-get-currentAlignment alignments)
curAlign (vll-item alignments curAlignName)
fgProfiles (vll-get-fgProfiles curAlign)
profile (vll-profileByType fgProfiles vll-kFgCenter)
ss (ssget '((0 . "AECC_POINT")))
) ;_ setq
(if ss
(progn
(setq count (sslength ss)
index -1
) ;_ setq
(vll-put-autoSave cogoPoints T)
;; make sure autoSave is on
(while (< (setq index (1+ index)) count)
(setq pt_num (cdr
(assoc 90 (entget (ssname ss index)))
) ;_ cdr
pt (vll-pointByNumber cogoPoints pt_num)
) ;_ setq
(setq err2 (vl-catch-all-apply
(function
(lambda ()
(vll-stationOffset
curAlign
(vll-get-easting pt)
(vll-get-northing pt)
'sta
'ofs
'dir
) ;_ vll-stationOffset
) ;_ lambda
) ;_ function
) ;_ vl-catch-all-apply
) ;_ setq
(if err2
(princ (strcat "\nPoint "
(itoa pt_num)
" is not adjacent to alignment."
) ;_ strcat
) ;_ princ
(progn
(setq elev (vll-elevationAt
profile
sta
) ;_ vll-elevationAt
elev (+ elev *ZYZ_DATUMADJ*)
elev (+ elev (* (/ *ZYZ_GRADEADJ* 100) (abs ofs)))
) ;_ setq
(vll-put-elevation
pt
elev
) ;_ vll-put-elevation
(vlax-release-object pt)
) ;_ progn
) ;_ if
) ;_ while
) ;_ progn
) ;_ if
) ;_ lambda
) ;_ function
) ;_ vl-catch-all-apply
) ;_ setq
(if (vl-catch-all-error-p err)
(princ (strcat "\nError: "
(vl-catch-all-error-message err)
"\nMake sure current alignment is selected, and alignment has a center FG profile."
) ;_ strcat
) ;_ princ
) ;_ if
(if profile (vlax-release-object profile))
(if fgProfiles (vlax-release-object fgProfiles))
(if curAlign (vlax-release-object curAlign))
(if alignments (vlax-release-object alignments))
(if cogoPoints (vlax-release-object cogoPoints))
(if aeccProj (vlax-release-object aeccProj))
(if aeccApp (vlax-release-object aeccApp))
(princ)
) ;_ defun
-
Actually, I found some free time I didn't expect this weekend, and made some improvements. It now uses a dialog box, and contains better error-checking.
; pt2align.lsp v1.01
; - uses p2align.dcl
; Richard Sincovec AUG-22-2004
; Datum-adjust selected cogo points to a FG profile in the current alignment.
; Can also apply another flat datum adjustment to profile grade,
; as well as an additional datum adjustment calculated from a grade
; percentage multiplied by the point's offset distance from the alignment.
(vl-load-com)
(if (null vll-kCurve)
(vlax-import-type-library
:tlb-filename "landauto.tlb"
:methods-prefix "vll-"
:properties-prefix "vll-"
:constants-prefix "vll-"
) ;_ vlax-import-type-library
) ;_ if
(defun c:pt2align (/ acadObj aeccApp aeccProj cogoPoints
alignments curAlign ss pt
pt_num curAlignName err
err2 fgProfiles sta ofs
dir elev count index
profile searchArray profileTypes
profileCodes dcl_id
) ;_ /
;_ /
(if (null *ZYZ_DATUMADJ*)
(setq *ZYZ_DATUMADJ* 0.0)
) ;_ if
(if (null *ZYZ_GRADEADJ*)
(setq *ZYZ_GRADEADJ* 0.0)
) ;_ if
(setq
profileCodes
(list
(cons vll-kFgCenter "Center")
(cons vll-kFgDitchLeft "Ditch Left")
(cons vll-kFgDitchRight "Ditch Right")
(cons vll-kFgDitchLeft "Ditch Left")
(cons vll-kFgLeft1 "L1")
(cons vll-kFgLeft2 "L2")
(cons vll-kFgLeft3 "L3")
(cons vll-kFgLeft4 "L4")
(cons vll-kFgLeft5 "L5")
(cons vll-kFgLeft6 "L6")
(cons vll-kFgLeft7 "L7")
(cons vll-kFgLeft8 "L8")
(cons vll-kFgRight1 "R1")
(cons vll-kFgRight2 "R2")
(cons vll-kFgRight3 "R3")
(cons vll-kFgRight4 "R4")
(cons vll-kFgRight5 "R5")
(cons vll-kFgRight6 "R6")
(cons vll-kFgRight7 "R7")
(cons vll-kFgRight8 "R8")
(cons vll-kFgNone "None")
) ;_ list
profileTypes (mapcar '(lambda (x)
(list (cdr x) (car x))
) ;_ lambda
profileCodes
) ;_ mapcar
) ;_ setq
(setq
err
(vl-catch-all-apply
(function
(lambda ()
(setq acadObj (vlax-get-acad-object)
aeccApp (vla-getInterfaceObject
acadObj
"Aecc.Application"
) ;_ vla-getInterfaceObject
aeccProj (vll-get-activeProject aeccApp)
cogoPoints (vll-get-cogoPoints aeccProj)
alignments (vll-get-alignments aeccProj)
curAlignName (vll-get-currentAlignment alignments)
index -1
searchArray nil
profile nil
err2 (vl-catch-all-apply
(function
(lambda ()
(setq
curAlign (vll-item alignments curAlignName)
) ;_ setq
) ;_ lambda
) ;_ function
) ;_ vl-catch-all-apply
) ;_ setq
(if (vl-catch-all-error-p err2)
(princ "Could not get current alignment - make sure it is selected.")
(if (> (setq fgProfiles (vll-get-fgProfiles curAlign)
count (vll-get-count fgProfiles)
) ;_ setq
0
) ;_ >
(progn
(while (< (setq index (1+ index)) count)
(setq searchArray
(append searchArray
(list
(vll-get-type
(vll-item fgProfiles index)
) ;_ vll-get-type
) ;_ list
) ;_ append
) ;_ setq
) ;_ while
(setq searchArray (mapcar '(lambda (x)
(cdr (assoc x profileCodes))
) ;_ lambda
searchArray
) ;_ mapcar
dcl_id (load_dialog "pt2align.dcl")
index 0 ; initially select first profile
) ;_ setq
(if (new_dialog "PT2ALIGN" dcl_id)
(progn
(set_tile "DATUMADJ" (rtos *ZYZ_DATUMADJ* 2))
(set_tile "GRADEADJ" (rtos *ZYZ_GRADEADJ* 2 2))
(start_list "FGPROFILES")
(mapcar 'add_list searchArray)
(end_list)
(set_tile "FGPROFILES" (car searchArray))
(action_tile
"FGPROFILES"
"(setq index (p2a:selectProfile))"
) ;_ action_tile
(action_tile
"accept"
(strcat
"(progn (setq *ZYZ_DATUMADJ* (atof (get_tile \"DATUMADJ\")))"
"(setq *ZYZ_GRADEADJ* (atof (get_tile \"GRADEADJ\")))"
"(done_dialog 1))"
) ;_ strcat
) ;_ action_tile
(if (= (start_dialog) 1)
(cond
(index
(setq
profile (vll-profileByType
fgProfiles
(last (assoc
(nth index searchArray)
profileTypes
) ;_ assoc
) ;_ last
) ;_ vll-profileByType
) ;_ setq
)
((princ "\nNo profile selected!"))
) ;_ cond
(princ "\nCancel...")
) ;_ if
) ;_ progn
) ;_ if
(unload_dialog dcl_id)
(if
(and profile (setq ss (ssget '((0 . "AECC_POINT")))))
(progn
(setq count (sslength ss)
index -1
) ;_ setq
(vll-put-autoSave cogoPoints T)
;; make sure autoSave is on
(while (< (setq index (1+ index)) count)
(setq pt_num (cdr
(assoc 90 (entget (ssname ss index)))
) ;_ cdr
pt (vll-pointByNumber cogoPoints pt_num)
) ;_ setq
(setq err2 (vl-catch-all-apply
(function
(lambda ()
(vll-stationOffset
curAlign
(vll-get-easting pt)
(vll-get-northing pt)
'sta
'ofs
'dir
) ;_ vll-stationOffset
) ;_ lambda
) ;_ function
) ;_ vl-catch-all-apply
) ;_ setq
(if (vl-catch-all-error-p err2)
(princ (strcat "\nPoint "
(itoa pt_num)
" is not adjacent to alignment."
) ;_ strcat
) ;_ princ
(progn
(setq elev (vll-elevationAt
profile
sta
) ;_ vll-elevationAt
elev (+ elev *ZYZ_DATUMADJ*)
elev (+ elev
(* (/ *ZYZ_GRADEADJ* 100) (abs ofs))
) ;_ +
) ;_ setq
(vll-put-elevation
pt
elev
) ;_ vll-put-elevation
(vlax-release-object pt)
) ;_ progn
) ;_ if
) ;_ while
) ;_ progn
) ;_ if got ss
) ;_ progn
(princ "No Finish Grade Profiles defined!")
) ;_ if (> count 0)
) ;_ if
) ;_ lambda
) ;_ function
) ;_ vl-catch-all-apply
) ;_ setq
(if (vl-catch-all-error-p err)
(princ (strcat "\nError: "
(vl-catch-all-error-message err)
) ;_ strcat
) ;_ princ
) ;_ if
(if profile (vlax-release-object profile))
(if fgProfiles (vlax-release-object fgProfiles))
(if curAlign (vlax-release-object curAlign))
(if alignments (vlax-release-object alignments))
(if cogoPoints (vlax-release-object cogoPoints))
(if aeccProj (vlax-release-object aeccProj))
(if aeccApp (vlax-release-object aeccApp))
(princ)
) ;_ defun
(defun p2a:selectProfile (/ idx)
(setq idx (get_tile "FGPROFILES"))
(if (= $REASON 4) (done_dialog 1))
(cond
((= idx "") nil)
((atoi idx))
)
) ; _defun p2a:selectProfile
And the dcl:
/*===============================================
pt2align.dcl - DCL definition file for pt2align.lsp
=================================================
*/
PT2ALIGN : dialog {
label = "Datum-Adjust Points from FG Profile";
: list_box {label="FG Profiles"; key="FGPROFILES"; is_default=true;}
: row {
: spacer {width=1;}
: text_part {label="Datum Adj:"; width=12;}
: edit_box {key="DATUMADJ"; width=12;}
: spacer {width=1;}
}
: row {
: spacer {width=1;}
: text_part {label="Grade %:"; width=12;}
: edit_box {key="GRADEADJ"; width=12;}
: spacer {width=1;}
}
ok_cancel;
}