[LISP函数]：动态添加多段线顶点

caddog · 发表于 2007-11-30 09:22:34

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

[FONT=courier new]
;;;--------------------------------------------------------
;;;函数： c:add
;;;--------------------------------------------------------
;;;来源：　作者: caddog
;;;编制时间：2007.3修改时间2007.11.23
;;;功能: 添加多段线的顶点
;;;语法:
;;;参数
;;;返回值:
;;;备注 : 学习VBA看到ADDVERTEX,试着写了一个看看
;;; 在2007.11.23加入了动态显示欲加点位的功能，使
;;; 加点更直观。编写中借用了XDCAD上《鼠标移动动态显示》
;;; 函数。作者的名字没能记下来，深表歉意
;;; 3DPOINT->2DPOINT函数取自CAD教程
;;; 可惜不支持捕捉！不知有没有办法解决，请高手指教:)
;;;--------------------------------------------------------
(DEFUN C:add (/ 2dp ename n obj p
pp ss1 ss2 t1 var2dp StartWidth
endWidth LOOP_ID N_OLD N_OLD1 N_OLD2
OLDERR PP1 PTVER1 PTVER2
)
(SETQ olderr *error*
*error* err_adv
) ;_ 结束setq
(COMMAND "_.undo" "_begin")
(SETQ SS1 (ENTSEL "\n请选择一条多段线:"))
(SETQ ENAME (CAR SS1))
(SETQ OBJ (VLAX-ENAME->VLA-OBJECT ENAME))
;;如果是多段线则处理
(IF (WCMATCH (VLA-GET-OBJECTNAME obj) "LWPOLYLINE,AcDbPolyline") ; _
; 结束wcmatch
(PROGN
;;显示多段线的夹点,便于用户查看
(SETQ ss2 (SSADD ENAME))
(SSSETFIRST NIL ss2)
;;提示用户选择插入点
;;(SETQ P (GETPOINT "\n请选择插入点:"))
(SETQ LOOP_ID T
objLine1 nil
p t
n_old1 nil
n_old2 nil
)
(while p
(WHILE LOOP_ID
(SETQ vptent (GRREAD T (+ 4 8) 0))
(COND
((AND vptent (= (CAR vptent) 5))
(PROGN
(setq pp1 (cadr vptent))
;;确定用户所指定的插入点的位置,是在哪个顶点之后
(SETQ PP (VLAX-CURVE-GETCLOSESTPOINTTO
OBJ
(TRANS pp1 1 0)
)
)
(SETQ N (+ (FIX (VLAX-CURVE-GETPARAMATPOINT OBJ PP)) 1))
(if (/= n n_old)
(SETQ ptVer1 (vlax-curve-getPointAtParam obj (- n 1))
ptVer2 (vlax-curve-getPointAtParam obj n)
n_old1 n
)
)
(if (not ptVer1)
(setq ptVer1 ptVer2)
)
(if (not ptVer2)
(setq ptVer2 ptVer1)
)
(if (not objLine1);_如果没有直线对象，则建立之
(progn
(setq objLine1 (VLA-ADDLINE
(model-space)
(VLAX-3D-POINT ptVer1)
(VLAX-3D-POINT pp1)
)
objLine2 (VLA-ADDLINE
(model-space)
(VLAX-3D-POINT ptVer2)
(VLAX-3D-POINT pp1)
)
)
) ;_end progn
) ;_end if objLine
(if (/= n n_old2)
(progn
(VLA-PUT-ENDPOINT objLine1 (VLAX-3D-POINT (3DPOINT->2DPOINT pp1)))
(vla-put-StartPoint objLine1 (VLAX-3D-POINT (3DPOINT->2DPOINT ptVer1)))
(VLA-PUT-ENDPOINT objLine2 (VLAX-3D-POINT (3DPOINT->2DPOINT pp1)))
(vla-put-StartPoint objLine2 (VLAX-3D-POINT (3DPOINT->2DPOINT ptVer2)))
(setq n_old2 n)
)
(progn
(VLA-PUT-ENDPOINT objLine1 (VLAX-3D-POINT (3DPOINT->2DPOINT pp1)))
(VLA-PUT-ENDPOINT objLine2 (VLAX-3D-POINT (3DPOINT->2DPOINT pp1)))
)
)
) ;_ 结束progn
)
((= 3 (CAR vptent)) ;_按下鼠标左键，选定了点
(progn
(SETQ p (cadr vptent))
;;; ;;确定用户所指定的插入点的位置,是在哪个顶点之后
;;; (SETQ
;;; PP (VLAX-CURVE-GETCLOSESTPOINTTO OBJ (TRANS P 1 0))
;;; )
;;; (SETQ N (+ (FIX (VLAX-CURVE-GETPARAMATPOINT OBJ PP)) 1))
;;; ;;取插入点外原来的起始宽度和终止宽度
;;; ;;试着用PEDIT命令添加顶点,观察加入点后宽度的变化可知
;;; ;;新加入顶点的起始/终止宽度均为原来的的终止宽度
(VLA-GETWIDTH obj (- n 1) 'StartWidth 'endWidth)
;; 创建安全数组,并将点取的坐标赋给它.注意ADDVERTEX方法只接受二维点
(SETQ 2DP (VLAX-MAKE-SAFEARRAY VLAX-VBDOUBLE '(0 . 1)))
(VLAX-SAFEARRAY-FILL 2DP (LIST (CAR P) (CADR P)))
;;转换安全数组为变体
(SETQ VAR2DP (VLAX-MAKE-VARIANT 2DP))
;;调用ACTIVEX方法添加顶点
(VLA-ADDVERTEX OBJ N VAR2DP)
;;调整宽度
(VLA-SETWIDTH obj n endWidth endWidth)
) ;_end progn
)
(T
(PROGN
(SETQ LOOP_ID NIL
p nil
)
;;
) ;_ 结束progn
)
) ;_ 结束cond
) ;_ 结束while
) ;_end while p
(if objLine1 ;_如果有直线对象则删除之
(progn (VLA-DELETE objLine1)
(VLA-DELETE objLine2)
)
) ;_end if objline1
(PRINC)
(SSSETFIRST NIL) ;_取消夹取的状态
) ;_end progn
(PROGN
(PRINC "\n您选择的不是多段线!")
(PRINC)
) ;_end else progn
) ;_end if
(COMMAND "_.undo" "_end")
(SETQ *error* olderr)
(PRINC)
) ;_end defun
;;错误处理，用以在用户按下了ESC键后取消所有的修改并删除指示线。
(DEFUN err_adv (s)
(if OBJLINE1 ;_若生成了指示线且未删除则删除掉
(progn (vla-delete OBJLINE1)
(vla-delete OBJLINE2)
)
)
(princ "\t *取消操作*")
(SETQ *error* olderr)
) ;_ 结束defun
;;; 函数： 3dPoint->2dPoint
;;;--------------------------------------------------
;;; 说明：本函数有一个参数，表示一个三维点
;;; （由三个整数或实数组成的表），函数将它
;;; 转换为二维点（由两个实数组成的表）。
;;; 本函数并不检查参数 3dpt，而是
;;; 总认为它是一个有效点。
;;;---------------------------------------------------
;;; 要添加的功能：加上一些参数检查功能，
;;; 这样即使传给它空值或不是三维点的值，
;;; 函数也不会导致程序崩溃。
;;;----------------------------------------------------
(DEFUN 3dPoint->2dPoint (3dpt)
(LIST (FLOAT (CAR 3dpt)) (FLOAT (CADR 3dpt)))
) ;_ 结束defun
[/FONT]

[FONT=courier new] 
;;;-------------------------------------------------------- 
;;;函数： c:add 
;;;-------------------------------------------------------- 
;;;来源：           　作者: caddog 
;;;编制时间：2007.3修改时间2007.11.23 
;;;功能:     添加多段线的顶点 
;;;语法:      
;;;参数       
;;;返回值:    
;;;备注  :   学习VBA看到ADDVERTEX,试着写了一个看看 
;;;         在2007.11.23加入了动态显示欲加点位的功能，使 
;;;         加点更直观。编写中借用了XDCAD上《鼠标移动动态显示》 
;;;         函数。作者的名字没能记下来，深表歉意 
;;;         3DPOINT->2DPOINT函数取自CAD教程 
;;;         可惜不支持捕捉！不知有没有办法解决，请高手指教:) 
;;;-------------------------------------------------------- 
(DEFUN C:add (/               2dp        ename         n          obj           p 
              pp       ss1        ss2         t1          var2dp   StartWidth 
              endWidth         LOOP_ID         N_OLD          N_OLD1   N_OLD2 
                       OLDERR         PP1          PTVER1   PTVER2 
             ) 
  (SETQ        olderr        *error* 
        *error*        err_adv 
  ) ;_ 结束setq 
  (COMMAND "_.undo" "_begin") 
 
  (SETQ SS1 (ENTSEL "\n请选择一条多段线:")) 
  (SETQ ENAME (CAR SS1)) 
  (SETQ OBJ (VLAX-ENAME->VLA-OBJECT ENAME)) 
  ;;如果是多段线则处理 
  (IF (WCMATCH (VLA-GET-OBJECTNAME obj) "LWPOLYLINE,AcDbPolyline") ; _ 
                                        ; 结束wcmatch 
    (PROGN 
      ;;显示多段线的夹点,便于用户查看        
      (SETQ ss2 (SSADD ENAME)) 
      (SSSETFIRST NIL ss2) 
      ;;提示用户选择插入点 
      ;;(SETQ P (GETPOINT "\n请选择插入点:")) 
 
      (SETQ LOOP_ID T 
            objLine1 nil 
            p t 
            n_old1 nil 
            n_old2 nil 
      ) 
 
      (while p 
        (WHILE LOOP_ID 
          (SETQ vptent (GRREAD T (+ 4 8) 0)) 
          (COND 
            ((AND vptent (= (CAR vptent) 5)) 
             (PROGN 
               (setq pp1 (cadr vptent)) 
 
               ;;确定用户所指定的插入点的位置,是在哪个顶点之后 
               (SETQ PP        (VLAX-CURVE-GETCLOSESTPOINTTO 
                          OBJ 
                          (TRANS pp1 1 0) 
                        ) 
               ) 
               (SETQ N (+ (FIX (VLAX-CURVE-GETPARAMATPOINT OBJ PP)) 1)) 
               (if (/= n n_old) 
                 (SETQ ptVer1 (vlax-curve-getPointAtParam obj (- n 1)) 
                       ptVer2 (vlax-curve-getPointAtParam obj n) 
                       n_old1 n 
                 ) 
               ) 
               (if (not ptVer1) 
                 (setq ptVer1 ptVer2) 
               ) 
               (if (not ptVer2) 
                 (setq ptVer2 ptVer1) 
               ) 
               (if (not objLine1);_如果没有直线对象，则建立之 
                 (progn 
                   (setq objLine1 (VLA-ADDLINE 
                                    (model-space) 
                                    (VLAX-3D-POINT ptVer1) 
                                    (VLAX-3D-POINT pp1) 
                                  ) 
                         objLine2 (VLA-ADDLINE 
                                    (model-space) 
                                    (VLAX-3D-POINT ptVer2) 
                                    (VLAX-3D-POINT pp1) 
                                  ) 
                   ) 
 
                 ) ;_end progn 
 
               ) ;_end if objLine 
               (if (/= n n_old2) 
                 (progn 
                   (VLA-PUT-ENDPOINT objLine1 (VLAX-3D-POINT (3DPOINT->2DPOINT pp1))) 
                   (vla-put-StartPoint objLine1 (VLAX-3D-POINT (3DPOINT->2DPOINT ptVer1))) 
                   (VLA-PUT-ENDPOINT objLine2 (VLAX-3D-POINT (3DPOINT->2DPOINT pp1))) 
                   (vla-put-StartPoint objLine2 (VLAX-3D-POINT (3DPOINT->2DPOINT ptVer2))) 
                   (setq n_old2 n) 
                 ) 
                 (progn 
                   (VLA-PUT-ENDPOINT objLine1 (VLAX-3D-POINT (3DPOINT->2DPOINT pp1))) 
                   (VLA-PUT-ENDPOINT objLine2 (VLAX-3D-POINT (3DPOINT->2DPOINT pp1))) 
                 ) 
               ) 
 
 
 
             ) ;_ 结束progn 
            ) 
            ((= 3 (CAR vptent)) ;_按下鼠标左键，选定了点 
             (progn 
               (SETQ p (cadr vptent)) 
;;;               ;;确定用户所指定的插入点的位置,是在哪个顶点之后 
;;;               (SETQ 
;;;                 PP (VLAX-CURVE-GETCLOSESTPOINTTO OBJ (TRANS P 1 0)) 
;;;               ) 
;;;               (SETQ N (+ (FIX (VLAX-CURVE-GETPARAMATPOINT OBJ PP)) 1)) 
;;;               ;;取插入点外原来的起始宽度和终止宽度 
;;;               ;;试着用PEDIT命令添加顶点,观察加入点后宽度的变化可知 
;;;               ;;新加入顶点的起始/终止宽度均为原来的的终止宽度 
               (VLA-GETWIDTH obj (- n 1) 'StartWidth 'endWidth) 
               ;; 创建安全数组,并将点取的坐标赋给它.注意ADDVERTEX方法只接受二维点 
               (SETQ 2DP (VLAX-MAKE-SAFEARRAY VLAX-VBDOUBLE '(0 . 1))) 
               (VLAX-SAFEARRAY-FILL 2DP (LIST (CAR P) (CADR P))) 
               ;;转换安全数组为变体 
               (SETQ VAR2DP (VLAX-MAKE-VARIANT 2DP)) 
               ;;调用ACTIVEX方法添加顶点 
               (VLA-ADDVERTEX OBJ N VAR2DP) 
               ;;调整宽度 
               (VLA-SETWIDTH obj n endWidth endWidth) 
             ) ;_end progn 
            ) 
            (T 
             (PROGN 
               (SETQ LOOP_ID NIL 
                     p nil 
               ) 
               ;; 
             ) ;_ 结束progn 
 
            ) 
          ) ;_ 结束cond 
        ) ;_ 结束while 
      ) ;_end while p 
      (if objLine1  ;_如果有直线对象则删除之 
        (progn (VLA-DELETE objLine1) 
               (VLA-DELETE objLine2) 
        ) 
      ) ;_end if objline1 
 
      (PRINC) 
      (SSSETFIRST NIL) ;_取消夹取的状态 
    ) ;_end progn 
    (PROGN 
      (PRINC "\n您选择的不是多段线!") 
      (PRINC) 
    ) ;_end else progn 
  ) ;_end if 
  (COMMAND "_.undo" "_end") 
  (SETQ *error* olderr) 
 
  (PRINC) 
) ;_end defun 
 
;;错误处理，用以在用户按下了ESC键后取消所有的修改并删除指示线。 
(DEFUN err_adv (s) 
 
      (if OBJLINE1 ;_若生成了指示线且未删除则删除掉 
          (progn (vla-delete OBJLINE1) 
                 (vla-delete OBJLINE2) 
          ) 
        ) 
       
      (princ "\t *取消操作*") 
 
  (SETQ *error* olderr) 
) ;_ 结束defun 
 
;;; 函数： 3dPoint->2dPoint                                        
;;;-------------------------------------------------- 
;;; 说明：本函数有一个参数，表示一个三维点                        
;;;                （由三个整数或实数组成的表）， 函数将它                
;;;                转换为二维点（由两个实数组成的表）。                
;;;                本函数并不检查参数 3dpt，而是                        
;;;                总认为它是一个有效点。                                
;;;--------------------------------------------------- 
;;; 要添加的功能：加上一些参数检查功能，                        
;;;       这样即使传给它空值或不是三维点的值，                
;;;       函数也不会导致程序崩溃。                                
;;;---------------------------------------------------- 
(DEFUN 3dPoint->2dPoint         (3dpt) 
  (LIST (FLOAT (CAR 3dpt)) (FLOAT (CADR 3dpt))) 
 
  ) ;_ 结束defun 
  [/FONT]

[swf w=600 h=450]h:\add.swf[/swf]

zbwei120 · 发表于 2013-8-17 22:53:57

命令:
请选择一条多段线: *取消操作*,
不知道怎么用不了，请楼主看看

caddog · 发表于 2013-8-30 14:49:28

请试试将这一句放在程序最前面看看能否解决：(vl-load-com)

yoyoho · 发表于 2013-8-30 18:37:13

caddog 发表于 2013-8-30 14:49
请试试将这一句放在程序最前面看看能否解决：(vl-load-com)

加了(vl-load-com),测试未能成功.
指令: ADD
请选择一条多段线: *取消操作*

在AUTOCAD2011下测试!{:soso_e132:}

账号		自动登录	找回密码
密码			立即注册

[LISP函数]：动态添加多段线顶点

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子

点评