型孔角部避位

刘炎华

xtjd 发表于 2021-12-5 14:24
已经更新 ，请重新下载测试

大师：
        还有提示，错误: no function definition: PLORLR

690994

yshf

;请试用以下程序
(defun c:xgbj()
    (defun pts_to_list(Xpts / fhz pt)
        (setq fhz nil)
        (foreach pt Xpts
            (setq fhz (cons (car pt) fhz))
            (setq fhz (cons (cadr pt) fhz))
        )
        (setq fhz (reverse fhz))
    )
  
    (setvar "cmdecho" 0)
    (command "_undo" "be")
  
    (if (progn
            (princ "\n请选取多段线:")
            (setq ssa (ssget ":S" '((0 . "lwpolyline"))))
        )
        (progn
            (setq ent (ssname ssa 0))
            (setq pts (mapcar 'cdr (vl-remove-if-not '(lambda(x)(= (car x) 10)) (entget ent))))
            (setq obj (vlax-ename->vla-object ent))
            (setq obj1 (car (vlax-invoke obj "offset" 1)))
            (if (> (vlax-curve-getarea obj1) (vlax-curve-getarea obj))
                (setq pdbz 1)   ;逆时针
                (setq pdbz -1)  ;顺时针
            )
            (vla-Delete obj1)
            (setq n (fix (vlax-curve-getendparam obj)))
            (setq i 0)
            (repeat n
                 (setq i-1 (1- i))
                 (if (= i-1 -1) (setq i-1 (1- n)))
                 (setq i+1 (1+ i))
                 (if (= i+1 n) (setq i+1 0))
                 (setq i+2 (1+ i+1))
                 (If (= i+2 n) (setq i+2 0))
                 (If (< i (1- n))
                     (setq jlz (- (vlax-curve-getdistatparam obj i+1)
                                  (vlax-curve-getdistatparam obj i)
                               )
                     )
         
                     (setq jlz (- (vlax-curve-getdistatparam obj (1+ i))
                                  (vlax-curve-getdistatparam obj i)
                               )
                    )
                 )
                 (mapcar 'set '(pti-1 pti pti+1 pti+2)
                               (mapcar '(lambda(param)
                                            (setq pt (vlax-curve-getPointAtParam obj param))
                                            (list (car pt) (cadr pt))
                                        )
                                        (list i-1 i i+1 i+2)
                               )
                 )
                 (setq ptjd (inters pti-1 pti pti+1 pti+2 nil))
                 (setq ang1 (angle pti-1 pti))
                 (setq ang2 (angle pti pti+1))
                 (setq ang3 (angle pti+1 pti+2))
                 (setq bul (vla-GetBulge obj i))
                 (cond ((= bul 0.0)
                          (setq djR (/ jlz (sqrt 2.0)))
                          (if (and (= (vla-GetBulge obj i+1) 0.0)
                                   (equal djR 4.0 1e-3)
                              )
                              (progn
                                  (setq ptia (polar ptjd ang1 (* -1.0 (- djR 0.2))))
                                  (setq pti+1a (polar ptjd ang3 (- djR 0.2)))
                                  (setq pts (subst ptia pti pts))
                                  (setq pts (subst pti+1a pti+1 pts))
                                  (setq zbsjb (pts_to_list pts))
                                  (vlax-put obj "Coordinates" zbsjb)
                              )
                          )
             
                       )
                       (t
                          (setq dang (atan (abs bul)))
                          (setq alf (* 2.0 dang))
                          (setq R (/ jlz (atan (abs bul)) 4.0))
                          (setq alf1 (* 0.5 alf))
                          (setq pdbz1 (/ bul (abs bul)))
                          (setq R1 (- R (* pdbz pdbz1 0.2)))
                          (setq qxc1 (* R1 (/ (sin alf) (cos alf))))
                          (setq qxc1 (abs qxc1))
                          (setq bul1 (* pdbz1 (/ (sin alf1) (cos alf1))))
                          (setq ptia (polar ptjd ang1 (* -1.0  qxc1)))
                          (setq pti+1a (polar ptjd ang3  qxc1))
                          (setq pts (subst ptia pti pts))
                          (setq pts (subst pti+1a pti+1 pts))
                          (setq zbsjb (pts_to_list pts))
                          (vlax-put obj "Coordinates" zbsjb)
                          (vla-SetBulge obj i bul1)
                       )
                 )
                 (setq i (1+ i))
           )
        )
    )
    (command "_undo" "e")
    (setvar "cmdecho" 1)
    (princ)
)

xtjd

刘炎华 发表于 2021-12-5 14:28
大师：
        还有提示，错误: no function definition: PLORLR

已经修改，烦再测试

刘炎华

yshf 发表于 2021-12-5 14:30
;请试用以下程序
(defun c:xgbj()
    (defun pts_to_list(Xpts / fhz pt)

大师：
      测试可以了！
      如果能多选对象处理逃角就更高效了

yshf

;请试用以下程序
(defun c:xgbj1()
    (defun pts_to_list(Xpts / fhz pt)
        (setq fhz nil)
        (foreach pt Xpts
            (setq fhz (cons (car pt) fhz))
            (setq fhz (cons (cadr pt) fhz))
        )
        (setq fhz (reverse fhz))
    )
  
    (setvar "cmdecho" 0)
    (command "_undo" "be")
  
    (if (progn
            (princ "\n请选取多段线:")
            (setq ssa (ssget '((0 . "lwpolyline"))))
        )
        (progn
            (setq m (sslength ssa))
            (setq j 0)
            (repeat m
                (setq ent (ssname ssa j))
                (setq pts (mapcar 'cdr (vl-remove-if-not '(lambda(x)(= (car x) 10)) (entget ent))))
                (setq obj (vlax-ename->vla-object ent))
                (setq obj1 (car (vlax-invoke obj "offset" 1)))
                (if (> (vlax-curve-getarea obj1) (vlax-curve-getarea obj))
                    (setq pdbz 1)   ;逆时针
                    (setq pdbz -1)  ;顺时针
                )
                (vla-Delete obj1)
                (setq n (fix (vlax-curve-getendparam obj)))
                (setq i 0)
                (repeat n
                    (setq i-1 (1- i))
                    (if (= i-1 -1) (setq i-1 (1- n)))
                    (setq i+1 (1+ i))
                    (if (= i+1 n) (setq i+1 0))
                    (setq i+2 (1+ i+1))
                    (If (= i+2 n) (setq i+2 0))
                    (If (< i (1- n))
                        (setq jlz (- (vlax-curve-getdistatparam obj i+1)
                                     (vlax-curve-getdistatparam obj i)
                                  )
                        )
         
                        (setq jlz (- (vlax-curve-getdistatparam obj (1+ i))
                                     (vlax-curve-getdistatparam obj i)
                                  )
                        )
                    )
                    (mapcar 'set '(pti-1 pti pti+1 pti+2)
                                  (mapcar '(lambda(param)
                                            (setq pt (vlax-curve-getPointAtParam obj param))
                                            (list (car pt) (cadr pt))
                                        )
                                        (list i-1 i i+1 i+2)
                               )
                    )
                    (setq ptjd (inters pti-1 pti pti+1 pti+2 nil))
                    (setq ang1 (angle pti-1 pti))
                    (setq ang2 (angle pti pti+1))
                    (setq ang3 (angle pti+1 pti+2))
                    (setq bul (vla-GetBulge obj i))
                    (cond ((= bul 0.0)
                               (setq djR (/ jlz (sqrt 2.0)))
                               (if (and (= (vla-GetBulge obj i+1) 0.0)
                                        (equal djR 4.0 1e-3)
                                   )
                                   (progn
                                      (setq ptia (polar ptjd ang1 (* -1.0 (- djR 0.2))))
                                      (setq pti+1a (polar ptjd ang3 (- djR 0.2)))
                                      (setq pts (subst ptia pti pts))
                                      (setq pts (subst pti+1a pti+1 pts))
                                      (setq zbsjb (pts_to_list pts))
                                      (vlax-put obj "Coordinates" zbsjb)
                                   )
                               )
             
                          )
                          (t
                              (setq dang (atan (abs bul)))
                              (setq alf (* 2.0 dang))
                              (setq R (/ jlz (atan (abs bul)) 4.0))
                              (setq alf1 (* 0.5 alf))
                              (setq pdbz1 (/ bul (abs bul)))
                              (setq R1 (- R (* pdbz pdbz1 0.2)))
                              (setq qxc1 (* R1 (/ (sin alf) (cos alf))))
                              (setq qxc1 (abs qxc1))
                              (setq bul1 (* pdbz1 (/ (sin alf1) (cos alf1))))
                              (setq ptia (polar ptjd ang1 (* -1.0  qxc1)))
                              (setq pti+1a (polar ptjd ang3  qxc1))
                              (setq pts (subst ptia pti pts))
                              (setq pts (subst pti+1a pti+1 pts))
                              (setq zbsjb (pts_to_list pts))
                              (vlax-put obj "Coordinates" zbsjb)
                             (vla-SetBulge obj i bul1)
                          )
                    )
                    (setq i (1+ i))
                )             
                (setq j (1+ j))
            )
        )
    )
    (command "_undo" "e")
    (setvar "cmdecho" 1)
    (princ)
)