社区 › AutoLISP/Visual LISP 编程技术 › 填充连接

love1030312 发表于 2014-6-16 09:04:16

填充连接

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

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


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

langjs 发表于 2014-6-16 22:13:37

本帖最后由 langjs 于 2014-6-17 11:18 编辑

修正个错误的地方

;;; 填充连线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 发表于 2022-3-31 16:53:08

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

;;; 填充连线2


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

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

love1030312 发表于 2014-6-16 20:35:28

xyp1964 发表于 2014-6-16 14:07 static/image/common/back.gif


院长

langjs 发表于 2014-6-16 22:14:33

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

langjs 发表于 2014-6-16 22:15:59

本帖最后由 langjs 于 2014-6-16 22:53 编辑

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

love1030312 发表于 2014-6-17 08:25:18

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




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

Gu_xl 发表于 2014-6-17 21:34:49

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

love1030312 发表于 2014-6-18 08:08:41

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

G版回帖无限感动啊   谢谢

贝壳太 发表于 2014-7-19 13:56:42

不错...试试看

查看完整版本: 填充连接