文字延直线方向的lisp程序
作者：dlcms 浏览量：1639 次 发布时间：2017-12-25 03:50:57
(VL-Load-Com)
(defun c:ttt(/ Pt Pt1 Pt2 EntLine HandTxt VlaObj Tmp)
(setq Pt1 (getpoint "n指定第一点:"))
(setq Pt2 (getpoint "n指定下一点:"))
(setq Pt (list (/ (+ (car Pt1) (car Pt2)) 2) (/ (+ (cadr Pt1) (cadr Pt2)) 2) (/ (+ (caddr Pt1) (caddr Pt2)) 2)))
(command "._Line" Pt1 Pt2 "")
(setq EntLine (entlast))
(setq VlaObj (cons (VLAX-EName->VLA-Object EntLine) '()));;将直线转换为VLA对象
(setq HandTxt '((0 . "TEXT"))
HandTxt (append HandTxt (list (append '(10) Pt1)))
HandTxt (append HandTxt (list (append '(11) Pt)))
HandTxt (append HandTxt (list (cons 40 (getdist "n指定高度:"))))
HandTxt (append HandTxt (list (cons 72 1)))
HandTxt (append HandTxt (list (cons 73 0)))
HandTxt (append HandTxt (list (cons 50 (angle pt1 Pt2))))
HandTxt (append HandTxt (list (cons 1 (getstring "n输入文字:>")))))
(entmake HandTxt)
(setq HandTxt (cdr (Assoc 5 (entget (entlast)))))
(VLR-Pers (VLR-Object-Reactor vlaObj HandTxt '((:vlr-modified . LineModefy))))
)
(defun LineModefy(EntLine EntTxt parameter-list / Pt Pt1 Pt2)
(setq EntTxt (entget (HandEnt (VLR-Data EntTxt))))
(setq EntLine (entget (VLAX-VLA-Object->EName EntLine)))
(setq Pt1 (cdr (assoc 10 EntLine)) Pt2 (cdr (assoc 11 EntLine)))
(setq Pt (list (/ (+ (car Pt1) (car Pt2)) 2) (/ (+ (cadr Pt1) (cadr Pt2)) 2) (/ (+ (caddr Pt1) (caddr Pt2)) 2)))
(setq EntTxt (subst (cons 50 (angle Pt1 Pt2)) (assoc 50 EntTxt) EntTxt)
EntTxt (subst (append '(10) Pt1) (assoc 10 EntTxt) EntTxt)
EntTxt (subst (append '(11) Pt) (assoc 11 EntTxt) EntTxt))
(entmod EntTxt)
)
(defun c:ttt(/ Pt Pt1 Pt2 EntLine HandTxt VlaObj Tmp)
(setq Pt1 (getpoint "n指定第一点:"))
(setq Pt2 (getpoint "n指定下一点:"))
(setq Pt (list (/ (+ (car Pt1) (car Pt2)) 2) (/ (+ (cadr Pt1) (cadr Pt2)) 2) (/ (+ (caddr Pt1) (caddr Pt2)) 2)))
(command "._Line" Pt1 Pt2 "")
(setq EntLine (entlast))
(setq VlaObj (cons (VLAX-EName->VLA-Object EntLine) '()));;将直线转换为VLA对象
(setq HandTxt '((0 . "TEXT"))
HandTxt (append HandTxt (list (append '(10) Pt1)))
HandTxt (append HandTxt (list (append '(11) Pt)))
HandTxt (append HandTxt (list (cons 40 (getdist "n指定高度:"))))
HandTxt (append HandTxt (list (cons 72 1)))
HandTxt (append HandTxt (list (cons 73 0)))
HandTxt (append HandTxt (list (cons 50 (angle pt1 Pt2))))
HandTxt (append HandTxt (list (cons 1 (getstring "n输入文字:>")))))
(entmake HandTxt)
(setq HandTxt (cdr (Assoc 5 (entget (entlast)))))
(VLR-Pers (VLR-Object-Reactor vlaObj HandTxt '((:vlr-modified . LineModefy))))
)
(defun LineModefy(EntLine EntTxt parameter-list / Pt Pt1 Pt2)
(setq EntTxt (entget (HandEnt (VLR-Data EntTxt))))
(setq EntLine (entget (VLAX-VLA-Object->EName EntLine)))
(setq Pt1 (cdr (assoc 10 EntLine)) Pt2 (cdr (assoc 11 EntLine)))
(setq Pt (list (/ (+ (car Pt1) (car Pt2)) 2) (/ (+ (cadr Pt1) (cadr Pt2)) 2) (/ (+ (caddr Pt1) (caddr Pt2)) 2)))
(setq EntTxt (subst (cons 50 (angle Pt1 Pt2)) (assoc 50 EntTxt) EntTxt)
EntTxt (subst (append '(10) Pt1) (assoc 10 EntTxt) EntTxt)
EntTxt (subst (append '(11) Pt) (assoc 11 EntTxt) EntTxt))
(entmod EntTxt)
)
上一篇：Lisp 连续标注
下一篇：测绘与地理信息国家及行业标准大全
相关阅读：
- 四川省房产测绘实施细则 (2017-12-01)
- 关于县（市）级土地调查数据库管理系统软件测评结果（第一批）的公告 (2018-03-22)
- 常见GIS工具软件介绍 (2017-12-04)
- 南方cass各种计算土方 (2017-12-01)
- 在服务性能方面，北斗二号已与GPS旗鼓相当 (2019-12-09)
