我想已经修好了，
最低限度的测试。
(defun c:perfil (/ ss1 ss itm obj osm_old
angb_old angd_old ct_basebase_obj ref lbtxt
pt1 pt2 pt3 ent1 obj1 dist1
dist2 base_obj itm ptint lent txt_obj
ptdist grade pt_txt pt_txt1pt_txt2
)
(vl-load-com)
(prompt "\nSelecione a Polyline do Grade : ")
(if (setq ss1 (ssget "_:S:E" '((0 . "LWPOLYLINE"))))
(progn
(prompt "\nSelecione as linhas verticais do Coletor: ")
(if (setq ss (ssget '((0 . "LINE,LWPOLYLINE"))))
(progn
(setq itm0
obj(vlax-ename->vla-object (ssname ss1 0))
osm_old(getvar "OSMODE")
angb_old (getvar "ANGBASE")
angd_old (getvar "ANGDIR")
)
(setvar "OSMODE" 0)
(setvar "ANGBASE" (/ PI 2.))
(setvar "ANGDIR" 1)
(setq ct_base(entsel "\nSelecione a linha da cota base :")
base_obj (vlax-ename->vla-object (car ct_base))
ref(atof
(cdr
(assoc
1
(entget
(car
(entsel "\nSelecione o texto da cota base :")
)
)
)
)
)
)
(setvar "OSMODE" 512)
(setq lbtxt
(nentselp
"\nSelecione a linha base para os textos cota do grade:"
)
)
(setvar "OSMODE" 128)
(setq pt1 (cadr lbtxt)
txt_obj (vlax-ename->vla-object (car lbtxt))
pt1 (vlax-curve-getClosestPointTo txt_obj pt1 T)
)
(setq pt2 (getpoint
pt1
"\nSelecione a linha base para os textos cota do coletor:"
)
pt3 (getpoint
pt1
"\nSelecione a linha base para os textos profundidade do coletor:"
)
dist1 (distance pt1 pt2)
dist2 (distance pt1 pt3)
)
(setvar "OSMODE" 0)
(repeat (sslength ss)
(setq ent1 (ssname ss itm)
obj1 (vlax-ename->vla-object ent1)
)
(if (setq ptint (vla-IntersectWith obj obj1 acExtendNone))
(progn
(setq lent (vla-get-length obj1)
ptint(vlax-safearray->list
(vlax-variant-value ptint)
)
ptdist (vlax-curve-getClosestPointTo base_obj ptint T)
grade(+ (distance ptint ptdist) ref)
pt_txt (vlax-curve-getClosestPointTo txt_obj ptint)
pt_txt (polar pt_txt (* (/ pi 4) 3) 0.15)
)
(command "TEXT" pt_txt 0. (rtos grade 2 3))
(setq pt_txt1 (polar pt_txt (angle pt1 pt2) dist1))
(command "TEXT" pt_txt1 0. (rtos (- grade lent) 2 3))
(setq pt_txt2 (polar pt_txt (angle pt1 pt3) dist2))
(command "TEXT" pt_txt2 0. (rtos lent 2 3))
)
;; progn
)
;; If
(setq itm (1+ itm))
)
;; repeat
)
;; progn
)
;; if
)
;; progn
)
;; if
(setvar "OSMODE" osm_old)
(setvar "ANGBASE" angb_old)
(setvar "ANGDIR" angd_old)
(princ)
)
干杯
亨里克 ：值得注意：
非常感谢你，亨里克。
你太棒了！！
工作得很有魅力！
当做 不客气，Madruga_SP
干杯
亨里克
页:
1
[2]