设为首页收藏本站CAD论坛CAD教程CAD下载明经币充值
切换到宽版

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 开发篇 › AutoLISP/Visual LISP 编程技术 › 地质上的，布剖面线
返回列表 发新帖
查看: 2645|回复: 3

[源码] 地质上的，布剖面线

[复制链接]
wzg356
发表于 2014-11-19 01:03:00 | 显示全部楼层 |阅读模式
本帖最后由 wzg356 于 2014-11-19 01:27 编辑

学llsp,源自不想被其它插件绑定
来明经近一年了，目前可以编写简单的插件了
小东西，代码长
就我而言，达到目的就行
纠结于最求完美反而剑走偏锋，荒废专业

里面有几个字符串函数也是自己写的，可以收集改进

分享一下
有高手来把它简化更好
  2. ;布剖面线;
  3. ;wzg356 写于20140926
  4. (defun c:pmx ( / sc pmbh answer )
  5.   
  6.   (princ "\n假定CAD中绘制比例为1:1千")
  7.   (if (not (setq sc (getreal "\n输入出图比例,1代表1:1千,10代表1:1万，以此类推<1>: ")))(setq sc 1.0))
  8.   (setq pmbh (getstring "\n输入剖面编号<1>:"))
  9.   (if (= pmbh "")(setq pmbh "1"))
  10.   (setq pmbh(apply 'strcat (mapcar 'vl-princ-to-string (read (strcat "(" pmbh ")")))));消除空格
  11.   (setq answer "Yes")
  12.   (while (= answer "Yes")
  13.     (drawpmx pmbh sc);画剖面
  14.     (initget  "Yes No")
  15.     (setq answer (getkword "\n是否继续下一条剖面线? [Yes/No]<No>:"))
  16.     (if (= answer nil)(setq answer "No"))
  17.     (setq pmbh (endnumchange pmbh 1));如果编号末尾是数字，编号加1
  18.     (setq pmbh (endABCchange pmbh 1));如果编号末尾是字母，编号递增
  19.   )   
  20. )

  22. (defun drawpmx (pmbh sc / newerr sysvarlst *olderror* en pt1 pt2 pml pmjd tmp
  23.                    PT3 pt4 pt_2 pt5 pt6 en1 en2 en3 en4)
  24.   ;自定义新的出错函数
  25.     (defun newerr (msg)
  26.       (mapcar 'eval sysvarlst);恢复变量设置
  27.       (if *olderror* (setq *error* *olderror*  *olderror* nil)) ;_ 恢复*error*函数
  28.       (if (not (member msg '(nil "函数被取消" ";错误:quit / exit abort")))
  29.         (princ (strcat ";错误:" msg))
  30.     )
  31.   )
  32.   ;;系统设置
  33.   (command "undo" "be");;命令编组开始
  34.   (setq sysvarlst(mapcar (function (lambda (n) (list 'setvar n (getvar n))))
  35.       '( "osmode" "cmdecho" "OSNAPCOORD"  "plinewid" "clayer" "cecolor")));保存系统变量
  36.   (setq *olderror* *error*);保存出错函数
  37.   (setq  *error* newerr);设置自定义出错函数  
  38.   (setvar "cmdecho" 0);;;关闭命令响应
  39.   (setvar "OSNAPCOORD" 1);;;坐标数据优先级设为：键盘输入替代对象捕捉设置
  40.   (setvar "OSMODE" 675);;;改变捕捉模式
  41.   (if (= (tblsearch "layer" "剖面") nil) (EntmakeLayer 7 "剖面"));如果无"剖面"图层,创建
  42.   (setvar "clayer" "剖面")
  43.   (setvar "cecolor" "4")

  45.   (if (= (Tblsearch "style" "MY_ST") nil)
  46.     (command "-style" "MY_ST" "宋体" 0 0.8 0 "n" "n");;;文字样式
  47.   )  
  48.     (setvar "textstyle" "MY_ST")  
  49.    
  50.   ;输入剖面起点、终点
  51.   (command "line" (getpoint "\n指定剖面起点:") pause "");取得剖面两端点
  52.   (setq en (entlast))  
  53.   (setq pt1 (cdr(assoc 10 (entget en))))
  54.   (setq pt2 (cdr(assoc 11 (entget en))))
  55.   (command "_erase" en "")
  56.   (setq pt1 (mapcar '+ pt1 '(0 0)));转为二维点
  57.   (setq pt2 (mapcar '+ pt2 '(0 0)));转为二维点
  58.   (setq pml (distance pt1 pt2));转为二维坐标计算剖面长度
  59.   (setq pmjd (* 180.0 (/ (angle pt1 pt2) pi)));线的角度
  60.   (setvar "plinewid" (* sc 0.5));剖面线宽
  61.   (if (or
  62.     (> (abs (- pmjd 90)) 1)
  63.     (> (abs (- pmjd 270)) 1)
  64.     );如果剖面线不是近南北向
  65.     (if (> (car pt1) (car pt2))
  66.         (setq tmp pt1 pt1 pt2  pt2 tmp);两点交换，把左边点置为剖面起点
  67.       )
  68.       (if (> (cadr pt1) (cadr pt2))
  69.         (setq tmp pt1 pt1 pt2  pt2 tmp);两点交换，把南边点置为剖面起点
  70.       )
  71.   )
  72.   (setq PT3 (polar pt1 (* 0.5 PI) (* 3.0 sc));起点截止线点
  73.       pt4 (polar pt1 (* -0.5 PI) (* 3.0 sc));起点截止线点
  74.       pt_2 (polar pt1 0 pml);为方便计算，选pt1正东向一点来过渡
  75.       pt5 (polar pt_2 (* 0.5 PI) (* 3.0 sc));终点截止线点
  76.       pt6 (polar pt_2 (* -0.5 PI) (* 3.0 sc));终点截止线点
  77.   )
  78.   
  79.   ;画剖面线   
  80.   (command "pline" pt1  pt2 "");;以指定宽度多线段画剖面线
  81.   (setq pmjd (* 180.0 (/ (angle pt1 pt2) pi)));线的角度
  82.   (command "pline" pt3  pt4 "");;以指定宽度多线段起点截止线
  83.   (setq en1 (entlast))
  84.   (command "pline" pt5 pt6 "");;以指定宽度多线段画终点截止线
  85.   (setq en2 (entlast))
  86.   (command "TEXT" "J" "MR" (polar pt1 (* -1.0 PI) (* 2.0 sc)) (* 4.0 sc) 0.0 pmbh);起点文字
  87.   (setq en3 (entlast))
  88.   (command "TEXT" "J" "ML" (polar pt_2 0 (* 2.0 sc)) (* 4.0 sc) 0.0 (strcat pmbh "′"));终点文字
  89.   (setq en4 (entlast))
  90.   (command "_rotate" en1 en2 en3 en4 "" pt1 pmjd "");旋转与剖面线对齐
  91.   
  92.   ;;恢复设置
  93.     (command "_undo" "_e");;活动编组结束
  94.   (mapcar 'eval sysvarlst);恢复变量设置
  95.   (setq *error* *olderror*);;恢复出错函数
  96.     (princ)  
  97. )
  98. ;;;字符串最后1个字母分离
  99. ;;(strEndIsABC "A2") 返回("A2" nil)
  100. ;;;;(strEndIsABC "A2a") 返回("A2" "a")
  101. ;;;;(strEndIsABC "c") 返回("" "c")
  102. ;;;;(strEndIsABC "bc") 返回("b" "c")
  103. ;;;;(strEndIsABC "3.5") 返回("3.5" nil)
  104. (defun strEndIsABC (str / e len str1 str2)
  105.   (setq Len (strlen str))
  106.   (setq str1 (substr str Len 1))
  107.   (setq e (ascii str1))
  108.   (if (and (> e 64) (< e 123));判断是否字母
  109.       (list (substr str 1 (1- len)) str1)
  110.       (list str nil)
  111.   )
  112. ) ;_ 结束defunr

  114. ;;应用示例，末尾字母（仅最后一个）增减
  115. ;;如果末尾无字母，返回原字串
  116. ;;当遇A，a递减时，不论步距，递减至Z,z
  117. ;;当遇Z,z递增时，不论步距，递增至A，a
  118. ;;str, ind分别为字串，步距
  119. ;;(endABCchange "a333.5G" -2)
  120. ;;(endABCchange "4" -2)
  121. (defun endABCchange (str ind / str1)
  122.   (setq str1 (cadr(strEndIsABC str)))  
  123.   (cond
  124.     ((and(= str1 "A") (< ind 0)) (setq str1 "Z"))
  125.     ((and(= str1 "a") (< ind 0)) (setq str1 "z"))
  126.     ((and(= str1 "Z") (> ind 0)) (setq str1 "A"))
  127.     ((and(= str1 "z") (> ind 0)) (setq str1 "z"))
  128.     ((= str1 nil) (setq str1 (substr str (strlen str)1)));末尾无字母不转换
  129.     (T (setq str1 (chr (+ (ascii str1) ind))))
  130.   )
  131.   (setq str (strcat (substr str 1 (1- (strlen str))) str1))
  132. )

  134. ;;字符串与末尾数字分离,返回字符串(或nil)、末尾数字(或nil)组成的表
  135. ;;(strEndIsNumber "222")返回("" "222")
  136. ;;;(strEndIsNumber "abcd")返回("abcd" nil)
  137. ;;;(strEndIsNumber "ab2")返回("ab" "2")
  138. ;;;(strEndIsNumber "ab2.2")返回("ab" "2.2")
  139. ;;;(strEndIsNumber "3")返回("" "3")
  140. (defun strEndIsNumber (str / e len str1 str2)
  141.   (if(numberp (read str ));判断是字符串是实数或整数
  142.     (list "" str)
  143.     (progn
  144.       (setq Len (strlen str))
  145.       (setq str1 (substr str Len 1))
  146.       (setq e (ascii str1))
  147.       (while (or (= e 46)(and (> e 47) (< e 58)));判断是小数点或数字
  148.         (if str2 (setq str2 (strcat str1 str2))(setq str2 str1))
  149.         (setq str (substr str 1 (1- len)))
  150.         (setq Len (strlen str))
  151.         (setq str1 (substr str Len 1))
  152.         (setq e (ascii str1))
  153.       )
  154.       (if (null str2) (list str nil)(list str str2))  
  155.     )
  156.   )
  157. ) ;_ 结束defun
  158. ;;应用示例：末尾数字加减，如果末尾无数字，返回原字串
  159. ;;str, ind分别为字串，步距
  160. ;;(endnumchange "a3" 1)
  161. ;;(endnumchange "aa" 1)
  162. (defun endnumchange (str ind / num jd)
  163.   (setq num (cadr(strEndIsNumber str)))
  164.   (if (/= num nil)
  165.     (if (member (type (read num)) (list 'INT));判断是否是INT整数型
  166.         (setq str(strcat (car(strEndIsNumber str))(rtos (+ (atof num) ind)2 0)))
  167.         (progn
  168.           (setq jd (- (- (strlen num)1) (strlen(rtos(atoi num)2 0))));取得小数位数
  169.           (setq str(strcat (car(strEndIsNumber str))(rtos (+ (atof num) ind)2 jd)))
  170.         )
  171.      )
  172.      str
  173.     )
  174. )
  175. ;[功能]entmake 图层
  176. ;[用法](EntmakeLayer  color str)
  177. ;(setq TK (tblsearch "layer" "TK"))
  178. ;  (if (= TK nil) (EntmakeLayer 7 "TK"))
  179. ;  (setvar "clayer" "TK")
  180. (defun EntmakeLayer (color str)
  181.   (entmake (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbLayerTableRecord") '(70 . 0) '(6 . "Continuous") (cons 62 color) '(370 . 0) (cons 2 str)))
  182. )
  183. (princ)

本帖子中包含更多资源

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

x
"觉得好，就打赏"
打赏
还没有人打赏，支持一下
回复

使用道具 举报

caogis
发表于 2015-8-31 19:16:30 来自手机 | 显示全部楼层
自己编的就是好程序
回复 支持 1 反对 0

使用道具 举报

无厘崖
发表于 2021-4-1 17:09:51 | 显示全部楼层
支持楼主，代码不在乎多少，能实现既定功能就是好程序
回复 支持 反对

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码，在未取得本站及作者授权的情况下，不得用于商业用途

GMT+8, 2025-4-8 09:31 , Processed in 0.156409 second(s), 28 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表