(defun c:Test (/ *error* IsAttributed Spread_The_Block s d l blk at)
(vl-load-com)
;; Tharwat 15. 01. 2013 ;
(defun *error* (x)
(if at
(setvar 'attdia at)
)
(princ "\n*Cancel*")
)
(or Doc (setq Doc (vla-get-ActiveDocument (vlax-get-acad-object))))
(defun IsAttributed (Doc name / yes)
(vlax-for o (vla-item (vla-get-blocks Doc) name)
(if (eq "AcDbAttributeDefinition" (vla-get-objectname o))
(setq yes t)
)
)
yes
)
(defun Spread_The_Block (s l d rm blk / sg i mrk)
(if rm
(setq sgrm
i (* d (fix (/ l d)))
mrk '-
)
(setq sgd
i d
mrk '+
)
)
(repeat (fix (/ l d))
(vl-cmdf "_.-insert"
blk
"_non"
(vlax-curve-getpointatdist s sg)
"1."
"1.0"
"0."
(strcat "DC-" (rtos i 2 0))
)
(setq sg (+ sg d)
i(apply mrk (list i d))
)
)
)
(setq blk "DC");; Specify Attibuted block name here with one attributes
(if (and (if (not (tblsearch "BLOCK" blk))
(progn (princ "\n Block name is not found in Drawing !!") nil)
t
)
(if (not (IsAttributed Doc blk))
(progn (princ "\n Block name is not Attributed Block !!") nil)
t
)
(setq d (getreal "\n Increment Distance:"))
(setq s (car (entsel "\n Select Polyline:")))
)
(progn (setq at (getvar 'attdia))
(setvar 'attdia 0)
(setq l (vlax-curve-getdistatparam s (vlax-curve-getendparam s)))
(if (> (car (vlax-curve-getstartpoint s)) (car (vlax-curve-getendpoint s)))
(Spread_The_Block s l d (rem l d) blk)
(Spread_The_Block s l d nil blk)
)
(setvar 'attdia at)
)
)
(princ "\nWritten by Tharwat Al Shoufi")
(princ)
)
Tharwat我印象深刻谢谢
我很高兴你喜欢它。 塔尔瓦特，
我刚刚发现了沿多段线放置属性块的lisp例程。它非常好，几乎完全符合我的要求，我有一个问题要问你。
是否很难使块插入，使其垂直于多段线（甚至围绕曲线），而不是当前的垂直？
我正在努力学习lisp，如果你能给我指出正确的方向，我愿意试一试！
当做
约翰 欢迎来到Cadboot rayboy。
你能举一个例子来说明你对这个项目的期望目标吗，不管这个项目在这个线程中是什么？
如果可以，请上载样例图形。 或者这里是如何玩角度的方法。
注意：不要忘记在程序中本地化变量“p”。
(vl-cmdf "_.-insert"
blk
"_non"
(setq p (vlax-curve-getpointatdist s sg))
"1."
"1.0"
(/ (* (angle '(0. 0. 0.)
(vlax-curve-getfirstderiv
s
(vlax-curve-getparamatpoint s p)
)
)
180.0
)
pi
)
(strcat "DC-" (rtos i 2 0))
)
谢谢塔瓦，很高兴来到这里。
我附上了一个简单的图纸显示了一个例子。
最上面的示例是lisp生成的内容。下面的例子是我想要的。
块应垂直于多段线（如齿轮上的齿）。
如果它可以在起点（0.0）插入一个块，并将其编号为0.0、0.5、1.0、1.5等，那也很好。
kp测试。图纸 这并不完美，但效果很好，现在您可以选择更多的对象，而不仅仅是多段线。
试试看。
(defun c:Test (/ *error* do isattributed spread_the_block s d l blk vals
p
)
;; Tharwat 26. 08. 2015 ;
(defun *error* (x)
(if vals
(mapcar 'setvar '(attdia dimzin) vals)
)
)
(defun isattributed (doc name / yes)
(vlax-for o (vla-item (vla-get-blocks doc) name)
(if (eq "AcDbAttributeDefinition" (vla-get-objectname o))
(setq yes t)
)
)
yes
)
(defun spread_the_block (s l d blk / sg i mrk)
(setq sgd
i d
mrk '+
)
(vl-cmdf "_.-insert"
blk
"_non"
(setq p (vlax-curve-getstartpoint s))
"1."
"1.0"
(/ (* (angle '(0. 0. 0.)
(vlax-curve-getfirstderiv
s
(vlax-curve-getparamatpoint s p)
)
)
180.0
)
pi
)
(strcat "DC-" "0.0")
)
(repeat (fix (/ l d))
(vl-cmdf "_.-insert"
blk
"_non"
(setq p (vlax-curve-getpointatdist s sg))
"1."
"1.0"
(/ (* (angle '(0. 0. 0.)
(vlax-curve-getfirstderiv
s
(vlax-curve-getparamatpoint s p)
)
)
180.0
)
pi
)
(strcat "DC-" (rtos i 2 1))
)
(setq i(apply mrk (list i d))
sg (+ sg d)
)
)
)
(setq blk "kptag1"
do (vla-get-activedocument (vlax-get-acad-object))
*incval* (if *incval*
*incval*
0.5
)
)
;; Specify Attibuted block name here with one attributes
(if
(and
(if (not (tblsearch "BLOCK" blk))
(progn (princ "\nBlock name is not found in Drawing !!")
nil
)
t
)
(if (not (isattributed do blk))
(progn (princ "\nBlock name is not Attributed Block !!")
nil
)
t
)
(progn (initget 6)
(setq
*incval* (cond ((getdist (strcat "\n Increment Distance <"
(rtos *incval* 2 2)
"> :"
)
)
)
(t *incval*)
)
)
)
(setq s (car (entsel "\nPick on :")))
(wcmatch (cdr (assoc 0 (entget s)))
"LWPOLYLINE,LINE,ARC,SPLINE"
)
)
(progn (setq vlas (mapcar 'getvar '(attdia cmdecho dimzin)))
(mapcar 'setvar '(attdia cmdecho dimzin) '(0 0 0))
(setq l (vlax-curve-getdistatparam s (vlax-curve-getendparam s)))
(vla-startundomark do)
(spread_the_block s l *incval* blk)
(vla-endundomark do)
)
)
(*error* nil)
(princ "\nWritten by Tharwat Al Shoufi")
(princ)
)(vl-load-com)
谢谢Tharwat，这已经很接近了。
我无法让文本从0开始（从0.5开始），然后它不显示整数的小数位（它显示1而不是1.0）。我已经调整了RTOS值，但它没有显示1.0格式。
页:
1
[2]