[编程交流] 从bl中绘制垂直线

(defun c:foo (/ selection pline sscount objpline inspoint intpoint entity)
(if (not (setq selection (ssget "_I" '((0 . "CIRCLE,INSERT")))))
(progn
(prompt "\nSelect circles: ")
(setq selection (ssget '((0 . "CIRCLE,INSERT"))))
)
)
(setq pline (entsel "\nSelect polyline: "))
(if (and
pline
(setq objpline (vlax-ename->vla-object (car pline)))
)
(repeat (setq sscount (sslength selection))
(setq
entity (entget (ssname selection (setq sscount (1- sscount))))
inspoint (cdr (assoc 10 entity)); both center of Circle and insertion pt of Block
intpoint (vlax-curve-getclosestpointto objpline inspoint)
)
(if intpoint
(command "_.line" "non" inspoint "non" intpoint "")
)
)
)
)

(defun KGA_Conv_Pickset_To_ObjectList (ss / i ret)
 (if ss
   (repeat (setq i (sslength ss))
     (setq ret (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) ret))
   )
 )
)
(defun KGA_List_Divide_3 (lst / ret)
 (repeat (/ (length lst) 3)
   (setq ret (cons (list (car lst) (cadr lst) (caddr lst)) ret))
   (setq lst (cdddr lst))
 )
 (reverse ret)
)
(defun KGA_Sys_ObjectOwner (obj)
 (vla-objectidtoobject (vla-get-database obj) (vla-get-ownerid obj))
)
(defun LineToCurve (sta vec curve / end line ptLst)
 (setq line
   (vla-addline
     (KGA_Sys_ObjectOwner curve)
     (vlax-3d-point sta)
     (vlax-3d-point (mapcar '+ sta vec))
   )
 )
 (if (setq ptLst (KGA_List_Divide_3 (vlax-invoke line 'intersectwith curve acextendthisentity)))
   (progn
     (setq end (car ptLst))
     (foreach pt (cdr ptLst)
       (if (< (distance sta pt) (distance sta end))
         (setq end pt)
       )
     )
     (vla-put-endpoint line (vlax-3d-point end))
     line
   )
   (progn
     (vla-delete line)
     nil
   )
 )
)
(defun c:LinesToCurve ( / curve doc pt1 pt2 ss vec)
 (setq doc (vla-get-activedocument (vlax-get-acad-object)))
 (vla-endundomark doc)
 (vla-startundomark doc)
 (if
   (and
     (setq curve (car (entsel "\nSelect curve: ")))
     (setq curve (vlax-ename->vla-object curve))
     (princ "\nSelect blocks: ")
     (setq ss (KGA_Conv_Pickset_To_ObjectList (ssget '((0 . "INSERT")))))
     (setq pt1 (getpoint "\nFirst point for direction: "))
     (setq pt2 (getpoint pt1 "\nSecond point for direction: "))
   )
   (progn
     (setq vec (trans (mapcar '- pt2 pt1) 1 0 T))
     (foreach blk ss
       (LineToCurve (vlax-get blk 'insertionpoint) vec curve)
     )
   )
 )
 (vla-endundomark doc)
 (princ)
)