[编程交流] [Lisp]需要“hard”l的帮助

(vl-load-com)
;;v2016-05-13
;;ziele_o2k
;;Main function
(defun c:teee ( / EntPline BlocksSS DistForFilterSS BlkEntLst)
(if
        (and
                (setq
                        EntPline (car (entsel "\nSelect Main Pline > "));select main pline
                        BlocksSS (ssget '((0 . "INSERT") (2 . "BLOCK") (66 . 1)));ssget blocks
                        DistForFilterSS (getreal "\nType offset distance to filter blocks > ");get distance for 
                )
                (member (cdr (assoc 0 (entget EntPline))) '("POLYLINE" "LWPOLYLINE"))
                (setq BlkEntLst (PZ:FilterSS EntPline BlocksSS DistForFilterSS))
        )
        (print BlkEntLst)
        (print "No blocks")
)
(princ)
)
;;Function to filter ssget. Returns list of entity names that are perpendicular
;;to selected center, main pline, else nil
(defun PZ:FilterSS (MainPline BlkSS dist / TmpEnts in BlkPt PerpBlkLst)
(setq 
        TmpEnts
        (mapcar
                'vlax-vla-object->ename
                (vlax-invoke (vlax-ename->vla-object MainPline) 'Explode)
        )
)
(repeat (setq in (sslength BlkSS))
        (setq BlkPt (cdr (assoc 10 (entget (ssname BlkSS (setq in (1- in)))))))
        (if 
                (and 
                        (getPerpendicularPoint TmpEnts BlkPt)
                        (<= (distance (getPerpendicularPoint TmpEnts BlkPt) BlkPt) dist)
                )
                (setq PerpBlkLst (cons (ssname BlkSS in) PerpBlkLst))
                nil
        )
)
(mapcar '(lambda (x) (vla-delete (vlax-ename->vla-object x))) TmpEnts) ; remove the segments
PerpBlkLst
)
;; modified function from this CAB post
;;http://www.cadtutor.net/forum/showthread.php?30556-Create-Perpendicular-Line-at-every-intersection-point&p=204357&viewfull=1#post204357
(defun getPerpendicularPoint (Ents pt / ent clspt endpts perpts result dist)
(foreach ent Ents
   (if 
                (or 
                        (< (distance (setq clspt (vlax-curve-getclosestpointto ent pt)) (vlax-curve-getstartpoint ent)) 0.0001)
                        (< (distance clspt (vlax-curve-getendpoint ent)) 0.0001)
                )
                nil
     (setq perpts (cons clspt perpts)) ; else got a perpendicular point
   )
 )
(setq 
        perpts
        (mapcar 
                '(lambda(x / tmp) 
                        (cond
                                ((null dist)(setq dist (distance pt x) result x))
                                ((< (setq tmp (distance pt x)) dist)
                                                                                                                                         (setq dist tmp result x))
                        )
                )
                perpts
        )
)
result
)

(defun c:test  (/ ss pl ds d lst l srt _att fnl fl out)
 ;; Tharwat - Date: 14.May.2016 ;;
 (cond
   ((not (setq ss (ssget "_X"
                         (list '(0 . "INSERT")
                               '(2 . "Block")
                               (cons 410 (getvar 'ctab))))))
    (princ
      "\nCould not find any block named <Block> in this drawing !"))
   ((not (and (princ "\nPick a LWpolyline:")
              (setq pl (ssget "_+.:S:E" '((0 . "LWPOLYLINE"))))
              ))
    (princ "\nMissed. Try again"))
   ((setq
      ds (getdist
           "\nSpecify gap distance between Polyline and blocks :"))
    ((lambda (i / sn pt cl)
       (while (setq sn (ssname ss (setq i (1+ i))))
         (setq pt (trans (cdr (assoc 10 (entget sn))) 1 0)
               cl (vlax-curve-getclosestpointto (ssname pl 0) pt)
               )
         (if (<= (distance pt cl) ds)
           (setq lst (cons (list sn pt cl) lst))
           )
         )
       )
      -1)
    (if lst
      (progn
        (mapcar '(lambda (x)
                   (setq
                     l (cons (list (vlax-curve-getdistatpoint
                                     (ssname pl 0)
                                     (caddr x))
                                   (car x))
                             l)))
                lst
                )
        (setq srt (vl-sort l '(lambda (j k) (< (car j) (car k)))))
        (defun _att  (e)
          (read (vla-get-textstring
                  (car (vlax-invoke
                         (vlax-ename->vla-object e)
                         'getattributes))))
          )
        (mapcar '(lambda (x)
                   (if d
                     (setq fnl (cons (list (_att (cadr x)) (- (car x) d))
                                     fnl)
                           d   (car x)
                           )
                     (setq d   (car x)
                           fnl (cons (list (_att (cadr x)) d) fnl)
                           )
                     ))
                srt)
        (setq fl  (list "last" (cadar fnl))
              out (cons fl (cdr fnl))
              )
        )
      )))
 (if out
   (reverse out)
   (princ))
 )(vl-load-com)

(vl-load-com)
;;v2016-05-17
;;ziele_o2k
;;Main function
(defun c:te2 ( / ss pl ds lst1 sl lst2 lst3 srt out)
 (cond
   ( 
     (not (setq ss (ssget "_X" (list '(0 . "INSERT") '(2 . "Block") (cons 410 (getvar 'ctab))))))
     (princ "\nCould not find any block named <Block> in this drawing !")
   );selecting all blocks in drawing
   (
     (not (and (princ "\nPick a LWpolyline:")(setq pl (ssget "_+.:S:E" '((0 . "LWPOLYLINE"))))))
     (princ "\nMissed. Try again")
   );get main pline
   (
     (setq ds (getdist "\nSpecify gap distance between Polyline and blocks :"));set distance to filter blocks
     (
       (lambda (i / sn pt cl)
         (while (setq sn (ssname ss (setq i (1+ i))))
           (setq 
             pt (trans (cdr (assoc 10 (entget sn))) 1 0);pt block base point in WCS
             cl (vlax-curve-getclosestpointto (ssname pl 0) pt);coordinates of point on curve (in WCS) which is nearest to curve
           )
           (if 
             (<= (distance pt cl) ds);filter blocks from ss which are in smaller or eqal distance to given distace
             (setq lst1 (cons (list sn pt cl) lst1));make list with ename of block, base point of block and point on curve
           )
         )
       )
      -1
     )
     (if lst1
       (progn
         (setq sl (PZ:getPolySegs (ssname pl 0)))
         (foreach %1 lst1
           (
             (lambda (%2 / )
               (cond
                 (
                   (= (vlax-curve-getParamAtPoint (ssname pl 0) (caddr %2))(vlax-curve-getStartParam(ssname pl 0)))
                   (if 
                     (PZ:IsPerpendicular 
                       (vlax-curve-getPointAtParam (ssname pl 0) (vlax-curve-getStartParam(ssname pl 0)))
                       (vlax-curve-getPointAtParam (ssname pl 0) (1+ (vlax-curve-getStartParam(ssname pl 0))))
                       (cadr %2)
                       (caddr %2)
                       (cadar sl)
                     )
                     (setq lst2 (cons %2 lst2))
                   )
                 )
                 (
                   (= (vlax-curve-getParamAtPoint (ssname pl 0) (caddr %2))(vlax-curve-getEndParam(ssname pl 0)))
                   (if 
                     (PZ:IsPerpendicular 
                       (vlax-curve-getPointAtParam (ssname pl 0) (vlax-curve-getEndParam(ssname pl 0)))
                       (vlax-curve-getPointAtParam (ssname pl 0) (1- (vlax-curve-getEndParam(ssname pl 0))))
                       (cadr %2)
                       (caddr %2)
                       (cadr (last sl))
                     )
                     (setq lst2 (cons %2 lst2))
                   )
                 )
                 (T (setq lst2 (cons %2 lst2)))
               )
             )
             %1
           )
         )
         (if lst2
           (progn
             (mapcar
               '(lambda (%1)
                 (setq lst3 (cons (list (vlax-curve-getdistatpoint(ssname pl 0)(caddr %1))(car %1))lst3))
               )
               lst2
             ) 
             (setq srt (vl-sort lst3 '(lambda (j k) (< (car j) (car k)))))
             (defun _att (e)
               (read 
                 (vla-get-textstring
                   (car (vlax-invoke (vlax-ename->vla-object e) 'getattributes))
                 )
               )
             )
             (mapcar
               '(lambda (%)
                 (setq 
                   out 
                   (cons 
                     (list  
                       (_att (cadr %)) (car %) (- (PZ:GetCurveLength (ssname pl 0)) (car %))
                     )
                     out
                   )
                 )
               )
               srt
             )
           )
         )
       )
     )
     
   )
 )
(if out
        (setq out (reverse out))
        (princ)
)
(terpri)
 (princ out)
 (princ)
)
;http://www.cadtutor.net/forum/archive/index.php/t-60816.html?
(defun LM:Roundto ( n p / f )
(setq n (- n (setq f (rem n (setq p (expt 10. (- p)))))))
(if (< 0.5 (/ (abs f) p))
((if (minusp n) - +) n p)
n
)
)
;modified from
;https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/get-polyline-length/td-p/817505
(defun PZ:GetCurveLength (curve / )
 (vl-load-com)
 (vlax-curve-getDistAtParam curve
   (vlax-curve-getEndParam curve)
 )
)
;verify if segment is perpendicular to pline segment
;segment is given by p3 and p4
;pline segment is given by p1 p2 and b
;if b is not equal 0 then given segment is arc
(defun PZ:IsPerpendicular (p1 p2 p3 p4 b / xu xv yu yv )
 (if (not (eq b 0))
        (setq 
                p1 p4
                p2 (LM:bulgecentre p1 p2 b)
        )
)
 (foreach n (list p1 p2 p3 p4) (print n))
(setq 
   xu (- (car p2) (car p1))
   yu (- (cadr p2) (cadr p1))
   xv (- (car p4) (car p3))
   yv (- (cadr p4) (cadr p3))
 )
 (if (eq b 0)
   (cond
     ((eq(LM:Roundto(+ (* xu xv) (* yu yv))6)0) (print "perp")T)
     (T  (print "notperp") nil)
   );condition for perpendicular
   (cond
     ((eq(LM:Roundto(- (* xu yv) (* xv yu))6)0)(print "parall")T)
     (T (print "notparall")nil)
   );condition for parallel
 )
)
;modified lisp from
;http://www.lee-mac.com/lisp/html/PolyInfoV1-3.html
;; Bulge Centre  -  Lee Mac
;; p1 - start vertex
;; p2 - end vertex
;; b  - bulge
;; Returns the centre of the arc described by the given bulge and vertices
(defun LM:bulgecentre ( p1 p2 b )
 (polar p1
   (+ (angle p1 p2) (- (/ pi 2) (* 2 (atan b))))
   (/ (* (distance p1 p2) (1+ (* b b))) 4 b)
 )
)
;modified lisp from
;http://www.afralisp.net/autolisp/tutorials/polyline-bulges-part-1.php
(defun PZ:getPolySegs (ent / entl p1 pt bulge seg ptlst)
 (cond (ent
                        (setq entl (entget ent))
        ;; save start point if polyline is closed
        (if (= (logand (cdr (assoc 70 entl)) 1) 1)
          (setq p1 (cdr (assoc 10 entl)))
        )
        ;; run thru entity list to collect list of segments
        (while (setq entl (member (assoc 10 entl) entl))
          ;; if segment then add to list
          (if (and pt bulge)
            (setq seg (list pt bulge))
          )
          ;; save next point and bulge
          (setq pt    (cdr (assoc 10 entl))
                bulge (cdr (assoc 42 entl))
          )
          ;; if segment is build then add last point to segment
          ;; and add segment to list
          (if seg
            (setq seg (append seg (list pt))
                  ptlst (cons seg ptlst))
          )
          ;; reduce list and clear temporary segment
          (setq entl  (cdr entl)
                seg   nil
          )
        )
       )
 )
 ;; if polyline is closed then add closing segment to list
 (if p1 (setq ptlst (cons (list pt bulge p1) ptlst)))
 ;; reverse and return list of segments
 (reverse ptlst)
)

((99 0.0) (1 17.7656) (2 36.4474) (3 26.4085) (5 59.6297) (7 62.222) (8 24.0023) (10 64.0678) (11 21.0495) (12 39.9307) ("last" 35.9001)) ((99 0.0) (1 17.7656) (2 36.4474) (3 26.4085) (5 59.6297) (7 62.222) (8 24.0023) (10 64.0678) (11 21.0495) (12 39.9307) ("last" 35.9001))