pm.lsp

CAD中软件编程很有用的哦！多次使用很好用

(defun c:pm( / dir fi pmzbj pmce pmtmp i stmpt pmzbt k dname lay pmel ls le)
  (setq dname(getvar "dwgname") dir(getvar "dwgprefix") dname(substr dname 1 (- (strlen dname) 4)))
  (setq dname(strcat dir dname "csh.txt"))
  (if (setq fi(open dname "r"))(rcsh dname)(csh dname))
  (command "units" 2 4 5 4 "e" "n")
  (command "osmode""0")
  (command "graphscr")
  (setq pmzbj(getpoint "\n剖面起点 ") pmel(list(getreal "\n起点高程\n ")) pmzbj (list(list (car pmzbj)(cadr pmzbj))) pmce "Y")
  (while (and (/= pmce "N")(/= pmce "n"))
	(setq pmtmp(getpoint "\n下一点 "))
	(setq pmzbj(append pmzbj(list(list (car pmtmp)(cadr pmtmp)))))
        (initget "1 Y y N n")
        (setq pmce(getkword "\n是否进行下一点? (Y/N)  <Y>"))
	(if (or (= pmce "N")(= pmce "n"))(setq pmel(append pmel(list(getreal "\n终点高程\n ")))))
  )
  (command "layer""make" "pmt-program-01" "off" "*" """")
  (setq i 0)
  (repeat (length layerdz)
	(setq lay(nth i layerdz))
	(command "layer" "on" lay "")
	(setq i(+ i 1))
  )
  (setq i 0)
  (repeat (length layerdx)
	(setq lay(nth i layerdx))
	(command "layer" "on" lay "")
	(setq i(+ i 1))
  )
  (setq i 0)
  (repeat (length layerpmx)
	(setq lay(nth i layerpmx))
	(command "layer" "on" lay "")
	(setq i(+ i 1))
  )
  (setq  i 0)
  (repeat (- (length pmzbj) 1)
  	(setq ls(nth i pmzbj) le(nth (+ i 1) pmzbj))
	(setq pmzbt(list (nth i pmzbj)(nth (+ i 1) pmzbj)))
	(command "pline" ls le "")
	(setq i(+ i 1))
  )
  (write dir pmzbj)
  (xcj pmzbj pmel)
  (hf)
)
;********************   恢复切图前状态    **************************
(defun hf()
  (setq fi(open pname "a"))
  (princ "(end)" fi)
  (close fi)
  (command"layer""on""*""set""0""")
  (command"erase""last""")
  (command"purge""la""pmt-program-01""n")
  (setq layerdz nil layerdx nil layerpmx nil pmtscale nil pname nil writesj nil)
  (prompt "\n谢谢使用!")
)
;********************   选择集筛选    **************************
(defun xcj(pmzbj pmel / i pmzb pmjh pmxs pmxe pmxlen fi stype k layert layert1 wri)
(setq k 0 i 0 stype 1 pmxlen 0 writesj nil)
(repeat 2 
  (setq i 0 writesj nil)
  (repeat (- (length pmzbj) 1)
	(setq pmzb(list (nth i pmzbj)(nth (+ i 1) pmzbj))
	      pmxs(trans (car pmzb) 1 0)
	      pmxe(trans (last pmzb) 1 0)
	      )
	(if (= i 0)(setq pmxlen 0)
		   (setq pmxlen(+ pmxlen (* pmtscale (distance (nth (- i 1)pmzbj) (nth i pmzbj)))))
	)
	(cond
		((= stype 1)(setq layert layerpmx))
		((= stype 2)(setq layert layerdx))
		((= stype 3)(setq layert layerdz))
	)
	(setq k 0)
	(repeat (length layert)
		(setq tjb(list(cons -4 "<or")
			      (cons -4 "<or")
			 	(cons -4 "<and")
					(cons 0 "LINE")
					(cons 8 (nth k layert))
				(cons -4 "and>")
				(cons -4 "<and")
					(cons 0 "LWPOLYLINE")
					(cons 8 (nth k layert))
				(cons -4 "and>")
			       (cons -4 "or>")
				(cons -4 "<and")
					(cons 0 "POLYLINE")
					(cons 8 (nth k layert))
				(cons -4 "and>")
			       (cons -4 "or>")
		))
		(ssget "f" pmzb)
		(if (setq pmjh(ssget "p" tjb))
			(cond
	   		((= stype 1)(jdpmx pmjh pmxs pmxe pmxlen))
	    		((= stype 2)(jddx pmjh pmxs pmxe pmxlen))
	    		((= stype 3)(jddz pmjh pmxs pmxe pmxlen))
			)
		)
		(setq k(+ k 1))
	)
	(setq i(+ i 1))
   )
  (if (/= writesj nil)
    (progn
     (if(= stype 2)
     (progn
     	(setq   wri(acad_strlsort writesj) i 0 writesj nil)
     	(repeat (length wri)(setq writesj(append writesj(list(list(nth i wri)))) i(+ i 1)))
	(setq	writesj(cons (list 0 (car pmel)) writesj)
	        writesj(cons 0 writesj)
		writesj(append writesj (list(list (+ pmxlen (* pmtscale (distance pmxs pmxe))) (last pmel))))
	)
     )
     )
   (setq fi(open pname "a") i 1)
   (repeat (length writesj)
   	(princ (nth (- i 1) writesj) fi)
	(if (= (/ i 5)(/ i 5.0))
	(princ "\n" fi)
	)
	(setq i(+ i 1))
   )
   (princ ")\n" fi)
   (if (= stype 1)(princ "(geo2 1)\n(" fi))
   (close fi)
   )
   (progn
    (setq fi(open pname "a") i 1)
    (if (= stype 1)(princ ")\n(geo2 1)\n(" fi))
    (if (= stype 2)(princ ")\n(end)" fi))
    (close fi)
   )
   )
   (setq stype(+ stype 1))
)
)
;********************   写出前导数据    **************************
(defun write(dir pmzbj / ce fi bl dxmax dxmin i len dis ang ang1 fx i)
(setq pname(getstring "\n输入剖面线名称 \n") pname(strcat dir pname ".txt") len 0)
(if (findfile pname)(setq ce "Y"))
(while (or (= ce "Y")(= ce "y"))
        (initget "1 Y y N n")
	(setq ce(getkword "\n文件已存在，是否覆盖  Y/N  <N>"))
	(if (or (= ce "Y")(= ce "y"))(setq ce "N")
		(progn
		(setq pname(getstring "\n请输入剖面线名称") pname(strcat dir pname ".txt") ce "N")
		(if (findfile pname)(setq ce "Y")(setq ce "N"))
		)
	)
)
(setq pmtbl(getint"\n输入剖面线比例 \n") dxmax(getint"\n输入剖面线最高高程 \n")dxmin(getint"\n输入剖面线最低高程 \n"))
  (setq i 0 fx "(")
  (repeat (- (length pmzbj) 1)
	(setq dis(* pmtscale (distance (nth i pmzbj)(nth (+ i 1) pmzbj)))
	      ang(strcat "\"" (angtos (angle (nth i pmzbj)(nth (+ i 1) pmzbj)) 4 4) "\"")
	      ang1(strcat "\"" (angtos (angle (nth (+ i 1) pmzbj)(nth i pmzbj)) 4 4) "\"")
	)
	(if (> (strlen ang) 1)
	     (setq ang(strcat (substr ang 1 (- (strlen ang) 4)) "\\" "\"" (substr ang (- (strlen ang) 1) 1) "\"")
		  ang1(strcat (substr ang1 1 (- (strlen ang1) 4)) "\\" "\"" (substr ang1 (- (strlen ang1) 1) 1) "\"")
	     )
	)
	(setq fx(strcat fx "(" (rtos dis) " " ang1 " " ang ")") 
	     len(+ len dis) i(+ i 1)
	)
  )
(setq fi(open pname "w"))
(princ "(geo1 \" \" " fi)
(princ pmtbl fi)
(princ ")\n" fi)
(princ "(" fi)
(princ dxmax fi)
(princ " " fi)
(princ dxmin fi)
(princ " " fi)
(princ len fi)
(princ " " fi)
(princ i fi)
(princ ")\n" fi)
(princ fx fi)
(princ ")\n(" fi)
(close fi)
)
;********************   地形线交点    **************************
(defun jddx(pmjh p3 p4 pmxlen / i jd p1 p2 z dis wr entzb k)
  (setq i 0)
  (repeat (sslength pmjh)
	(setq enttmp(entget(ssname pmjh i)))
	(if (= (cdr (assoc 0 enttmp)) "LINE")
	(progn
	   (setq jd nil
	      p1(list (cadr (assoc 10 enttmp))(caddr (assoc 10 enttmp)))
	      p2(list (cadr (assoc 11 enttmp))(caddr (assoc 11 enttmp)))
	      z(rtos (last (assoc 11 enttmp)) 2 0)
	      jd(inters p1 p2 p3 p4)
	    )
	    (if (/= jd nil)
		(progn
    		(setq  dis(+ pmxlen (* pmtscale (distance p3 jd))) wr(strcat  (rtos dis 2 4) " " z ))
		(repeat (- 5 (strlen (rtos dis 2 0)))
			(setq wr(strcat "0" wr))
		)
		(setq  writesj(append writesj (list wr)))
		)
	    )
	)
	)
	(setq k 0)
	(if (= (cdr (assoc 0 enttmp)) "LWPOLYLINE")
	   (progn
		(setq p1 nil)
		(repeat (length enttmp)
			(setq entzb(nth k enttmp) z(cdr(assoc 38 enttmp)) jd nil)
			(if (= (car entzb) 10)
				(if (= p1 nil)(setq p1(list (cadr entzb)(caddr entzb)))
					 (setq p2 p1 p1(list (cadr entzb)(caddr entzb))
						jd(inters p1 p2 p3 p4)
					)
				)
			)
			(if (/= jd nil)
				(progn
    				(setq  dis(+ pmxlen (* pmtscale (distance p3 jd))) wr(strcat  (rtos dis 2 4) " " (rtos z 2 0)))
				(repeat (- 5 (strlen (rtos dis 2 0)))(setq wr(strcat "0" wr)))
				(setq  writesj(append writesj (list wr)))
				)
			)
			(setq k(+ k 1))
		)
	    )
	)
	(setq    i(+ i 1))
  )
)
;********************   剖面线交点    **************************
(defun jdpmx(pmjh p3 p4 pmxlen / i p1 p2 enttmp dis ce pmn pmf) 
  (setq i 0)
  (repeat (sslength pmjh)
	(setq enttmp(entget(ssname pmjh i)) jd nil)
	(setq   p1(list (cadr (assoc 10 enttmp))(caddr (assoc 10 enttmp)))
		p2(list (cadr (assoc 11 enttmp))(caddr (assoc 11 enttmp)))
		jd(inters p1 p2 p3 p4)
	)
    	(if (/= jd nil)
	(progn
	(setq jd(trans jd 0 1))
	(command "zoom""c" jd "100")
	(command "circle" jd "2")
	(setq jd(trans jd 1 0))
        (initget "1 Y y N n")
	(setq ce(getkword "\n这是剖面线吗?  Y/N  <Y>\n"))
	(if (or (= ce "N")(= ce "n"))()
		(progn
		(setq dis(rtos (+ pmxlen (* pmtscale (distance p3 jd)))) pmn(getstring"\n剖面线名称\n"))
        	(initget "1 0 1")
		(setq pmf(getkword "\n剖面线方向  0 向右  1 向左\n"))
		(setq pmn(strcat "\"" pmn "\"") writesj(append writesj (list(list pmn dis pmf))))
		)
	)
	(command "undo" 2)
	)
	)
	(setq i(+ i 1))
  )
)
;********************   地质线交点    **************************
(defun jddz(pmjh p3 p4 pmxlen / i k p1 p2 enttmp)
  (setq i 0)
  (repeat (sslength pmjh)
	(setq enttmp(entget(ssname pmjh i)) jd nil)
	(setq   p1(list (cadr (assoc 10 enttmp))(caddr (assoc 10 enttmp)))
		p2(list (cadr (assoc 11 enttmp))(caddr (assoc 11 enttmp)))
		jd(inters p1 p2 p3 p4)
	)
    	(if (/= jd nil)
	(progn
	(setq jd(trans jd 0 1))
	(command "circle" jd "2")
	)
	)
	(setq i(+ i 1))
  )
)
;*************************   初始化   ***********************************************
(defun csh(dname / fi dis bl layert i layert1 chart)  
 (setq fi(open dname "w") i 1)   
 (princ "\n现在开始初始化......\n ")
   (setq dis(distance(getpoint"\n  请点击第一个网格点  ")(getpoint"\n  请点击相邻个网格点 :")))
   (while (/= (type bl)(type 1))
   (setq bl(getint "\n  请输入平面图比例  "))
   )
   (setq pmtscale(/ bl (* 10 dis)))
   (setq layerdz(getstring "\n  请输入地质界线所在层 : 如 DZ1,DZ2 \n"))
   (setq layerdx(getstring "\n  请输入地形线所在层 : 如 DX1,DX2 \n"))
   (setq layerpmx(getstring "\n  请输入剖面线所在层 : 如 PM1,PM2 \n"))
(setq layert "")
(repeat (strlen layerdz)
 (if (= "," (substr layerdz i 1))
	(setq layert1(append layert1 (list (strcat "\"" layert "\""))) layert "" i(+ i 1))
	(setq layert(strcat layert (strcase(substr layerdz i 1))) i(+ i 1))
 )
)
(setq i 1 layert1(append layert1 (list (strcat "\"" layert "\""))) layerdz layert1 layert1 nil layert "")
(repeat (strlen layerdx)
 (if (= "," (substr layerdx i 1))
	(setq layert1(append layert1 (list (strcat "\"" layert "\""))) layert "" i(+ i 1))
	(setq layert(strcat layert (strcase(substr layerdx i 1))) i(+ i 1))
 )
)
(setq i 1 layert1(append layert1 (list (strcat "\"" layert "\""))) layerdx layert1 layert1 nil layert "")
(repeat (strlen layerpmx)
 (if (= "," (substr layerpmx i 1))
	(setq layert1(append layert1 (list (strcat "\"" layert "\""))) layert "" i(+ i 1))
	(setq layert(strcat layert (strcase(substr layerpmx i 1))) i(+ i 1))
 )
)
(setq layert1(append layert1 (list (strcat "\"" layert "\""))) layerpmx layert1)
 (princ pmtscale fi)
 (princ "\n" fi)
 (princ layerdz fi)
 (princ "\n" fi)
 (princ layerdx fi)
 (princ "\n" fi)
 (princ layerpmx fi)
 (princ "\n" fi)
 (close fi)
)
;*************************   读取初始化信息   ***********************************************
(defun rcsh(dname / p f) 
 (setq p 0)
 (if (= (setq pmtscale(read-line fi)) nil)(setq p 1)(setq pmtscale(read pmtscale)))
 (if (= (setq layerdz(read-line fi)) nil)(setq p 1)(setq layerdz(read layerdz)))
 (if (= (setq layerdx(read-line fi)) nil)(setq p 1)(setq layerdx(read layerdx)))
 (if (= (setq layerpmx(read-line fi)) nil)(setq p 1)(setq layerpmx(read layerpmx)))
 (close fi)
 (if (= p 1)
   (progn
	(princ"\n初始文件格式有错，请重新初始化。")
	(csh dname)
    )
    (progn
	(initget "1 Y N y n")
	(setq f(getkword "\n底图已初始化,是否要修改? (Y/N)   <N>"))
	(if (or (= f "Y")(= f "y"))(csh dname))
    )
 )
)