[LISP程序]：简化版htb.lsp

chlh_jd

;;;重建填充边界
(defun c:htb () (c:hatchb))
(defun c:hatchb        (/         es         blay         ed1         ed2         loops1         bptf         part         et         noe
                 plist         ic         bul         nr         ang1         ang2         obj         space         cw         errexit
                 olderr         oldcmdecho         ss1         lastent en1         en2         ss         lwp         ent
                 i         ss2         knot-list         controlpoint-list         kn         cn
                 pos         xv         bot         area         hst     ent1
                 )
  (setq        olderr        *error*
        *error*        errexit
        space        (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object))))
  (if (setq ss2 (ssget '((0 . "HATCH"))))
    (progn
      (setq area 0
            i -1)      
      (while (setq ent (ssname ss2 (setq i (1+ i))))
        (setq ed1 (entget ent)
              xv  (cdr (assoc 210 ed1))
              loops1 (cdr (assoc 91 ed1));|边界路径（环）数|; );end setq
        (if (not (equal (assoc 210 ed1) '(210 0.0 0.0 1.0))) (princ "\nHatch not in WCS!"));end if
        (command "._ucs" "_w")
        (repeat        loops1
          (setq        ed1   (member (assoc 92 ed1) ed1)
                bptf  (cdr (car ed1))        ; boundary path type flag
                ic    (cdr (assoc 73 ed1)) ; “关闭”标志
                noe   (cdr (assoc 93 ed1)) ; 多段线顶点数
                bot   (cdr (assoc 92 ed1)) ; 边界路径类型标志（按位编码）：0 = 默认；1 = 外部；2 = 多段线4 = 导出；8 = 文本框；16 = 最外层
                hst   (cdr (assoc 75 ed1)) ; 图案填充样式：0 = 填充“奇校验”区域（“普通”样式）1 = 仅填充最外层区域（“外部”样式）2 = 填充整个区域（“忽略”样式）
                ed1   (member (assoc 72 ed1) ed1);边类型（仅当边界不是多段线时）：1 = 直线；2 = 圆弧；3 = 椭圆弧；4 = 样条曲线
                bul   (cdr (car ed1))        ; bulge
                plist nil
                blist nil );end setq
          (cond
            ((> (boole 1 bptf 2) 0)        ;cond1 polyline
             (repeat noe
               (setq ed1   (member (assoc 10 (cdr ed1)) ed1)
                     plist (append plist (list (cdr (assoc 10 ed1))))
                     blist (append blist (if (> bul 0) (list (cdr (assoc 42 ed1))) nil)))
               )
             (setq polypoints (apply 'append (mapcar '3dPoint->2dPoint plist))
                   VLADataPts (list->variantArray polypoints)
                   obj              (vla-addLightweightPolyline space VLADataPts)
                   nr              0);ent setq
             (repeat (length blist)               
               (if (/= (nth nr blist) 0)                 
                 (vla-setBulge obj nr (nth nr blist)))               
               (setq nr (1+ nr)));end repeat
             (if (= ic 1) (vla-put-closed obj T))
             );end cond1
            (t                                ;cond2 not polyline
             (setq lastent (entlast)
                   lwp           T)
             (repeat noe                ;repeat s
               (setq et (cdr (assoc 72 ed1)))
               (cond
                 ((= et 1)                ;cond21 line
                  (setq ed1 (member (assoc 10 (cdr ed1)) ed1))
                  (vla-AddLine space (vlax-3d-point (cdr (assoc 10 ed1)))
                    (vlax-3d-point (cdr (assoc 11 ed1))))
                  (setq ed1 (cddr ed1))
                 );end cond21
                 ((= et 2)                ;cond22 circular arc
                  (setq        ed1  (member (assoc 10 (cdr ed1)) ed1)
                        ang1 (cdr (assoc 50 ed1))
                        ang2 (cdr (assoc 51 ed1))
                        cw   (cdr (assoc 73 ed1)))
                  (if (equal ang2 6.28319 0.00001)
                    (progn (vla-AddCircle space (vlax-3d-point (cdr (assoc 10 ed1)))
                             (cdr (assoc 40 ed1))) (setq lwp nil))                    
                    (vla-AddArc
                      space
                      (vlax-3d-point (cdr (assoc 10 ed1)))
                      (cdr (assoc 40 ed1))
                      (if (= cw 0) (- 0 ang2) ang1)
                      (if (= cw 0) (- 0 ang1) ang2)
                      ));end if
                  (setq ed1 (cddddr ed1))
                 );end cond22
                 ((= et 3)                ;cond23 elliptic arc
                  (setq        ed1  (member (assoc 10 (cdr ed1)) ed1)
                        ang1 (cdr (assoc 50 ed1))
                        ang2 (cdr (assoc 51 ed1))
                        cw   (cdr (assoc 73 ed1))
                        obj  (vla-AddEllipse
                               space
                               (vlax-3d-point (cdr (assoc 10 ed1)))
                               (vlax-3d-point (cdr (assoc 11 ed1)))
                               (cdr (assoc 40 ed1))
                               ))
                  (vla-put-startangle obj (if (= cw 0) (- 0 ang2) ang1))
                  (vla-put-endangle obj (if (= cw 0) (- 0 ang1) ang2))
                  (setq lwp nil)
                  );end cond23
                 ((= et 4)                ;cond24 spline
                  (setq        ed1                  (member (assoc 94 (cdr ed1)) ed1)
                        knot-list          nil
                        controlpoint-list nil
                        kn                  (cdr (assoc 95 ed1))
                        cn                  (cdr (assoc 96 ed1))
                        pos                  (vl-position (assoc 40 ed1) ed1))
                  (repeat kn
                    (setq knot-list (cons (cons 40 (cdr (nth pos ed1))) knot-list)
                          pos            (1+ pos)))
                  (setq pos (vl-position (assoc 10 ed1) ed1))
                  (repeat cn
                    (setq controlpoint-list (cons (cons 10 (cdr (nth pos ed1)))
                                                  controlpoint-list) pos (1+ pos))
                    )
                  (setq        knot-list          (reverse knot-list)
                        controlpoint-list (reverse controlpoint-list))
                  (entmake (append
                             (list '(0 . "SPLINE"))                             
                             (list (cons 100 "AcDbEntity"))
                             (list (cons 100 "AcDbSpline"))
                             (list (cons 70 (+ 1 8 (* 2 (cdr (assoc 74 ed1)))
                                               (* 4 (cdr (assoc 73 ed1))))))
                             (list (cons 71 (cdr (assoc 94 ed1))))
                             (list (cons 72 kn))
                             (list (cons 73 cn))
                             knot-list
                             controlpoint-list
                             )                          
                           S
                           );end entmake
                  (setq        ed1 (member (assoc 10 ed1) ed1)
                        lwp nil )
                  );end cond24
                 );end repeat
               );end cond2
             (if lwp (progn
                       (setq en1 (entnext lastent)
                             ss  (ssadd))
                       (ssadd en1 ss)
                       (while (setq en2 (entnext en1))
                         (ssadd en2 ss)
                         (setq en1 en2))
                       (if (= (getvar "peditaccept") 1)
                         (command "_.pedit" (entlast) "_J" ss "" "")
                         (command "_.pedit" (entlast) "_Y" "_J" ss "" ""))
                       );|end progn|; );end if
             );end cond
            )
          );end repeat
        (setq ent1 (entget (entlast)))
        (setq ent1 (append (subst (cons 8 "COLU") (assoc 8 ent1) ent1)))
        (entmod ent1)
        (entdel ent)
        );end while
      );end progn
    );end if
  );end defun
;;;--------------------------------------------------------------------;;;
(defun errexit (s)
  (princ "\nError:  ")
  (princ s)
  )
(defun 3dPoint->2dPoint        (3dpt)
  (list (float (car 3dpt)) (float (cadr 3dpt)))
  )
(defun list->variantArray (ptsList / arraySpace sArray)
  (setq        arraySpace (vlax-make-safearray vlax-vbdouble (cons 0 (- (length ptsList) 1)))
        sArray           (vlax-safearray-fill arraySpace ptsList))
  (vlax-make-variant sArray)
  )

鬼魔

有弧,样条曲线,椭圆弧,会出错

allan439

试了不是很好用，有时会出错