等高線編輯的幾個(gè)程序源碼

文件名：CDGXZC.lsp
執(zhí)行命令：CDGXZC
功能：等高線層、值相符相符檢查
; =============================================
; =============================================
(defun C:CDGXZC()
(setvar "cmdecho" 0)
(if (car (atoms-family 1 '("vl-load-com"))) (vl-load-com))
(setq dgj(getreal "n 輸入等高距: "))
(setq sqx(getstring "n 輸入等高線首曲線層:"))
(setq sqxk(getreal "n 輸入首曲線寬度:"))
(setq jqx(getstring "n 輸入等高線計(jì)曲線層:"))
(setq jqxk(getreal "n 輸入計(jì)曲線寬度:"))
(setq ss (xzj sqx jqx))
(setq n (sslength ss) i 0 x 0)
(repeat n
(setq stm (ssname ss i))
(setq object(vlax-ename->vla-object stm))
(setq gcz (vla-get-Elevation object))
(setq l_with(vla-get-ConstantWidth object))
(if (= gcz 0) (vla-put-Color object 2))
(setq tc(vla-get-Layer Object))
(if (= dgj 2.5)
(progn
(setq km(rem gcz dgj)) ;; 為零對(duì)
(setq ys(rem (/ gcz dgj) 4.0)) ;; 為零計(jì)曲線
)
(PROGN
(setq km(rem gcz dgj ))
(setq ys(rem (/ gcz dgj) 5.0))
)
)
(if (/= km 0)
(progn
(vla-put-Color object 2)
(setq x 1)
)
)
(if (and (= ys 0) (= tc sqx))
(progn
(vla-put-Color object 2)
(setq x 1)
)
)
(if (and (/= ys 0) (= tc jqx))
(progn
(vla-put-Color object 2)
(setq x 1)
)
)
(setq i(+ 1 i))
)
(vlax-release-object object)
(if (= x 0) (alert "等高線層、值都相符"))
(setq kk (ssget "x" (list '(-4 . "<AND")
'(-4 . "<OR")
(cons 8 sqx)
(cons 8 jqx)
'(-4 . "OR>")
(cons 62 2)
'(-4 . "AND>")
)))
(if kk
(alert (strcat "圖內(nèi)共有" (itoa(sslength kk)) "根曲線層、值不符，注意查改!" ))
)
(setq stm nil dgj nil km nil ys nil kk nil xx nil xxx nil)
(setvar "cmdecho" 1)
)
(defun xzj(lay1 lay2)
(ssget "x" (list
'(-4 . "<AND")
'(-4 . "<OR")
(cons 0 "lwpolyline")
(cons 0 "polyline")
'(-4 . "OR>")
'(-4 . "<OR")
(cons 8 lay1)
(cons 8 lay2)
'(-4 . "OR>")
'(-4 . "AND>")
))
)

文件名：dgxfgc.lsp
執(zhí)行命令：DGXF
功能：根據(jù)第一根等高線賦高程
; =============================================
; | 根據(jù)第一根等高線賦高程 |
; | 版本: V1.1 作者: 金德海 |
; | E_mail jdhszh@163.com |
; =============================================
(defun C:DGXF( / w s z g1 g2 tp1 tp2 ss1)
(setvar "cmdecho" 0)
(if (car (atoms-family 1 '("vl-load-com"))) (vl-load-com))
(command "undo" "be")
(setq w(getvar "userr1"))
(if (= w 0)
(progn
(setq w(getreal "n輸入等高距: "))
(setvar "userr1" w)
(setq w(getvar "userr1"))
)
)
(initget "g d")
(setq qc_flags (getkword "nG<往高處>/D<往低處>:<G>"))
(if (eq qc_flags nil)
(setq qc_flags "g")
)
(if (eq qc_flags "g")
(princ)
)
(if (eq qc_flags "d")
(setq w(- 0 w))
)
(setq th(entsel "n選有值線:"))
(if th (gele (car th)) (setq elev(getreal "n沒(méi)選到!請(qǐng)輸入基線高程值: ")))
(setq tp1 (getpoint "n指定第一點(diǎn):"))
(setq tp2 (getpoint "n指定第二點(diǎn):"))
(setq plist (list tp1 tp2))
(setq S (ssget "F" plist ))
(if s
(progn
(setq a 0)
(repeat (sslength s)
(setq z (setq ss1(ssname s a)))
(setq g1(+ elev (* w a) w))
(pele z g1)
;(setq g2(cons 38 g1))
;(entmod (subst g2 (assoc '38 z) z))
(if (= (abs w) 2.5) (setq g3(rem (/ g1 w) 4)))
(if (/= (abs w) 2.5) (setq g3(rem (/ g1 w) 5)))
(if (= g3 0) (pcolor 1))
(if (or (= g3 1) (= g3 -1))(pcolor 2))
(if (or (= g3 2) (= g3 -2))(pcolor 3))
(if (or (= g3 3) (= g3 -3))(pcolor 4))
(if (or (= g3 4) (= g3 -4))(pcolor 5))
(setq a (1+ a ))
)
(princ "n ")
(princ "最后一線值" )
(princ g1)
(princ)
(command "undo" "e")
)(princ "n sorry 你沒(méi)選到等高線!"))
(setvar "cmdecho" 1)
)
;;
(defun gele(name-lsp)
(setq vlaobject-name (vlax-ename->vla-object name-lsp))
(setq elev (vla-get-Elevation vlaobject-name));;高程
(vlax-release-object vlaobject-name)
)
(defun pele(name-lsp elev)
(setq vlaobject-name (vlax-ename->vla-object name-lsp))
(vla-put-Elevation vlaobject-name elev) ;;寫入高程
)
(defun pcolor(n)
(vla-put-Color vlaobject-name n)
(vlax-release-object vlaobject-name)
)

文件名：GCFS.lsp
執(zhí)行命令：GCFS
功能：高程分色
; =============================================
; | 高程分色 |
; | 版本: V1.1 作者: 金德海 |
; | E_mail jdhszh@163.com |
; =============================================
(defun C:GCFS(/ LAY ss name a)
(if (car (atoms-family 1 '("vl-load-com"))) (vl-load-com))
(setq lay(getstring "n輸入等高線所在層<支持統(tǒng)配符*>:"))
(IF dg_j (princ) (setq dg_j(getreal "n輸入等高距: ")))
(setq ss(ssget "x" (list (cons 8 lay)(cons 0 "LWPOLYLINE"))))
(setq a 0)
(repeat (sslength ss)
(setq name(ssname ss a))
(gelve name)
(if (= (abs dg_j) 2.5) (setq g3(rem (/ elev dg_j) 4)))
(if (/= (abs dg_j) 2.5) (setq g3(rem (/ elev dg_j) 5)))
(if (= g3 0) (pcolor 1))
(if (or (= g3 1) (= g3 -1))(pcolor 2))
(if (or (= g3 2) (= g3 -2))(pcolor 3))
(if (or (= g3 3) (= g3 -3))(pcolor 4))
(if (or (= g3 4) (= g3 -4))(pcolor 5))
(if (and (/= g3 1) (/= g3 2) (/= g3 3) (/= g3 0) (/= g3 4)) (pcolor 8))
(setq a (1+ a ))
)
)
(defun gelve(name-lsp)
(setq vlaobject-name (vlax-ename->vla-object name-lsp))
(setq elev (vla-get-Elevation vlaobject-name));;高程
)
;;
(defun pcolor(n)
(vla-put-Color vlaobject-name n)
(vlax-release-object vlaobject-name)
)