文字延直線方向的lisp程序
作者：dlcms 瀏覽量：1652 次 發(fā)布時間：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) '()));;將直線轉(zhuǎn)換為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) '()));;將直線轉(zhuǎn)換為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)
)
相關(guān)閱讀：
- 四川省房產(chǎn)測繪實施細(xì)則 (2017-12-01)
- 關(guān)于縣（市）級土地調(diào)查數(shù)據(jù)庫管理系統(tǒng)軟件測評結(jié)果（第一批）的公告 (2018-03-22)
- 南方cass各種計算土方 (2017-12-01)
- 常見GIS工具軟件介紹 (2017-12-04)
- 在服務(wù)性能方面，北斗二號已與GPS旗鼓相當(dāng) (2019-12-09)
