Lee Mac 发表于 2022-7-6 12:01:45

Try this:
 

(defun c:chain ( / *error* DOC E1 E2 FILE L LEN LLST OFILE PA                           PT SDIS SPC TANG TOBJ UNDO VLST X) (vl-load-com) ;; © Lee Mac~24.05.10 (defun *error* ( msg )   (and Undo(vla-EndUndoMark doc))   (and ofile (close ofile))       (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")       (princ (strcat "\n** Error: " msg " **")))   (princ) )   (setq spc   (if   (or       (eq AcModelSpace         (vla-get-ActiveSpace         (setq doc             (vla-get-ActiveDocument               (vlax-get-acad-object)             )         )         )       )       (eq :vlax-true (vla-get-MSpace doc))   )   (vla-get-ModelSpace doc)   (vla-get-PaperSpace doc)   ) )(if   (apply (function and)   (append       (mapcar         (function         (lambda ( sym str )             (set sym               (CurveifFoo               (lambda ( x )                   (eq "LWPOLYLINE" (cdr (assoc 0 (entget x))))               )               str               )             )         )         )         '(e1 e2) '("\nSelect First Curve: ""\nSelect Curve to Measure to: ")       )       (list (setq file (getfiled "Create Output File" "" "txt" 1)))   )   )   (progn   (setq Undo (not (vla-StartUndoMark doc)))   (setq vLst       (GroupByNum         (vlax-get         (vlax-ename->vla-object e1) 'Coordinates         )         2       )   )   (while (setq x (car vLst))       (setq lLst         (cons         (list             (setq sDis               (vlax-curve-getDistatPoint e2               (setq pt                   (vlax-curve-getClosestPointto e2 x)               )               )             )             (car x) (cadr x)             (progn               (setq l (line x pt))               (setq len               (vlax-curve-getDistatParam l                   (vlax-curve-getEndParam l)               )               )             )         )         lLst         )         vLst (cdr vLst)       )       (vla-put-rotation         (setq tObj         (MText spc             (vlax-curve-getPointatParam l               (setq pa               (/ (vlax-curve-getEndParam l) 2.)               )             )             (rtos len)             acAttachmentPointMiddleCenter         )         )         (setq tAng         (MakeReadable             (angle '(0. 0. 0.)               (vlax-curve-getFirstDeriv l pa)             )         )         )       )       (vla-put-backgroundfill tObj :vlax-true)       (vla-put-rotation         (MText spc pt (rtos sDis) acAttachmentPointMiddleCenter) tAng       )                  )   (setq ofile (open file "w"))   (mapcar       (function         (lambda ( line )         (write-line             (lst2str                               (mapcar               (function                   (lambda ( p )                     (PadRight (rtos p) " " 10)                   )               )               line               )               "      "             )             ofile         )         )       )       (vl-sort Llst         (function         (lambda ( a b )             (< (car a) (car b))         )         )       )               )   (setq ofile (close ofile))          (setq Undo (vla-EndUndoMark doc))   ) ) (princ))(defun MakeReadable ( a ) ;; © Lee Mac (cond   (   (and (> a (/ pi 2)) ( a pi) (

bsimpson 发表于 2022-7-6 12:06:27

Hi Lee,
 
Thanks this is a master piece, I have being trying to generate the lisp file for at least 2 years.
 
I am sure there are intermediate programs that could write the lisp for me but your the best.
 
Some time I would like to change the coordinates that are sent to the ascii file as the other intersection point on the blue line.
 
 
ty
 
bsimpson:roll:

Lee Mac 发表于 2022-7-6 12:08:50

Thanks bSimpson.
页: 1 [2]
查看完整版本: 垂直线