[LISP程序]：添加和移除多段线顶点的小程序

caddog · 发表于 2006-4-6 19:38:49

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

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

×

XD工具箱中有添加和移除多段线上的顶点的命令.给多段线的编辑带来了很大的方便.但自从我升级到2006就不能用了.不知为何?
没办法,只好自己动手啦.趁着学习VLISP的热情,就写了个模拟这种功能的程序,所不同之处是我根据工作中的实际需要,使它可以反复地在一条线上加入或删除顶点.因为是刚开始真正学习VLISP编程,所以一定还有许多不合理,不足之处,还请各位前辈学长指正.不胜感激

;;;-----------------------------------------------------------------------
;;;顾名思义，本LISP文件是对ACAD函数的一些扩充。其中包含多个自行编写的函数
;;;(命令)，用以解决工作中一些小问题，籍以提高工作效率。
;;;这些工具，都是作者们在工作一点点地积累而成。也许从程序设计的各项评判指标
;;;来看，并不是很严谨、优化，肯定有许多的不足之处。但若仅从解决实际问题的角
;;;度来讲，能够让工作的繁琐得到哪怕是一丁点的减轻，也算是努力没有白费。
;;;当然，精益求精、尽善尽美是我们不懈追求的目标，这是永远都不会改变的!
;;;因此，对于个中的不足之处，还请各位前辈不吝指出，小弟先行在此致谢!
;;;最后，祝您工作愉快!
;;;我的Email: [email]IamYourHe@163.com[/email] 我的手机: 13568953509 何俊
;;;-----------------------------------------------------------------------
(SETQ *acad-object* nil) ; Initialize global variable
(DEFUN acad-object ()
(COND (*acad-object*) ; Return the cached object
(T
(SETQ *acad-object* (VLAX-GET-ACAD-OBJECT))
)
) ;_ 结束cond
) ;_ 结束defun
(SETQ *active-document* nil) ; Initialize global variable
(DEFUN active-document ()
(COND (*active-document*) ; Return the cached object
(T
(SETQ *active-document* (VLA-GET-ACTIVEDOCUMENT (acad-object)))
)
) ;_ 结束cond
) ;_ 结束defun
(SETQ *model-space* nil) ; Initialize global variable
(DEFUN model-space ()
(COND (*model-space*) ; Return the cached object
(T
(SETQ *model-space* (VLA-GET-MODELSPACE (active-document)))
)
) ;_ 结束cond
) ;_ 结束defun
(VL-LOAD-COM)
;;;以上代码取自AutoCad2000帮助文件
;;;--------------------------------------------------------
;;;--------------------------------------------------------
;;;函数： c:FunHelp
;;;--------------------------------------------------------
;;;编制日期:2006.3.31
;;;编制者 :何俊
;;;函数说明:显示本文件内函数（命令）的相关信息
;;;--------------------------------------------------------
(DEFUN c:FunHelp ()
(PRINT)
(TEXTSCR)
(PRINC "\n AddFun自定义命令一览")
(PRINC "\n----------------------------------")
(PRINC "\n 命令功能")
(PRINC "\n----------------------------------")
(PRINC "\n Bfill ........区域植被填充")
(PRINC "\n AddVertex......在多段线上添加顶点")
(PRINC "\n RemoveVertex...移除多段线上的顶点")
(PRINC "\n CC.............多重复制")
(PRINC "\n Swp............选择用户指定多边形内的实体")
(PRINC "\n (注意多边形要在当前视口内)")
(PRINC "\n Cwp............选择用户指定多边形内以及与多边形相交的实体")
(PRINC "\n (注意多边形要在当前视口内)")
(PRINC "\n ES.............选择用户指定多边形外的实体")
(PRINC "\n (注意多边形要在当前视口内)")
(PRINC "\n Cs.............用户指定多边形外且不与多边形相交实体")
(PRINC "\n (注意多边形要在当前视口内)")
(PRINC "\n----------------------------------")
(PRINC "\n 谢谢您的使用!愿您工作愉快!")
(PRINC)
) ;_ 结束defun
;;;-------------------------------------------
;;;函数名：RemoveVertex
;;;-------------------------------------------
;;;来源：　作者：何俊　
;;;编制时间：2006.3.31
;;;功能 :删除多段线顶点
;;;语法 :(RemoveVertex)
;;;参数 :
;;;返回值:成功....T 失败...nil
;;;备注 :
;;;-------------------------------------------
(DEFUN c:RemoveVertex (/ eName obj objNew
plObj pp n Plist
neElev nuVertex arry1 #Plist
nuLen nuID #temp1 vaPlist
entClose entLinet entLines entLinew
entThick enttruec entconwidth
)
(PRINC "\n RevmoveVertex......删除多段线的顶点(2006.3)")
(SETQ ss1 (ENTSEL "\n请选择一条多段线:"))
(SETQ eName (CAR ss1))
(SETQ p (CAR (CDR (ENTSEL "\n请选择要移除的顶点:"))))
(SETQ obj (VLAX-ENAME->VLA-OBJECT eName))
(WHILE p
(IF objNew
(SETQ obj objNew)
) ;_ 结束if
(IF
(WCMATCH
(VLA-GET-OBJECTNAME obj)
"LWPOLYLINE,AcDbPolyline"
) ;_ 结束wcmatch
(PROGN
(SETQ pp (VLAX-CURVE-GETCLOSESTPOINTTO obj (TRANS p 1 0)))
;;通过(VLAX-CURVE-GETPARAMATPOINT obj pp)取得的参数的值为小数
;;如0.8579说明用户所点取的P位置在0到1号点之间，且0-P/0-1为0.8579，点位接近1点
;;由此，可能确定用户希望移除的是哪一个顶点。
(SETQ n (ATOI (RTOS (VLAX-CURVE-GETPARAMATPOINT obj pp) 2 0)))
;;提出多段线的顶点坐标
(SETQ Plist
(VLAX-SAFEARRAY->LIST
(VLAX-VARIANT-VALUE
(VLA-GET-COORDINATES obj)
) ;_ 结束vlax-variant-value
) ;_ 结束vlax-safearray->list
) ;_ 结束setq
;;求算数组上下标,先求出Vertex的数目
(SETQ nuVertex (+ (FIX (VLAX-CURVE-GETENDPARAM obj)) 1))
;;若多段线为闭合的，通过上行语句求出的Vertex数目将会多一个
;;在下面的判断语句中减去
(IF (= (VLA-GET-CLOSED obj) :VLAX-TRUE)
(SETQ nuVertex (- nuVertex 1))
) ;_ 结束if
;;计算数组上下标
(SETQ array1 (CONS 0 (- (* (- nuVertex 1) 2) 1)))
(SETQ #plist (VLAX-MAKE-SAFEARRAY VLAX-VBDOUBLE array1))
;;计算顶点表内元素个数
(SETQ nuLen (LENGTH Plist))
;;根据n值，将点P的坐标插入到Plist中，先将Plist转为XYZ样式
(SETQ nuID 0)
(SETQ #templ nil)
;;若点取的为第一个点
;;; (if (= n 0)
;;; (setq nuID 2
;;; nuLen (- nuLen 2)
;;; ))
;;; ;;若点取的为最后一个点
;;; (if (= n nuVertex)
;;; (setq nuLen (- nuLen 2))
;;; )
(REPEAT nuLen
(IF (OR (= nuID (* n 2)) (= nuID (+ (* n 2) 1)))
(PROGN
)
(SETQ #templ (APPEND #templ (LIST (NTH nuID Plist))))
) ;_ 结束if
(SETQ nuID (+ 1 nuID))
) ;_ 结束repeat
(VLAX-SAFEARRAY-FILL #Plist #temPl)
;;由数组生成变体
(SETQ vaPlist (VLAX-MAKE-VARIANT #Plist))
;;删除旧线，换上新线.要匹配的项目
;;Closed......闭合 Layer.........图层
;;Linetype....线型 LinetypeScale.线型缩放比例
;;Lineweight..线宽 PlotStyleName.打印样式名
;;Thickness...厚度 TrueColor.....颜色
(SETQ entClose (VLA-GET-CLOSED obj)
entLayer (VLA-GET-LAYER obj)
entLinet (VLA-GET-LINETYPE obj)
entLines (VLA-GET-LINETYPESCALE obj)
entLinew (VLA-GET-LINEWEIGHT obj)
entThick (VLA-GET-THICKNESS obj)
entTruec (VLA-GET-TRUECOLOR obj)
entEleva (VLA-GET-ELEVATION obj)
entConwidth (VLA-GET-CONSTANTWIDTH obj) ;_全局宽度
entLTGen (VLA-GET-LINETYPEGENERATION obj) ;_线型生成
) ;_ 结束setq
;;删除原来的线
(SETQ eName (VLAX-VLA-OBJECT->ENAME obj))
(ENTDEL eName)
(SETQ objNew (VLA-ADDLIGHTWEIGHTPOLYLINE (model-space) vaPlist))
;;设置新生成多段线的各property值
(VLA-PUT-CLOSED objNew entClose)
(VLA-PUT-LAYER objNew entLayer)
(VLA-PUT-LINETYPE objNew entLinet)
(VLA-PUT-LINETYPESCALE objNew entLines)
(VLA-PUT-LINEWEIGHT objNew entLinew)
(VLA-PUT-THICKNESS objNew entThick)
(VLA-PUT-TRUECOLOR objNew entTruec)
(VLA-PUT-ELEVATION objNew entEleva)
(VLA-PUT-CONSTANTWIDTH objNew entConwidth)
(VLA-PUT-LINETYPEGENERATION objNew entLTGen)
;;赋值完成，更新对象
(VLA-UPDATE objNew)
(SETQ retuValue T)
) ;_ 结束progn
(PROGN (PRINT "您选择的不是多段线!")
(SETQ retuValue nil)
) ;_ 结束progn
) ;_ 结束IF
(PRINT)
(SETQ p (CAR (CDR (ENTSEL "\n请选择要移除的顶点:"))))
) ;_ 结束while
(PRINC "\n 本条多段线现有：")
(PRINC (- (/ nuLen 2) 1))
(PRINC "个顶点......谢谢使用!")
(PRINC)
) ;_ 结束defun
;;;--------------------------------------------------------
;;;函数： getPlList
;;;--------------------------------------------------------
;;;说明：本函数提取多段线的各端点坐标值构成一张表并返回
;;;
;;;
;;;编制者:高老师
;;;--------------------------------------------------------
(DEFUN getPlList (#entity / OBJ LW_T8 OBJ_1)
(SETQ obj (ENTGET #entity))
(SETQ lw_t8 (CDR (ASSOC 8 obj)))
(SETQ obj_1 nil)
(WHILE (/= (ASSOC 10 obj) nil)
(IF (AND (= (CAAR obj) 10)
(NOT (EQUAL (CDAR obj) (LAST obj_1) 0.001))
) ;_ 结束and
(SETQ obj_1 (APPEND obj_1 (LIST (CDAR obj))))
) ;生成坐标表同时去掉相邻重点,不带10
(SETQ obj (CDR obj))
) ;_ 结束while
(SETQ obj obj_1)
(IF (EQUAL (CAR obj) (LAST obj) 0.001)
(SETQ obj (REVERSE (CDR (REVERSE obj))))
) ;_ 结束if
;;判断首闭
(SETQ #temp obj)
) ;_ 结束defun
;;end defun
;;;--------------------------------------------------------
;;;函数： c:CC
;;;--------------------------------------------------------
;;;编制日期:2006.4.1
;;;编制者 :何俊
;;;函数说明:本函数用以模拟ACAD2006中的复制命令，其实就是默认为多重复制
;;;--------------------------------------------------------
(DEFUN c:cc ()
(PRINC "选择对象:")
(SETQ ss1 (SSGET))
(COMMAND "copy")
(COMMAND ss1)
(COMMAND "")
(COMMAND "M")
) ;_ 结束defun
;;;--------------------------------------------------------
;;;函数： c:SW
;;;--------------------------------------------------------
;;;编制日期:2006.4.1
;;;编制者 :何俊
;;;函数说明:本函数选择用户指定多边形内的实体(注意多边形要在当前视口内)。
;;;--------------------------------------------------------
(DEFUN c:sw (/ ENAME #MYLIST SS1)
(princ "\n 选择用户指定多边形内的实体(注意多边形要在当前视口内)。")
(SETQ ename (CAR (ENTSEL "\n请选择一个多边形:")))
(SETQ #mylist (getpllist ename))
(SETQ ss1 (SSGET "_WP" #mylist))
(SSSETFIRST NIL ss1)
(SETQ ss1 ss1)
) ;_ 结束defun
;;;--------------------------------------------------------
;;;函数： c:CW
;;;--------------------------------------------------------
;;;编制日期:2006.4.1
;;;编制者 :何俊
;;;函数说明:本函数选择用户指定多边形内以及与多边形相交的实体
;;; (注意多边形要在当前视口内)。
;;;--------------------------------------------------------
(DEFUN c:cw (/ ENAME #MYLIST SS1)
(princ "\n 选择用户指定多边形内以及与多边形相交的实体(注意多边形要在当前视口内)")
(SETQ ename (CAR (ENTSEL "\n请选择一个多边形:")))
(SETQ #mylist (getpllist ename))
(SETQ ss1 (SSGET "_CP" #mylist))
(SSSETFIRST NIL ss1)
(SETQ ss1 ss1)
) ;_ 结束defun
;;;--------------------------------------------------------
;;;函数： c:es
;;;--------------------------------------------------------
;;;编制日期:2006.4.
;;;编制者 :何俊
;;;函数说明:本函数选择用户指定多边形外的实体(注意多边形要在当前视口内)。
;;;--------------------------------------------------------
(DEFUN c:es (/ ename #mylist ss1)
(princ "\n 选择用户指定多边形外的实体(注意多边形要在当前视口内)。")
(SETQ ename (CAR (ENTSEL "\n请选择一个多边形:")))
(SETQ #mylist (getpllist ename))
(SETQ ss1 (SSGET "_WP" #mylist))
(COMMAND "select" "all" "r")
(COMMAND ss1)
(COMMAND "")
(SETQ ss1 (SSGET "_p"))
(SSSETFIRST NIL ss1)
(SETQ ss1 ss1)
) ;_ 结束defun
;;;--------------------------------------------------------
;;;函数： c:Cs
;;;--------------------------------------------------------
;;;编制日期:2006.4.
;;;编制者 :何俊
;;;函数说明:本函数选择用户指定多边形外且不与多边形相交实体
;;; (注意多边形要在当前视口内)。
;;;--------------------------------------------------------
(DEFUN c:Cs (/ ename #mylist ss1)
(princ "\n 选择用户指定多边形外且不与多边形相交实体(注意多边形要在当前视口内)")
(SETQ ename (CAR (ENTSEL "\n请选择一个多边形:")))
(SETQ #mylist (getpllist ename))
(SETQ ss1 (SSGET "_cP" #mylist))
(COMMAND "select" "all" "r")
(COMMAND ss1)
(COMMAND "")
(SETQ ss1 (SSGET "_p"))
(SSSETFIRST NIL ss1)
(SETQ ss1 ss1)
) ;_ 结束defun

;;;----------------------------------------------------------------------- 
;;;顾名思义，本LISP文件是对ACAD函数的一些扩充。其中包含多个自行编写的函数 
;;;(命令)，用以解决工作中一些小问题，籍以提高工作效率。 
;;;这些工具，都是作者们在工作一点点地积累而成。也许从程序设计的各项评判指标 
;;;来看，并不是很严谨、优化，肯定有许多的不足之处。但若仅从解决实际问题的角 
;;;度来讲，能够让工作的繁琐得到哪怕是一丁点的减轻，也算是努力没有白费。 
;;;当然，精益求精、尽善尽美是我们不懈追求的目标，这是永远都不会改变的! 
;;;因此，对于个中的不足之处，还请各位前辈不吝指出，小弟先行在此致谢! 
;;;最后，祝您工作愉快! 
;;;我的Email:  [email]IamYourHe@163.com[/email]   我的手机: 13568953509     何俊 
;;;----------------------------------------------------------------------- 
(SETQ *acad-object* nil)                ; Initialize global variable 
(DEFUN acad-object () 
  (COND        (*acad-object*)                        ; Return the cached object 
        (T 
         (SETQ *acad-object* (VLAX-GET-ACAD-OBJECT)) 
        ) 
  ) ;_ 结束cond 
 
) ;_ 结束defun 
 
(SETQ *active-document* nil)                ; Initialize global variable 
(DEFUN active-document () 
  (COND        (*active-document*)                ; Return the cached object 
        (T 
         (SETQ *active-document* (VLA-GET-ACTIVEDOCUMENT (acad-object))) 
        ) 
  ) ;_ 结束cond 
 
) ;_ 结束defun 
 
(SETQ *model-space* nil)                ; Initialize global variable 
(DEFUN model-space () 
  (COND        (*model-space*)                        ; Return the cached object 
        (T 
         (SETQ *model-space* (VLA-GET-MODELSPACE (active-document))) 
        ) 
  ) ;_ 结束cond 
 
 
) ;_ 结束defun 
(VL-LOAD-COM) 
;;;以上代码取自AutoCad2000帮助文件 
;;;-------------------------------------------------------- 
 
;;;-------------------------------------------------------- 
;;;函数： c:FunHelp                        
;;;-------------------------------------------------------- 
;;;编制日期:2006.3.31 
;;;编制者  :何俊 
;;;函数说明:显示本文件内函数（命令）的相关信息 
;;;-------------------------------------------------------- 
(DEFUN c:FunHelp () 
  (PRINT) 
  (TEXTSCR) 
  (PRINC "\n AddFun自定义命令一览") 
  (PRINC "\n----------------------------------") 
  (PRINC "\n  命令             功能") 
  (PRINC "\n----------------------------------") 
  (PRINC "\n Bfill  ........区域植被填充") 
  (PRINC "\n AddVertex......在多段线上添加顶点") 
  (PRINC "\n RemoveVertex...移除多段线上的顶点") 
  (PRINC "\n CC.............多重复制") 
  (PRINC "\n Swp............选择用户指定多边形内的实体") 
  (PRINC "\n                (注意多边形要在当前视口内)") 
  (PRINC "\n Cwp............选择用户指定多边形内以及与多边形相交的实体") 
  (PRINC "\n                (注意多边形要在当前视口内)") 
  (PRINC "\n ES.............选择用户指定多边形外的实体") 
  (PRINC "\n                (注意多边形要在当前视口内)") 
  (PRINC "\n Cs.............用户指定多边形外且不与多边形相交实体") 
  (PRINC "\n                (注意多边形要在当前视口内)") 
  (PRINC "\n----------------------------------") 
  (PRINC "\n 谢谢您的使用!愿您工作愉快!") 
  (PRINC) 
) ;_ 结束defun 
 
;;;------------------------------------------- 
;;;函数名：RemoveVertex        
;;;------------------------------------------- 
;;;来源：    　作者：何俊  　 
;;;编制时间：2006.3.31 
;;;功能  :删除多段线顶点 
;;;语法  :(RemoveVertex) 
;;;参数  : 
;;;返回值:成功....T    失败...nil 
;;;备注  : 
;;;------------------------------------------- 
(DEFUN c:RemoveVertex (/         eName           obj             objNew 
                       plObj         pp           n             Plist 
                       neElev         nuVertex  arry1     #Plist 
                       nuLen         nuID           #temp1    vaPlist 
                       entClose         entLinet  entLines  entLinew 
                       entThick         enttruec  entconwidth 
                      ) 
  (PRINC "\n RevmoveVertex......删除多段线的顶点(2006.3)") 
  (SETQ ss1 (ENTSEL "\n请选择一条多段线:")) 
  (SETQ eName (CAR ss1)) 
  (SETQ p (CAR (CDR (ENTSEL "\n请选择要移除的顶点:")))) 
  (SETQ obj (VLAX-ENAME->VLA-OBJECT eName)) 
  (WHILE p 
    (IF        objNew 
      (SETQ obj objNew) 
    ) ;_ 结束if 
    (IF 
      (WCMATCH 
        (VLA-GET-OBJECTNAME obj) 
        "LWPOLYLINE,AcDbPolyline" 
      ) ;_ 结束wcmatch 
       (PROGN 
         (SETQ pp (VLAX-CURVE-GETCLOSESTPOINTTO obj (TRANS p 1 0))) 
         ;;通过(VLAX-CURVE-GETPARAMATPOINT obj pp)取得的参数的值为小数 
         ;;如0.8579说明用户所点取的P位置在0到1号点之间，且0-P/0-1为0.8579，点位接近1点 
         ;;由此，可能确定用户希望移除的是哪一个顶点。 
         (SETQ n (ATOI (RTOS (VLAX-CURVE-GETPARAMATPOINT obj pp) 2 0))) 
         ;;提出多段线的顶点坐标 
         (SETQ Plist 
                (VLAX-SAFEARRAY->LIST 
                  (VLAX-VARIANT-VALUE 
                    (VLA-GET-COORDINATES obj) 
                  ) ;_ 结束vlax-variant-value 
                ) ;_ 结束vlax-safearray->list 
         ) ;_ 结束setq 
         ;;求算数组上下标,先求出Vertex的数目 
         (SETQ nuVertex (+ (FIX (VLAX-CURVE-GETENDPARAM obj)) 1)) 
         ;;若多段线为闭合的，通过上行语句求出的Vertex数目将会多一个 
         ;;在下面的判断语句中减去 
         (IF (= (VLA-GET-CLOSED obj) :VLAX-TRUE) 
           (SETQ nuVertex (- nuVertex 1)) 
         ) ;_ 结束if 
         ;;计算数组上下标 
         (SETQ array1 (CONS 0 (- (* (- nuVertex 1) 2) 1))) 
         (SETQ #plist (VLAX-MAKE-SAFEARRAY VLAX-VBDOUBLE array1)) 
         ;;计算顶点表内元素个数 
         (SETQ nuLen (LENGTH Plist)) 
         ;;根据n值，将点P的坐标插入到Plist中，先将Plist转为XYZ样式 
         (SETQ nuID 0) 
         (SETQ #templ nil) 
         ;;若点取的为第一个点 
;;;         (if (= n 0) 
;;;           (setq nuID 2 
;;;                 nuLen (- nuLen 2) 
;;;           )) 
;;;         ;;若点取的为最后一个点 
;;;         (if (= n  nuVertex) 
;;;           (setq nuLen (- nuLen 2)) 
;;;           ) 
 
         (REPEAT nuLen 
           (IF (OR (= nuID (* n 2)) (= nuID (+ (* n 2) 1))) 
             (PROGN 
             ) 
             (SETQ #templ (APPEND #templ (LIST (NTH nuID Plist)))) 
 
           ) ;_ 结束if 
 
           (SETQ nuID (+ 1 nuID)) 
         ) ;_ 结束repeat 
         (VLAX-SAFEARRAY-FILL #Plist #temPl) 
         ;;由数组生成变体 
         (SETQ vaPlist (VLAX-MAKE-VARIANT #Plist)) 
         ;;删除旧线，换上新线.要匹配的项目 
         ;;Closed......闭合    Layer.........图层 
         ;;Linetype....线型    LinetypeScale.线型缩放比例 
         ;;Lineweight..线宽    PlotStyleName.打印样式名 
         ;;Thickness...厚度    TrueColor.....颜色 
         (SETQ entClose           (VLA-GET-CLOSED obj) 
               entLayer           (VLA-GET-LAYER obj) 
               entLinet           (VLA-GET-LINETYPE obj) 
               entLines           (VLA-GET-LINETYPESCALE obj) 
               entLinew           (VLA-GET-LINEWEIGHT obj) 
               entThick           (VLA-GET-THICKNESS obj) 
               entTruec           (VLA-GET-TRUECOLOR obj) 
               entEleva           (VLA-GET-ELEVATION obj) 
               entConwidth (VLA-GET-CONSTANTWIDTH obj) ;_全局宽度 
               entLTGen           (VLA-GET-LINETYPEGENERATION obj) ;_线型生成 
 
         ) ;_ 结束setq 
         ;;删除原来的线 
         (SETQ eName (VLAX-VLA-OBJECT->ENAME obj)) 
         (ENTDEL eName) 
         (SETQ objNew (VLA-ADDLIGHTWEIGHTPOLYLINE (model-space) vaPlist)) 
         ;;设置新生成多段线的各property值 
         (VLA-PUT-CLOSED objNew entClose) 
         (VLA-PUT-LAYER objNew entLayer) 
         (VLA-PUT-LINETYPE objNew entLinet) 
         (VLA-PUT-LINETYPESCALE objNew entLines) 
         (VLA-PUT-LINEWEIGHT objNew entLinew) 
         (VLA-PUT-THICKNESS objNew entThick) 
         (VLA-PUT-TRUECOLOR objNew entTruec) 
         (VLA-PUT-ELEVATION objNew entEleva) 
         (VLA-PUT-CONSTANTWIDTH objNew entConwidth) 
         (VLA-PUT-LINETYPEGENERATION objNew entLTGen) 
         ;;赋值完成，更新对象 
         (VLA-UPDATE objNew) 
         (SETQ retuValue T) 
       ) ;_ 结束progn 
       (PROGN (PRINT "您选择的不是多段线!") 
              (SETQ retuValue nil) 
       ) ;_ 结束progn 
    ) ;_ 结束IF 
 
    (PRINT) 
    (SETQ p (CAR (CDR (ENTSEL "\n请选择要移除的顶点:")))) 
  ) ;_ 结束while 
  (PRINC "\n 本条多段线现有：") 
  (PRINC (- (/ nuLen 2) 1)) 
  (PRINC "个顶点......谢谢使用!") 
  (PRINC) 
) ;_ 结束defun 
 
 
 
;;;-------------------------------------------------------- 
;;;函数： getPlList                                
;;;-------------------------------------------------------- 
;;;说明：本函数提取多段线的各端点坐标值构成一张表并返回 
;;;                
;;;                
;;;编制者:高老师                
;;;-------------------------------------------------------- 
 
(DEFUN getPlList (#entity / OBJ LW_T8 OBJ_1) 
  (SETQ obj (ENTGET #entity)) 
  (SETQ lw_t8 (CDR (ASSOC 8 obj))) 
  (SETQ obj_1 nil) 
  (WHILE (/= (ASSOC 10 obj) nil) 
    (IF        (AND (= (CAAR obj) 10) 
             (NOT (EQUAL (CDAR obj) (LAST obj_1) 0.001)) 
        ) ;_ 结束and 
      (SETQ obj_1 (APPEND obj_1 (LIST (CDAR obj)))) 
    )                                        ;生成坐标表同时去掉相邻重点,不带10 
    (SETQ obj (CDR obj)) 
  ) ;_ 结束while 
  (SETQ obj obj_1) 
  (IF (EQUAL (CAR obj) (LAST obj) 0.001) 
    (SETQ obj (REVERSE (CDR (REVERSE obj)))) 
  ) ;_ 结束if 
  ;;判断首闭 
  (SETQ #temp obj) 
) ;_ 结束defun 
;;end defun 
 
 
 
;;;-------------------------------------------------------- 
;;;函数： c:CC                        
;;;-------------------------------------------------------- 
;;;编制日期:2006.4.1 
;;;编制者  :何俊 
;;;函数说明:本函数用以模拟ACAD2006中的复制命令，其实就是默认为多重复制 
;;;-------------------------------------------------------- 
(DEFUN c:cc () 
  (PRINC "选择对象:") 
  (SETQ ss1 (SSGET)) 
  (COMMAND "copy") 
  (COMMAND ss1) 
  (COMMAND "") 
  (COMMAND "M") 
) ;_ 结束defun 
 
;;;-------------------------------------------------------- 
;;;函数： c:SW 
;;;-------------------------------------------------------- 
;;;编制日期:2006.4.1 
;;;编制者  :何俊 
;;;函数说明:本函数选择用户指定多边形内的实体(注意多边形要在当前视口内)。 
;;;-------------------------------------------------------- 
(DEFUN c:sw (/ ENAME #MYLIST SS1) 
  (princ "\n 选择用户指定多边形内的实体(注意多边形要在当前视口内)。") 
  (SETQ ename (CAR (ENTSEL "\n请选择一个多边形:"))) 
  (SETQ #mylist (getpllist ename)) 
  (SETQ ss1 (SSGET "_WP" #mylist)) 
  (SSSETFIRST NIL ss1) 
  (SETQ ss1 ss1) 
) ;_ 结束defun 
;;;-------------------------------------------------------- 
;;;函数： c:CW 
;;;-------------------------------------------------------- 
;;;编制日期:2006.4.1 
;;;编制者  :何俊 
;;;函数说明:本函数选择用户指定多边形内以及与多边形相交的实体 
;;;         (注意多边形要在当前视口内)。 
;;;-------------------------------------------------------- 
(DEFUN c:cw (/ ENAME #MYLIST SS1) 
  (princ "\n 选择用户指定多边形内以及与多边形相交的实体(注意多边形要在当前视口内)") 
  (SETQ ename (CAR (ENTSEL "\n请选择一个多边形:"))) 
  (SETQ #mylist (getpllist ename)) 
  (SETQ ss1 (SSGET "_CP" #mylist)) 
  (SSSETFIRST NIL ss1) 
  (SETQ ss1 ss1) 
) ;_ 结束defun 
 
 
;;;-------------------------------------------------------- 
;;;函数： c:es 
;;;-------------------------------------------------------- 
;;;编制日期:2006.4. 
;;;编制者  :何俊 
;;;函数说明:本函数选择用户指定多边形外的实体(注意多边形要在当前视口内)。 
;;;-------------------------------------------------------- 
 
(DEFUN c:es (/ ename #mylist ss1) 
  (princ "\n 选择用户指定多边形外的实体(注意多边形要在当前视口内)。") 
  (SETQ ename (CAR (ENTSEL "\n请选择一个多边形:"))) 
  (SETQ #mylist (getpllist ename)) 
  (SETQ ss1 (SSGET "_WP" #mylist)) 
  (COMMAND "select" "all" "r") 
  (COMMAND ss1) 
  (COMMAND "") 
  (SETQ ss1 (SSGET "_p")) 
  (SSSETFIRST NIL ss1) 
  (SETQ ss1 ss1) 
 
) ;_ 结束defun 
;;;-------------------------------------------------------- 
;;;函数： c:Cs 
;;;-------------------------------------------------------- 
;;;编制日期:2006.4. 
;;;编制者  :何俊 
;;;函数说明:本函数选择用户指定多边形外且不与多边形相交实体 
;;;         (注意多边形要在当前视口内)。 
;;;-------------------------------------------------------- 
 
(DEFUN c:Cs (/ ename #mylist ss1) 
  (princ "\n 选择用户指定多边形外且不与多边形相交实体(注意多边形要在当前视口内)") 
  (SETQ ename (CAR (ENTSEL "\n请选择一个多边形:"))) 
  (SETQ #mylist (getpllist ename)) 
  (SETQ ss1 (SSGET "_cP" #mylist)) 
  (COMMAND "select" "all" "r") 
  (COMMAND ss1) 
  (COMMAND "") 
  (SETQ ss1 (SSGET "_p")) 
  (SSSETFIRST NIL ss1) 
  (SETQ ss1 ss1) 
 
) ;_ 结束defun

应朋友的要求编了一个去除完全平直的多段线中间的顶点的程序,也许有朋友也能够用到
;;;--------------------------------------------------------
;;;函数： C:frank
;;;--------------------------------------------------------
;;;来源： 　作者: 何俊
;;;编制时间：2006.4.
;;;功能: 移除多段线上完全平直的段上的顶点
;;;语法: frank
;;;参数
;;;返回值: 成功T nil
;;;备注 : 本程序调用了上面移除顶点程序中的一些子程序,因此需要先加载上面的子程序
;;; 这个程序才能使用
;;;--------------------------------------------------------
(DEFUN c:frank (/ name #pl1 #pl2 %ver
%id p1 p2 p3 ang1
ang2 array1 #plist vaPlist obj
objnew entClose entLayer entLinet entLines
entLinew entThick entTruec entEleva entConwidth
entLTGen $a
 )
 (SETQ name (CAR (ENTSEL "\n<请选择多段线>:")))
 ;;要增加判断是否是多段线的语句
 (IF (= (CDR (ASSOC 0 (ENTGET name))) "LWPOLYLINE")
(PROGN
 ;;调用子程序取出多段线所有顶点的坐标集合
 (SETQ #pl1 (getplList name))
 ;;求出顶点个数%ver，确定循环次数%ver-2,移除的原则：
 ;;求每个点和上一个点构成的角度以及和下一个点构成的角度，若相等则说明是完全平直的
 ;;将中间点滤去。以此类推。
 (SETQ %ver (LENGTH #PL1))
 (SETQ %id 1)
 (SETQ #pl2 nil)
 ;;加入多段线第一点的坐标,无论多段线中间有多少完全平直的点,首尾点是始终要的
 (SETQ #pl2 (APPEND #pl2 (NTH 0 #pl1)))
 (REPEAT (- %ver 2)
;;依次提取三个点，计算第一点到第二点的角度ANG1，与第二点到第三点角度ANG2进行比较，若相等
;;则说明三点共线，滤去p2点
(SETQ p1 (NTH (- %id 1) #pl1))
(SETQ p2 (NTH %id #pl1))
(SETQ p3 (NTH (+ %id 1) #pl1))
(SETQ ang1 (ANGLE p1 p2))
(SETQ ang2 (ANGLE p2 p3))
;;为什么要用EQUAL而不用“=”呢，因当用PE命令在直线上加点后，再用“=”比较p1->p2与p2->p3的角度
;;所得结果为NIL，即不相等，因此用EQUAL且将最大允许误差定为小数点后7位，这个值可以根据实际需要
;;进行修改
(IF (NOT (EQUAL ang1 ang2 0.0000001))
 (SETQ #pl2 (APPEND #pl2 (NTH %id #pl1)))
) ;_ 结束if
(SETQ %id (+ 1 %id))
 ) ;_ 结束repeat
 ;;加入最后一个点
 (SETQ #pl2 (APPEND #pl2 (NTH (- %ver 1) #pl1)))

;;; (SETQ %id 0)
;;; (SETQ #pl3 nil)
;;; (REPEAT (LENGTH #pl2)
;;; (SETQ #pl3 (APPEND #pl3 (CAR (NTH %id #pl2))))
;;; (SETQ #pl3 (APPEND #pl3 (CADR (NTH %id #pl2))))
;;; (setq %id (+ %id 1))
;;; ) ;_ 结束repeat
 ;;以下涉及VLISP的内容
 ;;计算数组上下标
 (SETQ array1 (CONS 0 (- (LENGTH #pl2) 1)))
 (SETQ #plist (VLAX-MAKE-SAFEARRAY VLAX-VBDOUBLE array1))
 (VLAX-SAFEARRAY-FILL #Plist #pl2)
 ;;由数组生成变体
 (SETQ vaPlist (VLAX-MAKE-VARIANT #Plist))

 (SETQ obj (VLAX-ENAME->VLA-OBJECT Name))

 ;;删除旧线，换上新线.要匹配的项目有
 ;;Closed......闭合 Layer.........图层
 ;;Linetype....线型 LinetypeScale.线型缩放比例
 ;;Lineweight..线宽 PlotStyleName.打印样式名
 ;;Thickness...厚度 TrueColor.....颜色
 (SETQ entClose (VLA-GET-CLOSED obj)
 entLayer (VLA-GET-LAYER obj)
 entLinet (VLA-GET-LINETYPE obj)
 entLines (VLA-GET-LINETYPESCALE obj)
 entLinew (VLA-GET-LINEWEIGHT obj)
 entThick (VLA-GET-THICKNESS obj)
 entTruec (VLA-GET-TRUECOLOR obj)
 entEleva (VLA-GET-ELEVATION obj)
 entConwidth (VLA-GET-CONSTANTWIDTH obj) ;_全局宽度
 entLTGen (VLA-GET-LINETYPEGENERATION obj) ;_线型生成
 ) ;_ 结束setq
 (ENTDEL Name)
 (SETQ objNew (VLA-ADDLIGHTWEIGHTPOLYLINE (model-space) vaPlist))
 ;;设置新生成多段线的各property值
 (VLA-PUT-CLOSED objNew entClose)
 (VLA-PUT-LAYER objNew entLayer)
 (VLA-PUT-LINETYPE objNew entLinet)
 (VLA-PUT-LINETYPESCALE objNew entLines)
 (VLA-PUT-LINEWEIGHT objNew entLinew)
 (VLA-PUT-THICKNESS objNew entThick)
 (VLA-PUT-TRUECOLOR objNew entTruec)
 (VLA-PUT-ELEVATION objNew entEleva)
 (VLA-PUT-CONSTANTWIDTH objNew entConwidth)
 (VLA-PUT-LINETYPEGENERATION objNew entLTGen)
 ;;赋值完成，更新对象
 (VLA-UPDATE objNew)
 (SETQ $a (STRCAT "\n ...处理完成! 处理前点数: "
 (ITOA %ver)
 " 处理后点数: "
 (ITOA (/ (LENGTH #pl2) 2))
 " !"
 ) ;_ 结束STRCAT
 ) ;_ 结束setq
 (PRINC $a)
 (SETQ retuValue T)
) ;_ 结束progn
(PROGN
 (PRINC "\n 选择的不是多段线!")
 (SETQ retuValue nil)
) ;_ 结束progn

 ) ;_ 结束if
 (PRINC)
) ;_ 结束defun

;;;--------------------------------------------------------
;;;函数： getPlList
;;;--------------------------------------------------------
;;;说明：本函数提取多段线的各端点坐标值构成一张表并返回
;;;
;;;
;;;编制者:高老师
;;;--------------------------------------------------------

(DEFUN getPlList (#entity)
 (SETQ obj (ENTGET #entity))
 (SETQ lw_t8 (CDR (ASSOC 8 obj)))
 (SETQ obj_1 nil)
 (WHILE (/= (ASSOC 10 obj) nil)
(IF (AND (= (CAAR obj) 10)
 (NOT (EQUAL (CDAR obj) (LAST obj_1) 0.001))
) ;_ 结束AND
 (SETQ obj_1 (APPEND obj_1 (LIST (CDAR obj))))
) ;生成坐标表同时去掉相邻重点,不带10
(SETQ obj (CDR obj))
 ) ;_ 结束WHILE
 (SETQ obj obj_1)
 (IF (EQUAL (CAR obj) (LAST obj) 0.001)
(SETQ obj (REVERSE (CDR (REVERSE obj))))
 ) ;_ 结束IF
 ;;判断首闭
 (SETQ #temp obj)
) ;_ 结束DEFUN
;;end defun

hisum · 发表于 2006-4-7 11:45:53

编程习惯很好，顶一下

caddog · 发表于 2006-4-8 19:39:04

谢谢

loe0927 · 发表于 2006-4-10 00:43:42

那个减少PL线点的程序如果能改成不用选择PL线直接用框选减点就更好了因为有时候要一起减少好几个点呢而且框选我感觉也能更方便些只是我个人意见不过很佩服楼主了我只懂得一点这方面的东西真的好希望能跟你好好学习一下

usercoolboy · 发表于 2006-4-13 10:10:36

楼主做得很不错，我在学LISP，VLISP还有些不懂

caddog · 发表于 2006-4-30 19:04:15

谢谢各位的支持
因为我没有足够多的时间上网,所以不能及时地表示我的谢意哈
窗选的建议,想了一下,是可以实现的.等我回去编过!
应朋友的要求编了一个去除完全平直的多段线中间的顶点的程序,也许有朋友也能够用到
;;;--------------------------------------------------------
;;;函数： C:frank
;;;--------------------------------------------------------
;;;来源： 　作者: 何俊
;;;编制时间：2006.4.
;;;功能: 移除多段线上完全平直的段上的顶点
;;;语法: frank
;;;参数
;;;返回值: 成功T nil
;;;备注 : 本程序调用了上面移除顶点程序中的一些子程序,因此需要先加载上面的子程序
;;; 这个程序才能使用
;;;--------------------------------------------------------
(DEFUN c:frank (/ name #pl1 #pl2 %ver
%id p1 p2 p3 ang1
ang2 array1 #plist vaPlist obj
objnew entClose entLayer entLinet entLines
entLinew entThick entTruec entEleva entConwidth
entLTGen $a
 )
 (SETQ name (CAR (ENTSEL "\n<请选择多段线>:")))
 ;;要增加判断是否是多段线的语句
 (IF (= (CDR (ASSOC 0 (ENTGET name))) "LWPOLYLINE")
(PROGN
 ;;调用子程序取出多段线所有顶点的坐标集合
 (SETQ #pl1 (getplList name))
 ;;求出顶点个数%ver，确定循环次数%ver-2,移除的原则：
 ;;求每个点和上一个点构成的角度以及和下一个点构成的角度，若相等则说明是完全平直的
 ;;将中间点滤去。以此类推。
 (SETQ %ver (LENGTH #PL1))
 (SETQ %id 1)
 (SETQ #pl2 nil)
 ;;加入多段线第一点的坐标,无论多段线中间有多少完全平直的点,首尾点是始终要的
 (SETQ #pl2 (APPEND #pl2 (NTH 0 #pl1)))
 (REPEAT (- %ver 2)
;;依次提取三个点，计算第一点到第二点的角度ANG1，与第二点到第三点角度ANG2进行比较，若相等
;;则说明三点共线，滤去p2点
(SETQ p1 (NTH (- %id 1) #pl1))
(SETQ p2 (NTH %id #pl1))
(SETQ p3 (NTH (+ %id 1) #pl1))
(SETQ ang1 (ANGLE p1 p2))
(SETQ ang2 (ANGLE p2 p3))
;;为什么要用EQUAL而不用“=”呢，因当用PE命令在直线上加点后，再用“=”比较p1->p2与p2->p3的角度
;;所得结果为NIL，即不相等，因此用EQUAL且将最大允许误差定为小数点后7位，这个值可以根据实际需要
;;进行修改
(IF (NOT (EQUAL ang1 ang2 0.0000001))
 (SETQ #pl2 (APPEND #pl2 (NTH %id #pl1)))
) ;_ 结束if
(SETQ %id (+ 1 %id))
 ) ;_ 结束repeat
 ;;加入最后一个点
 (SETQ #pl2 (APPEND #pl2 (NTH (- %ver 1) #pl1)))

;;; (SETQ %id 0)
;;; (SETQ #pl3 nil)
;;; (REPEAT (LENGTH #pl2)
;;; (SETQ #pl3 (APPEND #pl3 (CAR (NTH %id #pl2))))
;;; (SETQ #pl3 (APPEND #pl3 (CADR (NTH %id #pl2))))
;;; (setq %id (+ %id 1))
;;; ) ;_ 结束repeat
 ;;以下涉及VLISP的内容
 ;;计算数组上下标
 (SETQ array1 (CONS 0 (- (LENGTH #pl2) 1)))
 (SETQ #plist (VLAX-MAKE-SAFEARRAY VLAX-VBDOUBLE array1))
 (VLAX-SAFEARRAY-FILL #Plist #pl2)
 ;;由数组生成变体
 (SETQ vaPlist (VLAX-MAKE-VARIANT #Plist))

 (SETQ obj (VLAX-ENAME->VLA-OBJECT Name))

 ;;删除旧线，换上新线.要匹配的项目有
 ;;Closed......闭合 Layer.........图层
 ;;Linetype....线型 LinetypeScale.线型缩放比例
 ;;Lineweight..线宽 PlotStyleName.打印样式名
 ;;Thickness...厚度 TrueColor.....颜色
 (SETQ entClose (VLA-GET-CLOSED obj)
 entLayer (VLA-GET-LAYER obj)
 entLinet (VLA-GET-LINETYPE obj)
 entLines (VLA-GET-LINETYPESCALE obj)
 entLinew (VLA-GET-LINEWEIGHT obj)
 entThick (VLA-GET-THICKNESS obj)
 entTruec (VLA-GET-TRUECOLOR obj)
 entEleva (VLA-GET-ELEVATION obj)
 entConwidth (VLA-GET-CONSTANTWIDTH obj) ;_全局宽度
 entLTGen (VLA-GET-LINETYPEGENERATION obj) ;_线型生成
 ) ;_ 结束setq
 (ENTDEL Name)
 (SETQ objNew (VLA-ADDLIGHTWEIGHTPOLYLINE (model-space) vaPlist))
 ;;设置新生成多段线的各property值
 (VLA-PUT-CLOSED objNew entClose)
 (VLA-PUT-LAYER objNew entLayer)
 (VLA-PUT-LINETYPE objNew entLinet)
 (VLA-PUT-LINETYPESCALE objNew entLines)
 (VLA-PUT-LINEWEIGHT objNew entLinew)
 (VLA-PUT-THICKNESS objNew entThick)
 (VLA-PUT-TRUECOLOR objNew entTruec)
 (VLA-PUT-ELEVATION objNew entEleva)
 (VLA-PUT-CONSTANTWIDTH objNew entConwidth)
 (VLA-PUT-LINETYPEGENERATION objNew entLTGen)
 ;;赋值完成，更新对象
 (VLA-UPDATE objNew)
 (SETQ $a (STRCAT "\n ...处理完成! 处理前点数: "
 (ITOA %ver)
 " 处理后点数: "
 (ITOA (/ (LENGTH #pl2) 2))
 " !"
 ) ;_ 结束STRCAT
 ) ;_ 结束setq
 (PRINC $a)
 (SETQ retuValue T)
) ;_ 结束progn
(PROGN
 (PRINC "\n 选择的不是多段线!")
 (SETQ retuValue nil)
) ;_ 结束progn

 ) ;_ 结束if
 (PRINC)
) ;_ 结束defun

;;;--------------------------------------------------------
;;;函数： getPlList
;;;--------------------------------------------------------
;;;说明：本函数提取多段线的各端点坐标值构成一张表并返回
;;;
;;;
;;;编制者:高老师
;;;--------------------------------------------------------

(DEFUN getPlList (#entity)
 (SETQ obj (ENTGET #entity))
 (SETQ lw_t8 (CDR (ASSOC 8 obj)))
 (SETQ obj_1 nil)
 (WHILE (/= (ASSOC 10 obj) nil)
(IF (AND (= (CAAR obj) 10)
 (NOT (EQUAL (CDAR obj) (LAST obj_1) 0.001))
) ;_ 结束AND
 (SETQ obj_1 (APPEND obj_1 (LIST (CDAR obj))))
) ;生成坐标表同时去掉相邻重点,不带10
(SETQ obj (CDR obj))
 ) ;_ 结束WHILE
 (SETQ obj obj_1)
 (IF (EQUAL (CAR obj) (LAST obj) 0.001)
(SETQ obj (REVERSE (CDR (REVERSE obj))))
 ) ;_ 结束IF
 ;;判断首闭
 (SETQ #temp obj)
) ;_ 结束DEFUN
;;end defun

NET-JOB · 发表于 2006-7-2 15:02:57

为什么添加顶点不见了

caddog · 发表于 2006-7-2 18:30:12

这个函数有很多缺陷：比如当多段线各段的宽度不一样时，加点的话宽度会改变.....因一直以来工作都很忙，没有时间去完善，还请楼主谅解啦

[FONT=courier new]
;;;-------------------------------------------
;;;函数名：AddVertex
;;;-------------------------------------------
;;;来源：　作(译)者：　
;;;编制时间：2006.3.29-30
;;;功能 :添加/删除多段线顶点
;;;语法 :(AddVertex ename p)
;;;参数 :ename...图元名 p...点
;;;返回值:成功....T 失败...nil
;;;备注 :还应添加将老式多段线转换为轻便多段线的功能
;;; 还未加入删除点的功能还是另写一个吧
;;;-------------------------------------------
(DEFUN c:addvertex (/ ename obj objNew plobj
pp n plist nuelev nuVertex
array1 #plist nulen nux nuid
#templ vaplist entclose entlinet entlines
entlinew entthick enttruec entconwidth
)
(princ "\n AddVertex......在多段线上加点(2006.3)")
(SETQ ss1 (ENTSEL "\n请选择一条多段线:"))
(SETQ eName (CAR ss1))
(SETQ p (GETPOINT "请选择插入点:"))
(SETQ obj (VLAX-ENAME->VLA-OBJECT eName))
(WHILE p
(IF objNew
(SETQ obj objNew)
) ;_ 结束if
(IF
(WCMATCH
(VLA-GET-OBJECTNAME obj)
"LWPOLYLINE,AcDbPolyline"
) ;_ 结束wcmatch
(PROGN
(SETQ pp (VLAX-CURVE-GETCLOSESTPOINTTO obj (TRANS p 1 0)))
;;取FIX后，n的值始终是该多段线前进方向的前一个点，
;;加1后，表示点P成为继该点后的下一个点即n+1个顶点
(SETQ n (+ (FIX (VLAX-CURVE-GETPARAMATPOINT obj pp)) 1))
(SETQ Plist
(VLAX-SAFEARRAY->LIST
(VLAX-VARIANT-VALUE
(VLA-GET-COORDINATES obj)
) ;_ 结束vlax-variant-value
) ;_ 结束vlax-safearray->list
) ;_ 结束setq
;;求算数组上下标,先求出Vertex的数目
(SETQ nuVertex (+ (FIX (VLAX-CURVE-GETENDPARAM obj)) 1))
;;若多段线为闭合的，通过上行语句求出的Vertex数目将会多一个
;;在下面的判断语句中减去
(if (= (vla-get-Closed obj) :vlax-true)
(setq nuVertex (- nuVertex 1))
)
;;计算数组上下标,因轻便多段线只需XY故改为
(SETQ array1 (CONS 0 (- (* (+ nuVertex 1) 2) 1)))
(SETQ #plist (VLAX-MAKE-SAFEARRAY VLAX-VBDOUBLE array1))
;;计算顶点表内元素个数(主要是担心会不会出现Z值未被忽略的情况)
(SETQ nuLen (LENGTH Plist))
;;(SETQ nux (/ nulen nuVertex))
;;根据n值，将点P的坐标插入到Plist中，先将Plist转为XYZ样式
(SETQ nuID 0)
(SETQ #templ nil)
;;因为是轻便多段线只要XY所以只需简单地加入P点坐标即可
;;当用户点取了超过了最后一点时(不是在最后一点和次点之间)
;;点P的坐标不能通过下面的REPEAT语句加入到LIST中去，
;;因此，在REPEAT之后单独再写一个语句。
(REPEAT nuLen
(IF (= nuID (* n 2))
(SETQ #templ (APPEND #templ (LIST (CAR p) (CADR p))))
) ;_ 结束if
(SETQ #templ (APPEND #templ (LIST (NTH nuID Plist))))
(SETQ nuID (+ 1 nuID))
) ;_ 结束repeat
(IF (= nuLen (* n 2))
(SETQ #templ (APPEND #templ (LIST (CAR p) (CADR p))))
) ;_ 结束if
(VLAX-SAFEARRAY-FILL #Plist #temPl)
;;由数组生成变体
(SETQ vaPlist (VLAX-MAKE-VARIANT #Plist))
;;删除旧线，换上新线.要匹配的项目有
;;Closed......闭合 Layer.........图层
;;Linetype....线型 LinetypeScale.线型缩放比例
;;Lineweight..线宽 PlotStyleName.打印样式名
;;Thickness...厚度 TrueColor.....颜色
(SETQ entClose (VLA-GET-CLOSED obj)
entLayer (VLA-GET-LAYER obj)
entLinet (VLA-GET-LINETYPE obj)
entLines (VLA-GET-LINETYPESCALE obj)
entLinew (VLA-GET-LINEWEIGHT obj)
entThick (VLA-GET-THICKNESS obj)
entTruec (VLA-GET-TRUECOLOR obj)
entEleva (VLA-GET-ELEVATION obj)
entConwidth (VLA-GET-CONSTANTWIDTH obj) ;_全局宽度
entLTGen (VLA-GET-LINETYPEGENERATION obj) ;_线型生成
) ;_ 结束setq
;;删除原来的线
(SETQ eName (VLAX-VLA-OBJECT->ENAME obj))
(ENTDEL eName)
(SETQ objNew (VLA-ADDLIGHTWEIGHTPOLYLINE (model-space) vaPlist))
;;设置新生成多段线的各property值
(VLA-PUT-CLOSED objNew entClose)
(VLA-PUT-LAYER objNew entLayer)
(VLA-PUT-LINETYPE objNew entLinet)
(VLA-PUT-LINETYPESCALE objNew entLines)
(VLA-PUT-LINEWEIGHT objNew entLinew)
(VLA-PUT-THICKNESS objNew entThick)
(VLA-PUT-TRUECOLOR objNew entTruec)
(VLA-PUT-ELEVATION objNew entEleva)
(VLA-PUT-CONSTANTWIDTH objNew entConwidth)
(VLA-PUT-LINETYPEGENERATION objNew entLTGen)
;;赋值完成，更新对象
(VLA-UPDATE objNew)
(SETQ retuValue T)
) ;_ 结束progn
(PRINT "您选择的不是多段线!")
) ;_ 结束if
(PRINT)
(SETQ p (GETPOINT "请选择插入点:"))
) ;_ 结束while
(princ "\n 本条多段线现有：")
(princ (+ (/ nuLen 2) 1))
(princ "个顶点......谢谢使用!")
(PRINC)
) ;_ 结束defun
[/FONT]

[FONT=courier new] 
;;;------------------------------------------- 
;;;函数名：AddVertex        
;;;------------------------------------------- 
;;;来源：    　作(译)者：  　 
;;;编制时间：2006.3.29-30 
;;;功能  :添加/删除多段线顶点 
;;;语法  :(AddVertex ename p) 
;;;参数  :ename...图元名  p...点 
;;;返回值:成功....T    失败...nil 
;;;备注  :还应添加将老式多段线转换为轻便多段线的功能 
;;;       还未加入删除点的功能还是另写一个吧 
;;;------------------------------------------- 
(DEFUN c:addvertex (/              ename        obj          objNew    plobj 
                    pp              n                plist          nuelev    nuVertex 
                    array1    #plist        nulen          nux            nuid 
                    #templ    vaplist        entclose  entlinet  entlines 
                    entlinew  entthick        enttruec  entconwidth 
                   ) 
  (princ "\n AddVertex......在多段线上加点(2006.3)") 
  (SETQ ss1 (ENTSEL "\n请选择一条多段线:")) 
  (SETQ eName (CAR ss1)) 
  (SETQ p (GETPOINT "请选择插入点:")) 
  (SETQ obj (VLAX-ENAME->VLA-OBJECT eName)) 
  (WHILE p 
    (IF        objNew 
      (SETQ obj objNew) 
    ) ;_ 结束if 
    (IF 
      (WCMATCH 
        (VLA-GET-OBJECTNAME obj) 
        "LWPOLYLINE,AcDbPolyline" 
      ) ;_ 结束wcmatch 
       (PROGN 
         (SETQ pp (VLAX-CURVE-GETCLOSESTPOINTTO obj (TRANS p 1 0))) 
         ;;取FIX后，n的值始终是该多段线前进方向的前一个点， 
         ;;加1后，表示点P成为继该点后的下一个点即n+1个顶点 
         (SETQ n (+ (FIX (VLAX-CURVE-GETPARAMATPOINT obj pp)) 1)) 
         (SETQ Plist 
                (VLAX-SAFEARRAY->LIST 
                  (VLAX-VARIANT-VALUE 
                    (VLA-GET-COORDINATES obj) 
                  ) ;_ 结束vlax-variant-value 
                ) ;_ 结束vlax-safearray->list 
         ) ;_ 结束setq 
         ;;求算数组上下标,先求出Vertex的数目 
         (SETQ nuVertex (+ (FIX (VLAX-CURVE-GETENDPARAM obj)) 1)) 
         ;;若多段线为闭合的，通过上行语句求出的Vertex数目将会多一个 
         ;;在下面的判断语句中减去 
         (if (= (vla-get-Closed obj) :vlax-true) 
           (setq nuVertex (- nuVertex 1)) 
           ) 
         ;;计算数组上下标,因轻便多段线只需XY故改为 
         (SETQ array1 (CONS 0 (- (* (+ nuVertex 1) 2) 1))) 
         (SETQ #plist (VLAX-MAKE-SAFEARRAY VLAX-VBDOUBLE array1)) 
         ;;计算顶点表内元素个数(主要是担心会不会出现Z值未被忽略的情况) 
         (SETQ nuLen (LENGTH Plist)) 
         ;;(SETQ nux (/ nulen nuVertex)) 
         ;;根据n值，将点P的坐标插入到Plist中，先将Plist转为XYZ样式 
         (SETQ nuID 0) 
         (SETQ #templ nil) 
         ;;因为是轻便多段线只要XY所以只需简单地加入P点坐标即可 
         ;;当用户点取了超过了最后一点时(不是在最后一点和次点之间) 
         ;;点P的坐标不能通过下面的REPEAT语句加入到LIST中去， 
         ;;因此，在REPEAT之后单独再写一个语句。 
         (REPEAT nuLen 
           (IF (= nuID (* n 2)) 
             (SETQ #templ (APPEND #templ (LIST (CAR p) (CADR p)))) 
           ) ;_ 结束if 
           (SETQ #templ (APPEND #templ (LIST (NTH nuID Plist)))) 
           (SETQ nuID (+ 1 nuID)) 
         ) ;_ 结束repeat 
         (IF (= nuLen (* n 2)) 
           (SETQ #templ (APPEND #templ (LIST (CAR p) (CADR p)))) 
         ) ;_ 结束if 
         (VLAX-SAFEARRAY-FILL #Plist #temPl) 
         ;;由数组生成变体 
         (SETQ vaPlist (VLAX-MAKE-VARIANT #Plist)) 
         ;;删除旧线，换上新线.要匹配的项目有 
         ;;Closed......闭合    Layer.........图层 
         ;;Linetype....线型    LinetypeScale.线型缩放比例 
         ;;Lineweight..线宽    PlotStyleName.打印样式名 
         ;;Thickness...厚度    TrueColor.....颜色 
         (SETQ entClose           (VLA-GET-CLOSED obj) 
               entLayer           (VLA-GET-LAYER obj) 
               entLinet           (VLA-GET-LINETYPE obj) 
               entLines           (VLA-GET-LINETYPESCALE obj) 
               entLinew           (VLA-GET-LINEWEIGHT obj) 
               entThick           (VLA-GET-THICKNESS obj) 
               entTruec           (VLA-GET-TRUECOLOR obj) 
               entEleva           (VLA-GET-ELEVATION obj) 
               entConwidth (VLA-GET-CONSTANTWIDTH obj) ;_全局宽度 
               entLTGen           (VLA-GET-LINETYPEGENERATION obj) ;_线型生成 
 
         ) ;_ 结束setq 
         ;;删除原来的线 
         (SETQ eName (VLAX-VLA-OBJECT->ENAME obj)) 
         (ENTDEL eName) 
         (SETQ objNew (VLA-ADDLIGHTWEIGHTPOLYLINE (model-space) vaPlist)) 
         ;;设置新生成多段线的各property值 
         (VLA-PUT-CLOSED objNew entClose) 
         (VLA-PUT-LAYER objNew entLayer) 
         (VLA-PUT-LINETYPE objNew entLinet) 
         (VLA-PUT-LINETYPESCALE objNew entLines) 
         (VLA-PUT-LINEWEIGHT objNew entLinew) 
         (VLA-PUT-THICKNESS objNew entThick) 
         (VLA-PUT-TRUECOLOR objNew entTruec) 
         (VLA-PUT-ELEVATION objNew entEleva) 
         (VLA-PUT-CONSTANTWIDTH objNew entConwidth) 
         (VLA-PUT-LINETYPEGENERATION objNew entLTGen) 
         ;;赋值完成，更新对象 
         (VLA-UPDATE objNew) 
         (SETQ retuValue T) 
       ) ;_ 结束progn 
       (PRINT "您选择的不是多段线!") 
 
    ) ;_ 结束if 
    (PRINT) 
    (SETQ p (GETPOINT "请选择插入点:")) 
  ) ;_ 结束while 
  (princ "\n 本条多段线现有：") 
  (princ (+ (/ nuLen 2) 1)) 
  (princ "个顶点......谢谢使用!") 
  (PRINC) 
) ;_ 结束defun 
  [/FONT]

GTJ116600 · 发表于 2013-6-14 09:43:20

呵呵，多段线删除顶点程序，正需要研究呢

GTJ116600 · 发表于 2013-7-5 14:07:41

何俊的删除和添加多段线顶点程序:lol

杜流浪人 · 发表于 2016-5-30 20:01:12

好程序必须支持了

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

[LISP程序]：添加和移除多段线顶点的小程序

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

相关帖子

浏览过的版块