查询：站点标签

runner214 · 发表于 2022-7-6 11:01:50

如果有人能告诉我需要什么代码来增加站点值。

附加的lisp引用了早期的线程(http://www.cadtutor.net/forum/showthread.php?t=24278&highlight=chainage)

我已附上转换后的lisp文件和我的工作图纸

谢谢

fixo · 发表于 2022-7-6 11:06:01

这是老歌里的我不记得是怎么回事了
我记得它是为一个克罗地亚人写的

copy


;; written by Fatty T.O.H. ()2004 * all rights removed
;; edited 6/5/10
;; Stationing
;;load ActiveX library
(vl-load-com)
;;local defuns
;;//
(defun start (curve)
 (vl-catch-all-apply (function (lambda()
 (vlax-curve-getclosestpointto curve
 (vlax-curve-getstartpoint curve
   )
 )
)
   )
 )
 )
;;//
(defun end (curve)
 (vl-catch-all-apply (function (lambda()
 (vlax-curve-getclosestpointto curve
 (vlax-curve-getendpoint curve
   )
 )
)
   )
 )
 )
;;//
(defun pointoncurve (curve pt)
 (vl-catch-all-apply (function (lambda()
 (vlax-curve-getclosestpointto curve
 pt
   )
 )
)
   )
 )
;;//
(defun paramatpoint (curve pt)
 (vl-catch-all-apply (function (lambda()
 (vlax-curve-getparamatpoint curve
 pt
   )
 )
)
   )
 )
;;//
(defun distatpt (curve pt)
 (vl-catch-all-apply (function (lambda()
 (vlax-curve-getdistatpoint curve
   (vlax-curve-getclosestpointto curve pt)
   )
 )
   )
   )
 )
;;//
(defun pointatdist (curve dist)
 (vl-catch-all-apply (function (lambda()
 (vlax-curve-getclosestpointto curve
 (vlax-curve-getpointatdist curve dist)
   )
 )
)
   )
 )
;;//
(defun curvelength (curve)
 (vl-catch-all-apply (function (lambda()
 (vlax-curve-getdistatparam curve
 (- (vlax-curve-getendparam curve)
    (vlax-curve-getstartparam curve)
   )
 )
 )
)
   )
 )
;;//
(defun distatparam (curve param)
 (vl-catch-all-apply (function (lambda()
 (vlax-curve-getdistatparam curve
 param
 )
 )
   )
   )
 )
;;//
(defun statlabel (num step)
;; num - integer, zero based
;; step - double or integer, must be non zero
           (strcat
    (itoa (fix (/ num 2.)) )
    "+"
    (rtos (* (* step 2) (- (/  num 2.) (fix (/ num 2.)))) 2 2)
    )
    )
;;//
(defun insertstation (acsp bname pt rot tag num step / block)
 (vl-catch-all-apply
   (function (lambda()
    (setq block (vlax-invoke-method acsp 'InsertBlock pt bname 1 1 1 rot))
 )
      )
   )
 (changeatt block tag (statlabel num step))
block
 )
;;//
(defun changeatt (block tag value / att)
 (setq atts (vlax-invoke block 'GetAttributes))
 (foreach att atts
   (if (equal tag (vla-get-tagstring att))
     (vla-put-textstring att value)
     )
   )
   )
;;// written by VovKa (Vladimir Kleshev)
(defun gettangent (curve pt)
 (setq param (paramatpoint curve pt)
       ang ((lambda (deriv)
    (if (zerop (cadr deriv))
      (/ pi 2)
      (atan (apply '/ deriv))
    )
  )
   (cdr (reverse
   (vlax-curve-getfirstderiv curve param)
        )
   )
 )
)
 ang
 )
;;//
(defun c:st50 (/ acsp adoc block blkdef cnt en ent label lastp
         leng mul nop num pt rot sign start step)
 (setq adoc (vla-get-activedocument (vlax-get-acad-object))
   acsp (vla-get-block (vla-get-activelayout adoc))
    )
(if (not (tblsearch "block" "Station"))
  (progn
    (alert "Block "Station" does not exist. Error...")
    (exit)(princ)
    )
  )
 (setq blkdef (vla-item (vla-get-blocks adoc) "Station"))
 (setq nop T)
 (vlax-for item blkdef
   (if (not (and (eq "AcDbAttributeDefinition" (vla-get-objectname item))
     (eq "NUMBER" (vla-get-tagstring item))))
     (setq nop nil)
     )
   )
  (if nop
  (progn
    (alert "Block "Station" has not attribute "NUMBER". Error...")
    (exit)(princ)
    )
  )
(setq step 50.)
(if
 (setq
   ent (entsel
  "\nSelect curve near to the start point >>"
)
 )
  (progn
    (setq en (car ent)
   pt (pointoncurve en (cadr ent))
   leng (distatparam en (vlax-curve-getendparam en))
    )
    (setq num (fix (/ leng step))
    )
    (setq mul (- leng (* num step))
    )
    (if (not (zerop mul))
      (setq lastp T)
      (setq lastp nil)
    )
    (if (> (- (paramatpoint en pt)
       (paramatpoint en (vlax-curve-getstartpoint en))
    )
    (- (paramatpoint en (vlax-curve-getendpoint en))
       (paramatpoint en pt)
    )
 )
      (progn
 (setq start leng
       sign  -1
 )
 )
      (progn
 (setq start (distatparam en (vlax-curve-getstartparam en))
       sign  1
 )
      )
    )
    (vla-startundomark
      (vla-get-activedocument (vlax-get-acad-object))
    )
    (setq cnt 0)
    (repeat (1+ num)
      (setq pt  (pointatdist en start)
     rot (gettangent en pt)
      )
     (setq block
     (insertstation acsp "Station"
       (vlax-3d-point pt)
       rot
       "NUMBER" cnt step)
    )
      (setq cnt   (1+ cnt)
     start (+ start (* sign step))
      )
    )
 (if lastp
   (progn
   (if (= sign -1)
   (progn
     (setq pt  (vlax-curve-getstartpoint en)
     rot (gettangent en pt)
      )
     )
     (progn
     (setq pt  (vlax-curve-getendpoint en)
     rot (gettangent en pt)
      )
     )
     )
     (setq block
     (insertstation acsp "Station"
       (vlax-3d-point pt)
       rot
       "NUMBER" (1- cnt) 0)
    )
   (setq label (statlabel (1- cnt) 50.)
  label (strcat (substr label 1 (1+ (vl-string-search "+" label)))
  (rtos mul 2 2))
  )
   (changeatt block "NUMBER" label)
   )
   )
    (vla-endundomark
      (vla-get-activedocument (vlax-get-acad-object))
    )
  )
  (princ "\nNothing selected")
)
(princ)
)
(prompt "\n   >>>   Type ST50 to execute...")
(prin1)

~'J'~

runner214 · 发表于 2022-7-6 11:10:47

谢谢你，菲索，很好用。

感谢您抽出时间提供帮助。

stevesfr · 发表于 2022-7-6 11:13:04

这很漂亮。为了使其工作，使用一个名为NUMBER的属性创建一个名为STATION的块
块可以只是一条短垂直线，属性位于垂直线上方，块的插入点可以是短垂直线的底部。将块另存为桩号，并打开短垂直线和名为NUMBER的属性。
干杯
史蒂夫

fixo · 发表于 2022-7-6 11:16:18

不客气

~'J'~

runner214 · 发表于 2022-7-6 11:19:33

是否可以预加载块或添加代码来创建块“站”？

fixo · 发表于 2022-7-6 11:22:14

改为尝试编辑lisp

copy


;; written by Fatty T.O.H. ()2004 * all rights removed
;; edited 6/5/10
;; Stationing
;;load ActiveX library
(vl-load-com)
;;local defuns
;//
(defun makeblock (adoc aprompt atag bname txtheight tstyle / at_obj blk_obj lay line_obj tst)
(if (not (tblsearch "block" bname))
 (progn
 (setq tst (getvar "textstyle"))
 (setvar "textstyle" tstyle)
 (setq lay (getvar "clayer"))
 (setvar "clayer" "0")
 (setq blk_obj (vla-add (vla-get-blocks adoc) (vlax-3d-point '(0. 0. 0.)) bname))
 (setq line_obj (vlax-invoke blk_obj 'Addline '(0. 0. 0.) (list 0. 12.0 0.)))
 (vla-put-color line_obj acyellow)
 (setq at_obj (vla-addattribute blk_obj
  txtheight
  acattributemodeverify
  aprompt
  (vlax-3d-point '(-0.5 1. 0.))
  atag
  "0+0.00")
)
 (vla-put-rotation at_obj (/ pi 2))
 (vla-put-color at_obj acwhite)
 (mapcar (function (lambda(x) vlax-release-object x))
  (list at_obj line_obj blk_obj )
  )
 (setvar "clayer" lay)
 (setvar "textstyle" tst)
 )
 )
 )
;;//
(defun start (curve)
 (vl-catch-all-apply (function (lambda()
 (vlax-curve-getclosestpointto curve
 (vlax-curve-getstartpoint curve
   )
 )
)
   )
 )
 )
;;//
(defun end (curve)
 (vl-catch-all-apply (function (lambda()
 (vlax-curve-getclosestpointto curve
 (vlax-curve-getendpoint curve
   )
 )
)
   )
 )
 )
;;//
(defun pointoncurve (curve pt)
 (vl-catch-all-apply (function (lambda()
 (vlax-curve-getclosestpointto curve
 pt
   )
 )
)
   )
 )
;;//
(defun paramatpoint (curve pt)
 (vl-catch-all-apply (function (lambda()
 (vlax-curve-getparamatpoint curve
 pt
   )
 )
)
   )
 )
;;//
(defun distatpt (curve pt)
 (vl-catch-all-apply (function (lambda()
 (vlax-curve-getdistatpoint curve
   (vlax-curve-getclosestpointto curve pt)
   )
 )
   )
   )
 )
;;//
(defun pointatdist (curve dist)
 (vl-catch-all-apply (function (lambda()
 (vlax-curve-getclosestpointto curve
 (vlax-curve-getpointatdist curve dist)
   )
 )
)
   )
 )
;;//
(defun curvelength (curve)
 (vl-catch-all-apply (function (lambda()
 (vlax-curve-getdistatparam curve
 (- (vlax-curve-getendparam curve)
    (vlax-curve-getstartparam curve)
   )
 )
 )
)
   )
 )
;;//
(defun distatparam (curve param)
 (vl-catch-all-apply (function (lambda()
 (vlax-curve-getdistatparam curve
 param
 )
 )
   )
   )
 )
;;//
(defun statlabel (num step)
;; num - integer, zero based
;; step - double or integer, must be non zero
           (strcat
    (itoa (fix (/ num 2.)) )
    "+"
    (rtos (* (* step 2) (- (/  num 2.) (fix (/ num 2.)))) 2 2)
    )
    )
;;//
(defun insertstation (acsp bname pt rot tag num step / block)
 (vl-catch-all-apply
   (function (lambda()
    (setq block (vlax-invoke-method acsp 'InsertBlock pt bname 1 1 1 rot))
 )
      )
   )
 (changeatt block tag (statlabel num step))
block
 )
;;//
(defun changeatt (block tag value / att)
 (setq atts (vlax-invoke block 'GetAttributes))
 (foreach att atts
   (if (equal tag (vla-get-tagstring att))
     (vla-put-textstring att value)
     )
   )
   )
;;// written by VovKa (Vladimir Kleshev)
(defun gettangent (curve pt)
 (setq param (paramatpoint curve pt)
       ang ((lambda (deriv)
    (if (zerop (cadr deriv))
      (/ pi 2)
      (atan (apply '/ deriv))
    )
  )
   (cdr (reverse
   (vlax-curve-getfirstderiv curve param)
        )
   )
 )
)
 ang
 )
;;//
(defun c:st50 (/ acsp adoc block blkdef cnt en ent label lastp
         lay leng mul nop num pt rot sign start step)
 (setvar "dimzin" 2)
 (setq lay (getvar "clayer"))
 (setvar "clayer" "0")
 (setq adoc (vla-get-activedocument (vlax-get-acad-object))
   acsp (vla-get-block (vla-get-activelayout adoc))
    )
(if (not (tblsearch "block" "Station"))
  (makeblock adoc "NUMBER" "NUMBER" "Station" 2.0 "Standard")
  )
(setq step 50.)
(if
 (setq
   ent (entsel
  "\nSelect curve near to the start point >>"
)
 )
  (progn
    (setq en (car ent)
   pt (pointoncurve en (cadr ent))
   leng (distatparam en (vlax-curve-getendparam en))
    )
    (setq num (fix (/ leng step))
    )
    (setq mul (- leng (* num step))
    )
    (if (not (zerop mul))
      (setq lastp T)
      (setq lastp nil)
    )
    (if (> (- (paramatpoint en pt)
       (paramatpoint en (vlax-curve-getstartpoint en))
    )
    (- (paramatpoint en (vlax-curve-getendpoint en))
       (paramatpoint en pt)
    )
 )
      (progn
 (setq start leng
       sign  -1
 )
 )
      (progn
 (setq start (distatparam en (vlax-curve-getstartparam en))
       sign  1
 )
      )
    )
    (vla-startundomark
      (vla-get-activedocument (vlax-get-acad-object))
    )
    (setq cnt 0)
    (repeat (1+ num)
      (setq pt  (pointatdist en start)
     rot (gettangent en pt)
      )
     (setq block
     (insertstation acsp "Station"
       (vlax-3d-point pt)
       rot
       "NUMBER" cnt step)
    )
      (setq cnt   (1+ cnt)
     start (+ start (* sign step))
      )
    )
 (if lastp
   (progn
   (if (= sign -1)
   (progn
     (setq pt  (vlax-curve-getstartpoint en)
     rot (gettangent en pt)
      )
     )
     (progn
     (setq pt  (vlax-curve-getendpoint en)
     rot (gettangent en pt)
      )
     )
     )
     (setq block
     (insertstation acsp "Station"
       (vlax-3d-point pt)
       rot
       "NUMBER" (1- cnt) 0)
    )
   (setq label (statlabel (1- cnt) 50.)
  label (strcat (substr label 1 (1+ (vl-string-search "+" label)))
  (rtos mul 2 2))
  )
   (changeatt block "NUMBER" label)
   )
   )
   (setvar "clayer" lay)
    (vla-endundomark
      (vla-get-activedocument (vlax-get-acad-object))
    )
  )
  (princ "\nNothing selected")
)
(princ)
)
(prompt "\n   >>>   Type ST50 to execute...")
(prin1)