帮我处理我的脏代码
嘿伙计们，祝大家新年快乐！
祝你在新的一年里身体健康，万事如意。
我需要代码方面的帮助。我正试图编写一个lisp，将高程文本放置在选定多段线的交点处。
我的英语太差了，所以我附上了一个文件来更好地解释我的任务。
任何想法都很好。
测试。图纸 对不起，伙计们，
我忘了发代码。
(defun c:perfil()
(setq cota-base (getpoint "\nInforme um ponto para cota base :"))
(setq valor-cota (getreal "\nInforme a cota :"))
(setq mostre (entsel "\nSelecione a linha do projeto : "))
(setq bto (getpoint "\nInforme um ponto base para os textos :"))
;;;------------------------------------------------------------------------------------------------------------
(setvar"cmdecho" 0)
;(command "osmode" 0)
(command "angbase" 270)
(command "angdir" 1)
(setq flagv "falso")
(setq controle 0)
(setq controle1 0)
(setq contador 0)
(while (= flagv "falso")
(setq linha (entget (car mostre )))
(setq verificador (cdr(assoc 0 linha)))
(if (= verificador "LWPOLYLINE")
(progn
(setq verif (cdr (assoc 70 linha)))
(setq flagv "verdade")
)
(princ "tNão é Polyline !! ")
)
)
(setq controle1 (length linha))
(setq amostra '())
(repeat controle1
(setq x (caar linha))
(if (= x 10)
(progn
(setq item (car linha))
(setq amostra (cons item amostra))
(setq contador (1+ contador))
)
)
(setq linha (cdr linha))
)
(setq amostra1 (reverse amostra))
(if (= verif 1)
(setqamostra (cons (car amostra1)amostra))
(setq contador (1- contador))
)
(setq controle contador)
(repeat controle
(setq PTO1 (cdr(car amostra)))
(setq PTO2 (cdr(car(cdr amostra))))
(AZIMUTAR)
(setq amostra(cdr amostra))
)
(princ)
)
(defun AZIMUTAR ()
(setq padroes (getvar "osmode"))
(setvar"cmdecho" 0)
(command "osmode" 0)
(setqAPTO1)
(setqB PTO2)
;;(setqC" - Az")
;;(setqD(angtos (angle A B) 1 4))
;;(MUDAR)
;;(setqE (rtos (distance A B) 2 4))
;;(setq DADO (strcat E C PALAV))
;;(PARALELO)
;;(command "text" "j" "mc" ponto_meio 2.5 inicio dado )
;;(command "osmode" padroes)
(setq angulo (angle A B))
(setq ang2 (+ angulo (dtr 90)))
(princ angulo)
(princ ang2)
;-------------------------------------------------------------------------------------------------------------------------------------
(setq x-bto (car bto)
x-b (car b))
(setq dist (- x-b x-bto))
(setq p-proj (polar bto 0 dist))
(setq p-proj (polar p-proj (/ pi 2) 0.1))
(setq p-proj (polar p-proj 179 0.1))
(setq cota (cadr cota-base)
c-proj (cadr b))
(setq cota-final (rtos(+(abs(- c-proj cota))valor-cota)2 3))
(command "zoom" "o" mostre "")
(command "text" p-proj (/ pi 2) cota-final "")
;-------------------------------------------------------------------------------------------------------------------------------------
)
(defun PARALELO ()
(setqA1(polar A (+ (/ pi 2)(angle B A )) 2))
(setqB1(polar B (+ (/ pi 2)(angle B A )) 2))
(setq ptx (/ (+ (car B1) (car A1)) 2))
(setq pty (/ (+ (cadr B1) (cadr A1)) 2))
(setq ponto_meio (list ptx pty))
(if (< (car A1)(car B1))
(setq inicioB1)
(setq inicio A1)
)
)
(defun MUDAR ()
(setq XL 2)
(setqJ "d")
(setq COM1 (substr D 1 1))
(while (< XL 5)
(setq LETRAT (substr D XL 1))
(setq RESTOT (substr D (+ 1 XL) ))
(if(= LETRAT J)
(progn (setq J "%%d")
(setqXL 6)
(setqPALAV (strcatCOM1J RESTOT))
)
)
(setqCOM1 (strcatCOM1 LETRAT ))
(setq XL (1+ XL))
)
)
(defun RTD ()
(/ (* (angle A B) 180) Pi)
)
(defun DTR (AZIMUTE)
(* (/ AZIMUTE 180.0) pi) ;; esta linha também foi alterada
(setvar "osmode" 16383)
)
此例程将高程放置在项目线的每个端点。（选定的多段线）
我只需要更改交点的端点。
有人能帮我吗？
提前感谢。 Madruga_SP，
一种不同的方法，但我希望结果是你想要的。
随附的是您的dwg和一些注释，以解释代码的使用。
(defun c:perfil (/ss1ssitmobjptlst
ent1obj1intosm_old ct_base base_obj
lbtxttxt_obj distpt_txt
)
(vl-load-com)
(prompt "\nSelecione a Polyline do projeto : ")
(if (setq ss1 (ssget "_:S:E" '((0 . "LWPOLYLINE"))))
(progn
(prompt "\nSelecione as linhas verticais: ")
(if (setq ss (ssget '((0 . "LINE"))))
(progn
(setq itm 0
obj (vlax-ename->vla-object (ssname ss1 0))
ptlst nil
)
(repeat (sslength ss)
(setq ent1 (ssname ss itm)
obj1 (vlax-ename->vla-object ent1)
)
(if (setq int (vla-IntersectWith obj obj1 acExtendNone))
(progn
(setq int (vlax-safearray->list (vlax-variant-value int))
ptlst (append ptlst (list int))
)
)
;; progn
)
;; If
(setq itm (1+ itm))
)
(setq osm_old (getvar "OSMODE"))
(setvar "OSMODE" 0)
(setq ct_base (entsel "\nSelecione a linha da cota base :"))
(setq base_obj (vlax-ename->vla-object (car ct_base)))
(setq ref
(atof
(cdr
(assoc
1
(entget
(car
(entsel "\nSelecione o texto da cota base :")
)
)
)
)
)
)
(setq
lbtxt (entsel "\nSelecione a linha base para os textos :")
)
(setq txt_obj (vlax-ename->vla-object (car lbtxt)))
(foreach n ptlst
(setq dist (vlax-curve-getClosestPointTo base_obj n T))
(setq dist (+ (distance n dist) ref))
(setq pt_txt (vlax-curve-getClosestPointTo txt_obj n))
(setq pt_txt (polar pt_txt (* (/ pi 4) 3) 0.1))
(command "TEXT" pt_txt 0. (rtos dist 2 3))
)
;; foreach
)
;; progn
)
;; if
)
;; progn
)
;; if
(setvar "OSMODE" osm_old)
(princ)
)
希望有帮助
亨里克
测试1。图纸 嗨，Henrinque，
谢谢你的快速回放。
出色的lisp例程！
非常感谢，非常感谢你的帮助。
当做 不客气，Madruga_SP
亨里克 亨里克，
我可以请你再修改一件代码吗？
因为我需要添加两个信息：cota do coletor e defoundidade do coletor。
顺致敬意，
例如
Lisp Perfil。图纸 Madruga_SP，
随附的是示例图纸，
我认为代码可以满足您的需要。
(defun c:perfil (/ ss1 ss itm obj osm_old
angb_old angd_old ct_basebase_obj ref lbtxt
pt1 pt2 pt3 ent1 obj1 ss
itm ptint lent txt_objptdist 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)
(prompt
"\nSelecione a linha base para os textos cota do grade:"
)
(setq lbtxt
(nentselp
"\nSelecione a linha base para os textos cota do grade:"
(setq pt1 (getpoint))
)
)
(setvar "OSMODE" 128)
(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)
)
(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)
txt_obj (vlax-ename->vla-object (car lbtxt))
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)
)
希望有帮助
亨里克
Lisp Perfil-2。图纸 嗨，Henrique，
再次感谢。你的代码太棒了！
这正是我多年来一直在寻找的。我真的很感谢你的帮助和很好的解释如何使用代码。
但是你的文字位置不正确。也许我做错了什么。
你能帮我找出我的错误吗？
再次感谢你，我的朋友。
Muito obrigado，meu amigo。
Lisp Perfil-3。图纸 Madruga_SP，
我已经看到了错误，
我现在正在做另一个项目，
但我会尽快修复，
亨里克
页:
[1]
2