＿Levin 发表于 2023-5-25 23:07:24

求大佬完善一下这个偏移

求大佬帮忙完善一下，弄了一晚上，实在不会了




(defun c:KK (/ *error* en os p0)               
        (setq oldlayer (getvar "clayer"));_记录当前图层
        (if (not (tblsearch "layer" "图层AA"))
                (command "layer" "m" "图层AA" "c" 2 "" "lt" "DASHDOT" "" "");建立图层
        )
        (setvar "clayer" "图层AA")
       
        (defun *error* (msg)
                (princ mag)
                (setvar "cmdecho" 1)
                (setvar "osmode" os)               
                (princ)
        )
        (setq os (getvar "osmode"))
        (mapcar 'setvar '("cmdecho" "osmode") '(0 0))
        (setq SS 50)
       
        (while (and (setq en (car (entsel))) (setq p0 (getpoint "\n偏移方向:")))
                (if (= SS 0)
                        (command "copy" en "" p0 p0)
                        (command "offset" SS en p0 "")
                )
               
                (VLA-PUT-LAYER (VLAX-ENAME->VLA-OBJECT (ENTLAST))"图层AA")       
                (setq ent (ssget "X" (list (cons 8 "图层A")(cons 410 (getvar 'ctab)))))
                (command "change" ent "" "p" "c" "bylayer" "")                                       
        )
        (setvar "clayer" OldLayer)       
        (setvar "cmdecho" 1)
        (setvar "osmode" os)
        (princ)
)

liuhe 发表于 2023-5-25 23:07:25

(defun c:KK (/ *error* en os p0)
(setq oldlayer (getvar "clayer")) ;_记录当前图层
(if (not (tblsearch "layer" "图层AA"))
    (command "layer" "m" "图层AA" "c" 2 "" "lt" "DASHDOT" "" "")
                                        ;建立图层
)
(setvar "clayer" "图层AA")

(defun *error* (msg)
    (princ mag)
    (setvar "cmdecho" 1)
    (setvar "osmode" os)
    (princ)
)
(setq os (getvar "osmode"))
(mapcar 'setvar '("cmdecho" "osmode") '(0 0))
(setq        SS   50
        SS1(SSADD)
        LSTNIL
        LST1 NIL
        I    0
)
(SETQ SS1 (SSGET))
(setq p0 (getpoint "\n偏移方向:"))
(REPEAT (SSLENGTH SS1)
    (SETQ E (SSNAME SS1 I))
    (if        (= SS 0)
      (command "copy" en "" p0 p0)
      (command "offset" SS e p0 "")
    )
    (SETQ E1(ENTLAST)
          LST (CONS E1 LST)
          I   (1+ I)
    )
    (VLA-PUT-LAYER (VLAX-ENAME->VLA-OBJECT (ENTLAST)) "图层AA")
)
(IF (> (LENGTH LST) 1)
    (PROGN
      (SETQ II 0
          J (1+ II)
      )
      (REPEAT (1- (LENGTH LST))
        (REPEAT        (- (LENGTH LST) J )
          (SETQ        OBJ1 (vlax-ename->vla-object (NTH II LST))
                OBJ2 (vlax-ename->vla-object (NTH J LST))
          )

          (setq        ipts (vlax-variant-value
                     (vla-intersectwith
                       obj1
                       obj2
                       acExtendNone
                     )
                     )
          )
          (if (> (vlax-safearray-get-u-bound ipts 1) 0)
          (progn
              (setq ipts (vlax-safearray->list ipts)
                                        ;将vla交点变体转化成表的形式
                  lst1 '()
              )
              (if (> (length ipts) 3)        ;分离多个交点
                (repeat        (/ (length ipts) 3)
                  (setq        lst1
                             (cons (list (car ipts) (cadr ipts) (caddr ipts))
                                   lst1
                             )
                        ipts (cdddr ipts)
                  )
                )
                (SETQ LST1 (LIST ipts))
              )


              (FOREACH X (LIST (NTH II LST) (NTH J LST))
                (IF
                  (> (DISTANCE (vlax-curve-getEndPoint X) (CAR LST1))
                     (DISTANCE (vlax-curve-getStartPoint X) (CAR LST1))
                  )
                   (VLA-PUT-StartPoint
                     (vlax-ename->vla-object X)
                     (vlax-3D-point (CAR LST1))
                   )
                   (VLA-PUT-EndPoint
                     (vlax-ename->vla-object X)
                     (vlax-3D-point (CAR LST1))
                   )
                )
              )
          )
          )
          (SETQ J (1+ J))
        )
        (SETQ II (1+ II))
      )
    )
)
(setq
    ent        (ssget "X" (list (cons 8 "图层A") (cons 410 (getvar 'ctab))))
)
(command "change" ent "" "p" "c" "bylayer" "")
(setvar "clayer" OldLayer)
(setvar "cmdecho" 1)
(setvar "osmode" os)
(princ)
)

下文没句号。 发表于 2023-5-28 09:30:25

来学习来学习来学习

＿Levin 发表于 2023-6-2 17:34:54

liuhe 发表于 2023-5-25 23:07


向您学习~
页: [1]
查看完整版本: 求大佬完善一下这个偏移