填充连接

love1030312

  在CAD里边怎么样能达到这中效果，把填充的线连成2根， 只要达到最终的效果  ， 直接填充或者填充好格子后连接 怎么样都行

（红线和白线只是为了看起来清晰些，没有要求）


请 langjs 大大帮我解决下 万分感谢

langjs

修正个错误的地方

;;; 填充连线2
;;;                by:langjs
(defun c:aa ( / bz ent h i j loop lst lst1 maxpoint minpoint p0 p1 ptn ptn1 ptn2 ss w ww)
  (defun draw (lst / i)
    (entmake (append
               (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length lst)))
               (mapcar
                 '(lambda (i)
                    (cons 10 i)
                  )
                 lst
               )
             )
    )
  )
  (setq ent (car (entsel "\n选择填充：")))
  (vla-getboundingbox (vlax-ename->vla-object ent) 'minpoint 'maxpoint)
  (setq p1 (vlax-safearray->list maxpoint)
        p0 (vlax-safearray->list minpoint)
  )
  (command ".explode" ent)
  (setq ss (ssget "p")
        lst '()
  )
  (repeat (setq i (sslength ss))
    (setq ent (entget (ssname ss (setq i (1- i))))
          lst (cons (cdr (assoc 10 ent)) lst)
          lst (cons (cdr (assoc 11 ent)) lst)
    )
  )
  (setq lst (vl-sort lst (function (lambda (i j)
                                     (< (cadr i) (cadr j))
                                   )
                         )
            )
  )
  (setq lst (vl-sort lst (function (lambda (i j)
                                     (< (car i) (car j))
                                   )
                         )
            )
  )
  (setq lst1 lst
        h (- (cadr (cadr lst)) (cadr (car lst)))
        w h
        ww (- (car p1) (car p0))
        lst (list p0)
        ptn p0
        bz (car ptn)
        loop t
  )
  (while loop
    (setq i 0
          bz (car ptn)
    )
    (repeat (fix (/ (- (cadr p1) (cadr p0)) h))
      (setq ptn (polar ptn (* 0.5 pi) h)
            lst (cons ptn lst)
            ptn (polar ptn (* i pi) w)
      )
      (if (> (car ptn) (car p1))
        (setq loop nil
              w (- h (- (car ptn) (car p1)))
              ptn (list (car p1) (cadr ptn))
        )
      )
      (setq lst (cons ptn lst)
            i (1+ i)
      )
    )
    (setq ptn1 (list (car ptn) (cadr p1))
          lst (cons ptn1 lst)
    )
    (if loop
      (progn
        (setq w h
              ptn2 (polar ptn1 0.0 (* 2 w))
        )
        (if (and
              (> (- (car ptn2) (car p1)) h)
              (> (- (car ptn2) (car p1)) 0)
            )
          (setq loop nil)
        )
        (if (> (car ptn2) (car p1))
          (setq w (- h (- (car ptn2) (car p1)))
                ptn2 (list (car p1) (cadr ptn2))
          )
        )
        (setq lst (cons ptn2 lst))
        (if (= bz (car ptn))
          (setq i 0)
          (setq i 1)
        )
        (setq ptn (polar ptn 0.0 (* 2 h)))
        (if (and
              (> (- (car ptn) (car p1)) h)
              (> (- (car ptn) (car p1)) 0)
            )
          (setq loop nil)
        )
        (if (> (car ptn) (car p1))
          (setq w (- h (- (car ptn) (car p1)))
                ptn (list (car p1) (cadr ptn))
          )
        )
        (if loop
          (progn
            (setq lst (cons ptn lst))
            (repeat (fix (/ (- (cadr p1) (cadr p0)) h))
              (setq ptn (polar ptn (* i pi) w))
              (if (> (car ptn) (car p1))
                (setq loop nil
                      w (- h (- (car ptn) (car p1)))
                      ptn (list (car p1) (cadr ptn))
                )
              )
              (setq lst (cons ptn lst)
                    ptn (polar ptn (* -0.5 pi) h)
                    lst (cons ptn lst)
                    i (1+ i)
              )
            )
            (setq ptn (polar ptn 0.0 (* 2 h)))
            (if (> (car ptn) (car p1))
              (setq ptn (list (car p1) (cadr ptn))
                    loop nil
              )
            )
            (setq lst (cons ptn lst)
                  bz (car ptn)
            )
          )
        )
      )
    )
  )
  (draw lst)
  (setq lst (list p0)
        ptn p0
        i 0
        loop t
  )
  (while loop
    (setq ptn (polar ptn (* i pi) ww)
          lst (cons ptn lst)
          ptn (polar ptn (* 0.5 pi) h)
    )
    (if (> (cadr ptn) (cadr p1))
      (setq loop nil
            ptn (list (car ptn) (cadr p1))
      )
    )
    (setq lst (cons ptn lst)
          i (1+ i)
    )
  )
  (if (= (car ptn) (car p0))
    (setq lst (cons (list (car p1) (cadr ptn)) lst))
    (setq lst (cons (list (car p0) (cadr ptn)) lst))
  )
  (draw lst)
  (command "erase" ss "")
  (princ)
)

999999

langjs 发表于 2014-6-16 22:13
修正个错误的地方

;;; 填充连线2

大神您好，这个插件很完美，要是能完全的按照工字砖的填充图案生成就好了，感谢大神的辛苦付出

xyp1964

love1030312

xyp1964 发表于 2014-6-16 14:07

院长    

langjs

别再找人要程序了，自己学学试试

langjs

对了，这个程序只适合长方形填充

love1030312

langjs 发表于 2014-6-16 22:13
这个程序真心挺复杂的，调了好几个小时才搞出来。

感谢大大  无法用语言来表示我的感谢    不好意思啊 让你花费了好几个小时   真心的谢谢   

Gu_xl

见 http://bbs.mjtd.com/thread-92207-2-1.html 13楼

love1030312

Gu_xl 发表于 2014-6-17 21:34
见 http://bbs.mjtd.com/thread-92207-2-1.html 13楼

G版回帖  无限感动啊   谢谢

贝壳太

不错...试试看