[LISP程序]：新年献礼王婆卖瓜我新写的地形图注记程序

caddog · 发表于 2008-1-9 03:46:12

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

[FONT=courier new]
;;;工作中,往地形图上注记汉字时,要求不同类别有不同的字高和层次
;;;虽然有一些编制好的程序,但实际使用时不是很方便,不足之处主要
;;;表现在:注记的内容不能自动分层,
;;;大小不能依据比例尺自行调整
;;;常用的注记全部是写在程序中,不能够方便的进行增/删操作,
;;;每到一个新测区,若是有不一样的分层要求,要修改源程序,很不方便
;;;所以编写了这么一个小程序,使得用户可能通过维护一个文本文件:
;;;"注记分类.txt"来实现注记文本的选取/自动分层/调整大小的操作
;;;
;;;定义了两个命令C:ZZ用来生成新的注记
;;; C:ZC用来修改已有的注记
;;;关于"注记分类.txt"的格式
;;; 请看下面函数的说明,另外在随附的我用的"注记分类.txt"文档中亦有说明
;;;关于全局变量*MapBlc*
;;;我用它用存放图形的比例尺.
;;;我们是将它放在系统变量userr1中的,1为1:1000,0.5为1:500
;;;用它来确定注记字高.因为在"注记分类.txt"中指定的字高是1:1000下的
;;;需要用当前比例尺进行换算
;;;如果您的比例尺设定方法与此不同,请自行修改
;;;所以此处若没有此变量则将*MapBlc设置为0.5(1:500)
;;;关于注记的文字样式 "text"
;;;程序总是试图使用 "text" 样式(因我们用的是这个),如果当前图形中没有此样式,
;;;则使用当前样式,若用户有自己的需要,烦请自行修改
;;;还有要注意的是生成文字的对齐方式为"中间",若用户有不同的要求可按下表修改程序:
;;对齐方式有如下几种:
;; 常量值含义值常量值含义值
;;----------------------------------------------------------------------
;;acAlignmentLeft 左 0 ;;acAlignmentTopCenter 中上 7
;;acAlignmentCenter 中 1 ;;acAlignmentTopRight 右上 8
;;acAlignmentRight 右 2 ;;acAlignmentMiddleLeft 左中 9
;;acAlignmentAligned 对齐 3 ;;acAlignmentMiddleCenter正中 10
;;acAlignmentMiddle 中间 4 ;;acAlignmentMiddleRight 右中 11
;;acAlignmentFit 调整 5 ;;acAlignmentBottomLeft 左下 12
;;acAlignmentTopLeft 左上 6 ;;acAlignmentBottomCenter中下 13
;;acAlignmentBottomRight 右下 14
;;;;;;;;;;;;;;;;;;
;;;关于hj_1.sld
;;;这是我作的一张小图片,呵呵,新年快乐的图章.
;;;愿大家迎来一个欢欢喜喜的新春!
;;;请注意zj.lsp mydcl.dcl 注记分类.txt hj_1.sld要同时放在CAD的支持搜索路径之中
;;;最后祝您使用愉快!
;;;程序的不完善之处还望各位大侠指出,感谢!
;;;--------------------------------------------------------
;;;函数：h:zj
;;;编制日期:2008.1.6
;;;功能: 生成/修改注记
;;;参数: enText 文本对象图元名
;;; %way 1 新建注记 2 修改已有的注记
;;;备注：当新建注记时,请将参数enText置为nil
;;; 用于CR命令对注记进行修改时
;;; 本函数从"注记分类.txt"文件中读取注记分类信息,
;;; 因此用户可以通过修改"注记分类.txt"来定义自己的注记
;;; 分类信息."注记分类.txt"文件的格式如下:
;;; 未考虑宽高比
;;;
;|;<以下内容取自本人的"注记分类.txt">
;;;分号部分内容为注释,请勿修改
;;;注记文件格式:
;;;注记所在图层[空格]注记类别说明[空格]1:1000下注记字高[空格]本类常用注记1[空格]本类常用注记2[空格]本类常用注记3.......
;;;请注意一种注记占一行,不能够分成两行
;;;修改后重新运行命令即可看到修改的值
;;;最后祝您使用愉快
;;;by caddog 2008.1.7
A12 地名、单位名 4.0 山
A13 测量控制点 4.0
A14 居民地和垣栅 2.5 土砖混砼钢木石竹破建
...........
...........
...........
;|;;
;;;--------------------------------------------------------
;|;
本函数将注记分类文件分解为如下几张表
#zjFL 的格式如下:
(("A12" . "地名、单位名")
("A13" . "测量控制点")
("A14" . "居民地和垣栅")
("A15" . "工矿建（构）筑物及其它设施")
("A16" . "交通及其它设施")
("A17" . "管线及附属设施")
("A18" . "水系及附属设施")
("A19" . "境界")
("A20" . "地貌和土质")
("A21" . "植被")
)
#zjHeight的格式如下
#zjKey 的格式如下
("A12" "A13" "A14" "A15" "A16" "A17" "A18" "A19" "A20" "A21")
#zjTypeList 的格式如下
(("A12" ("山"))
("A13" nil)
("A14" ("土" "砖" "混" "砼" "钢" "木" "石" "竹" "破" "建"))
("A15" ("水" "涌" "探" "车" "铁" "铜" "煤" "硫"
"磷" "油" "废" "气" "沙" "球" "伞"
..........................
("A21" ("藕" "菱" "茭" "茨" "喷灌" "苹" "梨" "桃" "桔"
"栗" "杏" "椰" "咖" "葡" "蕉" "蔗" "椒"
"花椒" "啤" "松" "柏" "桦" "槟" "桐" "漆"
"榆" "杨" "柳" "青?" "枫" "椴" "栎" "柞"
"樟" "油茶" "棕" "苗" "苇" "席" "芒" "芒果"
)
)
)
;|;;
(defun h:zj( enText %way / #temp1 id-key #ZJ #ZJFL #ZJKEY #ZJTYPE #ZJTYPELIST $LAYEROLD $TEXT1 $VALUE %IDZJ %RESV DCL_ID HEIGHT WIDTH X Y)
(if enText
(setq $text1 (cdr(assoc 1 (entget enText)))
$layerOld(cdr(assoc 8 (entget enText)))
;;*MAPBLC* (GETVAR "userr1") ;_有可能图形打开时比例尺不对,用户会进行更改所以要重新读取
)
(setq $text1 "" $layerOld "")
)
;;将注记分类.txt文件读为表
(setq #zj (hj:file2list (findfile "注记分类.txt"))
#zjType nil #zjTypeList nil #zjFL nil #zjKey nil #zjHeight nil)
;;将读出的字符串解析为前面提到的几个表
(foreach #x #zj
(setq %idzj 3)
(setq #x (hj:str2list #x " "))
;(if (>(length #x) 2)
(setq #zjTypeList (append #zjTypeList (list(cons (car #x) (list(cdddr #x))))))
(setq #zjHeight (append #zjHeight (list (cons (car #x) (caddr #x)))))
(setq #zjFL(append #zjFL (list (cons(car #x) (cadr #x)))))
(setq #zjKey(append #zjKey(list (car #x))))
; )
(repeat (- (length #x) 3)
(setq #zjType (append #zjType (list (cons (nth %idzj #x) (car #x))))
%idzj (1+ %idzj)
)
);_end repeat
);end_foreach
;;得到了表,下面调用对话框
(SETQ dcl_id (LOAD_DIALOG "mydcl"))
(IF (< dcl_id 0)
(EXIT)
) ;_ 结束if
(NEW_DIALOG "diaModiZJ" dcl_id)
;;设置各控件的值
;;先是图像控件
(setq width (dimx_tile "image1")
height (dimy_tile "image1"))
(start_image "image1")
(fill_image 0 0 width height 53) ;_用53号色填充图像窗口
(end_image) ;_显示图片
(setq x (dimx_tile "image1")
y (dimy_tile "image1"))
(start_image "image1")
( slide_image 0 -15 x y "hj_1")
(end_image)
;;....
(if (= %way 2) ;_若是修改注记命令调用本函数
(progn
(MODE_TILE "edit2" 1)
(MODE_TILE "bu_zj" 1)
)
)
(SET_TILE "edit1" $text1) ;_设置注记内容编辑框的值
(SET_TILE "edit2" $layerOld);_设置所在图层编辑框的值
(START_LIST "list2") ;_添加预测图层下拉列表框的列表项
(mapcar '(LAMBDA(x) (ADD_LIST (strcat (car x) " " (cdr x)))) #zjFL)
(end_list)
(START_LIST "pop1")
(mapcar '(LAMBDA(x) (ADD_LIST (car x))) #zjFL)
(END_LIST)
(hj:zj-3 $text1);_调用函数,根据文字的值分析它所在的图层
(action_tile "list2" "(hj:zj-1 $value)");_当在注记分类列表框中点击时发生,根据所选类别更新备选注记列表框(LIST1)
(action_tile "list1" "(hj:zj-2 $value)");_当在备选注记列表框中点击时发生,更新注记内容编辑框及预测图层下拉列表框
(action_tile "edit1" "(hj:zj-3 $value)");_当在注记内容编辑框中输入内容时发生
(action_tile "pop1" "(hj:zj-1 $value)");_当点选了预测图层下拉列表框
(ACTION_TILE "bu_zj" "(DONE_DIALOG 2)")
(ACTION_TILE "bu_setup" "(DONE_DIALOG 3)")
(ACTION_TILE "accept" "(DONE_DIALOG 1)")
(ACTION_TILE "cancel" "(DONE_DIALOG 0)")
(SETQ %resv (START_DIALOG))
(cond
((= %resv 3)
(command"notepad"(findfile"注记分类.txt"))
)
((= %resv 1) ;_如果新输入了注记又未指定图层,则图层定为"A15500",字高定为2.5*比例尺
(if (/= $text1 "") (list $text1 (if id-key (nth id-key #zjKey)"A15500") (if id-key (*(atof(cdr(nth id-key #zjHeight)))*MAPBLC*)(* 2.5 *MAPBLC*))) nil)
)
((= %resv 2)
(if (/= $text1 "") (list $text1 (if id-key (nth id-key #zjKey)"A15500") (if id-key (*(atof(cdr(nth id-key #zjHeight)))*MAPBLC*)(* 2.5 *MAPBLC*))) nil)
)
(t nil)
)
)
;;查找用户输入的注记所在的图层,若找到则更新预测图层下拉列表框的值
(defun hj:zj-3 ($value /)
(setq $text1 $value)
(setq $layer (cdr(assoc $text1 #zjType)))
(if $layer
(progn
(SET_TILE "pop1" (itoa (-(length #zjKey)(length(member $layer #zjKey)))))
(hj:zj-1 (itoa (-(length #zjKey)(length(member $layer #zjKey)))))
)
)
)
;;按用户所选择的类别更新"备选注记"列表框的内容
(defun hj:zj-1 ($value / )
(setq !value (atoi $value)
id-key !value)
(setq #temp1 (cadr(nth !value #zjTypeList)))
(if #temp1
(progn
(START_LIST "list1")
(mapcar 'ADD_LIST #temp1)
(END_LIST)
)
(progn
(START_LIST "list1")
;;(mapcar 'ADD_LIST #temp1)
(END_LIST)
)
);_end if
(SET_TILE "error" (strcat "注记字高:" (rtos(* *MAPBLC*(atof(cdr(nth id-key #ZJHEIGHT)))) 2 2)))
)
;;当在备选注记列表框中点击时,更新注记内容编辑框及预测图层下拉列表框
(defun hj:zj-2 ($value)
(setq !value (atoi $value))
(setq $text1 (nth !value #temp1))
(if $text1
(progn
(SET_TILE "edit1" $text1)
(set_tile "pop1" (itoa id-key))
;;(set_tile "edit2" (car(nth id-key #zjTypeList)))
);_end progn
)
)
;;将文件按行解析为表
(defun hj:file2list (fn / f l ll)
(setq f (open fn "r"))
(while (setq l (read-line f))
;;(setq ll (cons (read (strcat "(" l ")")) ll))
(if (/= (substr l 1 3) ";;;")
(setq ll (append ll (list l)))
)
)
(close f)
ll
)
;;将字符串按分隔符解析为表
(defun hj:Str2List (string symble / )
(setq len (strlen string)
%id 1
#rev nil
$str "" )
(repeat len
(if (and (vl-string-search (substr string %id 1) symble) (/= $str ""))
(setq #rev (append #rev (list $str))
$str "")
(if (not (vl-string-search (substr string %id 1) symble) )
(setq $str (strcat $str (substr string %id 1)))
)
)
(setq %id (1+ %id))
);_end repeat
(if (/= $str "") (append #rev (list $str)) #rev)
)
;;;以下代码取自AUTOCAD的帮助.
;;;在使用VLA-ADD时要调用
(SETQ *acad-object* nil) ; Initialize global variable
(DEFUN acad-object ()
(COND (*acad-object*) ; Return the cached object
(T
(SETQ *acad-object* (VLAX-GET-ACAD-OBJECT))
)
) ;_ 结束cond
) ;_ 结束defun
(SETQ *active-document* nil) ; Initialize global variable
(DEFUN active-document ()
(COND (*active-document*) ; Return the cached object
(T
(SETQ *active-document* (VLA-GET-ACTIVEDOCUMENT (acad-object)))
)
) ;_ 结束cond
) ;_ 结束defun
(SETQ *model-space* nil) ; Initialize global variable
(DEFUN model-space ()
(COND (*model-space*) ; Return the cached object
(T
(SETQ *model-space* (VLA-GET-MODELSPACE (active-document)))
)
) ;_ 结束cond
) ;_ 结束defun
;;;--------------------------------------------------------
;;;函数：c:zz
;;;编制日期:2008.1.6 作者:caddog
;;;功能: 注记文本
;;;备注：
;;;--------------------------------------------------------
(defun c:zz (/ #revs !sideHeight)
(setq
*MapBlc* (if (GETVAR "userr1")(GETVAR "userr1") 0.5);_取图形的比例尺.
#revs (h:zj nil 1)
;;我们是将它放在系统变量userr1中的,1为1:1000,0.5为1:500
;;用它来确定注记字高.因为在"注记分类.txt"中指定的字高是1:1000下的
;;需要用当前比例尺进行换算
;;如果您的比例尺设定方法与此不同,请自行修改
;;所以此处若没有此变量则将*MapBlc设置为0.5(1:500)
)
(if #revs
(progn
(setq pt1 (getpoint "\n选择注记点位:"))
(if(tblsearch "style" "text") ;_设置文字样式为"text",若没有则为当前样式
(setvar "TEXTSTYLE" "text")
)
(while pt1
(setq objText (vla-AddText
(MODEL-SPACE)
(car #revs)
(vlax-3d-point pt1)
(caddr #revs)
)
)
(if (null (tblsearch "layer" (cadr #revs)))
(vla-add (vla-get-layers (ACTIVE-DOCUMENT)) (cadr #revs))
)
(VLA-PUT-ALIGNMENT objText 4)
(vla-put-layer objText (cadr #revs))
(VLA-PUT-TEXTALIGNMENTPOINT objText (VLAX-3D-POINT pt1));_文字对齐方式为"中间"
(setq pt1 (getpoint "\n选择注记点位:"))
) ;_end if pt1
) ;_end progn
)
(princ)
)
;;;修改注记
;;;可根据注记内容,自动判定应放置的层次及字高--当然是在用户已在"注记分类.txt"中加入了该注记之后
(defun c:zc(/ #revs)
(setq ss (ssget ":s"))
(if ss (progn
(setq ss1 (ssname ss 0)
obj1(vlax-ename->vla-object ss1)
objType(vla-get-objectname obj1))
(if (eq objType "AcDbText")
(progn
(setq #revs (h:zj ss1 2))
(if #revs
(progn
(vla-put-TextString obj1 (car #revs))
(if (null (tblsearch "layer" (cadr #revs)))
(vla-add (vla-get-layers (ACTIVE-DOCUMENT)) (cadr #revs))
)
(vla-put-layer obj1 (cadr #revs))
(vla-put-Height obj1(caddr #revs))
);_end progn
)
)
)
;;(princ)
)
)
);_end defun
[/FONT]

[FONT=courier new] 
;;;工作中,往地形图上注记汉字时,要求不同类别有不同的字高和层次 
;;;虽然有一些编制好的程序,但实际使用时不是很方便,不足之处主要 
;;;表现在:注记的内容不能自动分层, 
;;;大小不能依据比例尺自行调整 
;;;常用的注记全部是写在程序中,不能够方便的进行增/删操作, 
;;;每到一个新测区,若是有不一样的分层要求,要修改源程序,很不方便 
;;;所以编写了这么一个小程序,使得用户可能通过维护一个文本文件: 
;;;"注记分类.txt"来实现注记文本的选取/自动分层/调整大小的操作 
;;; 
;;;定义了两个命令C:ZZ用来生成新的注记 
;;;              C:ZC用来修改已有的注记 
 
;;;关于"注记分类.txt"的格式 
;;; 请看下面函数的说明,另外在随附的我用的"注记分类.txt"文档中亦有说明 
 
;;;关于全局变量*MapBlc* 
;;;我用它用存放图形的比例尺. 
;;;我们是将它放在系统变量userr1中的,1为1:1000,0.5为1:500 
;;;用它来确定注记字高.因为在"注记分类.txt"中指定的字高是1:1000下的 
;;;需要用当前比例尺进行换算 
;;;如果您的比例尺设定方法与此不同,请自行修改 
;;;所以此处若没有此变量则将*MapBlc设置为0.5(1:500) 
 
;;;关于注记的文字样式 "text" 
;;;程序总是试图使用 "text" 样式(因我们用的是这个),如果当前图形中没有此样式, 
;;;则使用当前样式,若用户有自己的需要,烦请自行修改 
;;;还有要注意的是生成文字的对齐方式为"中间",若用户有不同的要求可按下表修改程序: 
    ;;对齐方式有如下几种: 
    ;;    常量值             含义  值            常量值             含义  值 
    ;;---------------------------------------------------------------------- 
    ;;acAlignmentLeft          左  0       ;;acAlignmentTopCenter   中上   7 
    ;;acAlignmentCenter        中  1       ;;acAlignmentTopRight    右上   8 
    ;;acAlignmentRight         右  2       ;;acAlignmentMiddleLeft  左中   9 
    ;;acAlignmentAligned     对齐  3       ;;acAlignmentMiddleCenter正中  10 
    ;;acAlignmentMiddle      中间  4       ;;acAlignmentMiddleRight 右中  11 
    ;;acAlignmentFit         调整  5       ;;acAlignmentBottomLeft  左下  12 
    ;;acAlignmentTopLeft     左上  6       ;;acAlignmentBottomCenter中下  13 
    ;;acAlignmentBottomRight 右下  14 
;;;;;;;;;;;;;;;;;;    
;;;关于hj_1.sld 
;;;这是我作的一张小图片,呵呵,新年快乐的图章. 
;;;愿大家迎来一个欢欢喜喜的新春! 
 
;;;请注意zj.lsp mydcl.dcl 注记分类.txt hj_1.sld要同时放在CAD的支持搜索路径之中 
 
;;;最后祝您使用愉快! 
;;;程序的不完善之处还望各位大侠指出,感谢! 
 
        
 
 
 
;;;-------------------------------------------------------- 
;;;函数：h:zj 
;;;编制日期:2008.1.6 
;;;功能: 生成/修改注记 
;;;参数: enText 文本对象图元名 
;;;      %way 1 新建注记  2 修改已有的注记 
;;;备注：当新建注记时,请将参数enText置为nil 
;;;      用于CR命令对注记进行修改时 
;;;      本函数从"注记分类.txt"文件中读取注记分类信息, 
;;;      因此用户可以通过修改"注记分类.txt"来定义自己的注记 
;;;      分类信息."注记分类.txt"文件的格式如下: 
;;;      未考虑宽高比 
;;; 
;|;<以下内容取自本人的"注记分类.txt"> 
 
;;;分号部分内容为注释,请勿修改 
;;;注记文件格式: 
;;;注记所在图层[空格]注记类别说明[空格]1:1000下注记字高[空格]本类常用注记1[空格]本类常用注记2[空格]本类常用注记3....... 
;;;请注意一种注记占一行,不能够分成两行 
;;;修改后重新运行命令即可看到修改的值 
;;;最后祝您使用愉快 
;;;by caddog 2008.1.7 
A12 地名、单位名 4.0 山 
A13 测量控制点 4.0 
A14 居民地和垣栅 2.5 土 砖 混 砼 钢 木 石 竹 破 建 
........... 
........... 
........... 
 
;|;; 
;;;-------------------------------------------------------- 
;|; 
本函数将注记分类文件分解为如下几张表 
#zjFL 的格式如下: 
(("A12" . "地名、单位名") 
  ("A13" . "测量控制点") 
  ("A14" . "居民地和垣栅") 
  ("A15" . "工矿建（构）筑物及其它设施") 
  ("A16" . "交通及其它设施") 
  ("A17" . "管线及附属设施") 
  ("A18" . "水系及附属设施") 
  ("A19" . "境界") 
  ("A20" . "地貌和土质") 
  ("A21" . "植被") 
) 
#zjHeight的格式如下 
 
#zjKey 的格式如下 
("A12" "A13" "A14" "A15" "A16" "A17" "A18" "A19" "A20" "A21") 
#zjTypeList 的格式如下 
(("A12" ("山")) 
  ("A13" nil) 
  ("A14" ("土" "砖" "混" "砼" "钢" "木" "石" "竹" "破" "建")) 
  ("A15" ("水" "涌"    "探"    "车"    "铁"    "铜"    "煤"    "硫" 
               "磷"    "油"    "废"    "气"    "沙"    "球"    "伞" 
.......................... 
  ("A21" ("藕" "菱"   "茭"   "茨"   "喷灌" "苹"          "梨"         "桃"        "桔" 
               "栗"   "杏"   "椰"   "咖"   "葡"          "蕉"         "蔗"        "椒" 
               "花椒" "啤"   "松"   "柏"   "桦"          "槟"         "桐"        "漆" 
               "榆"   "杨"   "柳"   "青?" "枫"          "椴"         "栎"        "柞" 
               "樟"   "油茶" "棕"   "苗"   "苇"          "席"         "芒"        "芒果" 
              ) 
  ) 
) 
 
;|;; 
(defun h:zj( enText %way / #temp1 id-key #ZJ #ZJFL #ZJKEY #ZJTYPE #ZJTYPELIST $LAYEROLD $TEXT1 $VALUE %IDZJ %RESV DCL_ID HEIGHT WIDTH X Y) 
  (if enText 
  (setq $text1 (cdr(assoc 1 (entget enText))) 
        $layerOld(cdr(assoc 8 (entget enText))) 
        ;;*MAPBLC* (GETVAR "userr1") ;_有可能图形打开时比例尺不对,用户会进行更改所以要重新读取 
        ) 
    (setq $text1 "" $layerOld "") 
    ) 
  ;;将注记分类.txt文件读为表 
  (setq #zj (hj:file2list (findfile "注记分类.txt")) 
        #zjType nil #zjTypeList nil #zjFL nil #zjKey nil #zjHeight nil) 
  ;;将读出的字符串解析为前面提到的几个表 
  (foreach #x #zj 
    (setq %idzj 3) 
    (setq #x (hj:str2list #x " ")) 
    ;(if (>(length #x) 2) 
    (setq #zjTypeList (append #zjTypeList (list(cons (car #x) (list(cdddr #x)))))) 
    (setq #zjHeight (append #zjHeight (list (cons (car  #x) (caddr #x))))) 
    (setq #zjFL(append #zjFL (list (cons(car #x) (cadr #x))))) 
    (setq #zjKey(append #zjKey(list (car #x)))) 
    ;  ) 
    (repeat (- (length #x) 3) 
      (setq #zjType (append #zjType (list (cons (nth %idzj #x) (car #x)))) 
            %idzj (1+ %idzj) 
            ) 
      );_end repeat 
    );end_foreach 
  ;;得到了表,下面调用对话框 
  (SETQ dcl_id (LOAD_DIALOG "mydcl")) 
  (IF (< dcl_id 0) 
    (EXIT) 
    ) ;_ 结束if 
  (NEW_DIALOG "diaModiZJ" dcl_id) 
  ;;设置各控件的值 
  ;;先是图像控件 
  (setq width (dimx_tile "image1") 
        height (dimy_tile "image1")) 
  (start_image "image1") 
  (fill_image 0 0 width height 53)        ;_用53号色填充图像窗口 
  (end_image)                           ;_显示图片 
  (setq x (dimx_tile "image1") 
        y (dimy_tile "image1")) 
  (start_image "image1") 
  ( slide_image 0 -15 x y "hj_1") 
  (end_image)   
  ;;.... 
   
  (if (= %way 2)  ;_若是修改注记命令调用本函数 
    (progn 
      (MODE_TILE "edit2" 1) 
      (MODE_TILE "bu_zj" 1) 
      ) 
    )   
  (SET_TILE "edit1" $text1) ;_设置注记内容 编辑框的值 
  (SET_TILE "edit2" $layerOld);_设置所在图层 编辑框的值 
  (START_LIST "list2") ;_添加 预测图层 下拉列表框的列表项 
  (mapcar '(LAMBDA(x) (ADD_LIST (strcat (car x) " " (cdr x))))  #zjFL) 
  (end_list) 
  (START_LIST "pop1") 
  (mapcar '(LAMBDA(x) (ADD_LIST (car x))) #zjFL) 
  (END_LIST) 
   
  (hj:zj-3 $text1);_调用函数,根据文字的值分析它所在的图层 
   
  (action_tile "list2" "(hj:zj-1 $value)");_当在注记分类 列表框中点击时发生,根据所选类别更新备选注记 列表框(LIST1) 
  (action_tile "list1" "(hj:zj-2 $value)");_当在备选注记 列表框中点击时发生,更新注记内容编辑框及预测图层下拉列表框 
  (action_tile "edit1" "(hj:zj-3 $value)");_当在注记内容编辑框中输入内容时发生 
  (action_tile "pop1"  "(hj:zj-1 $value)");_当点选了预测图层下拉列表框 
  (ACTION_TILE "bu_zj" "(DONE_DIALOG 2)") 
  (ACTION_TILE "bu_setup" "(DONE_DIALOG 3)")   
  (ACTION_TILE "accept" "(DONE_DIALOG 1)") 
  (ACTION_TILE "cancel" "(DONE_DIALOG 0)") 
  (SETQ %resv (START_DIALOG)) 
  (cond 
    ((= %resv 3) 
     (command"notepad"(findfile"注记分类.txt")) 
     ) 
    ((= %resv 1) ;_如果新输入了注记又未指定图层,则图层定为"A15500",字高定为2.5*比例尺 
     (if (/= $text1 "") (list $text1 (if id-key (nth id-key #zjKey)"A15500") (if id-key (*(atof(cdr(nth id-key #zjHeight)))*MAPBLC*)(* 2.5 *MAPBLC*))) nil) 
     ) 
    ((= %resv 2) 
     (if (/= $text1 "") (list $text1 (if id-key (nth id-key #zjKey)"A15500") (if id-key (*(atof(cdr(nth id-key #zjHeight)))*MAPBLC*)(* 2.5 *MAPBLC*))) nil) 
     ) 
    (t nil) 
    ) 
 
) 
;;查找用户输入的注记所在的图层,若找到则更新预测图层下拉列表框的值 
(defun hj:zj-3 ($value /) 
  (setq $text1 $value) 
  (setq $layer (cdr(assoc $text1 #zjType))) 
  (if $layer 
    (progn 
      (SET_TILE "pop1" (itoa (-(length #zjKey)(length(member $layer #zjKey))))) 
      (hj:zj-1 (itoa (-(length #zjKey)(length(member $layer #zjKey))))) 
      ) 
    ) 
   
  ) 
   
 ;;按用户所选择的类别更新"备选注记"列表框的内容 
(defun hj:zj-1 ($value / ) 
  (setq !value (atoi $value) 
        id-key !value) 
  (setq #temp1 (cadr(nth !value #zjTypeList))) 
  (if #temp1 
    (progn 
      (START_LIST "list1") 
      (mapcar 'ADD_LIST #temp1) 
      (END_LIST) 
      ) 
    (progn 
      (START_LIST "list1") 
      ;;(mapcar 'ADD_LIST #temp1) 
      (END_LIST) 
      ) 
    );_end if 
  (SET_TILE "error" (strcat "注记字高:" (rtos(* *MAPBLC*(atof(cdr(nth id-key #ZJHEIGHT)))) 2 2))) 
  ) 
;;当在备选注记 列表框中点击时,更新注记内容编辑框及预测图层下拉列表框   
(defun hj:zj-2 ($value) 
  (setq !value (atoi $value)) 
  (setq $text1 (nth !value #temp1)) 
  (if $text1 
    (progn 
      (SET_TILE "edit1" $text1) 
      (set_tile "pop1" (itoa id-key)) 
      ;;(set_tile "edit2" (car(nth id-key #zjTypeList))) 
      );_end progn 
    ) 
  ) 
   
;;将文件按行解析为表 
(defun hj:file2list (fn / f l ll) 
  (setq f (open fn "r")) 
  (while (setq l (read-line f)) 
    ;;(setq ll (cons (read (strcat "(" l ")")) ll)) 
    (if (/= (substr l 1 3) ";;;") 
    (setq ll (append ll (list l))) 
      ) 
  ) 
  (close f) 
  ll 
) 
 
;;将字符串按分隔符解析为表 
(defun hj:Str2List (string symble / ) 
  (setq len (strlen string) 
        %id 1 
        #rev nil 
        $str "" ) 
  (repeat len 
    (if (and (vl-string-search  (substr string %id 1) symble) (/= $str "")) 
      (setq #rev (append #rev (list $str)) 
            $str "") 
      (if (not (vl-string-search (substr string %id 1) symble) ) 
        (setq $str (strcat $str (substr string %id 1))) 
        ) 
      )       
    (setq %id (1+ %id)) 
    );_end repeat 
  (if (/= $str "") (append  #rev (list $str)) #rev) 
  ) 
 
;;;以下代码取自AUTOCAD的帮助. 
;;;在使用VLA-ADD时要调用 
(SETQ *acad-object* nil)                ; Initialize global variable 
(DEFUN acad-object  () 
  (COND        (*acad-object*)                        ; Return the cached object 
        (T 
         (SETQ *acad-object* (VLAX-GET-ACAD-OBJECT)) 
         ) 
        ) ;_ 结束cond 
 
  ) ;_ 结束defun 
 
(SETQ *active-document* nil)                ; Initialize global variable 
(DEFUN active-document        () 
  (COND        (*active-document*)                ; Return the cached object 
        (T 
         (SETQ *active-document* (VLA-GET-ACTIVEDOCUMENT (acad-object))) 
         ) 
        ) ;_ 结束cond 
 
  ) ;_ 结束defun 
 
(SETQ *model-space* nil)                ; Initialize global variable 
(DEFUN model-space  () 
  (COND        (*model-space*)                        ; Return the cached object 
        (T 
         (SETQ *model-space* (VLA-GET-MODELSPACE (active-document))) 
         ) 
        ) ;_ 结束cond 
 
 
  ) ;_ 结束defun 
   
   
;;;-------------------------------------------------------- 
;;;函数：c:zz 
;;;编制日期:2008.1.6    作者:caddog 
;;;功能: 注记文本 
;;;备注： 
;;;-------------------------------------------------------- 
(defun c:zz (/ #revs !sideHeight) 
  (setq                
        *MapBlc* (if  (GETVAR "userr1")(GETVAR "userr1") 0.5);_取图形的比例尺. 
        #revs (h:zj nil 1) 
        ;;我们是将它放在系统变量userr1中的,1为1:1000,0.5为1:500 
        ;;用它来确定注记字高.因为在"注记分类.txt"中指定的字高是1:1000下的 
        ;;需要用当前比例尺进行换算 
        ;;如果您的比例尺设定方法与此不同,请自行修改 
        ;;所以此处若没有此变量则将*MapBlc设置为0.5(1:500) 
  ) 
   
  (if #revs 
    (progn 
      (setq pt1 (getpoint "\n选择注记点位:")) 
      (if(tblsearch "style" "text") ;_设置文字样式为"text",若没有则为当前样式 
        (setvar "TEXTSTYLE" "text")        
        ) 
      (while pt1 
        
          (setq        objText        (vla-AddText 
                          (MODEL-SPACE) 
                          (car #revs) 
                          (vlax-3d-point pt1) 
                          (caddr #revs) 
                        ) 
          ) 
          (if (null (tblsearch "layer" (cadr #revs))) 
            (vla-add (vla-get-layers (ACTIVE-DOCUMENT)) (cadr #revs)) 
          ) 
          (VLA-PUT-ALIGNMENT objText 4) 
          (vla-put-layer objText (cadr #revs)) 
          (VLA-PUT-TEXTALIGNMENTPOINT objText (VLAX-3D-POINT pt1));_文字对齐方式为"中间" 
        
        (setq pt1 (getpoint "\n选择注记点位:")) 
        
      ) ;_end if pt1 
       
    ) ;_end progn 
  ) 
(princ) 
) 
;;;修改注记 
;;;可根据注记内容,自动判定应放置的层次及字高--当然是在用户已在"注记分类.txt"中加入了该注记之后 
(defun c:zc(/ #revs) 
(setq ss (ssget ":s")) 
(if ss (progn 
(setq ss1 (ssname ss 0) 
            obj1(vlax-ename->vla-object ss1) 
            objType(vla-get-objectname obj1)) 
(if (eq objType "AcDbText") 
(progn             
  (setq #revs (h:zj ss1 2)) 
  (if #revs 
    (progn 
      (vla-put-TextString obj1 (car #revs)) 
      (if (null (tblsearch "layer" (cadr #revs))) 
        (vla-add (vla-get-layers (ACTIVE-DOCUMENT)) (cadr #revs)) 
        )       
      (vla-put-layer obj1 (cadr #revs)) 
      (vla-put-Height obj1(caddr #revs)) 
      );_end progn 
    ) 
    ) 
    ) 
  ;;(princ) 
  ) 
  ) 
  );_end defun 
  [/FONT]

J:\hj\zj.bmp

hounengwei · 发表于 2008-2-4 01:48:57

好东西哦~挺方便D

hisum · 发表于 2008-2-4 20:17:22

值得借鉴

hbcy168 · 发表于 2008-2-26 13:20:53

好东西.

账号		自动登录	找回密码
密码			立即注册

[LISP程序]：新年献礼 王婆卖瓜 我新写的地形图注记程序

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子

[LISP程序]：新年献礼王婆卖瓜我新写的地形图注记程序