批量交点插入块

429014673

交点布块，论坛里很多，带方向性的交点布块更有意思。

bai2000

看一看，学一学。

hao3ren

(defun INSERT_with (ss2brk        ss2brkwith   self          /
                   cmd                intpts             lst          masterlist
                   ss                ssobjs             onlockedlayer
                   ssget->vla-list             list->3pair  get_interpts
                   INSERT_obj
                  )
  (vl-load-com)
(setq ptlist nil)
  (defun onlockedlayer (ename / entlst)
    (setq entlst (tblsearch "LAYER" (cdr (assoc 8 (entget ename)))))
    (= 4 (logand 4 (cdr (assoc 70 entlst))))
  )

  (defun ssget->vla-list (ss / i ename lst)
    (setq i -1)
    (while (setq ename (ssname ss (setq i (1+ i))))
      (setq lst (cons (vlax-ename->vla-object ename) lst))
    )
    lst
  )
  (defun list->3pair (old / new)
    (while (setq new (cons (list (car old) (cadr old) (caddr old)) new)
                 old (cdddr old)
           )
    )
    (reverse new)
  )

  (defun get_interpts (obj1 obj2 / iplist)
    (if        (not
          (vl-catch-all-error-p
            (setq
              iplist (vl-catch-all-apply
                       'vlax-safearray->list
                       (list
                         (vlax-variant-value
                           (vla-intersectwith obj1 obj2 acextendnone)
                         )
                       )
                     )
            )
          )
        )
      iplist
    )
  )


  (defun INSERT_obj (ent               brkptlst          /             brkobjlst
                    en               enttype          maxparam   closedobj
                    minparam   obj          obj2INSERT  p1param
                    p2               p2param
                   )
    (setq obj2INSERT ent
          brkobjlst (list ent)
          enttype   (cdr (assoc 0 (entget ent)))
    )
    (foreach brkpt brkptlst
      (if brkobjlst
        (progn
          (if (not (numberp (vl-catch-all-apply
                              'vlax-curve-getdistatpoint
                              (list obj2INSERT brkpt)
                            )
                   )
              )
            (foreach obj brkobjlst       
              (if (numberp (vl-catch-all-apply
                             'vlax-curve-getdistatpoint
                             (list obj brkpt)
                           )
                  )
                (setq obj2INSERT obj)       
              )
            )
          )
        )
      )
      (cond
        ((and (= "SPLINE" enttype)       
              (vlax-curve-isclosed obj2INSERT)
         )
         (setq p1param (vlax-curve-getparamatpoint obj2INSERT brkpt)
               p2      (vlax-curve-getpointatparam
                         obj2INSERT
                         (+ p1param 0.000001)
                       )
         )

         (setq pt (list (trans brkpt 0 1)))
     (setq ptlist  (append ptlist pt));;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

        )
        ((= "CIRCLE" enttype)       
         (setq p1param (vlax-curve-getparamatpoint obj2INSERT brkpt)
               p2      (vlax-curve-getpointatparam
                         obj2INSERT
                         (+ p1param 0.000001)
                       )
         )
         (setq pt (list (trans brkpt 0 1)))
     (setq ptlist (append ptlist pt));;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

         (setq enttype "ARC")
        )
        ((and (= "ELLIPSE" enttype)       
              (vlax-curve-isclosed obj2INSERT)
         )
         (setq p1param        (vlax-curve-getparamatpoint obj2INSERT brkpt)
               p2param        (+ p1param 0.000001)
               minparam        (min p1param p2param)
               maxparam        (max p1param p2param)
               obj        (vlax-ename->vla-object obj2INSERT)
         )
         (vlax-put obj 'startparameter maxparam)
         (vlax-put obj 'endparameter (+ minparam (* pi 2)))
        )
        (t                                 
         (setq closedobj (vlax-curve-isclosed obj2INSERT))
         (setq pt (list (trans brkpt 0 1)))
     (setq ptlist  (append ptlist pt));;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
         (if (not closedobj)               
           (setq brkobjlst (cons (entlast) brkobjlst))
         )
        )
      )
    )
  )



  (if (and ss2brk ss2brkwith)
    (progn

      (foreach obj (ssget->vla-list ss2brk)
        (if (not (onlockedlayer (vlax-vla-object->ename obj)))
          (progn
            (setq lst nil)
            (foreach intobj (ssget->vla-list ss2brkwith)
              (if (and (or self (not (equal obj intobj)))
                       (setq intpts (get_interpts obj intobj))
                  )
                (setq lst (append (list->3pair intpts) lst))
                                       
              )
            )
            (if        lst
              (setq masterlist
                     (cons (cons (vlax-vla-object->ename obj) lst)
                           masterlist
                     )
              )
            )
          )
        )
      )
      (if masterlist
        (foreach obj2brk masterlist
          (INSERT_obj (car obj2brk) (cdr obj2brk))
        )
      )
    )
  )

(setq ptlist (gps->lst-delsame ptlist))
(setq num (length ptlist))
(setq n 0)
(repeat num
(setq pt (nth n ptlist))
         (if (and (>= maxX (car pt) minX)
                  (>= maxY (cadr pt) minY)
             )
           (command "_insert" ts pt d d "")
         )
         (setq n (1+ n))
        )
(princ)
)
;;;xshrimp的函数
;;;删除表中重复图元.不支持表中表的重复图元.
;;; (gps->lst-delsame '(1 2 1 2 (1 1) (1 2 1 2 1) 1 2 (1 1) (1 2)))
;;;  -->(1 2 (1 1) (1 2 1 2 1) (1 2))
(defun gps->lst-delsame (lst / lstitem lstnew)
   (foreach lstitem lst
     (if (not (member lstitem lstnew))
       (setq lstnew (append lstnew (list lstitem)))
     )
   )
   lstnew
)
(DEFUN C:ib (/ cmd ss)
  (command "._undo" "_begin")
  (setq cmd (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)
(setq ts "")
(while (not (tblsearch "BLOCK" ts))
  (setq ts (getstring "\n请输入块的名称(回车选取):"))
  (if (= "" ts)
    (progn
      (setq b0 nil)
      (while (not b0)
        (initget " ")
        (setq b0 (entsel "\n选取样块："))
        (cond
          ((= (type b0) 'STR) (setq b0 t))
          ((and
             (= (type b0) 'LIST)
             (/= (cdr (assoc 0 (setq b0 (entget (car b0)))))
                 "INSERT"
             )
           )
           (setq b0 nil)
          )
          (t (setq ts (cdr (assoc 2 b0))))
        )
      )
    )
  )
)
(setq d (getreal "\n插入比例<1.0>"))
  (if (null d)
(setq d 1.0)
(setq d (rtos d 2))
)
  (while (and
        (setq p1 (getpoint "\n请选择第一个角点："))
        (setq p2 (GETCORNER p1 "\n请选择第二个角点："))
      )
      (setq ss
             (ssget
               "c"
               p1
               p2
               '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
                )
             )
      )
      (setq minX (apply 'min (mapcar 'car (list p1 p2)));借用Gu_xl的程序
            minY (apply 'min (mapcar 'cadr (list p1 p2)))
            maxX (apply 'max (mapcar 'car (list p1 p2)))
            maxY (apply 'max (mapcar 'cadr (list p1 p2)))
      )
      (grvecs (list 1
                    (list minx miny)
                    (list maxx miny)
                    1
                    (list maxx miny)
                    (list maxx maxy)
                    1
                    (list maxx maxy)
                    (list minx maxy)
                    1
                    (list minx maxy)
                    (list minx miny)
              )
      )

      (INSERT_with ss ss nil)
    )
  
  (setvar "CMDECHO" cmd)
  (command "._undo" "_end")
  (princ)
)

荒野孤行

429014673 发表于 2015-6-10 09:44
交点布块，论坛里很多，带方向性的交点布块更有意思。

方向性的才是更合理的

rhww

感谢分享        

nadaloveluna

谢谢孤行前辈分享源码，你是结构的吗？

kwok

看图速度超快.

434939575

感谢！继续支持！

荒野孤行

lucas_3333 发表于 2015-6-10 08:08
这是在画太阳啊

是在画菊花

荒野孤行

smartstar 发表于 2015-6-10 09:35
插入用“vla-insertblock”是不是更快一点呢？

好的，我再优化下。