dxpmx1.lsp

在CAD电子地图中根据路径多段线剖 纵断面图。

		(progn
		  (set_tile "error" "请输入高程调整值! 如不需调整,请输入0")
		  (setq data (nth 7 tb))
		)
	      )
	    )
          )
	)
	
	(if (= "" (nth 5 data)) ;文件名为空时,错误处理
	  (progn
	    (set_tile "error" "请打开一个剖面数据文件!")
	    (setq data (nth 5 tb))
	  )
	)
	
      )
    )
  );测试数据是否输入完，如未输入完，返回最前一个未输入数据的控件关键字,否则返回数据表
  (setq data data)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;pmxs-剖面线选择;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun pmxs (data	/	   m_pqx      m_vlaobj	 m_vlaobjcopy
	     m_ent	m_vlaobjcopy1	      m_wlbpt	 m_wrupt
	     m_ss	m_enttmp   m_startpt  m_endpt	 m_endpt1
	     i		j	   m_entlen   m_jd	 m_jdtab
	     m_jdtab1	gctz	   dgj
	    )
  ;;(check_cs)

  (command "ucs" "w")                           ;;当前ucs为世界坐标系
  (setq m_pqx (entsel "\n请选择一条剖切线:"))   ;;entsel-select a single object (entity)
  (if (not m_pqx) (princ "未选择！"))
  (setq m_pqx (car m_pqx)) ;;所选剖切线图元表的第一字段ename检索标志(指针)
  (princ (cdr (assoc 0 (entget m_pqx))))  ;;(entget ename [applist])获得对象定义表
                                          ;;assoc 0关联图元对象定义表的第一个表;;
                                          ;;cdr获取该表除第一元素以外的表 

  (setq m_vlaobj (vlax-ename->vla-object m_pqx))  ;;Transforms entity to VLA-object 
  (vla-getboundingbox m_vlaobj 'm_wlbpt 'm_wrupt) ;;自定义边界函数
  (setq m_wlbpt (vlax-safearray->list m_wlbpt))   ;;windowLeftBottomPoint
  ;;窗口左下角点Returns the elements of a safearray in list form 
  (setq m_wrupt (vlax-safearray->list m_wrupt))   ;;windowRightUpPoint
  ;;窗口右上角点
  (command "zoom" "w" m_wlbpt m_wrupt)            ;;缩放以使剖切线充满屏幕 
  (setq	m_ss (ssget "c"
		    m_wlbpt
		    m_wrupt
		    '((-4 . "<or")
		      (0 . "line")
		      (0 . "polyline")
		      (0 . "lwpolyline")
		      (0 . "arc")
		      (0 . "circle")
		      (0 . "spline")
		      (0 . "ellipse")
		      (0 . "3dpolyline")
		      (-4 . "or>")
		     )
	     )
  )
  ;;窗口交选,'(...)为filter-list 

  (setq m_ss (ssdel m_pqx m_ss)) ;;在选择集中删除pqx图元,ename-An entity name. ss- A selection set. 

  (acet-ui-progress "正在处理,请等待..." 100) ;;显示进度条

  (setq m_vlaobjcopy (m_shadowtoxy (vla-copy m_vlaobj)));;复制剖切线实体,并求投影至XY平面的实体
  (setq m_jdtab '())
  (setq i 0)

  ;;;第一层loop
  ;;;按m_ent实体循环
  (repeat (sslength m_ss)         ;;the number of objects (entities) in a selection set 
    (setq m_ent (ssname m_ss i))  ;;取出选择集中的一个实体,ssname返回选择集索引号对应实体名
    
    (setq m_vlaobjcopy1           ;;复制并求投影实体
	   (m_shadowtoxy
	     (vla-copy (vlax-ename->vla-object m_ent))
	   )
    )
    ;;求剖切线拷贝与曲线拷贝实体的交点表
    (setq m_jdtab1 (vla-intersectwith           ;;交点表m_jdtab1
		     m_vlaobjcopy               ;;剖切线拷贝
		     m_vlaobjcopy1              ;;曲线实体拷贝
		     acExtendnone
		   )
    )
    
     
    (if	(> (vlax-safearray-get-u-bound (vlax-variant-value m_jdtab1) 1) ;;交点表最大维数>1
	   1
	);;判断有无交点
      
      (progn
	(setq m_jdtab1
	       (vlax-safearray->list (vlax-variant-value m_jdtab1))
	);;safearray数组->转换为list表
	
	(setq j 0)
	  ;;;内层loop
          ;;;按交点循环开始
	(repeat	(/ (length m_jdtab1) 3)                    ;;交点数目
	  (setq	m_jd (list (nth j m_jdtab1)
			   (nth (+ 1 j) m_jdtab1)
			   (nth (+ 2 j) m_jdtab1)
		     )
	  );;取得第(j+1)交点在投影剖切线上的交点,Z=0
	  
	  (setq m_entlen (vlax-curve-getdistatpoint m_vlaobjcopy m_jd));;得到第(j+1)交点到剖切线起点的长度
	  (if m_entlen    ;;判断距离是否为 nil,在极少数情况下可能出现,非nil则:
	    (progn
	      (setq m_jd (vlax-curve-getClosestPointToProjection     ;获得某曲线上被投影到某平面的点(in WCS) 
		       (vlax-ename->vla-object m_ent)      ;The VLA-object to be measured, m_ent选择集中的一个实体名 
		       (list (car m_jd) (cadr m_jd) 0.0)   ;给定点
		       '(0 0 1)   ;;投影平面的法向量 
		       )
	      );;取得虚交点在实际的等高线上的实际交点（主要是得到高程）
	      ;;m_jdtab初值为空表,构造交点表（距离 （交点表 等高线实体名表））
	      (setq m_jdtab (cons (list m_entlen (list m_jd m_ent)) m_jdtab))
	    )
	  )
	  (setq j (+ 3 j))    
	)      ;;;按交点循环end
	
      )
    )
    (vla-delete m_vlaobjcopy1)  ;;删除复制的曲线实体
    (setq i (1+ i))
    (acet-ui-progress (fix (* (/ i (sslength m_ss) 1.0) 100)))
  )    ;;;按m_ent实体循环end
  
  (vla-delete m_vlaobjcopy)  ;;删除复制的剖切线实体
  (acet-ui-progress-done)    ;;关闭进度条
  
  (setq m_jdtab (vl-sort m_jdtab '(lambda (a b) (< (car a) (car b)))))  ;;对构造交点表按距离从小到大排序
  (setq m_jdtab1 m_jdtab)
  (setq m_jd (car m_jdtab))    ;;当前第一个交点构造表
  (setq m_jdtab (cdr m_jdtab)) ;;当前第一个之外构造交点表

  (repeat (length m_jdtab)
    (if	(< (abs (- (car m_jd) (caar m_jdtab))) 0.00001)  ;;car m_jd取表中的第一个元素(距离);; caar取第二个表中的第一个元素(距离)
      (setq m_jdtab1 (vl-remove (car m_jdtab) m_jdtab1)) ;;;;删除当前重复的交点构造表
      (setq m_jd (car m_jdtab))                          ;;上一个表之后的表
    )
    (setq m_jdtab (cdr m_jdtab))                         ;;其它表
  )
  
  (setq m_jdtab m_jdtab1)
  ;;;data数据表内容---(原图比例 绘制比例 字型名 剖面编号  等高距 文件名 是否保存数据 高程调整值  是否自动获取高程)
  (if (not (listp data))
    (setq data (get_data))
  )
  
  (if (= "1" (nth 8 data))
    (setq gctz (atof (nth 7 data)))
    (setq gctz nil)
  )
  (setq dgj (atof (nth 4 data)))  ;;等高距
  (setq	m_jdtab
	 (reverse
	   (m_db m_jdtab gctz dgj (- (cadr m_wrupt) (cadr m_wlbpt)))
	 )
  )
  (if (and (listp data) m_jdtab)
    (draw_pmx m_jdtab data)
    (princ "\n数据输入有误!")
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun m_shadowtoxy (m_obj / m_obj1 m_objname m_pts m_pts1 i)
  ;;对曲线实体m_obj创建一个投影至xy平面的曲线实体，即对曲线实体上每个控制点的z坐标置为0
  ;;返回实体名m_obj1
  (setq m_objname (vla-get-objectname m_obj))
  ;;取得实体的类型名称
  (cond
    ((= "AcDbSpline" m_objname)
     ;;样条曲线(Spline)
     (setq m_pts (vlax-variant-value (vla-get-fitpoints m_obj)))
     ;;取得样条曲线的拟合点
     (setq m_pts1 (vlax-variant-value (vla-get-controlpoints m_obj)))
     ;;取得样条曲线的控制点
 
     (if (> (vla-get-numberoffitpoints m_obj) 0);;判断拟合点数目是否大于0
       (progn
	 (setq i 0)
	 (repeat (vla-get-numberoffitpoints m_obj)
	   (vlax-safearray-put-element m_pts (+ i 2) 0.0);;改变每个拟合点的z值为0.0
	   (setq i (+ i 3))
	 )
	 (vla-put-fitpoints m_obj m_pts);;更改曲线拟合点属性
       )
     )
     
     (if (> (vla-get-numberofcontrolpoints m_obj) 0);;判断控制点数目是否大于0
       (progn
	 (setq i 0)
	 (repeat (vla-get-numberofcontrolpoints m_obj);;循环
	   (vlax-safearray-put-element m_pts1 (+ i 2) 0.0);;改变每个控制点的z值为0.0
	   (setq i (+ i 3))
	 )
	 (vla-put-controlpoints m_obj m_pts1);;更改曲线控制点属性
       )
     )
    )
    
    ((= "AcDb3dPolyline" m_objname)
     ;;三维多段线(3dpolyline)
     (setq i 0)
     (setq m_pts (vlax-variant-value (vla-get-coordinates m_obj)))
     ;;取得3维多段线的控制点
     (repeat (/ (length (vlax-safearray->list m_pts)) 3)
       (vlax-safearray-put-element m_pts (+ i 2) 0.0)
       (setq i (+ i 3))
     )
     (vla-put-coordinates m_obj m_pts)
    )

    ((= "AcDbLine" m_objname)
     ;;直线(line)
     (setq m_pts (vlax-variant-value (vla-get-startpoint m_obj)))
     ;;取得直线的起点座标
     (setq m_pts1 (vlax-variant-value (vla-get-endpoint m_obj)))
     ;;取得直线的终点座标
     (vlax-safearray-put-element m_pts 2 0.0)
     ;;改变起点座标z值为0.0
     (vlax-safearray-put-element m_pts1 2 0.0)
     ;;改变终点座标z值为0.0
     (vla-put-startpoint m_obj m_pts)
     (vla-put-endpoint m_obj m_pts1)
    )

    ((or (= "AcDbCircle" m_objname)
	 ;;园(circle)
	 (= "AcDbArc" m_objname)
	 ;;圆弧(arc)
	 (= "AcDbEllipse" m_objname)
	 ;;椭圆及椭圆弧(ellipse)
     )
     (setq m_pts (vlax-variant-value (vla-get-center m_obj)))
     (vlax-safearray-put-element m_pts 2 0.0)
     ;;改变中心点座标z值为0.0
     (vla-put-center m_obj m_pts)
    )

    ((or (= "AcDbPolyline" m_objname)
	 ;;多段线(polyline、lwpolyline)
	 (= "AcDb2dPolyline" m_objname)
	 ;;拟合的2维多段线(polyline、lwpolyline)
     )
     (vla-put-elevation m_obj 0.0)
     ;;改变标高值为0.0
    )
  )
  (setq m_obj1 m_obj)
)

(defun get_data	(/ data key fg fn)
  (setq data '())
  (setq data (cons (getstring "原图比例1:") data))
  (setq data (cons (getstring "绘制比例1:") data))
  (setq data (cons (getstring "字体:") data))
  (setq data (cons (getstring "剖面编号:") data))
  (initget "Yes No")
  (setq key (getkword "数据需要存盘吗(Yes/No?)"))
  (setq fg 1)
  (if (= "Yes" key)
    (while fg
      (initget 7)
      (setq filename (getstring "\n文件名:"))
      (if (findfile filename)
	(progn
	  (initget "Yes No")
	  (setq
	    key	(getkword "文件已经存在，覆盖吗(Yes/No?)")
	  )
	  (if (= "Yes" key)
	    (progn
	      (setq data (cons filename data))
	      (setq data (cons "1" data))
	      (setq fg nil)
	    )
	  )
	)
	(if (setq fn (open filename "w"))
	  (progn
	    (setq data (cons filename data))
	    (setq data (cons "1" data))
	    (close fn)
	    (setq fg nil)
	  )
	  (princ (strcat "\n不合法的文件名:" filename))
	)
      )
    )
    (progn (setq data (cons "" data))
	   (setq data (cons "0" data))
    )
  )
  (setq data (reverse data))
  (if (> (length (member "" data)) 2)
    (setq data 0)
    (setq data data)
  )
)

;函数：m_db()
;功能：返回点表
;格式：((距离1 高程1)(距离2 高程2)...)
(defun m_db (inter_list	       gctz	dgj	 m_viewhight
	     /	      distz1   ds	ent	 gc0	  gct
	     gc1      fg       f	p	 inc	  pt
	     gctext   pre_gc   gc2	m_vlaline1 m_vlaline2 m_linelen	m_vlacircle
	    )
  (setq pt (car (cadr (car inter_list))))
  (command "zoom" "c" pt (/ m_viewhight 10));;缩放视口
  
  (setq	inc 0
	pre_gc nil
	gc0 ""
  )
  (repeat (length inter_list)
    (setq ds	     (caar inter_list)
	  pt	     (car (cadr (car inter_list)))

	  ent	     (cadr (cadr (car inter_list)))
	  inter_list (cdr inter_list)
	  fg	     0
    )
    (redraw ent 3)
    (command "zoom" "c" pt (getvar "viewsize"))
    (setq m_linelen (* 0.025 (getvar"viewsize")))
    (entmake (list (cons 0 "Line");;实体类型－直线
		 (cons 10 (list (+ (car pt) m_linelen) (+ (cadr pt) m_linelen)));;直线起点点座标
		 (cons 11 (list (- (car pt) m_linelen) (- (cadr pt) m_linelen)));;直线端点点座标
		 (cons 62 3);;颜色－绿色
	   )
    )
    ;;创建一条直线
    (setq m_vlaline1 (vlax-ename->vla-object (entlast)))
    (entmake (list (cons 0 "Line");;实体类型－直线