自用房地一体上图快捷键，工具及源码分享给大家

lang851 · 发表于 2020-8-19 08:50

#1混房命令 HF(defun c:HF () (command "DD" "141161") (princ) )#2砖房命令 ZF(defun c:ZF () (command "DD" "141121") (princ) )#3一般房屋命令 YB(defun c:YB () (command "DD" "141101") (princ) )#4棚房房屋命令 PF(defun c

F () (command "DD" "141500") (princ) )#5复制命令 Q(defun c

() (command "copy") (princ) )#6偏移命令 D(defun c

() (command "offset") (princ) )#7构造线命令 1(defun c:1 () (command "xline") (princ) )#8测量命令 2(defun c:2 () (command "distuser") (princ) )#9檐廊命令 YL(defun c:YL () (command "DD" "143130") (princ) )#10门顶命令 MD(defun c:MD () (command "DD" "143800") (princ) )#11刷新屏幕命令 3(defun c:3 () (command "regen") (princ) )#12楼梯命令 LT(defun c

T () (command "DD" "143400") (princ) )#13保存命令 P(defun c:P () (command "qsave") (princ)  )
#14修改建筑物属性命令 5(defun c:5 () (command "JZWXX") (princ)  )#15搜索命令 6(defun c:6 () (command "FIND") (princ)  )
#16重展房屋注记命令 4(defun c:4 () (command "REGENBUILDTEXT") (princ)  )
#16标注边长命令 BZ(defun c:BZ();边长注记  (setq os(getvar  "osmode" ))(setvar "osmode" 0)  (setq sskent(ssget '((0 . "lwpolyline"))))  (setq ssl(sslength sskent))  (setq i 0)  (command "style"  "宋体"  "STSONG.TTF" "0.3"  "1" "0" "n" "n" );;;  (setq num (getint "请键入一个数字："))  (while (< i ssl ) (setq ssn(ssname sskent i)) (tqjl ssn )  (setq i(1+ i) )) (setvar "osmode" os)  ) ;;;);;;)    (princ) ;1if

(defun  tqjl(ssn);提取距离  (setq n 0)  (setq y 0);;;  (setq li10 nil)  (setq li1 nil li2 nil)  (setq li0 nil)  ;;;(setq ssn(ssname ss i))(setq ssdata(entget ssn))
         (repeat (- (length ssdata) 1);提取多段线顶点列表             (setq tmp (car (nth n ssdata)))          (cond          ((= tmp 10)(progn ;(setq li10(nth n ssdata))               (setq li1(cdr(nth n ssdata)))       (if (= li0 nil )       (setq li0 li1)       )       (if (/= li2 nil)       (progn       (setq sjl(rtos (distance li1 li2)  2 2))       (setq hd(angle li2 li1))       (if (and (> hd 1.5708  )(< hd 6.26))(setq hd( + hd 3.14159)));;;       (if (and (> (- hd 1.5708)0)(< (- hd 3.14159)0)) (setq hd(+ hd 3.14159)))       (setq jd(angtos hd 0 4))               (setq zd(mapcar '/ (mapcar '+ li1 li2) '(2 2 2)))       (command "text"  "j" "bc" zd jd sjl)       )                )       (setq li2(cdr(nth n ssdata)));;;    (setq li10 (append (list (nth n ssdata)) li10)));找到顶点就添加进列表;;;                            (setq s (strcat "pt" "," (rtos (nth 1 li10) 2 3) "," (rtos (nth 2 li10) 2 3))));;;          (write-line s ff);;;       (if (> n (- (length ssdata)3));;;       (progn;;;       (setq sjl(rtos (* (distance li0 li1) 0.4) 2 2));;;       (setq jd(angtos (angle li0 li1)0 4));;;       (setq zd(mapcar '/ (mapcar '+ li0 li1) '(2 2 2)));;;       (command "text"  "j" "bc" zd "0" jd sjl);;;       );;;       )       (setq y (1+ y))          )))                                          (setq n (1+ n))    )          (if (AND (> y 2) (>= (cdr(ASSOC  70 SSDATA )) 128))          (progn       (setq sjl(rtos  (distance li0 li1) 2 2))                   (setq hd(angle li1 li0));;;                      (if (> (- hd 3.14159)0) (setq hd(+ hd 3.14159)))       (setq jd(angtos hd 0 4))                (setq zd(mapcar '/ (mapcar '+ li0 li1) '(2 2 2)))                            (command "text"  "j" "bc" zd jd sjl)       ))  ;;;    (setq sjl1(cdr(car li10)));;;    (setq sjl2(cdr(cadr li10)));;; (setq sjll(distance sjl1 sjl2))       ;;; (setq i(1+ i))  )(princ)

passgive · 发表于 2020-8-19 09:50

谢谢分享！

zqc0705 · 发表于 2020-8-20 09:53

好东西，必须赞

天空~3 · 发表于 2020-8-21 07:54

虽然你提供了插件，但是你这个有点搞不懂，混乱不堪。启动命令啥的都没有。

lang851 · 发表于 2020-8-22 00:35

天空~3 发表于 2020-8-21 07:54
虽然你提供了插件，但是你这个有点搞不懂，混乱不堪。启动命令啥的都没有。

appload加载，只是快捷键，不需要启动命令。

youshijie1 · 发表于 2020-8-29 10:19

看不懂后面尺寸标注还有就是用了尺寸标注命令后出来text是什么原因

lang851 · 发表于 2020-8-29 19:00

youshijie1 发表于 2020-8-29 10:19
看不懂后面尺寸标注还有就是用了尺寸标注命令后出来text是什么原因

这个我也不太明白，我还没遇到过

youshijie1 · 发表于 2020-8-30 15:24

你自己的你不知道?

lang851 · 发表于 2020-8-30 15:40

youshijie1 发表于 2020-8-30 15:24
你自己的你不知道?

自用，都是网上搜集来的。

qiaomulin · 发表于 2020-11-5 17:44

学习学习

[技术交流] 自用房地一体上图快捷键，工具及源码分享给大家

相关帖子

地信元老

地信专家组

名人堂勋章

灌水勋章

宣传勋章