fhcd88 发表于 2013-1-9 21:00:00

求高手编写LISP程序

本帖最后由 fhcd88 于 2013-1-9 22:39 编辑

求高手编写LISP程序，请下载
程序要求：在附件中用鼠标点绘形成如红线多边形选择框，在与其他线相交处打断其他线，保留红线框内多线段，红线框外线段删除。
选择框可用请用如下代码生成：
(setq gpt (getpoint "\n 第一圈围点: ") lst (list gpt))
(while gpt
    (initget 32)
    (princ "\n 指定直线的端点: ")
    (if (setq gpt (getpoint gpt "\n 指定直线的端点: "))
      (progn
    (setq lst (cons gpt lst))
    (redraw);;;
    (mapcar '(lambda (p1 p2)
               (grvecs (list -7 p1 p2))
             )
             lst
             (append (cdr lst) (list (car lst)))
    )
      )
    )
)

Andyhon 发表于 2013-1-9 21:00:01

本帖最后由 Andyhon 于 2013-1-9 22:33 编辑

Try only ...
(vl-load-com)
(Defun c:test ()
   (setq pt (getpoint "\n第一圈围点: "))
   (command "pline" pt)
   (while (= (logand (getvar "CmdActive") 1) 1) (command pause))
   (setq ee (entlast))
   (setq ;; (entsel "\n 选取红线多边形选择框: ")
      obj (vlax-ename->vla-object ee)   ; obj
   )
   (vla-offset obj 1)
   (setq aa1(vla-get-area (vlax-ename->vla-object (setq ee1 (entlast)))))
   (vla-offset obj -1)
   (setq aa2(vla-get-area (vlax-ename->vla-object (setq ee2 (entlast)))))
   (if (< aa2 aa1)
   (setq eee ee1)
   (setq eee ee2)
   )
   (setq pts (acet-geom-pline-point-list eee nil))
   (entdel ee1)
   (entdel ee2)
   
   (SetVar 'OsMode 0)
   (repeat 2
   (command "trim" ee "" "f")
   (mapcar 'command pts)
   (command "" "")
   )
)

ZZXXQQ 发表于 2013-1-9 21:48:00

给个图样

xsso 发表于 2013-1-9 21:53:10

留个脚印，等答案！

fhcd88 发表于 2013-1-9 22:30:31

本帖最后由 fhcd88 于 2013-1-9 22:31 编辑

试了一下，出错，再者能否就使用我贴子中给的绘制选择框的程序啊，请把代码加进去，谢谢

Andyhon 发表于 2013-1-9 22:33:02

...出错...

得有 Acet-* 函数;
搜 ET / Express Tools

fhcd88 发表于 2013-1-9 22:49:24

我再试试，能否还是请你完整用我给的绘选择框的代码绘选择框，因为我程序中其他部分在用

Andyhon 发表于 2013-1-9 23:06:28

本帖最后由 Andyhon 于 2013-1-9 23:41 编辑



(Defun test ()
(setq gpt (getpoint "\n 第一圈围点: ")
      lst (list gpt)
)
(while gpt
    (initget 32)
    (princ "\n 指定直线的端点: ")
    (if (setq gpt (getpoint gpt "\n 指定直线的端点: "))
      (progn
      (setq lst (cons gpt lst))
      (redraw)
      (mapcar '(lambda (p1 p2)
                   (grvecs (list -7 p1 p2))
               )
                lst
                (append (cdr lst) (list (car lst)))
      )
      )
    )
)
lst
)

(Defun c:test ()
   ;; (setq pt (getpoint "\n第一圈围点: "))
   (setq pts (test))
   (command "pline")
   (mapcar 'command pts)
   (command "C")
   (setq ee (entlast))
   ;; 红线多边形选择框请先绘制
   (setq ;; (entsel "\n 选取红线多边形选择框: ")
      obj (vlax-ename->vla-object ee)   ; obj
   )
   (vla-offset obj 1)
   (setq aa1(vla-get-area (vlax-ename->vla-object (setq ee1 (entlast)))))
   (vla-offset obj -1)
   (setq aa2(vla-get-area (vlax-ename->vla-object (setq ee2 (entlast)))))
   (if (< aa2 aa1)
   (setq eee ee1)
   (setq eee ee2)
   )
   (setq pts (acet-geom-pline-point-list eee nil))
   (entdel ee1)
   (entdel ee2)
   (SetVar 'OsMode 0)
   (repeat 2
   (command "trim" ee "" "f")
   (mapcar 'command pts)
   (command "" "")
   )
   (redraw)
   (entdel ee)
   (setq ss (ssget "WP" pts))
)

fhcd88 发表于 2013-1-9 23:14:08

能否再帮忙加两行代码，一是做一个选择集选择所绘框内所有图元，含框线经过的图元；二是，删除所绘框，谢谢

fhcd88 发表于 2013-1-9 23:21:14

能加上后面的代码的话，可以就用你前面的程序直接绘框
页: [1] 2 3 4
查看完整版本: 求高手编写LISP程序