dxpmx1.lsp

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

		 (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_vlaline2 (vlax-ename->vla-object (entlast)))
    (entmake (list (cons 0 "Circle");;实体类型－直线
		 (cons 10 pt);;圆心座标
		 (cons 40 m_linelen);;园半径
		 (cons 62 1);;颜色－红色
	   )
    )
    ;;创建一个园
    (setq m_vlacircle (vlax-ename->vla-object (entlast)))

    (if	gctz  ;自动获取高程
      (progn
	(setq gc0 (last pt))
	(if (and (/= 0.0 dgj )
		(or (= 0.0 gc0)
		    (if pre_gc (/= dgj (abs (- pre_gc gc0))) nil)
		)
	    )
	  (progn
	    (setq fg 0)
	    (while fg
	      (setq
		gc2 (getstring
		      (strcat "\n本条线高程(R-跳过)<"
			      (rtos gc0 2 2)
			      "m>: "
		      )
		    )
	      )
	      (if (/= "" gc2)
		(if (= "R" (strcase gc2))
		  (setq	gc0 nil
			fg  nil
		  )
		  (if (check_gc1 gc2)
		    (setq gc0 (atof gc2)
			  fg  nil
		    )
		    (princ (strcat "错误的输入:" gc2)
		    )
		  )
		)
		(setq fg nil)
	      )
	    )
	  )
	  (progn
	    (setq gctext (strcat "本条线高程(R-跳过)<"
				 (rtos (- gc0 gctz) 2 2)
				 ">: "
				 (rtos gc0 2 2)
				 " - "
				 (rtos gctz 2 2)
				 "\n"
			 )
	    )
	    (princ gctext)
	  )
	)
	(if gc0
	  (progn
	    (setq p (cons (list ds (- gc0 gctz)) p))
	    (setq pre_gc gc0)
	  )
	)
      )
      (while fg;手工输入高程
	(if (/= "" gc0)
	  (setq gc0 (rtos gc0 2 2))
	)
	(if
	  (/= ""
	      (setq gc1
		     (getstring
		       (strcat "\n本条线高程(R-跳过)<" gc0 "m>: ")
		     )
	      )
	  )
	   (if (setq gc1 (check_gc gc1))
	     (progn
	       (setq f (car gc1))
	       (cond
		 ((= -1 f)
		  (setq fg nil)
		  (if (/= "" gc0)
		    (setq gc0 (read gc0))
		  )
		 )
		 ((= 0 f)
		  (if (read gc0)
		    (progn
		      (setq inc (cadr gc1))
		      (setq gc0 (+ inc (read gc0)))
		      (setq p (cons (list ds gc0) p))
		      (setq gc0 (+ inc gc0))
		      (setq fg nil)
		    )
		    (princ "\n高程为空，请重输!")
		  )
		 )
		 ((= 1 f)
		  (setq	gc0 (cadr gc1)
			fg  nil
		  )
		  (setq p (cons (list ds gc0) p))
		 )
	       )
	     )
	     (setq gc0 (read gc0))
	   )
	   (if (/= "" gc0)
	     (setq fg  nil
		   gc0 (read gc0)
		   p   (cons (list ds gc0) p)
		   gc0 (+ inc gc0)
	     )
	     (princ "\n高程为空，请重输!")
	   )
	)
      )
    )
    (vla-delete m_vlaline1)
    (vla-delete m_vlaline2)
    (vla-delete m_vlacircle)
    (redraw ent 4)
  )
  (setq p p)
)

(defun check_gc1 (gc0 / npi ch n fg)
  (setq	npi 0
	n 1
	fg 0
  )
  (repeat (strlen gc0)
    (setq ch (substr gc0 n 1))
    (if	(and (>= (ascii ch) (ascii "0"))
	     (<= (ascii ch) (ascii "9"))
	)
      ()
      (if (= (ascii ".") (ascii ch))
	(setq npi (1+ npi))
	(setq fg nil)
      )
    )
    (setq n (1+ n))
  )
  (if (and fg (<= npi 1))
    (setq fg 0)
    (setq fg nil)
  )
)

					;函数：check_gc()
					;功能：检查串的合法性，合法的串："R","+?","-?","?"
					;      其中'?'代数
					;      串为"R",返回(-1 0)
					;      串为"+?",返回(0 ?)   
					;      串为"-?",返回(0 -?)  
					;      串为"?",返回(1 ?)
					;      其他为不合法，返回nil    

(defun check_gc	(gc0 / f gc1 msg n fg)
  (setq msg (strcat "\n非法输入<" gc0 ">,请重输!\n"))
  (setq fg 1)
  (if (> (strlen gc0) 1)
    (progn
      (setq n 2)
      (repeat (1- (strlen gc0))
	(if (= "." (substr gc0 n 1))
	  ()
	  (if (numberp (read (substr gc0 n 1)))
	    ()
	    (setq fg nil)
	  )
	)
	(setq n (1+ n))
      )
      (if fg
	(progn
	  (setq f (substr gc0 1 1))
	  (setq gc1 (read (substr gc0 2 (1- (strlen gc0)))))
	  (if (numberp gc1)
	    (setq gc1 (cond ((= "+" f) (list 0 gc1))
			    ((= "-" f) (list 0 (- 0 gc1)))
			    ((numberp (read f))
			     (list 1 (read gc0))
			    )
			    ((not (numberp (read f)))
			     (princ msg)
			     (setq gc1 nil)
			    )
		      )
	    )
	    (progn (princ msg) (setq gc1 nil))
	  )
	)
	(progn (princ msg) (setq gc1 nil))
      )
    )
    (if	(numberp (read gc0))
      (setq gc1 (list 1 (read gc0)))
      (if (= "R" (strcase gc0))
	(setq gc1 (list -1 0))
	(progn (princ msg) (setq gc1 nil))
      )
    )
  )
)

(defun draw_pmx	(b     data  /	   key	 ys    cs    cs1   bh	 jd
		 x     y     maxh  h	 minh  dx    dy	   b1	 ds
		 gc0   zt
		)
  
  (setq	ys (atof (nth 0 data))
	cs (atof (nth 1 data))
	zt (nth 2 data)
	bh (nth 3 data)
  )
  (if (and (read (nth 5 data)) (= "1" (nth 6 data)))
    (save_data b data)
  )

  (initget 7)
  (setq jd (getpoint "绘制基点: "))
  (command "color" 7)
  (setq	x (car jd)
	y (cadr jd)
  )
  (princ (strcat (rtos x 2 2) "," (rtos y 2 2)))
  
  (setq	gc0  (cadar b)
	maxh gc0
	minh (cadadr b)
  )
  (if (<= maxh minh)
    (progn (setq h    minh
		 minh maxh
		 maxh h
	   )
    )
  )
  (setq	ds  (* (caar b) (/ ys cs))
	gc0 (* gc0 (/ 1000.0 cs))
  )
  (setq	dx (- ds x)
	dy (- gc0 y)
  )
  (setq b1 (cons (list x y) '()))
  (repeat (length b)
    (setq gc0 (cadar b))
    (if	(<= maxh gc0)
      (setq maxh gc0)
      (if (>= minh gc0)
	(setq minh gc0)
      )
    )
    (setq ds  (* (caar b) (/ ys cs))
	  gc0 (* gc0 (/ 1000.0 cs))
    )
    (setq x (- ds dx)
	  y (- gc0 dy)
    )
    (setq b1 (cons (list x y) b1))
    (setq b (cdr b))
  )
  (setq b1 (reverse b1))
  (command "pline" '(0 0) "w" 0 0 '(0 0))
  (command)
  (command "erase" (entlast) "")	;使默认线宽为1
  (apply 'command (cons "pline" b1))
  (command)				;绘出剖面线
  (setq	x1   (caar b1)
	x2   (car (last b1))
	cs1  (* 10 (/ cs 1000.0))
	maxh (+ (- maxh (rem maxh cs1)) cs1)
	minh (- minh (rem minh cs1))
	y1   (- (* maxh (/ 1000.0 cs)) dy)
	y2   (- (* minh (/ 1000.0 cs)) dy)
	n    0
  )
  (command "pline" (list x1 y1) (list x1 y2))
  (command)

  (repeat (1+ (fix (/ (- y1 y2) 10.0)))
    (command "line" (list x1 (- y1 (* 10.0 n))) "@-2,0")
    (command)
    (m_DrawText zt "mr" (list (- x1 3) (- y1 (* 10.0 n))) 3 0 (rtos (- maxh (* cs1 n)) 2 0))
    (setq n (1+ n))
  )

  (setq jd (list (/ (+ x1 x2) 2.0) (+ y1 10)))
  (m_DrawText zt "tc" jd 6 0 (strcat "1: " (itoa (fix cs))));;标注比例
  (m_DrawText zt "mc" (polar jd (angtof "90") 7) 8 0 (strcat bh " 剖面"));;标注剖面号
  (vla-getboundingbox (vlax-ename->vla-object (entlast)) 'x 'y)
  (setq ds (abs (- (car (vlax-safearray->list x)) (car (vlax-safearray->list y)))))
  (setq jd (polar jd (angtof "180") (/ (+ 2 ds) 2.0)))
  (setq jd (polar jd (angtof "90") 1.5))
  (command "pline" jd (polar jd 0 (+ 2 ds)) "")
)

(defun save_data (b init_data / filname n fn)
  (setq	filename (nth 5 init_data)
	n	 0
  )
  (if (setq fn (open filename "w"))
    (progn
      (prin1 init_data fn)
      (princ "\n" fn)
      (mapcar '(lambda (x) (princ x fn) (princ "\n" fn)) b)
      (close fn)
    )
    (alert (strcat "\n不能打开文件<" (strcase filename 1) ">!"))
  )
)

(defun m_DrawText(m_FontStyle m_AlignmentStyle m_AlignmentPosition m_TextHeight m_Rotate m_Text / ztb)
  ;;根据给定的字体、对齐方式、对齐点、字高、旋转角绘制文字
  (if (setq ztb (tblsearch "style" m_FontStyle));;如果指定字体m_zt存在
    (if (> (cdr (assoc '40 ztb)) 0.0);;如果指定字体的默认高度大于0.0
      (progn
	(command "text" "s" m_FontStyle m_AlignmentStyle m_AlignmentPosition m_Rotate m_Text);;先按默认高度写字
	(setq ztb (entget(entlast)))
	(setq ztb (subst (cons 40 m_TextHeight) (assoc '40 ztb) ztb));;改变默认高度为指定字高m_zg
	(entmod ztb)
      )
      (command "text" "s" m_FontStyle m_AlignmentStyle m_AlignmentPosition m_TextHeight m_Rotate m_Text);;如果指定字体默认高度等于0.0则按指定字高直接写字
    )
    (m_DrawText "STANDARD" m_AlignmentStyle m_AlignmentPosition m_TextHeight m_Rotate m_Text);;如果指定字体不存在，则用标准字体STANDARD写字
  )	
)

(princ "\n地形剖面线绘制程序\n    运行命令：PMX")