社区 › Auto Lisp › 查询：站点标签

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

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

;; 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))
       sign1
)
      )
    )

    (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

;; 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))
       sign1
)
      )
    )

    (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)

 
~'J'~

runner214 发表于 2022-7-6 11:26:22

谢谢fixo-这真的很管用！：眨眼：

stevesfr 发表于 2022-7-6 11:28:21

真的需要把方块翻转180度。
当沿着指定位置的线“行走”时
你得把书倒过来读！！
只有我的意见和2美分
 
当然，人们可以使用第一个版本并制作自己的区块。
S

fixo 发表于 2022-7-6 11:31:16

 
嗨，史蒂夫，我不知道帝国标准
 
你能纠正你说的话吗？
 
~'J'~

查看完整版本: 查询：站点标签