修剪完善下

crazylsp

修改要求: （1）每拾取两点就能显示出修剪效果 （2）保留动态线 （3）让动态线颜色能显示出来
[pcode=lisp,true](defun C:4S()
    (setq ptlst '())
    (while (setq pt (getpoint "拾取点<"))
     (setq a t )
      (while a
       (setq pt2 (cadr(grread t 7 0)))
       (grdraw pt pt2 1)
       (redraw)
       (setq ptlst(cons pt ptlst))
        (if (= (length ptlst) 2)
         (progn
          (command "trim"  "" "F"  (car ptlst) (cadr ptlst)  "" "" )
          (setq ptlst '() a nil)
         )
        )
       )
     )
   )[/pcode]

XDSoft

把测试DWG文件贴上来吧。

crazylsp

不加动态拾取两点就能见到删除，但是没有动态线。

Lispboy

crazylsp 发表于 2013-5-9 21:09

                               
登录/注册后可看大图

不加动态拾取两点就能见到删除，但是没有动态线。

楼主，你不想在里面的多段线外面点一点，就直接得到你这么多步骤的结果？为什么要交互这么多次？

crazylsp

调整了一下可以如我愿了了，只是第一步没有动态，余下的步子都{:soso_e189:}
[pcode=lisp,true]  (defun C:4S()
    (setq pt(getpoint "拾取点<") ptlst (list pt))
      (while  (setq pt (getpoint "拾取点<"))
        (grdraw pt (car ptlst) 1)
        (setq ptlst(append  ptlst (list pt)))
         (if (= (length ptlst) 2)
          (progn
            (command "trim"  "" "F"  (car ptlst) (cadr ptlst)  "" "" )
            (setq ptlst (cdr ptlst)  )
           )
         )
      )
  )[/pcode]

crazylsp

空闲时间又扩充了下功能，设计T键修剪，E键延伸{:soso_e100:}[pcode=lisp,true](defun C:4S ()
  ( setq g ( grread ) )
  ( if  ( and ( = ( car g ) 2) ( = ( cadr g ) 116 ) ( member ( cadr g ) '( 101 116 ) ) )
   ( progn
     ( setq ss ( ssget ) pt ( getpoint "拾取点<" ) ptlst ( list pt )  )
       ( while  ( setq pt ( getpoint ( car ptlst ) "拾取点<" ) )
         ( grdraw pt ( car ptlst ) 1 )
         ( setq ptlst ( append  ptlst ( list pt ) ) )
          ( if ( = ( length ptlst ) 2 )
           ( progn
            ( command "trim"  ss"" "F"  ( car ptlst ) ( cadr ptlst )  "" "" )
            ( setq ptlst ( cdr ptlst )  )
           )
         )
       )
    )
  )
  ( if ( and ( = (car g) 2) ( = ( cadr g ) 101 ) ( member ( cadr g ) '( 101 116 ) ) )
   ( progn
     ( setq ss ( ssget ) pt ( getpoint "拾取点<" ) ptlst ( list pt )  )
       ( while  ( setq pt ( getpoint ( car ptlst ) "拾取点<" ) )
         ( grdraw pt ( car ptlst ) 1 )
         ( setq ptlst ( append  ptlst ( list pt ) ) )
          ( if ( = ( length ptlst ) 2 )
           ( progn
            ( command "extend"  ss"" "F"  ( car ptlst ) ( cadr ptlst )  "" "" )
            ( setq ptlst ( cdr ptlst )  )
           )
         )
       )
    )
  )
) [/pcode]

XDSoft

crazylsp 发表于 2013-5-11 16:01

                               
登录/注册后可看大图

空闲时间又扩充了下功能，设计T键修剪，E键延伸(defun C:4S ()
  ( setq g ( grread ) )
   ...

恭喜你，把你的程序所有功能用个动画演示贴给大家看吧。

crazylsp

谢谢管理员{:soso_e121:}， 完整地做对自己资料归档也是很好的。

Lispboy

crazylsp 发表于 2013-5-11 17:08

                               
登录/注册后可看大图

谢谢管理员， 完整地做对自己资料归档也是很好的。

沃鸥，白色的，平时不刺眼吗？

crazylsp

楼主，你不想在里面的多段线外面点一点，就直接得到你这么多步骤的结果？为什么要交互这么多次？

这样做速度快，但是我的图纸的线很多是交叉出线头的，不能连接成多段线

Lispboy

crazylsp 发表于 2013-5-11 17:36

                               
登录/注册后可看大图

这样做速度快，但是我的图纸的线很多是交叉出线头的，不能连接成多段线

为什么当初都画成出头的了？当时有什么需要吗?

crazylsp

没办法钢筋有锚固长度，必须绘出来{:soso_e101:}

2012淡然之马

crazylsp 发表于 2013-5-11 16:01
空闲时间又扩充了下功能，设计T键修剪，E键延伸(defun C:4S ()
  ( setq g ( grread ) )
   ...

有问题勒，
命令: 4s nil

crazylsp

把( setq g ( grread ) )
  ( if  ( and ( = ( car g  )  2) ( = ( cadr g ) 116 ) ( member ( cadr g ) '( 101 116 ) ) )
改成
( if  ( and ( = ( car ( setq g ( grread ) ) ) 2) ( = ( cadr g ) 116 ) ( member ( cadr g ) '( 101 116 ) ) )试试

2012淡然之马

crazylsp 发表于 2013-5-22 10:54
把( setq g ( grread ) )
  ( if  ( and ( = ( car g  )  2) ( = ( cadr g ) 116 ) ( member ( cadr g ) ' ...

跟没改之前是一样的，