求一个能做出剖切标记的lisp，过程步骤思路见下面！

Smile cop

file:///C:/Documents%20and%20Settings/wjlib/Application%20Data/Tencent/Users/561523794/QQ/WinTemp/RichOle/]7@_LE%7B1%7D]~Q%25]NL5_qLA.jpg

xiahwan

[pcode=lisp,true]
;剖切箭头、文字大小与标注全局比例关联
(defun c:pq ()
  (VL-LOAD-COM)
  (setq osm (getvar"osmode")
        dim(getvar"dimscale")
        )
  (setq dlb nil)
  (setq zf(strcase(getstring "\n输入剖切符号:"))
        pt(getpoint"\n指定剖切点：")
        )
  (command "pline" pt)
  (while (= 1 (getvar "cmdactive"))
    (command pause)
    )
  (setvar "osmode" 31743)
  (setq dlb(delys (MASSOC 10 (entget (entlast)))))
  (setq pt(getpoint pt"\n指定剖切方向："))
  (vla-put-Color (vlax-ename->vla-object (entlast)) 1)
  (command "_offset" (* dim 5) (entlast) pt"")
  (setq pl(entlast))
  (setq sd(vlax-curve-getStartPoint pl)
        pt1(polar sd (angle sd (NTH 0 dlb)) (* 2.5 dim))
        pt2(polar (NTH 0 dlb) (angle (NTH 0 dlb)(NTH 1 dlb)) dim)
        )
  (setq md(vlax-curve-getendPoint pl)
        pt3(polar md (angle md (NTH (-(LENGTH dlb)1) dlb)) (* 2.5 dim))
        pt4(polar (NTH (-(LENGTH dlb)1)dlb) (angle (NTH (-(LENGTH dlb)1)dlb)(NTH (-(LENGTH dlb)2)dlb)) dim)
        )
  (setq pta(polar sd (angle pt1 sd) (* 4 dim))
        ptb(polar md (angle pt3 md) (* 4 dim))
        )
  (command "pline" sd "w" 0 (* 0.8 dim) pt1  "w" (* 0.3 dim) (* 0.3 dim) (NTH 0 dlb)pt2 "w" 0 0"")
  (vla-put-Color (vlax-ename->vla-object (entlast)) 5)
  (command "pline" md "w" 0 (* 0.8 dim) pt3  "w" (* 0.3 dim) (* 0.3 dim)  (NTH (-(LENGTH dlb)1) dlb)pt4 "w" 0 0"")
  (vla-put-Color (vlax-ename->vla-object (entlast)) 5)
  (entdel pl)
  (setq n 1)
  (REPEAT (- (LENGTH dlb)2)
    (setq pt1(polar (NTH n dlb) (angle (NTH n dlb)(NTH (- n 1)dlb)) dim)
          pt2(polar (NTH n dlb) (angle (NTH n dlb)(NTH (+ n 1)dlb)) dim)
          )
    (command "pline" pt1 "w" (* 0.3 dim) (* 0.3 dim) (NTH n dlb)pt2 "w" 0 0"")
    (vla-put-Color (vlax-ename->vla-object (entlast)) 5)
    (SETQ n(1+ n))
    )
  (command"_text" "j" "mc"pta (* 4 dim) 0 zf"")
  (command"_text" "j" "mc" ptb (* 4 dim) 0 zf"")
  (setvar "osmode" osm)
  )

(defun massoc (key alist / x nlist);函数来自于论坛
  (foreach x alist
    (if (eq key (car x))
      (setq nlist (cons (cdr x) nlist))
      )
    )
  (reverse nlist)
  );
;删除列表中的相同元素
(defun delys (Lst / LstNew);函数来自于论坛
  (foreach _LstItem Lst
    (if (not (member _LstItem LstNew))
      (setq LstNew (append LstNew (list _LstItem)))
      )
    )
  LstNew
  )
[/pcode]

Smile cop

过程步骤思路见下面！

XDSoft

rxing 发表于 2013-5-1 17:19

                               
登录/注册后可看大图

过程步骤思路见下面！

看你的图片，有现成的程序在运行？ 如果有把程序贴上来吧。

Smile cop

真的没有，希望高手们帮忙写一个，谢谢

xiahwan

剖切文字还没有写进去 不知道是不是你想要的

XDSoft

xiahwan 发表于 2013-5-2 22:33

                               
登录/注册后可看大图

剖切文字还没有写进去 不知道是不是你想要的

代码贴到论坛吧，谢谢！

Free-Lancer

比较有意思的一个绘制，写了一小半，回退处理不完善，没有绘制两端箭头和文字
[pcode=lisp,true](defun c:tt (/ pt->2d addpline setwid)
  (defun pt->2d        (p)
    (list (car p) (cadr p))
  )
  (defun mkvar (pts)
    (vlax-make-variant
      (vlax-safearray-fill
        (vlax-make-safearray
          vlax-vbdouble
          (cons 0 (1- (length pts)))
        )
        pts
      )
    )
  )
  (defun addpl (pts)
    (vla-addlightweightpolyline
      ms
      (mkvar (apply 'append (mapcar 'pt->2d pts)))
    )
  )
  (defun chpline (obj pts /)
    (vla-put-coordinates
      obj
      (mkvar (apply 'append (mapcar 'pt->2d pts)))
    )
  )
  (defun setwid        (obj pts / n m)
    (setq n (fix (/ (length pts) 3))
          m 1
    )
    (repeat n
      (vla-setwidth obj m 1. 1.)
      (vla-setwidth obj (1+ m) 1. 1.)
      (setq m (+ m 3))
    )
  )
  ;;Mail
  (setq        doc (vla-get-activedocument (vlax-get-acad-object))
        ms  (vla-get-modelspace doc)
  )
  (vl-catch-all-apply
    (function
      (lambda (/ p p1 ptl pl p2 p3 p4 p5)
        (if (setq p (getpoint "\nFirst Point: "))
          (progn
            (setq ptl (cons p ptl))
            (while
              (progn
                (initget 128 "U")
                (setq p1 (getpoint p "\nNext Point[U - Exit]<exit>: "))
              )
               (if (listp p1)
                 (setq ptl (cons p1 ptl))
                 (setq ptl (cddddr ptl))
               )
               (if (> (length ptl) 1)
                 (progn
                   (if pl
                     (progn
                       (setq p2         (car ptl)
                             p3         (cadr ptl)
                             ptl (cddr ptl)
                       )
                       (setq p4        (polar p3 (angle p3 (car ptl)) 3.)
                             p5        (polar p3 (angle p3 p2) 3.)
                       )
                       (setq ptl (append (list p2 p5 p3 p4) ptl))
                       (chpline pl (reverse ptl))
                       ;;Setwid
                       (setwid pl (reverse ptl))
                     )
                     (setq pl (addpl (reverse ptl)))
                   )
                 )
               )
               (setq p (car ptl))
            )
          )
        )
      )
    )
  )
  (vlax-release-object doc)
  (vlax-release-object ms)
  (princ)
)[/pcode]

Free-Lancer

继续第二步，完成绘制、回退及出错处理
[pcode=lisp,true](defun c:tt (/ pt->2d addpline setwid pl setptl)
  ;;Convert 3D point to 2D point
  (defun pt->2d        (p)
    (list (car p) (cadr p))
  )
  ;;Variant Pts
  (defun mkvar (pts)
    (vlax-make-variant
      (vlax-safearray-fill
        (vlax-make-safearray
          vlax-vbdouble
          (cons 0 (1- (length pts)))
        )
        pts
      )
    )
  )
  ;;mod - t Add index ; nil - delete
  (defun setptl        (p ptl mod le / l a b c d)
    (if        p
      (setq ptl (cons p ptl))
    )
    (setq l (length ptl))
    (if        mod
      (if (> l 2)
        (progn
          (setq        a   (car ptl)
                b   (cadr ptl)
                ptl (cddr ptl)
          )
          (setq        c (polar b (angle b (car ptl)) le)
                d (polar b (angle b a) le)
          )
          (setq ptl (append (list a d b c) ptl))
        )
        ptl
      )
      (if (< l 3)
        nil
        (setq ptl (cons (caddr ptl) (cddddr ptl)))
      )
    )
  )
  ;;Add Lwpolyline in Modelspace
  (defun addpl (pts)
    (vla-addlightweightpolyline
      ms
      (mkvar (apply 'append (mapcar 'pt->2d pts)))
    )
  )
  ;;Reset Pline Coordinates
  (defun chpline (obj pts /)
    (vla-put-coordinates
      obj
      (mkvar (apply 'append (mapcar 'pt->2d pts)))
    )
  )
  ;;Change Width of SegentIndex
  (defun setwid        (obj pts w / n m)
    (setq n (fix (/ (length pts) 3))
          m 1
    )
    (repeat n
      (vla-setwidth obj m w w)
      (vla-setwidth obj (1+ m) w w)
      (setq m (+ m 3))
    )
  )
  ;;Mail
  (setq        doc (vla-get-activedocument (vlax-get-acad-object))
        ms  (vla-get-modelspace doc)
  )
  (if (vl-catch-all-error-p
        (vl-catch-all-apply
          (function
            (lambda (/ scl widl widw p p1 ptl )
              (setq scl         (getvar "dimscale")
                    widl (* 6 scl)
                    widw (* 0.3 scl)
              )
              (if (setq p (getpoint "\nFirst Point: "))
                (progn
                  (setq ptl (cons p ptl))
                  (while
                    (progn
                      (initget 128 "U")
                      (setq p1
                             (getpoint p "\nNext Point[U - Exit]<exit>: ")
                      )
                    )
                     (if (listp p1)
                       (setq ptl (setptl p1 ptl t widl)) ;_Add point
                       (setq ptl (setptl nil ptl nil widl)) ;_U
                     )
                     (if pl
                       (if ptl
                         (progn
                           (chpline pl (reverse ptl)) ;_reset coordinates
                           (setwid pl (reverse ptl) widw) ;_Setwid
                         )
                         (progn
                           (vl-catch-all-apply 'vla-delete (list pl))
                           (setq pl nil)
                           (if (not (listp p1))
                             (princ "\nAll is Undo!")
                           )
                         )
                       )
                       (setq pl (addpl (reverse ptl))) ;_Initialize Pline
                     )
                     (setq p (car ptl)) ;_reset startpoint
                  )
                )
              )
            )
          )
        )
      )
    (vl-catch-all-apply 'vla-delete (list pl)) ;_ Cancel will delete Pline
  )
  (vlax-release-object doc)
  (vlax-release-object ms)
  (princ)
)[/pcode]

冰心

期待第三步，完成箭头和文字标识{:soso_e179:}

Free-Lancer

冰心 发表于 2013-5-15 10:33
期待第三步，完成箭头和文字标识

后面你接力了，写这个程序感兴趣的是实时绘制Pline并可以回退，包括 Coordinates 的修改技巧，后面就是用 Grread 控制箭头方向，这个箭头可以是单独生成的 Pline

冰心

Free-Lancer 发表于 2013-5-15 17:49
后面你接力了，写这个程序感兴趣的是实时绘制Pline并可以回退，包括 Coordinates 的修改技巧，后面就是用 ...

刚看到，几天没上来了。还是大师出手吧，我很少用vl、vla、vlax。。。。类函数，没有好好学习过，:(

XDSoft

冰心 发表于 2013-5-23 21:29
刚看到，几天没上来了。还是大师出手吧，我很少用vl、vla、vlax。。。。类函数，没有好好学习过，

尝试下用下就好了，没啥难的，就是多看代码，多写，几个程序就熟练了，VL函数确实强。编程思路也靠面向对象的方向去了。

xyp1964

Lisphk

xyp1964 发表于 2013-6-7 22:45

院长，最后生成的是个组？ 还是块了？