能不能对一个封闭的多断线自动插入坐标？

Lisphk

工作中，很多时候要对总图的用地界限啥的标注坐标，网上虽然有些工具能单独对一点点坐标标注，但还是很慢，能不能给写个工具。

1、点下多段线，坐标就自动标注了。
2、坐标的引线长度，角度什么的可以自定义
3、文字下面的基线的角度最好也能定义，适应不同角度的线段
4、最好这个坐标能智能，我要把它拷贝或者移动到别的位置，能自动更新。

XDSoft

沿线坐标提供下载测试，见帖子：http://bbs.xdcad.net/thread-668276-1-1.html

eachy

这个老早就写过,只不过论坛没附件了,呵呵

Lisphk

eachy 发表于 2013-5-22 17:27
这个老早就写过,只不过论坛没附件了,呵呵

哇，大师回我贴了，这么快啊，大师能否帮帮忙。

eachy

Lisphk 发表于 2013-5-22 17:38
哇，大师回我贴了，这么快啊，大师能否帮帮忙。

反应器在 CAD 高版本中有变化，以前程序运行有问题，需要重新调试

cy956

eachy 发表于 2013-5-22 15:56
反应器在 CAD 高版本中有变化，以前程序运行有问题，需要重新调试

eachy，这样的总图坐标你是用什么标的？pl+text，line+block，leader 还是其它什么？

XDSoft

先写了个 单注坐标的工具和坐标更新的工具，请看：http://bbs.xdcad.net/thread-668262-1-1.html

测试中有什么建议请跟工具箱论坛的帖字。

eachy

cy956 发表于 2013-5-22 23:59
eachy，这样的总图坐标你是用什么标的？pl+text，line+block，leader 还是其它什么？

原来写的是属性块,下面这个是早期加在XD工具箱那个ZBBZ,首先声明以下代码直接编译不一定可以直接成功,因为后来好像改过,因为各种原因没有彻底完成,现在基本也不用了,偶尔使用的时候就用Netbee那个或者天正的标注,有兴趣的可以自己修改

原来的更新是用程序处理,后来想改成反应器,下面的 Lisp 是未完成的 反应器代码!
这是标注的一个菜单部分

1. 
   
2. ID_ZBBZ      [->坐标标注(&Z)]
   
3. ID_EzSystem      [综合设定(&S)]^C^C^PEa_setcoordsys
   
4. ID_EzSetUCS      [设坐标系]^C^C^PEa:setucs
   
5.                  [--]
   
6. ID_EzZBBZ        [坐标标注(&D)]^C^C^PEa_ZBBZ
   
7. ID_EzMZbbz       [批量标注(&M)]^C^C^PEa_mZBBZ
   
8.                  [--]
   
9. ID_EzDZBBZ       [动态开关(&O)]^C^C^PEa_SetDrag
   
10.                  [--]
    
11. ID_EzChkZBBZ     [检查(&C)]^C^C^PEa_ChkZb
    
12. ID_EzScZBBZ      [缩放(&S)]^C^C^PEa_ScZB
    
13. ID_EzMovZBBZ     [移位(&M)]^C^C^PEa_MovZB
    
14. ID_EzMirZBBZ     [翻转(&R)]^C^C^PEa_MirZB
    
15.                  [--]
    
16. ID_EzJStr        [连字符(&J)]^C^C^PEa_JStr
    
17. ID_EzPStr        [前缀开关(&P)]^C^CPEa_PStr
    
18.                  [--]
    
19. ID_EzDrAxis      [绘坐标网(&X)]^C^C^PEa_DrAxis
    
20. ID_EzDmAxis      [标注格线(&I)]^C^C^PEa_DmAxis
    
21. ID_EzZbAxis      [坐标定网(&W)]^C^C^PEa_ZbAxis
    
22.                  [--]
    
23. ID_EzIFile       [输入文件(&F)]^C^C^PEa_Ifile
    
24. ID_EzEfile       [输出坐标(&E)]^C^C^PEa_Efile

复制代码

[pcode=lisp,true];|
词典  : [Ea_DICT] 索引[Ea_ZBBZ] 值: 记录 当前标注坐标系|org|Xdir|Ydir|是否动态|是否水平
坐标块：标注块过滤选择用 (ssget "x" '((-3 ("yb_zbbz"))))
        ea_info 块信息纪录
        
         ("ea_info" "0|0|0|3|0|3.0|X|Y")
         互换标志   0 不互换 1 互换；默认 1
         高程标志   0 不提示 1 提示；默认 0
         建筑坐标   0 标A/B  1 标X/Y；默认 1
         小数点位数 0 1 2 3 4；默认 3
         连字符     0 空格 1 = 2 - 3 无；默认 0
         字高       默认系统字高，可变
         X前缀      默认无
         Y前缀      默认无
         互换标志|高程标志|建筑坐标|小数点位数|连字符|字高|X前缀|Y前缀|
            1       0      1         3         0     3.0   0     0
            
        ea_ucs 块UCS扩展记录与Dict一致
        
         Ucs|ucsorg|xdir|ydir|是否动态|是否水平
|;
(if (not $yb_coord_angle)  ;默认角度
  (setq $yb_coord_angle 0)
)
;;命令反应器，命令结束时调用
(if (null ea-zbbz-reactor)
  (setq ea-zbbz-command-reactor
  (vlr-command-reactor
    "ea-zbbz-UPDATa"
    '((:vlr-commandEnded . ea-zbbz-updata))
  )
  )
)
;; ea-zbbz-command-reactor 命令回调函数，命令结束后执行
(defun ea-zbbz-updata (reactor-object   parameter-list
         /    ea-zbbz-ename
         ea-zbbz-object
        )
  (if ea-zbbz-to-update
    (progn
      (setq ea-zbbz-to-update (vl-remove nil ea-zbbz-to-update))
      (foreach ea-zbbz-object ea-zbbz-to-update
(if (= (type ea-zbbz-object) 'ENAME)
   (progn
     (setq ea-zbbz-object
     (vlax-ename->vla-object ea-zbbz-object)
     )
     (vlr-owner-add ea-zbbz-reactor ea-zbbz-object)
   )
)
(if (vlax-erased-p ea-zbbz-object)
   nil
   (ea-zbbz-update-attr ea-zbbz-object)
)   
      )
      ;(setq ea-zbbz-to-update nil)
      (princ)
    )     
  )
  (princ)
)
;;实体反应器，实体复制或被修改时调用
(if (null ea-zbbz-object-reactor)
  (setq ea-zbbz-object-reactor
  (vlr-object-reactor
    nil
    "EA-ZBBZ-Reactor"
    '((:vlr-ObjectClosed . ea-zbbz-record)
      (:vlr-Copied . ea-zbbz-copied)
     )
  )
  )
)
;
;;; ea-zbbz-object-Reactor 反应器回调函数,对象被修改后调用
(defun EA-Zbbz-Record (owner-object reactor-object parameter-list)
  (if (not (vlax-erased-p owner-object))
    (setq ea-zbbz-to-update
    (append ea-zbbz-to-update (list owner-object))
    )
  )
)
;; 反应器回调函数，复制实体后调用
(defun EA-Zbbz-Copied (owner-object reactor-object
         parameter-list /
         new-ename
        )
  (setq ea-zbbz-reactor reactor-object)
  (setq new-ename (car parameter-list))
  (setq ea-zbbz-to-update (append ea-zbbz-to-update (list new-ename)))
)
(defun c:Ea:Zbbz-Reset (/ ss)
  (if (setq ss (ssget '((-3 ("EA_ZBBZ")))))
    (vlax-for item (vla-get-activeselectionset
       (thisdrawing)
     )
      (if (not (member item (vlr-owners ea-zbbz-reactor)))
(vlr-owner-add ea-zbbz-reactor item)
      )
      (ea-zbbz-update-attr item)
    )
  )
)     ; end progn
(defun c:Ea:Zbbz-Release (/ ss)
  (if (setq ss (ssget '((-3 ("EA_ZBBZ")))))
    (vlax-for item (vla-get-activeselectionset
       (thisdrawing)
     )
      (if (member item (vlr-owners ea-zbbz-reactor))
(vlr-owner-remove ea-zbbz-reactor item)
      )
    )
  )     ; end vlax-for
  (princ)
)
(defun ea:ucson ()
  (if (tblsearch "ucs" "$Ea_tmpucs")
    (vl-cmdf "ucs" "d" "$Ea_tmpucs")
  )
  (if (and (zerop (getvar "worlducs"))
    (= (getvar "ucsname") "")
      )
    (vl-cmdf ".ucs" "s" "$Ea_tmpucs")
    (setq $ea_tmpucs (getvar "ucsname"))
  )
  (vl-cmdf ".ucs" "w")
  (princ)
)
(defun ea:ucsoff ()
  (cond
    ($Ea_tmpucs
     (vl-cmdf ".ucs" "r" $Ea_tmpucs)
     (setq $ea_tmpucs nil)
    )
    ((tblsearch "ucs" "$Ea_tmpucs")
     (vl-cmdf ".ucs" "r" "$Ea_tmpucs")
     (vl-cmdf ".ucs" "d" "$Ea_tmpucs")
    )
    (T)
  )
  (princ)
)
(defun c:ea:linUCS (/ p do_pick do_ucs  _ealucs_id )
  (defun do_pick (/ e ucsname)
    (if (setq e (ea:entself "\n选择参照坐标块: " '((-3 ("Yb_zbbz*")))))
(setq ucsname (vlax-ldata-get "ea_ucs")
       pointmat     (ea:getucsmatrix ucsname)
)
    )
  )
  (defun do_ucs ()
    (setq ucslst (ea:table "ucs"))
    (if (not ucslst)
      (setq ucslst (list "WCS"))
    )
    (setq cucs (nth $value cuclst))
  )
  (defun do_default (/ ucslst cucs)
    (setq ucslst (ea:table "ucs"))
    (if (not ucslst)
      (setq ucslst (list "WCS"))
    )
    (if (= (getvar "ucsname") "")
      (setq cucs "WCS")
    )
    ($EADCL_AddList "ucsname" ucslst cucs)
  )
  (initget "S")
  (while (setq p (getpoint "\nPoint [S - 设定UCS]: "))
  (cond
    ((= p "S")
     (if (not _ealucs_id)
       (setq _ealucs_id (load_dialog "ea_zbbz.dcl"))
     )
     (if (not (new_dialog "ea_linUCS" _ealucs_id))
       (exit)
     )
     (do_default)
     (action_tile "accept" "(done_dialog 0)")
     (action_tile "pick" "(do_pick)")
     (action_tile "ucsname" "(do_ucs)")
     (setq what_next (start_dialog))
     (if (= what_next 4)
       (do_pickpt)
     )
    )
    (t
     (setq p (ea:point_transformby p mat)
  )
)
;;自动保存UCS
(defun Ea:Zbbz_GetEAucs (/ r d n num)
  (while (setq d (tblnext "ucs" (null d)))
    (if
      (and (wcmatch (setq n (strcase (cdr (assoc 2 d)))) "EA_*")
    (numberp
      (setq
        num (read (vl-string-left-trim "EA_" n))
      )
    )
      )
       (setq r (cons num r))
    )
  )
  (if r
    (apply 'max r)
    0
  )
)
(defun ea:WgtoUCS (/ p0 p00 p1 p2 vx vy wcs_orgin d_xy p11 p21 por)
  (princ "\n注意: 选择网格线交点...")
  (if (and
(setq p0 (getpoint "\n定位点<回车取当前坐标系>: "))
(if p0
   (princ p0)
   t
)
(if (not (setq p00 (getpoint "\n定位点实际坐标<确认>：")))
   (setq p00 p0)
   t
)
(setq xAxis (getpoint po "\nX 轴正向任意一点: "))
(setq yAxis (getpoint po "\nY 轴正向任意一点: "))
      )
    (progn
      (ea:grdraw p0)
      (setq an (angle p0 px)
     vx (mapcar '- px p0)
     vy (mapcar '- py p0)
     tf (- (* (car vx) (cadr vy))
    (* (car vy) (cadr vx))
        )
      )
      (setq py (polar p0
        (if (> tf 0.)
   (+ an (/ pi 2))
   (- an (/ pi 2))
        )
        (distance p0 py)
        )
      )
      (ea:adducs "Ea_1"
   (trans p0 1 0)
   (trans px 1 0)
   (trans py 1 0)
      )
      (setq mat (ea:getucsmatrix "01"))
      (setq po (ea:point_transformby (mapcar '- p) mat))
      (vla-put-origin
(vla-item (vla-get-UserCoordinateSystems
      (vla-get-activedocument (vlax-get-acad-object))
    )
    "01"
)
(vlax-3d-point po)
      )
      (vlax-ldata-put
"ea_axis"
"ea_form"
(ea:matrix_inverse
   (ea:getucsmatrix
     "ea_zbbz"
   )
)
      )
      (ea:grdraw p0)
    )
  )
)
(defun ea:2ptoUcs (/ p11 p1 p22 p2 v1 v2 pl $ea_tmpentity)
  (if (and (setq p1 (getpoint "\n第一定位点: "))
    (setq p11 (getpoint "\n定位点实际坐标: "))
    (setq p2 (getpoint p1 "\n第二定位点: "))
    (setq p22 (getpoint "\n定位点实际坐标: "))
    (setq p1 (trans p1 1 0)
   p2 (trans p2 1 0)
   v1 (mapcar '- p2 p1)
   v2 (mapcar '- p22 p11)
    )
    (equal (distance '(0. 0.)
       v1
    )
    (distance '(0. 0.) v2)
    1e-4
    )
      )
    (progn
      (ea:ucson)
      (if (equal (car p11) (car p22) 1e-5) ; x 相等
(if (< (cadr p11) (cadr p22))
   (setq pl (list p2 p1))
   (setq pl (list p1 p2))
)
(if (< (car p11) (car p22))
   (setq pl (list p1 p2))
   (setq pl (list p2 p1))
)
      )
      (apply 'command (cons ".line" pl))
      (command)
      (setq $ea_tmpentity (entlast))
      (vl-cmdf ".ucs" "e" $ea_tmpentity)
      (entdel $ea_tmpentity)
      (vl-cmdf ".ucs" "z" (* (/ (- (angle '(0. 0.) v2)) pi) 180))
      (vl-cmdf ".ucs" "o" (mapcar '- p11))
      (if (tblsearch "ucs" "ea_1")
(vl-cmdf "ucs" "s" "ea_1" "y")
(vl-cmdf ".ucs" "s" "ea_1")
      )
      (ea:ucsoff)
    )
  )
  (princ)
)
;;当前标注坐标系的词典信息
(defun Ea:ZBBZ_DictInfo (/ ucs ucsname org xdir ydir dragmode ang)
  (setq ucs (ea:string_parse (vlax-ldata-get "Ea_Dict" "Ea_zbbz") "|"))
  (list (car ucs);name
(read (cadr ucs));org
(read (caddr ucs));xdir
(read (cadddr ucs));ydir
(read (nth 4 ucs));动态
(read (last ucs));水平
  )
)
;;初始化坐标标注环境
(defun Ea:Zbbz_Init (/ aucs eucs num org ucs ucsname xdir ydir)
  (if (setq ucs (ea:zbbz_dictinfo))
    ;;有纪录
    (progn
      (setq ucsname (car ucs)
     org     (cadr ucs)
     xdir    (caddr ucs)
     ydir    (cadddr ucs)
      )
      ;;       互换标志|高程标志|建筑坐标|小数点位数|连字符|字高|X前缀|Y前缀|
      (cond
((tblsearch "Ucs" ucsname) ;仍有UCS
  (princ (strcat "\n\t当前标注坐标系 [" ucsname "]."))
  (if (not
        (vlax-ldata-get
   (setq
     aucs (vla-item
     (vla-get-UserCoordinateSystems (thisdrawing))
     ucsname
   )
   )
   "Ea_info"
        )
      )    ;纪录是否丢失
    (vlax-ldata-put
      aucs
      "Ea_info"
      (strcat "1|0|1|3|0|"
       (vl-princ-to-string (last (ea:init)))
       "0|0"
      )
    )
  )
)
(t    ;UCS被删除
  (setq eucs
  (vla-add (vla-get-UserCoordinateSystems (thisdrawing))
    (vlax-3d-point org)
    (vlax-3d-point xdir)
    (vlax-3d-point ydir)
    ucsname
  )
  )
  (vlax-ldata-put
    eucs
    "Ea_info"
    (strcat "1|0|1|3|0|"
     (vl-princ-to-string (last (ea:init)))
     "0|0"
    )
  )
  (princ (strcat "\n\t当前标注坐标系恢复为 ["
   (vla-get-name eucs)
   "]. 并保存!"
  )
  )
)
      )
    )
    ;;词典无纪录
    (progn
      (setq num (ea:zbbz_geteaucs))
      (if (= (getvar "ucsname") "")
(setq eucs
        (vla-add (vla-get-UserCoordinateSystems (thisdrawing))
   (vlax-3d-point (getvar "ucsorg"))
   (vlax-3d-point (getvar "ucsxdir"))
   (vlax-3d-point (getvar "ucsydir"))
   (if (= (getvar "ucsname") "")
     (strcat "EA_" (itoa (1+ num)))
   )
        )
)
(setq
   eucs (vla-get-activeucs
   (vla-get-activedocument (vlax-get-acad-object))
        )
)
      )
      (vlax-ldata-put
eucs
"Ea_info"
(strcat "1|0|1|3|0|"
  (vl-princ-to-string (last (ea:init)))
  "0|0"
)
      )
      (vlax-ldata-put
"Ea_Dict"
"Ea_zbbz"
(strcat (vla-get-name eucs)
  "|"
  (vl-princ-to-string (getvar "ucsorg"))
  "|"
  (vl-princ-to-string (getvar "ucsxdir"))
  "|"
  (vl-princ-to-string (getvar "ucsydir"))
  "|0|0"
)
      )
      (princ (strcat "\n\t当前坐标系已保存为 ["
       (vla-get-name eucs)
       "] ,并设为当前标注坐标系!"
      )
      )
    )
  )
  (princ)
)
;;获取UCS信息
(defun ea:zbbz_sysinfo ()
  (ea:string_parse
    (vlax-ldata-get
      (vla-item
(vla-get-UserCoordinateSystems (thisdrawing))
(car (ea:zbbz_dictinfo))
      )
      "Ea_info"
    )
    "|"
  )
)
;;转换点到指定标注坐标系
(defun Ea:Point_to_UCS (p / cucs)
  (setq cucs (car (ea:zbbz_dictinfo)))
  (if (/= cucs (getvar "ucsname"))
    (ea:point_transformby
      (trans p 1 0)
      (ea:matrix_inverse
(ea:getucsmatrix cucs)
      )
    )
    p
  )
)
;;坐标串变为等长
(defun ea:strlst_same_length (pl num)
  (mapcar
    '(lambda (x)
       (ea:string_zeropad
  (read x)
  (apply
    'max
    (mapcar 'strlen
     pl
    )
  )
  " "
  num
       )
     )
    pl
  )
)
;;标注点表转换为串表
(defun ea:point_to_string (p_     /      #build_crd        #lstr
      #num_num #xy_xcon p       plst     px_
      py_     x      _contrl  #xpre    #ypre
      #lcon
     )
  ;;互换标志|高程标志|建筑坐标|小数点位数|连字符|字高|X前缀|Y前缀
  (setq _contrl (ea:zbbz_sysinfo))
  (setq #xy_xcon   (car _contrl) ;互换标志
#num_num   (nth 3 _contrl) ;小数位数
#build_crd (nth 2 _contrl) ;建筑标
#lcon    (nth 4 _contrl) ;连字符
#xpre    (nth 7 _contrl)
#ypre    (last _contrl)
  )
  (cond
    ((= #lcon 0)
     (setq #lstr " ")
    )
    ((= #lcon 1)
     (setq #lstr "=")
    )
    ((= #lcon 2)
     (setq #lcon "-")
    )
    (t (setq #lstr ""))
  )
  ;;p 标注数字
  (setq p (ea:Point_to_UCS p_))
  ;;转为串表
  (setq plst (mapcar '(lambda (x)
   (rtos (if (= (cadr (ea:init)) 1.0)
    (* x 0.001)
    x
         )
         2
         #num_num
   )
        )
       (ea:point_2d p)
      )
  )
  (if (= #build_crd 1)
    (setq px_ (strcat "A" #lstr)
   py_ (strcat "B" #lstr)
    )
    (setq px_ (strcat "X " #lstr)
   py_ (strcat "Y " #lstr)
    )
  )
  (if (or (= #xy_xcon 1)
   (wcmatch px_ "A*")
      )
    (setq plst (reverse plst))
  )
  (list (list (vl-string-left-trim #xpre (car plst))
       (vl-string-left-trim #ypre (cadr plst))
)
(list px_ py_)
  )
)
;;互换标志|高程标志|建筑坐标|小数点位数|连字符|字高|X前缀|Y前缀
;;参数对话框设定
(defun Ea:SetSyscrd (/ #num_num      #xy_xcon    lb1
         nl_list      what_next    _contrl
         _eabz_id      rs_error    do_set_error
         check_in      do_default    do_coordsys
         do_xconvert   do_dmhigh    edit_in
        )
  (setq nl_list '(0 1 2 3 4))
  (defun rs_error ()
    (set_tile "error" "")
  )
  (defun do_set_error (val)
    (rs_error)
    (set_tile "error" val)
  )
  ;;检查输入格式
  (defun check_in (input format kk /)
    (if (and (distof input 2) (> (atof input) 0))
      (progn (rs_error) input)
      (progn
(do_set_error (strcat "无效的" format "输入"))
(mode_tile kk 2)
nil
      )
    )
  )  
  (defun do_default (/   _contrl     #bl  #scl
       #yb_coord_sys      #hi_mark  #num_num
       #build_crd do_mkbul do_help0
      )
    (setq _contrl (ea:zbbz_sysinfo))
    (setq #yb_coord_sys (car _contrl) ;坐标系
   #hi_mark (nth 2 _contrl) ;高程标志
   #num_num (nth 4 _contrl) ;小数位数
   #build_crd (nth 3 _contrl) ;建筑标
   #xy_xcon (cadr _contrl)
    )
    (set_tile "xcv" (itoa #xy_xcon))
    (set_tile "num" (itoa #num_num))
    (set_tile "bul" (itoa #build_crd))
    (set_tile "hig" (itoa #hi_mark))
  )
  ;;设定坐标系
  (defun do_coordsys (/ str _contrl #yb_coord_sys)
    (setq _contrl (ea:getsysinfo))
    (setq #yb_coord_sys (car _contrl)) ;坐标系
    (setq str (vlax-ldata-get "ea_axis" "ea_contrl"))
    (vlax-ldata-put
      "ea_axis"
      "ea_contrl"
      (vl-string-subst
(cond
   ((= (get_tile "type_crd") "cus") "0")
   ((= (get_tile "type_crd") "cur") "1")
   ((= (get_tile "type_crd") "wor") "2")
)
(itoa #yb_coord_sys)
str
0
      )
    )
  )
  ;;设定标注值互换;
  (defun do_xconvert (/ str _contrl #xy_xcon)
    (setq _contrl (ea:getsysinfo))
    (setq #xy_xcon (cadr _contrl)) ;互换标志
    (setq str (vlax-ldata-get "ea_axis" "ea_contrl"))
    (vlax-ldata-put
      "ea_axis"
      "ea_contrl"
      (vl-string-subst
$value
(itoa #xy_xcon)
str
1
      )
    )
  )
  ;;设定是否为建筑坐标;
  (defun do_mkbul (/ str _contrl #build_crd)
    (setq _contrl (ea:getsysinfo))
    (setq #build_crd (nth 3 _contrl)) ;建筑标
    (setq str (vlax-ldata-get "ea_axis" "ea_contrl"))
    (vlax-ldata-put
      "ea_axis"
      "ea_contrl"
      (vl-string-subst
(if (= $value "1")
   "1"
   "0"
)
(itoa #build_crd)
str
6
      )
    )
  )
  ;;设定标高标注标志；
  (defun do_dmhigh (/ str _contrl #hi_mark)
    (setq _contrl (ea:getsysinfo))
    (setq #hi_mark (nth 2 _contrl)) ;高程标志
    (setq str (vlax-ldata-get "ea_axis" "ea_contrl"))
    (vlax-ldata-put
      "ea_axis"
      "ea_contrl"
      (vl-string-subst
$value
(itoa #hi_mark)
str
3
      )
    )
  )
  (defun edit_in (n val / ppt k1)
    (cond ((= n 1)
    (setq ppt "出图比例"
   k1  "scal"
    )
   )
   ((= n 2)
    (setq ppt "坐标系数"
   k1  "scl"
    )
   )
    )
    (if (check_in val ppt k1)
      (cond
((= n 1) (do_scale))
((= n 2) (do_scle))
      )
    )
  )
  ;;设定小数位数
  (defun do_num (/ str)
    (setq _contrl (ea:getsysinfo))
    (setq #num_num (nth 4 _contrl)) ;小数位数
    (setq str (vlax-ldata-get "ea_axis" "ea_contrl"))
    (vlax-ldata-put
      "ea_axis"
      "ea_contrl"
      (vl-string-subst
$value
(itoa #num_num)
str
6
      )
    )
  )
  (defun do_help0 ()
    (alert
      "\n坐标标注系统 Eatools
         \n===========================================
         \n  1 标注坐标系　设定要标注坐标的坐标系
         \n    新建　　　　通过拾取点并输入数值建立坐标系
         \n    重建　　　　重建当前标注坐标系
         \n    参照        通过拾取已有坐标块设定标注坐标系
         \n  2 字高　　　　标注文字的实际字高
         \n  3 小数位数　　指定坐标值保留小数点后的位数
         \n  4 连字符　　　X/A后面与数字的联系符号
         \n  5 前缀　　　　X/A字串很长时的前缀数字
         \n  6 互换　　　　点坐标值上下位置互换
         \n  7 建筑坐标　　标注A/B坐标
         \n  8 标注高程　　坐标后含高程,两种格式坐标上下带高程或后面随高程
         \n  9 动态标注　　标注坐标在所属坐标系自动更新
         \n 10 水平标注　　坐标块始终平行视图, 省略角度提示"
    )
  )
  (if (not _eabz_id)
    (setq _eabz_id (load_dialog "ea_zbbz.dcl"))
  )
  (if (not (new_dialog "ea_zbbz" _eabz_id))
    (exit)
  )
  (do_default)
  (action_tile "accept" "(done_dialog 0)")
  (action_tile "pick" "(done_dialog 1)(ea:wgtoucs)")
  (action_tile "scal" "(edit_in 1 $value)")
  (action_tile "scl" "(edit_in 2 $value)")
  (action_tile "num" "(do_num)")
  (action_tile "type_crd" "(do_coordsys)")
  (action_tile
    "xcv"
    "(setq lb1 (= $value \"0\"))(do_xconvert)"
  )
  (action_tile "bul" "(do_mkbul)")
  (action_tile "help" "(do_help0)")
  (action_tile "hig" "(do_dmhigh)")
  (setq what_next (start_dialog))
  (unload_dialog _eabz_id)
  (princ)
)
;;主程序;
;;pl (标注点  输出点  角度)  str1 "高程,高程"   str3－－单个H高程;;
;;可以作为批量标注的子程序
(defun Ea:ZBBZ (pl str1 str2 str3 / modelspace
  $yb_mkunblk tf p_ pt2 p pangle
  plst px_ py_ px py $high $hi_1
  $hi_2 #bl #num_num xylst strlst
        )
   (setq _contrl (ea:getsysinfo))
    (setq #bl    (last _contrl) ;出图比例
   #num_num (nth 4 _contrl) ;小数位数
    )
    (setq p_  (car pl)
   p2  (cadr pl)
   pangle (last pl)
    )
    (setq plst (ea:point_to_string p_)) ;点表转换为串表
    (setq xylst (ea:strlst_same_length (car plst) #num_num))
     ;空格补位使字符数相等
    (setq strlst (mapcar 'strcat (last plst) xylst)
   px  (car strlst)
   py  (cadr strlst)
    )
    ;;增加高程
    (if str1
      (setq px (strcat px " H=" str1)
     py (strcat py " h=" str2)
      )
    )
    (setq lx (ea:text_maxlength (list px py) #bl))
    (setq pt3 (polar p2 pangle lx)) ;线末点
    (if (or (> pangle _3pi) (<= pangle _pi2))
      (progn
(setq pa2 (polar p2 (+ pangle _pi4) (* (sqrt 2.0) #bl)))
     ;X插入点
(setq pa3 (polar pa2 (- pangle _pi2) (* 2 #bl))) ;Y插入点
      )
      (progn
(setq pa2 (polar pt3 (+ pangle (* pi 1.25)) (* (sqrt 2.0) #bl)))
     ;X插入点
(setq pa3 (polar pa2 (+ pangle _pi2) (* 2 #bl))) ;Y插入点
      )
    )
    (if tf
      (progn
(setq BLKDEF (ea:addblk "*U"))
(vla-AddLightweightPolyline
   blkdef
   (list->VariantArray (list p_ p2 pt3) vlax-vbdouble)
)
(mapcar
   '(lambda (x y / txt)
      (setq txt (vla-addattribute
    BLKDEF
    0.25
    acAttributeModePreset
    ""
    (vlax-3d-point x)
    ""
    ""
         )
      )
      (vla-put-alignment txt acAlignmentMiddleCenter)
      (vla-put-TextAlignmentPoint txt (vlax-3d-point y))
    )
   (list pa2 pa3)
   ;;点表
   (list px py)
   ;;串表
)
(setq blkref (vla-insertblock
         (vla-get-modelspace (thisdrawing))
         (trans p 1 0)
         1.
         1.
         1.
         0.
       )
)
(ea:entity_addatt (entlast) "Yb_zbbz" "Yb_zbbz")
(if (null ea-zbbz-reactor)
   (setq ea-zbbz-reactor
   (vlr-object-reactor
     (list blkref)
     "EA-ZBBZ-REACTOR"
     '((:vlr-ObjectClosed . ea-zbbz-record) ;对对象的修改
       (:vlr-Copied . ea-zbbz-copied) ;对象复制
      )
   )
   )
   (vlr-owner-add ea-zbbz-reactor blkref)
)
      );生成插入块
      (progn;生成模拟部分
)
    )
)
;;模拟标注位置。
;;Grvecs与矩阵配合实例：动态拖动演示框 By Eachy 2003.02.28
(defun ea:drawbox (pl tf / urp0 loop urp1 source pt col)
  (setq urp (car pl))
  (setq loop t)
  (prompt (if tf
     "\n目标点<退出>: "
     "\n输出点<退出>: "
   )
  )
  (while loop
    (setq urp1 (grread t 1 2))
    (setq source (car urp1)
   pt  (cadr urp1)
    )
    (cond
      ((and (= source 5)  ;跟踪点
     (or (/= (car urp) (car pt))
  (/= (cadr urp) (cadr pt))
     )
     loop
       )
       (progn
  (if urp0   ;用屏幕色覆盖前次绘制的矢量不可用windows颜色背景
    (ea:grvecs (if (= (length pl) 3)
   (list urp urp0 (last pl))
   (list urp urp0)
        )
        col
    )
  )
  (ea:grvecs (if (= (length pl) 3)
        (list urp pt (last pl))
        (list urp pt)
      )
      (if (= col 255)
        255
        -1
      )
  )
  (setq urp0 pt)
       )
      )
      ((and (or (= source 3)  ;拾取点
  (and (= source 2) (or (= pt 13) (= pt 32)))
     )
     loop
       )
       (ea:zbbz pt str);
       (setq loop nil)
      
      )
    )
  )
)
;;坐标标注
(defun c:ea:zbbz (/ _contrl #hi_mark tf col p1_ lst pangle1 $hi_1 $hi_2
    $high)
  (setq _contrl (ea:getsysinfo))
  (setq #hi_mark (nth 2 _contrl)) ;高程标志
  (ea:begin '("dimzin" "cmdecho" "textstyle" "osmode"))
  (setvar "textstyle" "yb_zbbz")
  (setq tf t)
  (setq col (ea:getmsbackgroundcolor))
  (if (> col 255)
    (setq col 255)
  )
  (while tf
    (initget "S")
    (setq p1_ (getpoint "\n测量点[S - 设置]<退出>: "))
    (cond
      ((= (type p1_) 'STR)
       (cond
  ((= p1_ "S")
   (ea:setsyscrd)
   (setq _contrl (ea:getsysinfo))
   (setq #hi_mark (nth 2 _contrl)) ;高程标志
  )
  (T "输入错误!")
       )
      )
      ((= (type p1_) 'LIST)
       (setq lst (ea:drawbox (list p1_) nil))
       (if (= (type lst) 'LIST)
  (progn
    (grdraw p1_ lst 1 -1)
    (setq
      pangle1 (getangle
         lst
         (strcat "\n角  度<"
          (rtos (ea:rtd $yb_coord_angle) 2 3)
          ">: "
         )
       )
    )
    (grdraw p1_ lst col)
    (if pangle1
      (setq $yb_coord_angle pangle1)
      (setq pangle1 $yb_coord_angle)
    )
    (if (= #hi_mark 1)
      (progn
        (princ "\n注意: 两个标高时用逗号隔开.......")
        (SETQ $high
        (getstring
   "\n输入标注点高程[<标高> / 设计标高,自然标高]: "
        )
        )
        ;;是否输入两个标高
        (cond
   ((wcmatch $high "*`,*")
    (setq $hi_1 (rtos
    (read
      (car (ea:string_parse $high ","))
    )
    2
    2
         )
   $hi_2 (rtos
    (read
      (last (ea:string_parse $high ","))
    )
    2
    2
         )
    )
    (setq $high nil)
   )
   ((ea:string_isnum $high) $high)
   (t
    (setq $high nil
   $hi_1 nil
   $hi_2 nil
    )
   )
        )
      )    ;progn
    )    ;if
    (ea:zbbz (list p1_ lst pangle1) $hi_1 $hi_2 $high)
    (setq $hi_1 nil
   $hi_2 nil
   $high nil
    )
  )
       )
      )
      (t (setq tf nil))
    )
  )
  
  (ea:end)
  (princ)
)

;|;标网格线坐标
(defun c:Ea:BzAxis (/      #bl      #scl     #yb_coord_sys
      #form    #build_crd        #xy_xcon tf
      e      sp       ep       pick_pt p
      p1      _angle   alin     str
     )
  (setq tf t)
  (ea:begin '("osmode" "textstyle"))
  (setvar "osmode" 16384)
  (setvar "textstyle" "yb_zbbz")
  (while tf
    (if (setq e (entsel "\n选择网格线标注一端: "))
      (progn
(setq _contrl (ea:getsysinfo))
(setq #bl     (last _contrl) ;出图比例
       #scl     (nth 5 _contrl) ;坐标系数
       #yb_coord_sys (car _contrl) ;坐标系
       #form     (vlax-ldata-get "ea_axis" "ea_form")
       #build_crd    (nth 3 _contrl) ;建筑标
       #xy_xcon     (cadr _contrl) ;互换标志;
)
(setq sp      (ea:dxf (car e) 10)
       ep      (ea:dxf (car e) 11)
       pick_pt (last e)
)
(cond
   ((= #yb_coord_sys 0)  ;自定义坐标系
    (setq sp  (ea:point_transformby (trans sp 1 0) #form)
   ep  (ea:point_transformby (trans ep 1 0) #form)
   pick_pt (ea:point_transformby (trans pick_pt 1 0) #form)
    )
   )
   ((= #yb_coord_sys 1)  ;当前坐标系
    (setq sp (trans sp 0 1)
   ep (trans ep 0 1)
    )
   )
   ((= #yb_coord_sys 2)  ;世界坐标系
    (setq pick_pt (trans pick_pt 1 0))
   )
)
(setq
   p
    (if (> (distance pick_pt sp) (distance pick_pt ep))
      ep
      sp
    )
)
(setq
   p1  (polar p
   (if (equal p sp)
     (angle ep sp)
     (angle sp ep)
   )
   #bl
   )
   _angle (angle p1 p)
)
(setq p (mapcar '(lambda (x) (* x #scl)) p))
(if
   (or (> _angle _3pi)
       (<= _angle _pi2)
   )
    (setq alin "mr")
    (setq alin "ml")
)
(if (= (ea:angle_format _angle) 0.0)
   (progn
     (setq str (ea:point_to_string p))
     (command ".text"
       "j"
       alin
       p1
       (* 4 #bl)
       (ea:rtd (ea:angle_format (angle sp ep)))
       str
     )
   )
   (princ "\n选择线不是整数坐标线，重新检查!")
)
      )
      (setq tf nil)
    )
  )
  (ea:end)
  (princ)
)
;;通过两点定网格线
(defun c:ea:draxis (/    p1   p2  #bl #scl   #xy_xcon
      v1    v2   j1  j2 _j$    pint   mat0
      mat    p_lt   p_lb  p_rt p_rb   pbox   p10
      p20    p0   #xyconvert #BL    #SCL   #XY_XCON
     )
  (ea:begin '("osmode" "cmdecho"))
  (if (and (setq p1 (getpoint "\n第一定位点: "))
    (setq p10 (getpoint "\n定位点实际坐标: "))
    (setq p2 (getpoint "\n第二定位点: "))
    (setq p20 (getpoint "\n定位点实际坐标: "))
      )
    (progn
      (setq _contrl (ea:getsysinfo))
      (setq #bl      (last _contrl) ;出图比例
     #scl     (nth 5 _contrl) ;坐标系数
     #xy_xcon (cadr _contrl) ;互换标志;
      )
      (setvar "osmode" 0)
      (setvar "cmdecho" 0)
      (setq mat0 (ea:matrix_identity))
      (setq v1 (mapcar '- p2 p1)
     v2 (mapcar '- p20 p10)
     p0 '(0. 0.)
     j1 (angle p0 v1)
     j2 (angle p0 v2)
     _j$ (ea:vector_angle v1 v2)
      )
      (setq p_lb (mapcar '(lambda (x)
       (- x (rem x (* 100 #bl)))
     )
    (mapcar 'fix p10)
   )
      )
      (setq p_rb (polar p_lb 0. (* 100 #bl))
     p_lt (polar p_lb _pi2 (* 100 #bl))
     p_rt (mapcar '(lambda (x) (+ x (* 100 #bl))) p_lb)
      )
      (setq pbox (mapcar '(lambda (x) (trans x 0 1))
    (list p_lb p_rb p_rt p_lt)
   )
      )
      (apply 'command (cons ".pline" pbox))
      (command "c")
      (command ".align"
        (entlast)
        ""
        (trans p10 0 1)
        p1
        (trans p20 0 1)
        p2
        ""
        "n"
      )
    )
  )
  (ea:end)
  (princ)
)
;;;|
对坐标块返回(标志 (插入点 输出点 角度) H(x) h(y) H)
标志 T 正确 nil 移动或拷贝的
;;;;;;
(defun ea:get_zb_block_info (e     /    obj   pinst  $blkang
        mat    blockobj   plst  p2 p3
        pangle lst    xstr   ystr  hstr x
        y     h1    h2   p  #form REALLST
        X     num
       )
  (setq obj (vlax-ename->vla-object e))
  (setq pinst (ea:dxf e 10)
$blkang (ea:dxf e 50)  ;旋转角
  )
  (setq reallst (car (ea:point_to_string pinst))) ;应标注坐标
  (setq lst  (ea:getattributes obj)
xstr (cadar lst)  ;X字串
ystr (cadadr lst)  ;Y字串
hstr (if (= (length lst) 3) ;H字串
        (if (= (substr (cadr (last lst)) 1 1) "H")
   (substr (cadr (last lst)) 3)
   (cadr (last lst))
        )
        nil
      )
  )
  (setq x (vl-string-left-trim " " (substr xstr 2))
y (vl-string-left-trim " " (substr ystr 2))
  )
  (if (setq num (vl-string-search "H" xstr))
    (setq x  (vl-string-right-trim
        " "
        (vl-string-left-trim " " (substr xstr 2 (- num 2)))
      )
   h1 (substr xstr (+ num 3))
   y  (vl-string-right-trim
        " "
        (vl-string-left-trim " " (substr ystr 2 (- num 2)))
      )
   h2 (substr xstr (+ num 3))
    )
  )
  (setq entlst (ea:totale_entity_InBlock e))
  (setq blockobj (vla-item (vla-item (vla-get-blocks (active-document))
         (vla-get-name obj)
      )
      0
   )
plst  (mapcar '(lambda (x) (ea:point_3d x 0.))
    (xylist->listofpoints
      (ea:lisp-value
        (vla-get-Coordinates blockobj)
      )
    )
   )   ;PL线点
  )
  (setq mat (ea:matrix_settranslation
       (ea:matrix_identity)
       (mapcar '- pinst (car plst))
     )
  )
  (if (not (zerop $blkang))
    (setq mat (ea:matrx_setrotation mat pinst $blkang))
  )
  (setq p2     (ea:point_transformby (cadr plst) mat)
p3     (ea:point_transformby (last plst) mat)
pangle (angle p2 p3)
  )
  (list (equal reallst (list x y)) ;标志
(list pinst   ;插入点
       p2
       pangle
)
h1
h2
hstr
  )
)
;;坐标缩放
;|
对坐标块返回(标志 (插入点 输出点 角度) H(x) h(y) H)
标志 T 正确 nil 移动或拷贝的
;
(defun c:Ea_SCLzb (/     listEntitiesInBlock        $yb_list_del
     ss     n      e       elst     plst
     e1     e2      e3       inspt    $midp
     $ep     att_x    att_y    att_h    pangle
     $yb_sclzb      p1       p2       p3
     p4     $px      $py      $ph      $z_ang
     $z_h     _h      lst0     lst1     blkn
     lastent  exdata   newent   _lz      $dis_xy
     $b_pm    $blkang
    )
  (defun listEntitiesInBlock (e / ent lst blockName)
    (setq blockName (cdr (assoc 2 (entget e))))
    (setq ent (tblobjname "block" blockName))
    (while (setq ent (entnext ent)) (setq lst (cons ent lst)))
    (reverse lst)
  )
  (defun $yb_list_del (lt n / lt1 lt2)
    (setq lt2 lt)
    (repeat n
      (setq lt1 (cons (car lt2) lt1)
     lt2 (cdr lt2)
      )
    )
    (append (reverse lt1) (cdr lt2))
  )
  (princ "\n选择变比坐标实体.....")
  (if (setq ss (ssget '((-3 ("Yb_zbbz")))))
    (progn
      (ea:begin '("dimzin" "cmdecho" "textstyle" "osmode"))
      (setvar "textstyle" "yb_zbbz")
      (setq $yb_sclzb (getreal "\n缩放系数: "))
      (setq n 0)
      (repeat (sslength ss)
(setq e (ssname ss n))
;;(pl x y h)
(setq elst (append (listEntitiesInBlock e) (ea:block_getatt e)))
(setq
   plst   (ea:massoc 10 (entget (car elst)))
   inspt   (ea:dxf e 10)
   $blkang (ea:dxf e 50)
   plst   (list inspt
   (setq $b_pm
          (polar
     inspt
     (+ $blkang (angle (car plst) (cadr plst)))
     (distance (car plst) (cadr plst))
          )
   )
   (polar $b_pm
          (+ $blkang (angle (cadr plst) (last plst)))
          (distance (cadr plst) (last plst))
   )
    )
   $midp   (cadr plst)
   $ep   (last plst)
   pangle  (angle $midp $ep)
   e1   (cadr elst)  ;X
   $px   (ea:dxf e1 10)
   e2   (nth 2 elst)  ;Y
   $py   (ea:dxf e2 11)
   e3   (last elst)  ;H
   $ph   (ea:dxf e3 10)
   $z_ang  (ea:dxf e1 50)
   $z_h   (ea:dxf e1 40)
   _lz   (max (abs (car (last (textbox (entget e1)))))
         (abs (car (last (textbox (entget e2)))))
    )
   _h   (cadr (last (textbox (entget e1))))
   $dis_xy (distance $px $py)
)
(cond
   ((> (* (ea:point_online $midp $ep inspt) ;X侧
   (ea:point_online $midp $ep $px)
       )
       0
    )
    (if (< (distance $px $midp) (distance $px $ep))
      (progn   ;插入点为基点
        (setq
   p1
    (polar $px (angle $px $py) (* (1- $yb_sclzb) _h))
        )   ;x
        (setq
   p2 (polar p1 (angle $px $py) (* $yb_sclzb $dis_xy))
        )   ;y
        (setq p3
        (polar
   (ea:midp p1 p2)
   (- pangle pi)
   (* $yb_sclzb (distance $midp (ea:midp $px $py)))
        )
        )   ;midp
        (setq p4
        (polar p3 pangle (* $yb_sclzb (distance $midp $ep)))
        )   ;ep
      )
      (progn
        (setq
   p1
    (polar $px (angle $px $py) (* (1- $yb_sclzb) _h))
        )   ;右上交点
        (setq p1 (polar p1 pangle (* (1- $yb_sclzb) _lz)))
        (setq
   p2 (polar p1 (angle $px $py) (* $yb_sclzb $dis_xy))
        )
     ;y
        (setq
   p4
    (polar
      (ea:midp p1 p2)
      pangle
      (* $yb_sclzb (distance $ep (ea:midp $px $py)))
    )
        )   ;midp
        (setq p3 (polar p4
          (+ pangle pi)
          (* $yb_sclzb (distance $midp $ep))
   )
        )   ;ep
      )
    )
   )
   ;;Y侧
   ((< (* (ea:point_online $midp $ep inspt)
   (ea:point_online $midp $ep $px)
       )
       0
    )
    (if (< (distance $py $midp) (distance $py $ep))
      (progn   ;插入点为基点
        (setq
   p2
    (polar $py (angle $py $px) (* (1- $yb_sclzb) _h))
        )   ;x
        (setq
   p1 (polar p2 (angle $py $px) (* $yb_sclzb $dis_xy))
        )
     ;y
        (setq p3
        (polar
   (ea:midp p1 p2)
   (+ pangle pi)
   (* $yb_sclzb (distance $midp (ea:midp $px $py)))
        )
        )   ;midp
        (setq p4
        (polar p3 pangle (* $yb_sclzb (distance $midp $ep)))
        )   ;ep
      )
      (progn
        (setq
   p2
    (polar $py (angle $py $px) (* (1- $yb_sclzb) _h))
        )   ;右上交点
        (setq p2 (polar p2 pangle (* (1- $yb_sclzb) _lz)))
        (setq
   p1 (polar p2 (angle $py $px) (* $yb_sclzb $dis_xy))
        )   ;y
        (setq
   p4
    (polar
      (ea:midp p1 p2)
      pangle
      (* $yb_sclzb (distance $ep (ea:midp $px $py)))
    )
        )   ;midp
        (setq p3 (polar p4
          (+ pangle pi)
          (* $yb_sclzb (distance $midp $ep))
   )
        )   ;ep
      )
    )
   )
   ((= (* (ea:point_online $midp $ep inspt) ;直线
   (ea:point_online $midp $ep $px)
       )
       0
    )
    (if (or (equal pangle 0) (equal pangle _pi2 0.000000001))
      (progn
        (setq
   p1 (polar $px
      (angle $py $px)
      (* (1- $yb_sclzb)
         (/ $dis_xy 2)
      )
      )
        )
        (setq p2 (polar p1
          (angle $px $py)
          (* $yb_sclzb $dis_xy)
   )
        )
        (setq p3 $midp)
        (setq p4 (polar p3
          pangle
          (* $yb_sclzb (distance $midp $ep))
   )
        )
      )
      (progn
        (setq p3 $midp)
        (setq p4
        (polar p3 pangle (* $yb_sclzb (distance $midp $ep)))
        )
        (setq
   p1 (polar p4
      (+ pangle pi)
      (* $yb_sclzb (ea:point_toline $ep $px $py))
      )
        )
        (setq p1
        (polar p1
        (angle $py $px)
        (* $yb_sclzb (ea:point_toline $px $midp $ep))
        )
        )
        (setq p2 (polar p1
          (angle $px $py)
          (* $yb_sclzb $dis_xy)
   )
        )
      )
    )
   )
)
(entdel e)
(entmake
   (list '(0 . "block") '(2 . "*U") '(70 . 67) (cons 10 inspt))
)
(entmake (list '(0 . "LWPOLYLINE")
         '(100 . "AcDbEntity")
         '(8 . "0")
         '(100 . "AcDbPolyline")
         '(90 . 3)
         (cons 10 inspt)
         (cons 10 p3)
         (cons 10 p4)
         '(210 0.0 0.0 1.0)
   )
)
(setq blkn (entmake '((0 . "ENDBLK"))))
(setq lst0 (list '(0 . "INSERT")
    '(100 . "AcDbEntity")
    (cons 8 (getvar "clayer"))
    '(100 . "AcDbBlockReference")
    '(66 . 1)
    (cons 10 inspt)
    '(41 . 1.0)
    '(42 . 1.0)
    '(43 . 1.0)
    '(50 . 0.0)
    '(70 . 0)
    '(71 . 0)
    '(44 . 0.0)
    '(45 . 0.0)
    '(210 0.0 0.0 1.0)
     )
)
(setq lst1 (append lst0 (list (cons 2 blkn))))
(entmake lst1)
(setq att_x (subst (cons (if (equal (ea:dxf e1 11) '(0 0 0))
       10
       11
     )
     p1
      )
      (assoc (if (equal (ea:dxf e1 11) '(0 0 0))
        10
        11
      )
      (entget e1)
      )
      (entget e1)
      )
       att_x (subst (cons 40 (* (ea:dxf e1 40) $yb_sclzb))
      (assoc 40 att_x)
      att_x
      )
)
(entmake (cdr ($yb_list_del att_x 3)))
(setq att_y (subst (cons (if (equal (ea:dxf e2 11) '(0 0 0))
       10
       11
     )
     p2
      )
      (assoc (if (equal (ea:dxf e2 11) '(0 0 0))
        10
        11
      )
      (entget e2)
      )
      (entget e2)
      )
       att_y (subst (cons 40 (* (ea:dxf e2 40) $yb_sclzb))
      (assoc 40 att_y)
      att_y
      )
)
(entmake (cdr ($yb_list_del att_y 3))) ;去实体名及句柄 For R14
(if (= (length elst) 4)
   (progn (setq att_h (subst (cons (if (equal (ea:dxf e3 11) '(0 0 0))
         10
         11
       )
       p4
        )
        (assoc (if (equal (ea:dxf e3 11) '(0 0 0))
          10
          11
        )
        (entget e3)
        )
        (entget e3)
        )
         att_h (subst (cons 40 (* (ea:dxf e3 40) $yb_sclzb))
        (assoc 40 att_h)
        att_h
        )
   )
   (entmake (cdr ($yb_list_del att_h 3)))
   )
)
(entmake '((0 . "SEQEND")))
(ea:entity_addatt (entlast) "Yb_zbbz" "Yb_zbbz")
(setq n (1+ n))
     ;(ea:chkzb0 (vlax-ename->vla-object (entlast)))
      )
      (ea:end)
    )
    (princ "\n未找到本标注系统生成的标注实体!")
  )
  (princ)
)
;;坐标删除
(defun c:Ea_EraZB (/ ss)
  (ea:begin '("osmode"))
  (princ "\n选择范围[All - 全选]....")
  (setq ss (ssget '((-3 ("Yb_zbbz")))))
  (command "_.erase" ss "")
  (ea:end)
  (princ)
)
;;坐标移位
(defun c:Ea_StrZB (/ tf e lst pl pt inspt pangle)
  (ea:begin '("osmode" "textstyle" "cmdecho"))
  (setvar "cmdecho" 0)
  (setq tf t)
  (while tf
    (setq
      e (car
   (ea:entself "\n选择要移位坐标<退出>: " '((-3 ("Yb_zbbz"))))
)
    )
    (if e
      (progn
;;对坐标块返回(标志 (插入点 输出点 角度) H(x) h(y) H)
(setq lst    (ea:get_zb_block_info e)
       pl     (cadr lst)
       inspt  (car pl)
       pangle (last pl)
)
(setq pt (ea:drawbox (cadr lst) -1))
(if pt
   (progn
     (entdel e)
     (ea:zbbz (list inspt pt pangle)
       (nth 2 lst)
       (nth 3 lst)
       (nth 4 lst)
     )
   )
)
      )
      (setq tf nil)
    )
  )
  (ea:end)
  (princ)
)
;;坐标检查
(defun c:Ea:CHKZb (/ ss ss_ent e lst m n tf)
  (ea:begin '("osmode" "textstyle"))
  (princ "\n选择标注<回车全选>....")
  (if (not (setq ss (ssget '((-3 ("Yb_zbbz"))))))
    (setq ss (ssget "x" '((-3 ("Yb_zbbz")))))
  )
  (if ss
    (progn
      (princ
(strcat "\n共选中 " (rtos (sslength ss) 2 0) " 个标注!")
      )
      (princ "\n请等候........")
      (setq n 0
     m 0
      )
      (setq ss_ent (ea:ssgettoentitylist ss))
      (foreach e ss_ent
(setq lst (ea:get_zb_block_info e)
       tf  (car lst)
)
(if (not tf)
   (progn
     (setq m (1+ n))
     (entdel e)
     (ea:zbbz (cadr lst)
       (nth 2 lst)
       (nth 3 lst)
       (nth 4 lst)
     )
     (setq n m)
   )
)
      )
      (if (zerop m)
(princ "\n恭喜你，全部正确^_^")
(princ (strcat "\n处理完毕............OK!"
         "\n共更新了 "
         (itoa m)
         " 个坐标!"
        )
)
      )
    )
    (princ "\n未发现本系统生成的坐标块!")
  )
  (ea:end)
  (princ)
)
(defun c:Ea:SetSysCrd
       (/ #BL #BUILD_CRD #FORM #SCL #XY_XCON #YB_COORD_SYS)
  (ea:setsyscrd)
  (princ)
)
;;批量标注
(defun c:Ea:mZBBZ (/      redraw_le ss  le_drw    le_del
     e      _contrl   #bl  ll    ss1
     intspt    $ea_pts_zbbz
    )
  (defun redraw_le ()
    (foreach e le_drw (redraw e 4))
    (foreach e le_del (entdel e))
    (setq le_drw nil
   le_del nil
    )
  )
  (defun $ea_pts_zbbz (pl / pts)
    (setq pts (mapcar '(lambda (x / p2)
    (setq p2 (polar x _pi4 (* 40. #bl)))
    (list x p2 0.)
         )
        pl
       )
    )
    (mapcar '(lambda (x) (ea:zbbz x nil nil nil)) pts)
  )
  (ea:begin '("osmode" "cmdecho" "textstyle"))
  (setvar "osmode" 0)
  (setvar "cmdecho" 0)
  (setvar "textstyle" "yb_zbbz")
  (setq e (entsel "\n拾取典型图元<退出>: "))
  (if e
    (progn
      (setq ll (list (assoc 8 (entget (car e)))
       '(0 . "*line,arc,circle,ellipse")
        )
      )
      (setq ss (ssget "X" ll))
      (foreach x (ea:ssgettoentitylist ss)
(redraw x 3)
(setq le_drw (cons x le_drw))
      )
      (princ "\n选择标注图元(回车全选)....")
      (setq ss1 (ssget ll)
     ss (if ss1
    ss1
    ss
  )
      )
      (redraw_le)
      (setq _contrl
      (mapcar
        'read
        (ea:string_parse (vlax-ldata-get "ea_axis" "ea_contrl") "|")
      )
      )
      (setq #bl (last _contrl))  ;出图比例
      (if ss
(progn
   (setq intspt (ea:intlines ss))
   ($ea_pts_zbbz intspt)
   (mapcar
     '(lambda (x)
        (if (wcmatch (ea:dxf x 0)
       "*POLYLINE"
     )
   ($ea_pts_zbbz
     (reverse
       (cdr (reverse (cdr (ea:massoc 10 (entget x)))))
     )
   )
        )
      )
     (ea:ssgettoentitylist ss)
   )
)
      )
    )
  )
  (ea:end)
  (princ)
)
;;2003.04.23增加
(defun c:Ea:ZBFZ (/  ea:pointsmirror      tf     e     lst
    pl  inspt ang1   key1   p2     p21    p3
    p31  p01 an     key    msg    $ANGLE ANG
    P  P0 P1     P2     PINT
   )
  (defun ea:pointsmirror (pts p1 p2 / ang)
    (setq ang (angle p1 p2))
    (mapcar '(lambda (p / pint p0)
        (setq p0   (polar p (+ ang (/ pi 2)) 1.)
       pint (inters p1 p2 p0 p nil)
        )
        (polar pint (angle p pint) (distance p pint))
      )
     pts
    )
  )
  (ea:begin '("osmode" "textstyle" "cmdecho"))
  (setvar "cmdecho" 0)
  (setvar "textstyle" "yb_zbbz")
  (setq tf t)
  (setq msg  "左右翻转"
key1 "<R>"
  )
  (while tf
    (setq e (car
       (ea:entself
  (strcat "\n选择要" msg "的标注块<退出>: ")
  '((-3 ("Yb_zbbz")))
       )
     )
    )
    (if e
      (progn
(setq lst   (ea:get_zb_block_info e)
       pl    (cadr lst)
       inspt (car pl)
       p2    (cadr pl)
       ang1  (last pl)
       p3    (polar p2 ang1 1.)
)
(initget "T R E")
(setq
   key (getkword (strcat "\n[T 上下翻转 / R 左右翻转 / E 退出]"
    key1
    ": "
   )
       )
)
(cond
   ((or (and (null key)
      (= msg "上下翻转")
        )
        (= key "T")
    )
    (setq msg "上下翻转")
    (setq $angle ang1)
    (setq key1 "<T>")
   )
   ((or (and (null key)
      (= msg "左右翻转")
        )
        (= key "R")
    )
    (setq $angle (+ ang1 _pi2))
    (setq key1 "<R>")
    (setq msg "左右翻转")
   )
   (T
    (setq tf nil)
   )
)
(if tf
   (progn
     ;;对坐标块返回(标志 (插入点 输出点 角度) H(x) h(y) H)
     (setq p01 (polar inspt $angle 1.)
    p21 (ea:pointsmirror (list p2) inspt p01)
    p31 (ea:pointsmirror (list p3) inspt p01)
    an  (angle (car p21) (car p31))
     )
     (entdel e)
     (ea:zbbz (list inspt (car p21) an)
       (nth 2 lst)
       (nth 3 lst)
       (nth 4 lst)
     )
   )
)
      )     ;progn
      (setq tf nil)
    )     ;if
  )     ;while
  (ea:end)
  (princ)
)
;;分隔符、前缀开关
(defun Ea:ZBonoff (tf / ss ss_ent lst xstring)
  (ea:begin '("osmode" "cmdecho"))
  (setvar "cmdecho" 0)
  (setq ss (ssget "x" '((-3 ("Yb_zbbz")))))
  (if ss
    (progn
      (setq ss_ent (ea:ssgettoentitylist ss))
      (foreach e ss_ent
(setq lst     (ea:getattributes (vlax-ename->vla-object e))
       xstring (cadar lst)
)
;;tf - t 分隔符开关
(cond
   ((= tf 1)
    (mapcar '(lambda (x / str obj newstr)
        (setq str (cadr x)
       obj (vlax-ename->vla-object (last x))
        )
        (if (/= (car x) "H")
   (progn
     (setq newstr
     (vl-string-subst
       (strcat
         (substr str 1 1)
         (if (vl-string-search "X " xstring)
           "="
           " "
         )
       )
       (substr str 1 2)
       str
     )
     )
     (vla-put-textstring obj newstr)
   )
        )
      )
     lst
    )
   )
   ;;tf - nil 前缀开关
   ((= tf 2)
    (mapcar '(lambda (x / str obj newstr)
        (setq str (cadr x)
       obj (vlax-ename->vla-object (last x))
        )
        (setq newstr
        (if (= (substr xstring 1 1) "X")
          (if (/= (car x) "H")
     ;(substr str 3)
     (strcat " " (substr str 3))
          )
          (cond
     ((= (car x) "X") (strcat "X" (cadr x)))
     ((= (car x) "Y") (strcat "Y" (cadr x)))
     ;((= (car x) "H") (strcat "H=" (cadr x)))
          )
        )
        )
        (vla-put-textstring obj newstr)
      )
     lst
    )
   )
   ((= tf 3)
    (mapcar '(lambda (x / str obj newstr)
        (setq str (cadr x)
       obj (vlax-ename->vla-object (last x))
        )
        (setq newstr
        (if (or (= (substr str 1 1) "X")
         (= (substr str 1 1) "Y")
     )
          (cond
     ((= (substr str 1 1) "X")
      (strcat "A" (substr str 2))
     )
     ((= (substr str 1 1) "Y")
      (strcat "B" (substr str 2))
     )
          )
          (cond
     ((= (substr str 1 1) "A")
      (strcat "X" (substr str 2))
     )
     ((= (substr str 1 1) "B")
      (strcat "Y" (substr str 2))
     )
          )
        )
        )
        (vla-put-textstring obj newstr)
      )
     lst
    )
   )
)
      )     ;cond
    )     ;foreach
  )     ;progn
)     ;if
;|
坐标块中连字符、前缀(XY/AB)、临时开关切换，所有变换在使用移动复制;
检查后将恢复系统设定值
;;;
(defun c:Ea:FgOnf () (ea:zbonoff 1) (princ))
(defun c:Ea:Preonf () (ea:zbonoff 2) (princ))
(defun c:Ea:xacon () (ea:zbonoff 3) (princ))
;|
查询命令： 点坐标查询、两坐标块间距离查询;
;
(defun c:Ea:ZBID (/ p string plst)
  (setq p (getpoint "\n查询点: "))
  (setq string (ea:point_to_string (trans p 1 0)))
  (setq plst (ea:strlst_same_length (car string) 3))
  (alert (strcat "\n查询点标注系统坐标为: "
   "\n   "
   (caadr string)
   "= "
   (car plst)
   "\n   "
   (cadadr string)
   "= "
   (cadr plst)
  )
  )
  (princ)
)
;;通过拾取两坐标显示两坐标点间距离
(defun c:Ea:Zb2Dist (/ e1 e2 p1 p2)
  (setq e1 (ea:entself "\n第一个坐标: " '((-3 ("Yb_zbbz")))))
  (if e1
    (progn
      (redraw (car e1) 3)
      (setq p1 (ea:dxf (car e1) 10))
      (setq e2 (car (ea:entself "\n第二个坐标: " '((-3 ("Yb_zbbz"))))))
      (redraw e2 3)
      (setq p2 (ea:dxf e2 10))
      (alert (strcat "\n两坐标点间距离 ＝ "
       (vl-princ-to-string (distance p1 p2))
      )
      )
      (redraw (car e1) 4)
      (redraw e2 4)
    )
  )
  (princ)
)
(ea:zbbz_init)
|;
(defun c:Ea:BZZBWG (/ ss ssl sp ep ang txt obj)
  (princ "\n选择网格线...")
  (if (setq ss (ssget '((0 . "line") (8 . "Ea_zbw"))))
    (progn
     ;(setq p (getpoint "\n拾取标注端<默认标注左/下>: "))
      (setq ssl (sslength ss))
      (while (> ssl 0)
(setq e (ssname ss (setq ssl (1- ssl))))
(setq sp  (vlax-curve-getstartpoint e)
       ep  (vlax-curve-getendpoint e)
       ang (ea:angle_format (angle sp ep))
)
(if (equal ang 0. 1e-5)
   (progn
     (setq txt (strcat "X " (rtos (cadr sp) 2 0)))
     (ea:mktxt txt sp 3.0 0.75)
     (setq obj (vlax-ename->vla-object (entlast)))
     (vla-put-alignment obj acAlignmentMiddleRight)
     (vla-put-textalignmentpoint obj (vlax-3d-point sp))
   )
   (progn
     (setq txt (strcat "Y " (rtos (car sp) 2 0)))
     (ea:mktxt txt sp 3.0 0.75)
     (setq obj (vlax-ename->vla-object (entlast)))
     (vla-put-alignment obj acAlignmentMiddleRight)
     (vla-put-textalignmentpoint obj (vlax-3d-point sp))
     (vla-put-rotation obj _pi2)
   )
)
      )
    )
  )
  (princ)
)[/pcode]

eachy

配套的 DCL

2. ea_zbbz : dialog {
   
3.   label = " 坐标标注系统设置 By Eachy";
   
4.   fixed_width = true;
   
5.   : row {
   
6.     : boxed_column {
   
7.       label = "新建UCS" ;
   
8.       fixed_width = 20;
   
9.       : row {
   
10.         : button {
    
11.           label = "格点";
    
12.           fixed_width  = true;
    
13.           key = "wg";
    
14.           }
    
15.         : button {
    
16.           label = "两点";
    
17.           fixed_width  = true;
    
18.           key = "pt";
    
19.           }
    
20.       }
    
21.       : row {
    
22.         : text {
    
23.           label =" 名  称";
    
24.           }
    
25.         : edit_box {
    
26.           key = "name";
    
27.           fixed_width = true;
    
28.           edit_width = 8;
    
29.           edit_limit = 8;
    
30.           }
    
31.       }
    
32.     }
    
33.     : boxed_column {
    
34.       label = "当前标注UCS";
    
35.       : list_box {
    
36.         key = "cucs";
    
37.         height = 5;
    
38.         width = 10;
    
39.         }
    
40.       }
    
41.     }
    
42. : row {
    
43.   : boxed_column {
    
44.       fixed_width = true;
    
45.         label = "标注格式";
    
46.         : popup_list {
    
47.           label = "小数位数";
    
48.           edit_width = 6;
    
49.           list = " 0\n 1\n 2\n 3\n 4";
    
50.           key = "num";
    
51.         }
    
52.         : popup_list {
    
53.           label = "连 字 符";
    
54.           edit_width = 6;
    
55.           list = "空格\n =\n -\n 无";
    
56.           key = "spa";
    
57.         }
    
58.       }
    
59.    : boxed_column {
    
60.      label = "前缀";
    
61.      : row {
    
62.        : text {
    
63.          label = " X/A";
    
64.          }
    
65.        : edit_box {
    
66.          key = "xx";
    
67.          fixed_width = true;
    
68.          edit_width = 8;
    
69.          edit_limit = 8;
    
70.          }
    
71.        }
    
72.      : row {
    
73.        : text {
    
74.          label = " Y/B";
    
75.          }
    
76.        : edit_box {
    
77.          key = "yy";
    
78.          fixed_width = true;
    
79.          edit_width = 8;
    
80.          edit_limit = 8;
    
81.          }
    
82.      }
    
83.     }   
    
84.    }
    
85.    : row {
    
86.      fixed_width = true;
    
87.      : toggle {
    
88.        label = "数值互换X";
    
89.        key = "xcv" ;
    
90.        mnemonic = "X";
    
91.        }
    
92.      : toggle {
    
93.        label = "建筑坐标B";
    
94.        key = "bul" ;
    
95.        mnemonic = "B";
    
96.        }
    
97.      : toggle {
    
98.        label = "标高程值H";
    
99.        key = "hig" ;
    
100.        mnemonic = "H";
     
101.        }
     
102.      }
     
103.    : row {
     
104.      fixed_width = true;
     
105.      : toggle {
     
106.        label = "动态坐标D";
     
107.        key = "drag" ;
     
108.        mnemonic = "D";
     
109.        }
     
110.      : toggle {
     
111.        label = "水平标注V";
     
112.        key = "Ver" ;
     
113.        mnemonic = "V";
     
114.        }
     
115.    }
     
116.    : row {
     
117.      fixed_width= true;
     
118.      : spacer {
     
119.        width = 12;
     
120.        }
     
121.      ok_only;
     
122.      : button {
     
123.        label = "帮助";
     
124.        width  = 12;
     
125.        key = "help";
     
126.        }
     
127.    }
     
128.    errtile;  
     
129. }

ea_zbbz : dialog {<br />   label = " 坐标标注系统设置 By Eachy";<br />   fixed_width = true;<br />   : row {<br />     : boxed_column {<br />       label = "新建UCS" ;<br />       fixed_width = 20;<br />       : row {<br />         : button {<br />           label = "格点";<br />           fixed_width  = true;<br />           key = "wg";<br />           }<br />         : button {<br />           label = "两点";<br />           fixed_width  = true;<br />           key = "pt";<br />           }<br />       }<br />       : row {<br />         : text {<br />           label =" 名  称";<br />           }<br />         : edit_box {<br />           key = "name";<br />           fixed_width = true;<br />           edit_width = 8;<br />           edit_limit = 8;<br />           }<br />       }<br />     }<br />     : boxed_column {<br />       label = "当前标注UCS";<br />       : list_box {<br />         key = "cucs";<br />         height = 5;<br />         width = 10;<br />         }<br />       }<br />     }<br /> : row {<br />   : boxed_column {<br />       fixed_width = true;<br />         label = "标注格式";<br />         : popup_list {<br />           label = "小数位数";<br />           edit_width = 6;<br />           list = " 0\n 1\n 2\n 3\n 4";<br />           key = "num";<br />         } <br />         : popup_list {<br />           label = "连 字 符";<br />           edit_width = 6;<br />           list = "空格\n =\n -\n 无";<br />           key = "spa";<br />         }<br />       }<br />    : boxed_column {<br />      label = "前缀";<br />      : row {<br />        : text {<br />          label = " X/A";<br />          }<br />        : edit_box {<br />          key = "xx";<br />          fixed_width = true;<br />          edit_width = 8;<br />          edit_limit = 8;<br />          }<br />        }<br />      : row {<br />        : text {<br />          label = " Y/B";<br />          }<br />        : edit_box {<br />          key = "yy";<br />          fixed_width = true;<br />          edit_width = 8;<br />          edit_limit = 8;<br />          }<br />      }<br />     }   <br />    }<br />    : row {<br />      fixed_width = true;<br />      : toggle {<br />        label = "数值互换X";<br />        key = "xcv" ;<br />        mnemonic = "X";<br />        }<br />      : toggle {<br />        label = "建筑坐标B";<br />        key = "bul" ;<br />        mnemonic = "B";<br />        }<br />      : toggle {<br />        label = "标高程值H";<br />        key = "hig" ;<br />        mnemonic = "H";<br />        }<br />      }<br />    : row {<br />      fixed_width = true;<br />      : toggle {<br />        label = "动态坐标D";<br />        key = "drag" ;<br />        mnemonic = "D";<br />        }<br />      : toggle {<br />        label = "水平标注V";<br />        key = "Ver" ;<br />        mnemonic = "V";<br />        }<br />    }<br />    : row {<br />      fixed_width= true;<br />      : spacer {<br />        width = 12;<br />        }<br />      ok_only;<br />      : button {<br />        label = "帮助";<br />        width  = 12;<br />        key = "help";<br />        }<br />    }<br />    errtile;  <br /> }

eachy

另外一个DCL

2. ea_setucs : dialog {
   
3.   label = "设置标注坐标系";  
   
4.   : column {
   
5.     : button {
   
6.       label = "网格交点定UCS";
   
7.       key = "int";
   
8.       }
   
9.     : button {
   
10.       label = "已知两点定UCS";
    
11.       key = "pick";
    
12.       }
    
13.     : boxed_column {
    
14.       label = "UCS列表";
    
15.       : list_box {
    
16.         key = "what";
    
17.         height = 10;
    
18.         width = true;
    
19.         allow_accept = true; // 可双击鼠标选取
    
20.         }
    
21.       }
    
22.     }
    
23.   ok_only;
    
24. }

ea_setucs : dialog {<br />   label = "设置标注坐标系";  <br />   : column {<br />     : button {<br />       label = "网格交点定UCS";<br />       key = "int";<br />       }<br />     : button {<br />       label = "已知两点定UCS";<br />       key = "pick";<br />       }<br />     : boxed_column {<br />       label = "UCS列表";<br />       : list_box {<br />         key = "what";<br />         height = 10;<br />         width = true;<br />         allow_accept = true; // 可双击鼠标选取<br />         }<br />       }<br />     }<br />   ok_only;<br /> }

eachy

03年为这个程序写的一个Help，编译版在 XD工具箱 和我的网盘有下载，不过那个编译版我也没有源码了，上面贴的应该是没有修改完成的。为此作的工具条

cy956

eachy 发表于 2013-5-23 05:37
原来写的是属性块,下面这个是早期加在XD工具箱那个ZBBZ,首先声明以下代码直接编译不一定可以直接成功,因 ...

用的少，写的就少了，像cbx老师那样的一直做的很少了。
总图的工具我最早的来源是abd2.0，后来自己也加了一些，不过用的不多。其实南方地区设计院的总图一直是比较弱的，稍做做就达标了，:lol。
有一段因为在做重庆项目，自己加了一些简单的边坡堡坎工具，使用很简单但不能成系统，真要模拟还得用飞时达什么的3d模----当然用起来也很麻烦。
重庆项目的难点是落差大，不到80亩的地原始落差50多米。总图更多的考虑是地质条件的利用，归纳起来就是岩质好的地方尽量做堡坎、土质厚的注意卸荷、尽量做挖方挡墙不做填方挡墙等等，这样做才能省钱。话虽简单要考虑的东西很多，规划的消防的景观的物业管理的，真正制图倒在其次。土方量计算也不那么重要，因为当时政府需要土，由他们按我们的要求挖走即可，所以当时取走80万方--才80亩地不到，平均差不多16米！当然最后落差还是有40多米，这就是重庆特色！

我记得在晓东001年代，我们也讨论过是2d、2.5d和3d，说的是建筑软件。这个问题似乎到现在还没个完。2d纠错最差，模拟精度最差，但最简单，至今使用还是最广泛。

XDSoft

坐标方面的还需要什么？

Lisphk

eachy 发表于 2013-5-23 07:37
原来写的是属性块,下面这个是早期加在XD工具箱那个ZBBZ,首先声明以下代码直接编译不一定可以直接成功,因 ...

谢谢大神，不知道你们那如果标注还有标高，半径的时候是怎么标注的？ 我们这是XY在上，R,H在下。

Lisphk

XDSoft 发表于 2013-5-24 00:41
坐标方面的还需要什么？

太感谢了，试用中。有建议会跟帖的，希望工具越做越好。

我希望坐标能标出后，还能调整那些比如角度，引线的长度，字高什么的，暂时想到这，有新的想法再补充，再次感谢老大。