本程序的功能：根据指定的坐标范围，计算所有处于该范围及相交于该范围边缘的将外部标准图幅的地形图，以块的形式按绝对坐标插入在当前指定图中。
包含的功能：指定外部标准图幅的地形图存放的路径，编制图幅对照表
定制界面：
dlgdxtsslj : dialog {label = "数字图路径 [创建于2003.8]";
: boxed_column {label = "";fixed_width = true;
: row {
: concatenation {: text_part {label = "顺序号:";}: text_part {key = "select_num"; width = 5;fixed_width = true;}}
: concatenation {: text_part {label = "列表共:";}: text_part {key = "sum"; width = 5;fixed_width = true;}}
}
: list_box {key = "pathlist";width = 50;height = 15;
tabs = "12";tab_truncate = true;
}
: row {
: button {label = "增加";key = "add";}
: button {label = "修改";key = "edit";}
: button {label = "删除";key = "remove";}
}
: row {
: concatenation {: text_part {label = "路径:";}: text_part {key = "path"; width = 25;}}
: button {key = "selpath";fixed_width = true;label = "浏览...";}
}
}
spacer;
ok_cancel;
errtile;
}
dlgcreatb : dialog {label = "图幅对照表 [创建于2003.8]";
: boxed_column {label = "";fixed_width = true;
: row {
: concatenation {: text_part {label = "顺序号:";}: text_part {key = "select_num"; width = 5;fixed_width = true;}}
: concatenation {: text_part {label = "列表共:";}: text_part {key = "sum"; width = 5;fixed_width = true;}}
}
: list_box {key = "thlist";width = 50;height = 15;
tabs = "10 25";tab_truncate = true;
}
: row {
: button {label = "增加";key = "add";}
: button {label = "修改";key = "edit";}
: button {label = "删除";key = "remove";}
}
: row {
: edit_box {label = "图幅图号";key = "th";}
: button {label = "点取<";key = "pick";}
}
: boxed_row {label = "左下角坐标";
: edit_box {label = "X=";key = "x";}
: edit_box {label = "Y=";key = "y";}
}
: edit_box {label = "图幅图名";key = "tm";}
}
spacer;
ok_cancel;
errtile;
}
住程序
;RFileName 文件名.当RFileName=nil时RFileName为当前工作图的文件名
;RFileExName 后缀名
(defun ReadSetData (HeadList RFileName RFileExName / Readfile $a $b $c $d $l $exit dwg_flname dwg_flpath)
; (if RFileExName (progn
(if (not RFileName)
(setq dwg_flname (getvar "dwgname") dwg_flpath (getvar "dwgprefix")
$a (substr dwg_flname 1 (- (strlen dwg_flname) 4))
Readfile (strcat dwg_flpath $a "." RFileExName)
)
(if (wcmatch RFileName "*`.*")
(setq Readfile RFileName RFileName (car (fg RFileName '(".") nil)))
(if (and RFileExName (/= "" RFileExName))
(setq Readfile (strcat RFileName "." RFileExName))
)
)
)(princ Readfile)
(if (setq Readfile (findfile Readfile))(progn
(if (setq $a (open Readfile "r"))(progn
(foreach $b headlist
(setq headlist (subst (strcase $b) $b headlist))
)
(while (and (not $exit) (setq $b (read-line $a)))
(if (and (/= "" $b) (not (wcmatch $b ";*")))(progn
(setq $b (fg $b '("=") nil) $b (subst (strcase (car $b)) (car $b) $b)) ;改为大写
(if (not headlist)
(setq $l (cons $b $l))
(progn
(if (member (car $b) headlist)(setq $l (cons $b $l)))
(if (and $l (= (length $l) (length headlist)))(setq $exit t))
)
)
))
)
(setq $l (reverse $l)
)
(close $a)
)) ;(if (findfile readfile)(progn
))
; ))
$l
)
;当不存在当前要写入的WFileExName后缀文件时,先找到FFileExName后缀的文件所在的位置后在该位置创建新的要写入的文件.
(defun CoverSetData (coverlist WFileName WFileExName FFileExName / Wfile $a $b $c $d $l dwg_flname dwg_flpath)
(foreach $b coverlist ;改大写
(cond
((not (car $b))(setq $c nil))
((not (cadr $b))(setq $c (list (car $b) "")))
((and (car $b) (cadr $b))(setq $c (list (strcase (car $b)) (strcase (cadr $b)))))
(t (setq $c nil))
)
(if $c (setq coverlist (subst $c $b coverlist)))
)
; (if (and WFileExName (/= "" WFileExName)) (progn
(if (not WFileName)
(setq dwg_flname (getvar "dwgname") dwg_flpath (getvar "dwgprefix")
WFileName (substr dwg_flname 1 (- (strlen dwg_flname) 4))
WFileName (strcat dwg_flpath WFileName)
Wfile (strcat WFileName "." WFileExName)
)
(if (wcmatch WFileName "*`.*")
(setq Wfile WFileName WFileName (car (fg WFileName '(".") nil)))
(if (and WFileExName (/= "" WFileExName))
(setq Wfile (strcat WFileName "." WFileExName))
)
)
)
; (foreach $b coverlist ;改大写
; (setq coverlist (subst (list (strcase (car $b)) (strcase (cadr $b))) $b coverlist))
; )
(princ Wfile)
(if (not (setq Wfile (findfile Wfile)))
(if (and FFileExName (setq $a (findfile (strcat WFileName "." FFileExName))))
(setq Wfile (strcat (substr $a 1 (- (strlen $a) (strlen FFileExName))) WFileExName))
)
;;; (if (setq $a (open Wfile "r"))(progn
;;; (while (and (setq $b (read-line $a)) $b (/= "" $b))
;;; (setq $b (fg $b '("=") nil)
;;; $b (subst (strcase (car $b)) (car $b) $b)
;;; $l (cons $b $l)
;;; )
;;; )(setq $l (reverse $l))
;;; (close $a)
;;; ))
)
(if Wfile
(if (setq $a (open Wfile "w"))(progn
(foreach $b $l (progn
(if (setq $c (assoc (car $b) coverlist))
(setq $b $c
coverlist (append (reverse (cdr (member $b (reverse coverlist))))
(cdr (member $b coverlist))
) )
)
(if (not (cadr $b))(setq $b (append $b (list ""))))
(write-line (strcat (car $b) "=" (cadr $b)) $a)
))
(foreach $b coverlist
(if (not (cadr $b))(setq $b (append $b (list ""))))
(write-line (strcat (car $b) "=" (cadr $b)) $a)
)
(close $a)
))
)
; ))
)
;;;----------------fg------------------------------------------
;;;待分隔的字符串strsourse,分隔符列表fg_code_list,是否返回为空字符串null_count
;;;注意:该程序无法分隔"~"字符
(defun fg (strsourse fg_code_list null_count / li lj p1 lcount la1 la2 la3 la4 new_list intrue jamp1)
(setq li 1 p1 1 lcount 0)
(if (and strsourse fg_code_list)(progn
(while (>= (strlen strsourse) li)
(setq lj -1 intrue nil jamp1 1)
(while (and (< (setq lj (1+ lj)) (length fg_code_list)) (not intrue))
(setq la2 (- (strlen strsourse) lj) la3 (nth lj fg_code_list) la4 (strlen la3))
(if (>= la2 la4) (progn
(setq la (substr strsourse li la4))
(if (setq intrue (or (wcmatch la la3) (= la la3)))
(setq jamp1 la4)
) ))) ;(while
(if intrue (progn ; 分隔
(setq lcount (1+ lcount) la1 (substr strsourse p1 (- li p1)))
(if (= "" la1)
(if null_count (setq new_list (cons la1 new_list)))
(setq new_list (cons la1 new_list))
) (setq p1 (+ jamp1 li))
) ) (setq li (+ jamp1 li))
) ;while
(if (or (/= 0 lcount) (/= (1- li) (strlen strsourse)))
(progn
(setq la1 (substr strsourse p1 (- li p1)))
(if (/= "" la1)(setq new_list (cons la1 new_list)))
)(setq new_list (cons strsourse new_list))
)
))
(reverse new_list)
)
;;;增加功能:可用窗口选定
(defun xzdxt_sx ( / _x _y _x1 _y1 _p _mm _r _i _a _b _c _cq _ch _tfbh _n oldp wp2)
;1.根据坐标点定位地形图图名
;2.根据图幅编号定位地形图图名
;3.输入图名
(setq _r t)
(initget "N")
(if (setq _p (getpoint "\n输入数字地形图内一个点:[N--图名]"))(progn
(setq _mm _p)
(cond
((= "N" _p)
(if (setq _n (getstring "\n输入数字地形图的图名(不带扩展名):"))
(setq _r (assoc _n DZBList))
(setq _r nil) ;is null
)
)
(t
(setq _x (car _p) _y (cadr _p) oldp _p
_x (* 500 (fix (/ _x 500)))
_y (* 500 (fix (/ _y 500)))
_i -1
)
(while (and (setq _r (nth (setq _i (1+ _i)) DZBList))
(not (member (list _x _y) _r))
)
)
(if (not _r) (setq _r (list nil (list _x _y) nil)))
) ;t
) ;cond
)(setq _r nil)) ; if
_r
)
(defun c:ddxt( / a re _point _name xzdxt_path DZBList pathlist
readXZDXT findXZDXT
);调入数字地形图
(defun readXZDXT ( / a b)
(setq a (ReadSetData nil "ddxt" "pth"))
(foreach b a
(if (and (or (= (car b) "XZDXT1000-PATH")
(wcmatch (car b) "XZDXT1000-PATH#")
(wcmatch (car b) "XZDXT1000-PATH##")
)
(not (member (cadr b) pathlist))
)
(setq pathlist (cons (cadr b) pathlist))
)
)
(setq pathlist (reverse pathlist))
)
(defun findXZDXT (name / a k)
(setq k 0 xzdxt_path nil)
(while (and (not xzdxt_path)
(setq a (nth k pathlist))
)
(if (findfile (strcat a name)) (setq xzdxt_path a))
(setq k (1+ k))
)
)
(reaDZB)
(if (not pathlist)(readXZDXT))
(setvar "cmdecho" 0)
(princ "\n调数字地形图. [创建于2003.8]")
(while (setq re (xzdxt_sx)) (progn
(if (setq _name (nth 0 re))(progn
(if (ssget "x" (list (cons 0 "INSERT") (cons 2 _name)))
(alert (strcat "\n图名为" _name "数字地形图已经调入过."))
(progn
(setq _name (strcat _name ".dwg"))
(findXZDXT _name)
(princ xzdxt_path)
(if xzdxt_path
(progn
(command "_insert" (strcat xzdxt_path _name) "0,0,0" "" "" "")
)
(alert (strcat "无法定位该点对应的这张数字地形图:\t\n\t" _name "\n\n可能超出数字地形图范围!"))
))
)
)(alert "无当前图幅数字地形图.\n\n可能超出数字地形图范围!"))
)) ;if
(setvar "cmdecho" 1)
(princ)
)
(defun reaDZB ( / a b c)
(setq DZBList (ReadSetData nil "图名与坐标对照表" "txt"))
(foreach b DZBList
(SETQ c (fg (cadr b) '(",") t)
DZBList (subst (list (car b) (list (atoi (cadr c)) (atoi (car c))) (caddr c)) b DZBList)
)
)
)
(defun chaxun (havereturn / @return @point @name @tfbh @lx @ly @ux @uy tm DZBList
a b c d e
);数字地形图
(setvar "cmdecho" 0)
(reaDZB)
(princ "\n数字地形图查询. [创建于2003.8]")
(if (setq @return (xzdxt_sx)) (progn
(setq @point (cadr @return) @name (car @return) tm (caddr @return)
@lx (car @point) @ly (cadr @point) @ux (+ 500 @lx) @uy (+ 500 @ly))
(if (or (not @name) (= "" @name))(setq @name "无"))
(if (or (not tm) (= "" tm))(setq tm "无"))
(setq a (rtos @ly 2 0) b (rtos @uy 2 0) c (rtos @lx 2 0) d (rtos @ux 2 0))
(if (> 5 (setq e (strlen a)))(setq a (strcat (substr " " 1 (- 5 e)) a)))
(if (> 5 (setq e (strlen b)))(setq b (strcat (substr " " 1 (- 5 e)) b)))
(if (> 5 (setq e (strlen c)))(setq c (strcat (substr " " 1 (- 5 e)) c)))
(if (> 5 (setq e (strlen d)))(setq d (strcat (substr " " 1 (- 5 e)) d)))
(if (not havereturn)
(alert (strcat "数字地形图图幅查询:"
"\n"
"\n━━━━━━━━┯━━━━━━━━━┯━━━━━━━━━"
"\n 图幅坐标 │ 左下角 │ 右上角 "
"\n────────┼─────────┼─────────"
"\n Ｘ │ " a " │ " b
"\n Ｙ │ " c " │ " d
"\n━━━━━━━━┷━━━━━━━━━┷━━━━━━━━━"
"\n"
"\n 图号: " @name
"\n 图名: " tm
"\n────────────────────────────"
))
)
)) ;if
(setvar "cmdecho" 1)
(if havereturn
(list @name @ly @lx @uy @ux)
)
)
(defun c:cx()
(chaxun nil)
(princ)
)
(defun c:dxtml( / a b c dcl_id pathlist
showpathlist addpathlist removepathlist editpathlist
selpath pickpathlist showpathcontrol showselectpath
)
;----------------showpathlist-------------------------------------------
(defun showpathlist (list1 addordel / a)
(cond
((= "del" addordel)(start_list "pathlist"))
((= "add" addordel)(start_list "pathlist" 2))
)
(foreach a list1 (add_list a))
(end_list)
)
;----------------addpathlist-------------------------------------------
(defun addpathlist ( / a last1)
(setq a (get_tile "path"))
(if (and a (/= "" a) (not (member a pathlist)))(progn
(setq last1 (list a)
pathlist (append pathlist last1)
)
(start_list "pathlist" 1 (1- (length pathlist)))(add_list a)(end_list)
(set_tile "pathlist" (itoa (1- (length pathlist))))
(mode_tile "path" 2)(mode_tile "path" 3)
(pickpathlist)
))
)
;----------------removepathlist-------------------------------------------
(defun removepathlist ( / a b i deli showi)
(setq deli (atoi (get_tile "pathlist")) i 0)
(foreach a pathlist
(if (/= i deli)(setq b (cons a b)))
(setq i (1+ i))
)
(setq pathlist (reverse b))
(showpathlist pathlist "del")
(if (= 0 deli)
(if pathlist (setq showi "0") (setq showi ""))
(if (= (length pathlist) deli)
(setq showi (itoa (1- (length pathlist))))
(setq showi (itoa deli))
)
)
(set_tile "pathlist" "")
(set_tile "pathlist" showi)
(mode_tile "pathlistt" 2)
(pickpathlist)
)
;----------------editpathlist-------------------------------------------
(defun editpathlist ( / a b editi)
(setq editi (atoi (get_tile "pathlist"))
a (nth editi pathlist)
b (get_tile "path")
)
(if (/= a b)(progn
(setq pathlist (subst b a pathlist))
(start_list "pathlist" 1 editi)(add_list b)(end_list)
))
)
;----------------pickpathlist-------------------------------------------
(defun pickpathlist ( / a showi)
(setq showi (get_tile "pathlist"))
(if (and showi (/= "" showi))(progn
(setq showi (atoi showi) a (nth showi pathlist))
(set_tile "select_num" (itoa (1+ showi)))
)(set_tile "select_num" "无"))
(showpathcontrol a)
)
;----------------showpathcontrol-------------------------------------------
(defun showpathcontrol (ina /)
(if (or (not ina) (= "" ina) (= "0" ina))
(progn ;无效
(mode_tile "remove" 1)
(mode_tile "edit" 1)
)
(progn
(mode_tile "remove" 0)
(mode_tile "edit" 0)
)
)
(if (= 0 (length pathlist))
(set_tile "sum" "无")
(set_tile "sum" (itoa (length pathlist)))
)
(if (and ina (/= "" ina)) (showselectpath ina))
)
;----------------showselectpath-------------------------------------------
(defun showselectpath (pickf2 /)
(set_tile "path" pickf2)
(set_tile "error" "添加数字地形图的路径.")
)
;----------------selpath-------------------------------------------
(defun selpath ( / a b i p )
(if (setq a (getfiled "选择数字地形图中任意一张地形图" "" "dwg" 0))(progn
(setq i 0)
(while (and (>= (strlen a) i)
(setq b (substr a (setq i (1+ i)) 1))
)
(if (= "\\" b) (setq p i))
)
(set_tile "path" (substr a 1 p))
))
)
;----------------main-------------------------------------------
(setq a (ReadSetData nil "ddxt" "pth"))
(foreach b a
(if (and (or (= (car b) "XZDXT1000-PATH")
(wcmatch (car b) "XZDXT1000-PATH#")
(wcmatch (car b) "XZDXT1000-PATH##")
)
(not (member (cadr b) pathlist))
)
(setq pathlist (cons (cadr b) pathlist))
)
)
(setq pathlist (reverse pathlist))
(if (not (setq dcl_id (load_dialog "ddxt.dcl")))(exit))
(if (not (new_dialog "dlgdxtsslj" dcl_id))(exit))
(showpathlist pathlist "del")
(showpathcontrol nil)
(action_tile "pathlist" "(pickpathlist)")
(action_tile "edit" "(editpathlist)")
(action_tile "remove" "(removepathlist)")
(action_tile "add" "(addpathlist)")
(action_tile "selpath" "(selpath)")
(action_tile "accept" "(done_dialog 1)")
(action_tile "cencel" "(done_dialog 0)")
(if (= 1 (start_dialog))(progn
(setq b 1 c nil)
(foreach a pathlist
(setq c (cons (list (strcat "XZDXT1000-PATH" (itoa b)) a) c)
b (1+ b)
)
)(setq c (reverse c))(princ c)
(CoverSetData c "ddxt" "pth" "vlx")
))
(princ)
)
(defun c:creatb (/ a b p x y th tm value DZBList wlist what
showthlist addthlist removethlist editthlist pickthlist
showthcontrol showselectth
checkth pickZB getall
)
;----------------showpathlist-------------------------------------------
(defun showthlist (list1 addordel / a)
(cond
((= "del" addordel)(start_list "thlist"))
((= "add" addordel)(start_list "thlist" 2))
)
(foreach a DZBList
(setq b (strcat (car a)
"\t" (itoa (cadadr a))
"," (itoa (caadr a))
"\t" (caddr a)
)
)(add_list b)
)
(end_list)
)
;----------------addpathlist-------------------------------------------
(defun addthlist ( / a b last1)
(if (getall)
(if (not (assoc th DZBList))(progn
(setq last1 (list th (list y x) tm)
DZBList (append DZBList (list last1))
a (strcat th
"\t" (itoa x)
"," (itoa y)
"\t" tm
)
)
(start_list "thlist" 1 (1- (length DZBList)))(add_list a)(end_list)
(set_tile "thlist" (itoa (1- (length DZBList))))
(pickthlist)
)(set_tile "error" "列表中已存在该图号的图幅信息!"))
)
)
;----------------removepathlist-------------------------------------------
(defun removethlist ( / a b i deli showi)
(setq deli (atoi (get_tile "thlist")) i 0)
(foreach a DZBList
(if (/= i deli)(setq b (cons a b)))
(setq i (1+ i))
)
(setq DZBList (reverse b))
(showthlist DZBList "del")
(if (= 0 deli)
(if pathlist (setq showi "0") (setq showi ""))
(if (= (length DZBList) deli)
(setq showi (itoa (1- (length DZBList))))
(setq showi (itoa deli))
)
)
(set_tile "thlist" "")
(set_tile "thlist" showi)
(mode_tile "thlistt" 2)
(pickthlist)
)
;----------------editpathlist-------------------------------------------
(defun editthlist ( / a b c editi)
(if (getall)(progn
(setq editi (atoi (get_tile "thlist"))
a (nth editi DZBList)
b (list th (list y x) tm)
c (strcat th
"\t" (itoa x)
"," (itoa y)
"\t" tm
)
)
(if (not (equal a b))(progn
(setq DZBList (subst b a DZBList))
(start_list "thlist" 1 editi)(add_list c)(end_list)
(set_tile "thlist" (itoa editi))
(mode_tile "th" 2)
(mode_tile "th" 3)
))
))
)
;----------------pickpathlist-------------------------------------------
(defun pickthlist ( / a showi)
(setq showi (get_tile "thlist"))
(if (and showi (/= "" showi))(progn
(setq showi (atoi showi) a (nth showi DZBList))
(set_tile "select_num" (itoa (1+ showi)))
)(set_tile "select_num" "无"))
(showthcontrol a)
)
;----------------showpathcontrol-------------------------------------------
(defun showthcontrol (ina /)
(if (or (not ina) (= "" ina) (= "0" ina))
(progn ;无效
(mode_tile "remove" 1)
(mode_tile "edit" 1)
)
(progn
(mode_tile "remove" 0)
(mode_tile "edit" 0)
)
)
(if (= 0 (length DZBList))
(set_tile "sum" "无")
(set_tile "sum" (itoa (length DZBList)))
)
(if (and ina (/= "" ina)) (showselectth ina nil))
)
;----------------showselectpath-------------------------------------------
(defun showselectth (pickf2 in /)
(if (and (not in) pickf2)(setq in pickf2))
(if in (progn
(if (setq a (car in)) (set_tile "th" a))
(if (setq a (caddr in)) (set_tile "tm" a))
(if (setq a (cadr in))(progn
(if (= 'INT (type (setq b (car a))))(set_tile "y" (itoa b)))
(if (= 'INT (type (setq b (cadr a))))(set_tile "x" (itoa b)))
))
(mode_tile "th" 2)
(mode_tile "th" 3)
))
)
;----------------main-------------------------------------------
(defun checkth ($key va)
(cond
((and (= "th" $key) (= "" va))
(set_tile "error" "<图幅图号>不能为空!")
(mode_tile "th" 2)
(mode_tile "th" 3)
nil
)
((and (= "x" $key) (= 0 va))
(set_tile "error" "左下角坐标<X>不能为空或零!")
(mode_tile "x" 2)
(mode_tile "x" 3)
nil
)
((and (= "y" $key) (= 0 va))
(set_tile "error" "左下角坐标<Y>不能为空或零!")
(mode_tile "y" 2)
(mode_tile "y" 3)
nil
)
(t t)
)
)
(defun pickZB ( / p)
(if (setq p (getpoint "\n点击当前图幅内的任意一点:"))(progn
(setq x (* 500 (fix (/ (car p) 500)))
y (* 500 (fix (/ (cadr p) 500)))
)
(if (>= 0 x)(setq x nil))
(if (>= 0 y)(setq y nil))
(if (or (not x) (not y))(princ "\t点击位置过小!"))
))
)
(defun getall ( / a b c)
(setq th (get_tile "th")
tm (get_tile "tm")
x (atoi (get_tile "x"))
y (atoi (get_tile "y"))
)
(if (and (checkth "th" th) (checkth "x" x)(checkth "y" y)) t nil)
)
(reaDZB)
(if (not (setq dcl_id (load_dialog "ddxt.dcl")))(exit))
(setq what 10)
(WHILE (< 1 what)
(if (not (new_dialog "dlgcreatb" dcl_id))(exit))
(showthlist DZBList "del")
(showthcontrol nil)
(showselectth nil (list th (list x y) tm))
(action_tile "thlist" "(pickthlist)")
(action_tile "edit" "(editthlist)")
(action_tile "remove" "(removethlist)")
(action_tile "add" "(addthlist)")
(action_tile "pick" "(done_dialog 2)")
(action_tile "th" "(setq th (get_tile $key))")
(action_tile "tm" "(setq tm (get_tile $key))")
(action_tile "x" "(setq x (atoi (get_tile $key)))")
(action_tile "y" "(setq y (atoi (get_tile $key)))")
(action_tile "accept" "(done_dialog 1)")
(action_tile "cencel" "(done_dialog 0)")
(setq what (start_dialog))
(cond
((= 2 what)(pickZB))
((= 1 what)
(foreach a DZBList
(setq b (list (car a) (strcat (itoa (cadadr a)) "," (itoa (caadr a)) "," (caddr a) ","))
wlist (cons b wlist)
)
)
(CoverSetData (reverse wlist) "图名与坐标对照表.txt" "dat" nil)
)
)
)
(princ)
)
(princ "\n调数字地形图ddxt.图幅查询cx.添加图幅的图号对照表creatb.添加数字地形图存放路径dxtml.")
(princ)
posted on 2006-08-20 21:36
深藏记忆 阅读(468)
评论(1) 编辑 收藏 所属分类:
Vlisp之韵