[LISP程序]：自已写的一个结构绘图板钢剪切命令。

xiagood

自已写的一个结构绘图板钢剪切命令。
存在UCS的问题。不过还可以用用。
;;/ curOsmode Ojb_se ObjLine Line_st Line_end  ObjPL SelObjPt Plcolor Points  Numb i ints
(Defun C:Exf()
  (vl-load-com)
  (setq Acadobject   (vlax-get-Acad-object)
        AcadDocument (vla-get-ActiveDocument Acadobject)
        mSpace             (vla-get-Modelspace Acaddocument)
   )
  (setvar "cmdecho" 0)
  (princ "\n板钢筋剪切与延伸V1.1. ")
  (princ "\nWrite by xib, 2005/07/12")
  (setq Ojb_se (entsel "\nPlease Select line:"))
  (setq ObjLine (entget (car Ojb_se)))
  (setq Line_st (cdr (assoc 10 ObjLine)))
  (setq Line_end (cdr (assoc 11 ObjLine)))
  (setq objPL_se (entsel "\nPlease Select PLine:"))
  (setq SelObjPt (cadr objPL_se))
  (setq Plcolor (cdr (assoc 8 (entget (car objPL_se)))))
  (setq ObjPL (entget (car objPL_se)))
  (setq Points nil)
  (while (setq ObjPL (member (assoc 10 ObjPL) ObjPL))
    (setq Points (append Points (list (car ObjPL))))
    (setq ObjPL (cdr ObjPL))
  )
  (command "UNdo" "BE")
  (setq curOsmode (getvar "osmode"))
  (setvar "osmode" 0)
  (setq Numb (length Points))
  (setq p1 (cdr (nth 0 Points)))
  (setq p2 (cdr (nth 1 Points)))
  (setq P_1 (cdr (nth (- Numb 2) Points)))
  (setq p_2 (cdr (nth (- Numb 1) Points)))

  (setq ax_ent_1 (vlax-ename->vla-object (car Ojb_se)))   ;;add by xib 2005/08/03
  (setq ax_ent_2 (vlax-ename->vla-object (car objPL_se)))   ;;add by xib 2005/08/03
  
  (if (and (= (vla-intersectwith ax_ent_1 ax_ent_2 acextendnone) nil)
           (/= (vla-intersectwith ax_ent_1 ax_ent_2 acExtendBoth) nil)
      )
    (progn
      (setq ints (vla-intersectwith ax_ent_1 ax_ent_2 acExtendBoth)) ;;add by xib 2005/08/03
      (setq ints (vlax-variant-value ints))  ;;add by xib 2005/08/03
      (if (and (> (distance p2 ints) (distance p_1 ints))
               (> (distance p2 ints) (distance SelObjPt ints))
          )
        ;;需要延伸的判断<<<Item1----------------------------------
        (progn
          (setq P_2[x] (+ (car P_2) (- (car ints) (car p_1))))
          (setq p_2[y] (+ (cadr P_2) (- (cadr ints) (cadr p_1))))
          (setq p_2 (list P_2[x] P_2[y]))
          (setq P_1 ints)
          (setq i 0)
          (command "erase" objPL_se "")
          (command "Pline")
          (while (< i (- Numb 2))
            (setq inve1 (cdr (nth i Points)))
            (command inve1)
            (setq i (+ i 1))
          )
          (command P_1)
          (command P_2)
          (command "")
          (command "change" "L" "" "P" "LA" PLcolor "")
        )
        ;;;---------------------------------------------------Item1>>>
        ;;;------------------------------------------------------------------------
        ;;;<<<Item2----------------------------------------------------
        (progn
          (setq P1[x] (+ (car P1) (- (car ints) (car p2))))
          (setq p1[y] (+ (cadr P1) (- (cadr ints) (cadr p2))))
          (setq p1 (list P1[x] P1[y]))
          (setq P2 ints)
          (setq i 2)
          (command "erase" objPL_se "")
          (command "Pline")
          (command p1)
          (command p2)
          (while (< i Numb)
            (setq inve1 (cdr (nth i Points)))
            (command inve1)
            (setq i (+ i 1))
          )
          (command "")
          (command "change" "L" "" "P" "LA" PLcolor "")
        )
        ;;;-------------------------------------------------------Item2>>>
      )                    ;;;
    )

    (progn
      (if (/= (vla-intersectwith ax_ent_1 ax_ent_2 acExtendBoth) nil)
        (progn
          (setq ints (vla-intersectwith ax_ent_1 ax_ent_2 acExtendBoth))
          (setq ints (vlax-variant-value ints))
          (if (< (distance P2 ints) (distance P2 SelObjPt))
            ;;;<<<item3---------------------------------------------------
            (progn
              (setq ints (vla-intersectwith ax_ent_1 ax_ent_2 acExtendBoth))
              (setq ints (vlax-variant-value ints))
              (setq P_2[x] (- (car P_2) (- (car p_1) (car ints))))
              (setq p_2[y] (- (cadr P_2) (- (cadr p_1) (cadr ints))))
              (setq p_2 (list P_2[x] P_2[y]))
              (setq P_1 ints)
              (setq i 0)
              (command "erase" objPL_se "")
              (command "Pline")
              (while (< i (- Numb 2))
                (setq inve1 (cdr (nth i Points)))
                (command inve1)
                (setq i (+ i 1))
              )
              (command P_1)
              (command P_2)
              (command "")
              (command "change" "L" "" "P" "LA" PLcolor "")
            )
            ;;;-------------------------------------------------------------item3>>>
            ;;;---------------------------------------------------------------------
            ;;;<<<Item4------------------------------------------------------------
            (progn
                (setq P1[x] (+ (car P1) (- (car ints) (car p2))))
                (setq p1[y] (+ (cadr P1) (- (cadr ints) (cadr p2))))
                (setq p1 (list P1[x] P1[y]))
                (setq P2 ints)
                (setq i 2)
                (command "erase" objPL_se "")
                (command "Pline")
                (command p1)
                (command p2)
                (while (< i Numb)
                     (setq inve1 (cdr (nth i Points)))
                (command inve1)
                (setq i (+ i 1))
                )
               (command "")
               (command "change" "L" "" "P" "LA" PLcolor "")
               )
           ;;;--------------------------------------------------------------------Item4>>>
          )
        )
        (Princ "\nUnable to Extrim!")
      )
    )
  )
  (setvar "Osmode" curOsmode)
  (command "UNDO" "E")
  (setvar "cmdecho" 0)
)