单边偏移

http://bbs.mjtd.com/forum.php?mod=viewthread&tid=182681&page=1#pid881384

;;;1.命令可以连续执行,中键(或ESC)结束命令。
;;;2.不要调用offset命令。因为对于(直线，圆弧，圆)这些对象不能进行0值偏移，且新生成的图元不在当前层。
(defun c:ERR()
    ;;计算多义线的各顶点的坐标值返回点表(pt_1 pt_2 falg)
    ;;参数plename----多段线图元名，ptj@----跟多段线某一段的交点或是ENTSEL在多段线上的选择点
    ;;全局变量flag1---如果为Ture，表示是直线段，否则为圆弧段
    ;;全局变量PTB#；pldata---存储多义线圆弧的一些参数
    (defun polyline_pt (plename ptj@ /   ptz pts  pte jd jd1 jd2 pt1## pt2## cnt pt_1 pt_2 flag pt_3 ptb### arcb#  arcdata)
        (if (null ptb#)
            (progn
                (pline_pt plename)
                ;;rem---去余数 70组码代表多段线的标志，1代表封闭
                (if (= (rem (cdr (assoc '70 (entget plename))) 2) 1)
                    (if (equal (car pt1##) (caar (reverse ptb#)) 0.0001)
                        (setq ptb# (reverse (cons pt1## ptb#)))
                        (setq ptb# (reverse (cons pt1## (reverse ptb#))))
                    )
                )
            )
        )
        (setq cnt 1)
        ;;38组码代表标高
        (setq ptz (cdr (assoc '38 (entget plename))))
        (setq  pts    (caar ptb#)
            ptb### ptb#
        )
        (setq ptb# (cdr ptb#))
        (setq  pt_1 nil
            pt_2 nil
        )
        (setq ptj@ (trans ptj@ 1 0))
        ;;通过交点跟各个点值的角度来判断交点在哪两点之间的直线上
        (while ptb#
            (cond
                ;;当是多义线的直线段时
                ((= (setq flag (cadar ptb###)) 0.0)
                    (setq pte (caar ptb#))
                    (setq jd (rem (angle pts pte) (* 2 pi)))
                    (if (equal jd (* 2 pi) 0.0001)
                        (setq jd 0)
                    )
                    (setq jd1 (rem (angle pts ptj@) (* 2 pi)))
                    (if (equal jd1 (* 2 pi) 0.0001)
                        (setq jd1 0)
                    )
                    (setq jd2 (rem (angle ptj@ pte) (* 2 pi)))
                    (if (equal jd2 (* 2 pi) 0.0001)
                        (setq jd2 0)
                    )
                    (if (and (equal jd1 jd2 0.0001) (equal jd1 jd 0.0001))
                        (setq pt_1 (list pts flag)
                            pt_2 pte
                        )
                    )
                    (setq pts pte)
                    (setq ptb#   (cdr ptb#)
                        ptb### (cdr ptb###)
                    )
                    (setq cnt (1+ cnt))
                )
                ;;当时多义线的圆弧段时
                ((/= (setq flag (cadar ptb###)) 0.0)
                    (setq pte (caar ptb#))
                    (if (setq arcdata (if-pointatarc flag pts pte ptj@))
                        (if arcdata
                            (setq pldata arcdata
                                pt_1 (list pts flag)
                                pt_2 pte
                            )
                        )
                    )
                    (setq pts pte)
                    (setq ptb#   (cdr ptb#)
                        ptb### (cdr ptb###)
                    )
                    (setq cnt (1+ cnt))
                )
            )
        )
        ;;取出交点所在段的两端点
        (if (and pt_1 pt_2)
            (progn
                (setq pt_3  pt_1
                    pt_1  (list (caar pt_1) (cadr (car pt_1)) ptz)
                    pt_2  (list (car pt_2) (car (cdr pt_2)) ptz)
                    flag1 t
                )
                (list pt_1 pt_2 (cadr pt_3))
            )
            (progn
                (setq flag1 nil)
            )
        )
    )
    ;;;;ZDM2000
    ;;;;寻找lwpolyline,polyline的各顶点并返回点表ptb#
    ;;参数plname为图元名
    ;;返回值：为(((100.0 100.0) 0.0) ((100.0 200.0) 0.0)((150.0 200.0) 0.423)...)的表，其中最后一项代表凸度
    (DEFUN PLINE_PT  (plename / ssb ssb1 N PT PT_B arc_b arcbz ssn5 arcbz1)
        (setq  SSB  (ENTGET plename)
            N    1
            ssb1 ssb
        )
        (if (= (cdr (assoc '0 ssb)) "LWPOLYLINE")
            (progn (while (SETQ PT_B (assoc '10 SSB))
                             (SETQ PT    (CDR PT_B)
                                 arcbz1 (assoc 42 ssb)
                                 arcbz  (cdr arcbz1)
                                 pt    (list pt arcbz)
                             )
                             (IF (= N 1)
                                 (SETQ PT1## PT
                                     PTB#  (LIST PT)
                                 )
                                 (SETQ PT2## PT
                                     PTB#  (CONS PT PTB#)
                                 )
                             )
                             (SETQ SSB (CDR (MEMBER arcbz1 SSB)))
                             (SETQ N (+ N 1))
                         )
                ;;; ;;;有些封闭的LWPOLYLINE末端多出一点,该点与第一点的差值为本0.001需除去
                ;;;;;;在编译后的vlsp中LWPOLYLINE点位为三维点,而在Autocad中是二维点
                (if (and (= (rem (cdr (assoc '70 (entget plename))) 2) 1)
                            (equal (car pt1##) (car pt2##) 0.002)
                        )
                    (setq ptb#   (reverse (cdr ptb#))
                        pt2## (car ptb#)
                    )
                )
                (setq n   1
                    ssb ssb1
                )
                (while (setq arc_b (assoc '42 ssb))
                    (setq arcbz (cdr arc_b))
                    (if (= n 1)
                        (setq arcb# (list arcbz))
                        (setq arcb# (cons arcbz arcb#))
                    )
                    (setq ssb (cdr (member arc_b ssb)))
                    (setq n (+ n 1))
                )
            )
            (progn ;;polyline
                (setq ssn5 (entnext plename))
                (setq pt (cdr (assoc '10 (entget ssn5))))
                (setq arcbz (cdr (assoc '42 (entget ssn5))))
                (setq ptb#  (list pt)
                    pt1## pt
                    arcb# (list arcbz)
                )
                (setq ssn5 (entnext ssn5))
                (while (/= (cdr (assoc '0 (entget ssn5))) "SEQEND")
                    (setq pt (cdr (assoc '10 (entget ssn5))))
                    (setq arcbz (cdr (assoc '42 (entget ssn5))))
                    (setq ptb#   (cons pt ptb#)
                        pt2## pt
                        arcb# (cons arcbz arcb#)
                    )
                    (setq ssn5 (entnext ssn5))
                )
            )
        )
        (setq arcb# (cons 0 (reverse arcb#)))
        (SETQ PTB# (REVERSE PTB#))
    )
    ;;函数：判断一个点是否在圆弧上
    ;;参数：b---凸度=2h/d h---拱高 ， d---弦长；pnt1---圆弧的起点；pnt2---圆弧的终点；pnt3---需要判断的点
    ;;当b<0的时候，圆弧为顺时针旋转
    ;;变量：r--圆弧的半径；acpnt--圆弧中心点
    (defun If-PointAtArc ( b pnt1 pnt2 pnt3 / d h r acpnt refang1 refang2 strang endang midang arcdata dist1 refpnt1)
        (setq d (distance pnt1 pnt2)
            h (abs (/ (* b d) 2.0))
            r (/ (+ (expt d 2.0) (* 4 (expt h 2.0))) (* 8.0 h))
            refang1 (rem (angle pnt1 pnt2) (* pi 2))
            refpnt1 (polar pnt1 refang1 (/ d 2.0))
        )
        ;;当圆弧是逆时针旋转时
        (if (> b 0)
            (setq refang2 (rem (+ refang1 (/ pi 2)) (* pi 2)))
            (setq refang2 (rem (- refang1 (/ pi 2)) (* pi 2)))
        )
        (setq acpnt (polar refpnt1 refang2 (- r h))
            strang (rem (angle acpnt pnt1) (* pi 2))
            endang (rem (angle acpnt pnt2) (* pi 2))
            midang (rem (angle acpnt pnt3) (* pi 2))
            dist1 (distance pnt3 acpnt)
        )
        (setq midang1  (- midang strang)
            endang1  (- endang strang)
        )
        (if (< midang1 0.0)
            (setq midang1 (+ (* pi 2) midang1))
        )
        (if (< endang1 0)
            (setq endang1 (+ (* pi 2) endang1))
        )
        (if (< b 0)
            (setq strang1 (* pi 2))
            (setq strang1 0.0)
        )
        (if (and
                    (or (and (>= strang1 midang1) (<= endang1 midang1)) (and (<= strang1 midang1) (>= endang1 midang1)))
                    (equal dist1 r 0.0001)
                )
            (progn
                (setq arcdata (list (list acpnt))
                    arcdata (append arcdata (list strang) (list endang) (list r))
                )
            )
        )
    )
    ;;计算在非世界坐标系时的点对应于世界坐标系的坐标值
    ;;此函数是针对直线段的
    ;;参数elist----用nselect、nselectp选择函数返回的表
    ;;此处有2个全局变量p10a p11a
    (defun matrix_b
        (elist / ent ename bname matlist p10 p11 cnt p10x p11x)
        (setq  ent  elist
            ename  (car ent)
            bname  (nth 3 ent)
            matlist  (nth 2 ent)
            p10  (cdr (assoc 10 (entget ename)))
            cnt  0
        )
        (repeat 3
            (setq p10x (+ (* (car p10) (car (nth cnt matlist)))
                                     (* (cadr p10) (cadr (nth cnt matlist)))
                                     (* (caddr p10) (caddr (nth cnt matlist)))
                                     (cadddr (nth cnt matlist))
                                 )
                p10a (append p10a (list p10x))
                cnt  (1+ cnt)
            )
        )
        (if (= (cdr (assoc 0 (entget ename))) "LINE")
            (progn (setq p11 (cdr (assoc 11 (entget ename)))
                             cnt 0
                         )
                (repeat 3
                    (setq p11x  (+ (* (car p11) (car (nth cnt matlist)))
                                                (* (cadr p11) (cadr (nth cnt matlist)))
                                                (* (caddr p11) (caddr (nth cnt matlist)))
                                                (cadddr (nth cnt matlist))
                                            )
                        p11a  (append p11a (list p11x))
                        cnt  (1+ cnt)
                    )
                )
            )
        )
    )
    ;;针对点的模型坐标系和世界坐标系的转换
    ;;参数entlist--通过entsel或nentselp选择的返回表，pt--选择的点坐标
    (defun matrix_b_pt
        (entlist pt / ent ename bname matlist p10 cnt p10x p10a)
        (setq  ent  entlist
            ename  (car ent)
            bname  (nth 3 ent)
            matlist  (nth 2 ent)
            p10  pt
            cnt  0
        )
        (repeat 3
            (setq p10x (+ (* (car p10) (car (nth cnt matlist)))
                                     (* (cadr p10) (cadr (nth cnt matlist)))
                                     (* (caddr p10) (caddr (nth cnt matlist)))
                                     (cadddr (nth cnt matlist))
                                 )
                p10a (append p10a (list p10x))
                cnt  (1+ cnt)
            )
        )
        p10a
    )
    (defun *error* (msg)
        (if old-osmode
            (setvar "osmode" old-osmode)
        )
        (if old-ortho
            (setvar "orthomode" old-ortho)
        )
        (if old-cmdecho
            (setvar "cmdecho" old-cmdecho)
        )
        (if (member msg
                    '("Function cancelled"
                         "quit / exit abort"
                         "console break"
                         "函数被取消"
                     )
                )
            (princ)
            (princ (strcat "Error: " msg))
        )
        (princ)
    )
    (defun dtr (a)
        (if (numberp a)
            (* pi (/ a 180.0))
            (princ "\nError : Invalid datatype.")
        )
    )
  ;;偏移复制函数
  (defun oneoffset (dist pldata / pnt refpnt intpnt ang acpnt r)
    (if  pldata
      (setq acpnt  (caar pldata)
        strang (cadr pldata)
        endang (caddr pldata)
        r     (last pldata)
      )
    )
    (initget 1)
    (setq pnt (getpoint "\n指定要偏移的那一侧的点："))
    (cond
      ((or (= ename "CIRCLE") (= ename "ARC"))
        (while (and
                 (or
                   (and (> (distance pt1 pnt) radius)
                     (> (distance pnt selectpnt) (distance pt1 pnt))
                   )
                   (< (distance pt1 pnt) radius)
                 )
                 (<= radius dist)
               )
          (setq pnt (getpoint "无法偏移对象。指定要偏移的那一侧的点："))
          (if (not pnt) (exit))
        )
      )
      ((and (or (= ename "LWPOLYLINE") (= ename "POLYLINE"))
         pldata
       )
        (while (and
                 (or
                   (and (> (distance acpnt (trans pnt 1 0)) r)
                     (> (distance (trans pnt 1 0) (trans neapt 1 0)) (distance (trans pnt 1 0) acpnt))
                   )
                   (< (distance acpnt (trans pnt 1 0)) r)
                 )
                 (<= r dist)
               )
          (setq pnt (getpoint "无法偏移对象。指定要偏移的那一侧的点："))
          (if (not pnt) (exit))
        )
      )
    )
    (if  pnt
      (cond
        ;;第一种情况：选择的是直线，多义线的直线段时
        ((and (or (= ename "LINE")
                (= ename "LWPOLYLINE")
                (= ename "POLYLINE")
              )
           (null pldata)
         )
          (setq refpnt (polar pnt (+ (angle pt1 pt2) (dtr 90)) 10)
            intpnt (inters pnt refpnt pt1 pt2 nil)
            ang    (angle intpnt pnt)
            pt1    (trans (polar pt1 ang dist) 1 0)
            pt2    (trans (polar pt2 ang dist) 1 0)
          )
          (entmake (list  '(0 . "LINE")
                     '(100 . "AcDbEntity")
                     '(100 . "AcDbLine")
                     (cons 10 pt1)
                     (cons 11 pt2)
                   )
          )
        )
        ;;第二种情况：选择的是多义线的圆弧段
        ((and (or (= ename "LWPOLYLINE") (= ename "POLYLINE"))
           pldata
         )
          (setq pnt   (trans pnt 1 0)
            neapt (trans neapt 1 0)
          )
          (if (or (and (> (distance acpnt pnt) r)
                    (> (distance pnt neapt) (distance acpnt pnt))
                  )
                (< (distance acpnt pnt) r)
              )
            (setq radius (- r dist))
            (setq radius (+ r dist))
          )
          (if (> b 0)
            (entmake (list '(0 . "ARC")
                       '(100 . "AcDbEntity")
                       '(100 . "AcDbArc")
                       (cons 10 acpnt)
                       (cons 40 radius)
                       (cons 50 strang)
                       (cons 51 endang)
                     )
            )
            (entmake (list '(0 . "ARC")
                       '(100 . "AcDbEntity")
                       '(100 . "AcDbArc")
                       (cons 10 acpnt)
                       (cons 40 radius)
                       (cons 50 endang)
                       (cons 51 strang)
                     )
            )
          )
        )
        ;;第三种情况：选择的是圆
        ((= ename "CIRCLE")
          (if (< (distance pt1 pnt) radius)
            (setq radius (- radius dist))
            (setq radius (+ radius dist))
          )
          (setq pt1 (trans pt1 1 0))
          (entmake (list  '(0 . "CIRCLE")
                     '(100 . "AcDbEntity")
                     '(100 . "AcDbCircle")
                     (cons 10 pt1)
                     (cons 40 radius)
                   )
          )
        )
        ;;第四种情况：选择的是圆弧
        ((= ename "ARC")
          (if (or (and (> (distance pt1 pnt) radius)
                    (> (distance pnt selectpnt) (distance pt1 pnt))
                  )
                (< (distance pt1 pnt) radius)
              )
            (setq radius (- radius dist))
            (setq radius (+ radius dist))
          )
          (setq pt1 (trans pt1 1 0))
          (entmake (list  '(0 . "ARC")
                     '(100 . "AcDbEntity")
                     '(100 . "AcDbArc")
                     (cons 10 pt1)
                     (cons 40 radius)
                     strang
                     endang
                   )
          )
        )
      )
    )
  )
    (defun main (/ selectlist ent ename etype old-dist jingdu1 sedpnt old-ortho old-osmode err nselectlist s42 s41 s70 s71
                                selectpnt pt1 pt2 ptw ptws pts plpts ptb# old-error newent strang endpnt radius p10a p11a neapt pldata
                                endang)
        (vl-load-com)
        ;(setsysvar)
        (setvar "cmdecho" 0)
        ;(chg_undo_push)
        (or *dist*(setq *dist* 10))
        (setvar "errno" 0)
        (Initget 128 "D")
        (while
            (=(setq selectlist (nentselp (strcat"\n选择需要偏移复制的对象,改距离按D键：< "(itoa *dist*)">")))"D")
            (setq jingdu1 (getint (Strcat "\n请输入要偏移的距离<" (itoa *dist*) ">:")))
            (if jingdu1 (setq *dist* jingdu1))
            (Initget 128 "D")
        )
        (setq selectpnt (cadr selectlist))
        (setq err (getvar "errno"))
        (if selectlist
            (setq ename (cdr (assoc 0 (entget (car selectlist)))))
        )
        ;;如果用户用右键则退出，左键未选中则循环
        (if (= err 52)
            (exit)
        )
        (while (= err 7)
            (setvar "errno" 0)
            (setq selectlist (nentselp "选择需要偏移复制的对象： "))
            (setq selectpnt (cadr selectlist))
            (setq err (getvar "errno"))
            (if  selectlist
                (setq ename (cdr (assoc 0 (entget (car selectlist)))))
            )
        )
        (if (= err 52)
            (exit)
        )
        ;;如果是块，则查看是否是阵列、比例不一致的块
        (if (nth 3 selectlist)
            (progn
                (setq nselectlist (entget (car (last selectlist)))
                    s41    (cdr (assoc 41 nselectlist))
                    s42    (cdr (assoc 42 nselectlist))
                    s70    (cdr (assoc 70 nselectlist))
                    s71    (cdr (assoc 71 nselectlist))
                )
                (if (or (and (/= s41 -1.0) (/= s41 1.0))
                            (and (/= s42 -1.0) (/= s42 1.0))
                            (> s70 1)
                            (> s71 1)
                        )
                    (progn
                        (princ
                            "\n不支持阵列后或不一致比例的块。"
                        )
                        (exit)
                    )
                )
            )
        )
        ;;是否是块中的多段线，是，找出选择点两端的断点值
        (cond
            ;;如果是块
            ((nth 3 selectlist)
                ;;如果是块中的多段线
                (if (or (= ename "LWPOLYLINE") (= ename "POLYLINE"))
                    (progn
                        (setq neapt (osnap selectpnt "nea"))
                        (setq plpts (pline_pt (car selectlist)))
                        ;;先将块中的各端点值通过矩阵转换成世界坐标，然后再找出选择点两端的点值
                        (while  (caar plpts)
                            (setq ptw (matrix_b_pt selectlist (append (caar plpts) '(0.0))))
                            (setq ptw (append (list ptw) (cdar plpts)))
                            (setq ptws (append ptws (list ptw)))
                            (setq plpts (cdr plpts))
                        )
                        (setq ptws (append ptws (list (car ptws))))
                        (setq ptb# ptws
                            ptws nil
                        )
                        ;;如果是圆弧段，则提示并退出
                        (if
                            (or (/= (last (setq pts (polyline_pt (car selectlist) neapt)))
                                        0.0
                                    )
                                (= flag1 nil)
                            )
                            (progn
                                (setq pt1 (trans (car pts) 0 1)
                                    pt2 (trans (cadr pts) 0 1)
                                    b (caddr pts)
                                )
                                (oneoffset *dist* pldata)
                            )
                            ;;如果是直段，则取出端点，并绘制成线
                            (progn
                                (setq pt1  (trans (car pts) 0 1 )
                                    pt2  (trans (cadr pts) 0 1)
                                )
                                (oneoffset *dist* nil)
                            )
                        )
                    );;结束多段线程序
                    ;;如果选中的不是块中的多段线
                    (progn
                        (cond
                            ;;当选中的是直线
                            ((= ename "LINE")
                                (matrix_b selectlist)
                                (setq pt1 (trans p10a 0 1)
                                    pt2 (trans p11a 0 1)
                                )
                                (oneoffset *dist* nil)
                            )
                            ;;当选中的是圆
                            ((= ename "CIRCLE")
                                (setq pt1 (cdr (assoc 10 (entget (car selectlist)))))
                                (setq pt1 (trans (matrix_b_pt selectlist pt1) 0 1))
                                (setq radius (cdr (assoc 40 (entget (car selectlist)))))
                                (oneoffset *dist* nil)
                            )
                            ;;当选中的是圆弧
                            ((= ename "ARC")
                                (setq pt1 (cdr (assoc 10 (entget (car selectlist)))))
                                (setq pt1 (trans (matrix_b_pt selectlist pt1) 0 1))
                                (setq radius (cdr (assoc 40 (entget (car selectlist))))
                                    strang (assoc 50 (entget (car selectlist)))
                                    endang (assoc 51 (entget (car selectlist)))
                                )
                                (oneoffset *dist* nil)
                            )
                        )
                    )
                )
            )
            ;;非块的情况
            ((not (nth 3 selectlist))
                ;;如果是多义线
                (if (or (= ename "LWPOLYLINE") (= ename "POLYLINE"))
                    (progn
                        (setq neapt (osnap selectpnt "nea"))
                        (if
                            (or (/= (last (setq pts (polyline_pt (car selectlist) neapt)))
                                        0.0
                                    )
                                (= flag1 nil)
                            )
                            ;;如果选择了圆弧段
                            (progn
                                (setq pt1 (trans (car pts) 0 1)
                                    pt2 (trans (cadr pts) 0 1)
                                    b (caddr pts)
                                )
                                (oneoffset *dist* pldata)
                            )
                            ;;如果选择了直段
                            (progn
                                (setq pt1 (trans (car pts) 0 1)
                                    pt2 (trans (cadr pts) 0 1)
                                )
                                (oneoffset *dist* nil)
                            )
                        )
                    )
                    ;;如果是非多义线，则直接调用offset命令
                    (progn
                        (cond ((setq sss(equal *dist* 0.0 1.0e-4))
                                        (command "_COPY" selectlist "" "0" "0")
                                    )
                            (t(princ "\n指定要偏移的那一侧的点：")
                                (command "_offset" *dist* selectlist  pause "")
                            )
                        )
                        (command "change" (entlast) "" "p" "la" (getvar "clayer") "c" "bylayer" "")
                    )
                )
            )
        )
        ;(setvar "offsetdist" *dist*)
        (main)
        ;(setvar "cmdecho" 0)
        ;(chg_undo_pop)
        ;(setsysvar)
        (princ)
    )
    (main)
  (princ)
)