地质上的，布剖面线
本帖最后由 wzg356 于 2014-11-19 01:27 编辑学llsp,源自不想被其它插件绑定
来明经近一年了，目前可以编写简单的插件了
小东西，代码长
就我而言，达到目的就行
纠结于最求完美反而剑走偏锋，荒废专业
里面有几个字符串函数也是自己写的，可以收集改进
分享一下
有高手来把它简化更好;布剖面线;
;wzg356 写于20140926
(defun c:pmx ( / sc pmbh answer )
(princ "\n假定CAD中绘制比例为1:1千")
(if (not (setq sc (getreal "\n输入出图比例,1代表1:1千,10代表1:1万，以此类推<1>: ")))(setq sc 1.0))
(setq pmbh (getstring "\n输入剖面编号<1>:"))
(if (= pmbh "")(setq pmbh "1"))
(setq pmbh(apply 'strcat (mapcar 'vl-princ-to-string (read (strcat "(" pmbh ")")))));消除空格
(setq answer "Yes")
(while (= answer "Yes")
(drawpmx pmbh sc);画剖面
(initget"Yes No")
(setq answer (getkword "\n是否继续下一条剖面线? <No>:"))
(if (= answer nil)(setq answer "No"))
(setq pmbh (endnumchange pmbh 1));如果编号末尾是数字，编号加1
(setq pmbh (endABCchange pmbh 1));如果编号末尾是字母，编号递增
)
)
(defun drawpmx (pmbh sc / newerr sysvarlst *olderror* en pt1 pt2 pml pmjd tmp
PT3 pt4 pt_2 pt5 pt6 en1 en2 en3 en4)
;自定义新的出错函数
(defun newerr (msg)
(mapcar 'eval sysvarlst);恢复变量设置
(if *olderror* (setq *error* *olderror**olderror* nil)) ;_ 恢复*error*函数
(if (not (member msg '(nil "函数被取消" ";错误:quit / exit abort")))
(princ (strcat ";错误:" msg))
)
)
;;系统设置
(command "undo" "be");;命令编组开始
(setq sysvarlst(mapcar (function (lambda (n) (list 'setvar n (getvar n))))
'( "osmode" "cmdecho" "OSNAPCOORD""plinewid" "clayer" "cecolor")));保存系统变量
(setq *olderror* *error*);保存出错函数
(setq*error* newerr);设置自定义出错函数
(setvar "cmdecho" 0);;;关闭命令响应
(setvar "OSNAPCOORD" 1);;;坐标数据优先级设为：键盘输入替代对象捕捉设置
(setvar "OSMODE" 675);;;改变捕捉模式
(if (= (tblsearch "layer" "剖面") nil) (EntmakeLayer 7 "剖面"));如果无"剖面"图层,创建
(setvar "clayer" "剖面")
(setvar "cecolor" "4")
(if (= (Tblsearch "style" "MY_ST") nil)
(command "-style" "MY_ST" "宋体" 0 0.8 0 "n" "n");;;文字样式
)
(setvar "textstyle" "MY_ST")
;输入剖面起点、终点
(command "line" (getpoint "\n指定剖面起点:") pause "");取得剖面两端点
(setq en (entlast))
(setq pt1 (cdr(assoc 10 (entget en))))
(setq pt2 (cdr(assoc 11 (entget en))))
(command "_erase" en "")
(setq pt1 (mapcar '+ pt1 '(0 0)));转为二维点
(setq pt2 (mapcar '+ pt2 '(0 0)));转为二维点
(setq pml (distance pt1 pt2));转为二维坐标计算剖面长度
(setq pmjd (* 180.0 (/ (angle pt1 pt2) pi)));线的角度
(setvar "plinewid" (* sc 0.5));剖面线宽
(if (or
(> (abs (- pmjd 90)) 1)
(> (abs (- pmjd 270)) 1)
);如果剖面线不是近南北向
(if (> (car pt1) (car pt2))
(setq tmp pt1 pt1 pt2pt2 tmp);两点交换，把左边点置为剖面起点
)
(if (> (cadr pt1) (cadr pt2))
(setq tmp pt1 pt1 pt2pt2 tmp);两点交换，把南边点置为剖面起点
)
)
(setq PT3 (polar pt1 (* 0.5 PI) (* 3.0 sc));起点截止线点
pt4 (polar pt1 (* -0.5 PI) (* 3.0 sc));起点截止线点
pt_2 (polar pt1 0 pml);为方便计算，选pt1正东向一点来过渡
pt5 (polar pt_2 (* 0.5 PI) (* 3.0 sc));终点截止线点
pt6 (polar pt_2 (* -0.5 PI) (* 3.0 sc));终点截止线点
)
;画剖面线
(command "pline" pt1pt2 "");;以指定宽度多线段画剖面线
(setq pmjd (* 180.0 (/ (angle pt1 pt2) pi)));线的角度
(command "pline" pt3pt4 "");;以指定宽度多线段起点截止线
(setq en1 (entlast))
(command "pline" pt5 pt6 "");;以指定宽度多线段画终点截止线
(setq en2 (entlast))
(command "TEXT" "J" "MR" (polar pt1 (* -1.0 PI) (* 2.0 sc)) (* 4.0 sc) 0.0 pmbh);起点文字
(setq en3 (entlast))
(command "TEXT" "J" "ML" (polar pt_2 0 (* 2.0 sc)) (* 4.0 sc) 0.0 (strcat pmbh "′"));终点文字
(setq en4 (entlast))
(command "_rotate" en1 en2 en3 en4 "" pt1 pmjd "");旋转与剖面线对齐
;;恢复设置
(command "_undo" "_e");;活动编组结束
(mapcar 'eval sysvarlst);恢复变量设置
(setq *error* *olderror*);;恢复出错函数
(princ)
)
;;;字符串最后1个字母分离
;;(strEndIsABC "A2") 返回("A2" nil)
;;;;(strEndIsABC "A2a") 返回("A2" "a")
;;;;(strEndIsABC "c") 返回("" "c")
;;;;(strEndIsABC "bc") 返回("b" "c")
;;;;(strEndIsABC "3.5") 返回("3.5" nil)
(defun strEndIsABC (str / e len str1 str2)
(setq Len (strlen str))
(setq str1 (substr str Len 1))
(setq e (ascii str1))
(if (and (> e 64) (< e 123));判断是否字母
(list (substr str 1 (1- len)) str1)
(list str nil)
)
) ;_ 结束defunr
;;应用示例，末尾字母（仅最后一个）增减
;;如果末尾无字母，返回原字串
;;当遇A，a递减时，不论步距，递减至Z,z
;;当遇Z,z递增时，不论步距，递增至A，a
;;str, ind分别为字串，步距
;;(endABCchange "a333.5G" -2)
;;(endABCchange "4" -2)
(defun endABCchange (str ind / str1)
(setq str1 (cadr(strEndIsABC str)))
(cond
((and(= str1 "A") (< ind 0)) (setq str1 "Z"))
((and(= str1 "a") (< ind 0)) (setq str1 "z"))
((and(= str1 "Z") (> ind 0)) (setq str1 "A"))
((and(= str1 "z") (> ind 0)) (setq str1 "z"))
((= str1 nil) (setq str1 (substr str (strlen str)1)));末尾无字母不转换
(T (setq str1 (chr (+ (ascii str1) ind))))
)
(setq str (strcat (substr str 1 (1- (strlen str))) str1))
)
;;字符串与末尾数字分离,返回字符串(或nil)、末尾数字(或nil)组成的表
;;(strEndIsNumber "222")返回("" "222")
;;;(strEndIsNumber "abcd")返回("abcd" nil)
;;;(strEndIsNumber "ab2")返回("ab" "2")
;;;(strEndIsNumber "ab2.2")返回("ab" "2.2")
;;;(strEndIsNumber "3")返回("" "3")
(defun strEndIsNumber (str / e len str1 str2)
(if(numberp (read str ));判断是字符串是实数或整数
(list "" str)
(progn
(setq Len (strlen str))
(setq str1 (substr str Len 1))
(setq e (ascii str1))
(while (or (= e 46)(and (> e 47) (< e 58)));判断是小数点或数字
(if str2 (setq str2 (strcat str1 str2))(setq str2 str1))
(setq str (substr str 1 (1- len)))
(setq Len (strlen str))
(setq str1 (substr str Len 1))
(setq e (ascii str1))
)
(if (null str2) (list str nil)(list str str2))
)
)
) ;_ 结束defun
;;应用示例：末尾数字加减，如果末尾无数字，返回原字串
;;str, ind分别为字串，步距
;;(endnumchange "a3" 1)
;;(endnumchange "aa" 1)
(defun endnumchange (str ind / num jd)
(setq num (cadr(strEndIsNumber str)))
(if (/= num nil)
(if (member (type (read num)) (list 'INT));判断是否是INT整数型
(setq str(strcat (car(strEndIsNumber str))(rtos (+ (atof num) ind)2 0)))
(progn
(setq jd (- (- (strlen num)1) (strlen(rtos(atoi num)2 0))));取得小数位数
(setq str(strcat (car(strEndIsNumber str))(rtos (+ (atof num) ind)2 jd)))
)
)
str
)
)
;[功能]entmake 图层
;[用法](EntmakeLayercolor str)
;(setq TK (tblsearch "layer" "TK"))
;(if (= TK nil) (EntmakeLayer 7 "TK"))
;(setvar "clayer" "TK")
(defun EntmakeLayer (color str)
(entmake (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbLayerTableRecord") '(70 . 0) '(6 . "Continuous") (cons 62 color) '(370 . 0) (cons 2 str)))
)
(princ) 自己编的就是好程序 支持楼主，代码不在乎多少，能实现既定功能就是好程序 可以用吗？
页:
[1]