帮我完成口齿不清。。。恳求
大家好，我的while声明有问题，希望你能帮助我。我想从块上画一条线，垂直于最近的线。我想通过窗口选择来实现这一点。
(defun C:QQ ()(load "C:\\Lisp\\driveway.lsp"))
(vl-load-com)
(defun _line ( a b c) (entmakex (list (cons 0 "LINE") (cons 10 a) (cons 11 b) (cons 8 c))))
(defun C:AA (/)
(setq ss (ssget ":L" '((0 . "INSERT,LINE") (8 . "CHOUSE,CROAD"))))
(setq ssb (ssadd));;blocks-selection set;;
(setq ssl (ssadd));;line-selection set;;
(setq ct 0)
(while (< ct (sslength ss))
(setq en (ssname ss ct))
(if (= "INSERT" (cdr (assoc 0 (entget en)))) (ssadd en ssb))
(setq ct (+ ct 1))
)
(setq ct 0)
(while (< ct (sslength ss))
(setq en (ssname ss ct))
(if (= "LINE" (cdr (assoc 0 (entget en)))) (ssadd en ssl))
(setq ct (+ ct 1))
)
(setq ctb 0)
(setq ctl 0)
(while (< ctb (sslength ssb))from this part, it's driving me insane
(setq ed (ssname ssb ctb))
(setq cd (cdr(assoc 10 (entget ed))))
(setq d1 '(0 0))
(while (< ctl (sslength ssl))
(setq el (ssname ssl ctl))
(setq vla-el (vlax-ename->vla-object el))
(setq d (vlax-curve-getClosestPointToProjection vla-el cd '(0 0 0)))
(if (< (distance cd d) (distance d1 cd)) (setq d1 d))
(setq ctl (+ ctl 1))
)
(_line cd d1 "CDRIVEWAY")
(setq ctb (+ ctb 1))I'm really insane right here
)
(princ)
)
谢谢 我认为你的括号不对，我把）；如果结束）；end while，这样我就可以看到这组行的结束位置，从而更容易找到缺少的括号。
添加）；结束卸载并检查 我对代码进行了一点修改，但仍然没有按照我的意图进行操作。现在它只创建从块到只有一条线的垂直线。我的声明“红色”有点不对劲，我想不出来。谢谢你的时间比格尔，真的很感谢。
(defun C:test (/ dl ssct en ssl ssb ctl ctb cd ed d el vla-el p)
(setq ss (ssget ":L" '((0 . "INSERT,LINE") (8 . "CHOUSE,CROAD"))))
(setq ssb (ssadd);;blocks-selection set;;
ssl (ssadd));;line-selection set;;
(setq ct 0);;;begin ssadd ssb;;;
(while (< ct (sslength ss))
(setq en (ssname ss ct))
(if (= (cdr (assoc 0 (entget en))) "INSERT") (ssadd en ssb))
(setq ct (+ ct 1))
) ;;;;end ssadd ssb;;;
(setq ct 0);;;begin ssadd ssl;;;;;;;;;
(while (< ct (sslength ss))
(setq en (ssname ss ct))
(if (= (cdr (assoc 0 (entget en))) "LINE") (ssadd en ssl))
(setq ct (+ ct 1)) ;;;end ssadd ssl;;;;;;;;;
)
(setq ctb 0);;;counter for blocks
(setq ctl 0);;;counter for lines
(while (< ctb (sslength ssb)) ;;;begin while blocks
(setq ed (ssname ssb ctb)
cd (cdr(assoc 10 (entget ed)))
d1 '(0 0))
(while (< ctl (sslength ssl)) ;;; iterate ssl for the nearest line for ssname (ed);;;
(setq el (ssname ssl ctl)
vla-el (vlax-ename->vla-object el)
d (vlax-curve-getClosestPointToProjection vla-el cd '(0 0 0)))
(if (< (distance cd d) (distance cd d1)) (setq p vla-el d1 d));;;store the nearest line and loop
;;;store nearest distance for compare;;;
(setq ctl (+ ctl 1))
) ;;;end while looking for nearest line for block ed;;;
(setq ctb (+ ctb 1))
(_line cd (vlax-curve-getClosestPointToProjection p cd '(0 0 0))) ;;; draw a line from the block;;;;
;;; to the nearest line;;;
);;;end while blocks
(princ)
);;;end defun
(vl-load-com)
(defun _line ( a b ) (entmakex (list (cons 0 "LINE") (cons 10 a) (cons 11 b)))) 这是一个新的VL函数吗？
不，我只是使用vla preffix来知道它是变量中的vl对象。我的一个坏习惯。
谢谢你，比格尔，不用麻烦了，我已经完成了例行程序。
我猜这是一个变量名。。。
(setq el (ssname ssl ctl)
vla-el (vlax-ename->vla-object el)
)
这就是我如何完成任务的方法，希望您可以从我的代码LISP2LEARN中学习
(defun c:blkline ( / d1 d2 el en in l1 l2 p2 p3 ss )
(if (setq ss (ssget '((0 . "INSERT,LINE"))))
(progn
(repeat (setq in (sslength ss))
(setq en (ssname ss (setq in (1- in)))
el (entget en)
)
(if (eq "LINE" (cdr (assoc 0 el)))
(setq l1 (cons en l1))
(setq l2 (cons (trans (cdr (assoc 10 el)) en 0) l2))
)
)
(foreach p1 l2
(setq p2 (vlax-curve-getclosestpointto (car l1) p1)
d1 (distance p1 p2)
)
(foreach en (cdr l1)
(setq p3 (vlax-curve-getclosestpointto en p1)
d2 (distance p1 p3)
)
(if (< d2 d1) (setq d1 d2 p2 p3))
)
(entmake (list '(0 . "LINE") (cons 10 p1) (cons 11 p2)))
)
)
)
(princ)
)
(vl-load-com) (princ)
不客气。
ssget函数不允许其他用户输入函数允许的自定义提示消息；但是，您可以构造一个ssget包装器来进行一些欺骗：
(entsel) -->> "Select object:"
(entsel "\nSelect a block:") -->> "Select a block:"
例如。：
;; _ssget-Lee Mac
;; ssget wrapper function to allow a custom prompt message
;; msg= prompt
;; args = list of standard ssget parameters
;; Returns: Selection Set or nil
(defun _ssget ( msg args / sel )
(princ msg)
(setvar 'NOMUTT 1)
(setq sel (vl-catch-all-apply 'ssget args))
(setvar 'NOMUTT 0)
(if (and sel (null (vl-catch-all-error-p sel)))
sel
)
) 谢谢李，效果很好。 不客气LISP2LEARN
页:
[1]
2