动态建筑符号的【正交】程式摸索？
本帖最后由 尘缘一生 于 2018-2-4 18:33 编辑自己写的“动态折断线”，
很遗憾，在扯动中不能使用“正交”，如何完善修改呢？
(defun c:ZDX(/ pt1 pt2 pt3 pt4 pt5 pt6 pt7 ang dis gr n %k i)
(setq pt1 (getpoint "\ngive the left point:"))
(setq %k t) ;循环条件
(setq i nil);初始设置）
(while %k
(setq gr (grread t 4 0);;取得鼠标操作及坐标
n (car gr) ;;鼠标操作
pt2 (cadr gr) ;;鼠标坐标
)
(if (= n 5) ;;没有操作
(progn
(if (/= i nil)
(entdel i)
);;如果有过度实体就删除
(setq ang (angle pt1 pt2))
(setq dis (distance pt1 pt2))
(setq pt3 (polar pt1 ang (/ dis 2)))
(setq pt4 (polar pt1 ang (- (/ dis 2) 1.3)))
(setq pt5 (polar pt3 (+ ang (/ pi 2)) 3.5))
(setq pt6 (polar pt3 (- ang (/ pi 2)) 3.5))
(setq pt7 (polar pt1 ang (+ (/ dis 2) 1.3)))
(entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '
(90 . 5) (cons 10 pt1) (cons 10 pt4) (cons 10 pt5) (cons 10 pt6)
(cons 10 pt7) (cons 10 pt2)
)
)
(setq i (entlast));;得到过度实体名
)
)
(if (= n 3)
(setq %k nil)
);;3表示左键;结束循环
(if (or
(= n 2)
(= n 25)
);;2表示空格;25表示右键;结束循环
(progn
(setq %k nil)
(entdel i)
)
)
)
(print)
)
总之：需要有正交功能的grread函数，谁有提供吗？非源码请绕行。
本帖最后由 尘缘一生 于 2018-2-5 22:04 编辑
总结本帖：
建筑符号，已写完全，他们是：
1：折断线 ZDX
2:双折断线 ZDX1
3:箭头 JT
4：对称符号 duichen
特点：
grread方式且支持正交切换。
程序说明：
程序内部进行了角度改写，已避免双折断线时线条交叉；
程序适合PKPM系列，对于天正系列1:1画图来说，修改很简单，或者在实用中，把天正图纸缩小0.01倍即可
源码程序如下：
本帖最后由 尘缘一生 于 2018-2-4 09:41 编辑
终于实现了正交：程序“扑捉”部分功能暂时去掉了，经试验，不完善。
(defun c:ZDX-1 (/ pt1 pt2 ennext ang gr grr z)
(setq pt1 (getpoint "\n给出起点？give the first point:"))
(setq f8(getvar 'ORTHOMODE))
(setvar 'cmdecho 0)
(setq z t)
(while z
(setq grr (grread t ));请求输入
(setq gr(car grr) pt2 (cadr grr))
(cond
((equal grr '(2 15));F8切换正交开关
(if (= f8 0)
(progn(setq f8 1)(prompt "\n<正交 开>"))
(progn(setq f8 0)(prompt "\n<正交 关>"))
)
(setvar 'orthomode f8)(redraw)
)
((= gr 5);移动时
(cond ((= f8 1);正交打开时
(setq ang (atoi (angtos (angle pt1 pt2))))
(if(> ang 315)(setq ang (- 360 ang)))
(cond ((and (< ang 45) (> ang -45))
(setq pt (list (car pt2) (cadr pt1)))
)
((and (< ang 135) (> ang 45))
(setq pt (list (car pt1) (cadr pt2)))
)
((and (< ang 225) (> ang 135))
(setq pt (list (car pt2) (cadr pt1)))
)
((and (< ang 315) (> ang 225))
(setq pt (list (car pt1) (cadr pt2)))
)
)
)
((= f8 0)(setq pt pt2));正交关闭时
)
(entmake-zdx);生成引线|;
)
((= gr 3);左击
(setq z nil)
)
((or(equal grr '(2 32));空格
(equal grr '(2 13));回车
(equal grr'(11 0));右击
)
(setq z nil)
)
)
)
(redraw)
(setvar 'cmdecho 1)
(princ)
)
;;;
(defun entmake-zdx(/ ang dis pt3 pt4 pt5 pt6 pt7);;;生成折断线
(if ennext (entdel ennext));;删除上次画的线
(setq ang (angle pt1 pt))
(setq dis (distance pt1 pt))
(setq pt3 (polar pt1 ang (/ dis 2)))
(setq pt4 (polar pt1 ang (- (/ dis 2) 1.3)))
(setq pt5 (polar pt3 (+ ang (/ pi 2)) 3.5))
(setq pt6 (polar pt3 (- ang (/ pi 2)) 3.5))
(setq pt7 (polar pt1 ang (+ (/ dis 2) 1.3)))
(entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '
(90 . 5) (cons 10 pt1) (cons 10 pt4) (cons 10 pt5) (cons 10 pt6)
(cons 10 pt7) (cons 10 pt)
)
)
(setq ennext (entlast));;提取刚划的线
)
本帖最后由 尘缘一生 于 2018-2-5 18:51 编辑
应用实例：
两个命令：折断线；箭头
发过来，立春了，给论坛拜年，更有两点期望：
1：线性建筑符号，还有：对称符号；双折断线等，希望谁能编出来下，按这种办法编写，基本就是高仿PKPM的，很实用。
2：下面这个应用实例，整合的自以为很不好，不知道谁能改写，整合好一些呢？
(defun C:JT-2();;;画箭头符号，支持正交
(jzfh 2)
)
(defun C:ZDX-2();;;;画折断线符号，支持正交
(jzfh 1)
)
(defun jzfh (k / ennext pt1 pt2 ang gr grr z)
(setq pt1 (getpoint "\n给出起点？give the first point:"))
(setq f8(getvar 'ORTHOMODE))
(setvar 'cmdecho 0)
(setq z t)
(while z
(setq grr (grread t ));请求输入
(setq gr(car grr) pt2 (cadr grr))
(cond
((equal grr '(2 15));F8切换正交开关
(if (= f8 0)
(progn(setq f8 1)(prompt "\n<正交 开>"))
(progn(setq f8 0)(prompt "\n<正交 关>"))
)
(setvar 'orthomode f8)(redraw)
)
((= gr 5);移动时
(cond ((= f8 1);正交打开时
(setq ang (atoi (angtos (angle pt1 pt2))))
(if(> ang 315)(setq ang (- 360 ang)))
(cond ((and (< ang 45) (> ang -45))
(setq pt (list (car pt2) (cadr pt1)))
)
((and (< ang 135) (> ang 45))
(setq pt (list (car pt1) (cadr pt2)))
)
((and (< ang 225) (> ang 135))
(setq pt (list (car pt2) (cadr pt1)))
)
((and (< ang 315) (> ang 225))
(setq pt (list (car pt1) (cadr pt2)))
)
)
)
((= f8 0)(setq pt pt2));正交关闭时
)
(if (= k 1)
(progn
;;;(command "LAYER" "S" "MM" "")
(if ennext (entdel ennext));;删除上次画的实体
(entmake-zdx);生成折断线|;
(setq ennext (entlast));;提取刚画的实体
;;;(command "LAYER" "S" "0SX" "")
)
)
(if (= k 2)
(progn
;;;(command "LAYER" "S" "MM" "")
(entmake-jt);生成箭头|;
;;;(command "LAYER" "S" "0SX" "")
)
)
)
((= gr 3);左击
(setq z nil)
)
((or(equal grr '(2 32));空格
(equal grr '(2 13));回车
(equal grr'(11 0));右击
)
(setq z nil)
)
)
)
(redraw)
(setvar 'cmdecho 1)
(princ)
)
;;;
(defun entmake-zdx(/ ang dis pt3 pt4 pt5 pt6 pt7);;;生成折断线
(setq ang (angle pt1 pt))
(setq dis (distance pt1 pt))
(setq pt3 (polar pt1 ang (/ dis 2)))
(setq pt4 (polar pt1 ang (- (/ dis 2) 1.3)))
(setq pt5 (polar pt3 (+ ang (/ pi 2)) 3.5))
(setq pt6 (polar pt3 (- ang (/ pi 2)) 3.5))
(setq pt7 (polar pt1 ang (+ (/ dis 2) 1.3)))
(entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '
(90 . 5) (cons 10 pt1) (cons 10 pt4) (cons 10 pt5) (cons 10 pt6)
(cons 10 pt7) (cons 10 pt)
)
)
)
;;;;;
(defun entmake-jt(/ ang dis pt3 pt4);;;生成箭头
(if ennext (progn
(entdel(ssnameennext0))
(entdel(ssnameennext1))
)
);;删除上次画的实体
(setq ang (angle pt1 pt))
(setq dis (distance pt1 pt))
(setq pt3 (polar pt (- (+ pi ang) 0.25) 5))
(setq pt4 (polar pt (- 0.0 (- (- pi ang) 0.25)) 5))
(entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '
(90 . 5) (cons 10 pt1) (cons 10 pt) (cons 10 pt3)
)
)
(setq ennext(ssadd))
(ssadd (entlast) ennext)
(entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '
(90 . 5) (cons 10 pt) (cons 10 pt4)
)
)
(ssadd (entlast) ennext)
)
谢谢楼主分享。程序中的折线对我来说比较小，我给改大了。另外又加了一条折线。
下载链接见：
演示动画见：
一？？？？？
学习，学习！研究一下！ 下载学习,感谢分享!!!!!!
页:
[1]