提取方格网及分解后高程点数据.lsp

(defun LC:Pt2XY (pt x y)
  (mapcar '(lambda (x y) (+ x y)) pt (list x y))
)
(defun try-ss2EnList(ss / a en lst)
    (setq a -1)
    (if ss
        (while
            (setq en(ssname ss(setq a(1+ a))))
            (setq lst(cons en lst))
        )
    )
    (reverse lst)
)
(defun LC:STRTONUM1(a / b c d e)
  (setq b(vl-string->list a))
  (while b
    (setq a(car b)b(cdr b)c(car b)d(if(or(= a 46)(< 47 a 58))(list a)))
    (while(or(and(< -1 a 46)(< -1 c 46))
      (or(= a 46)(= c 46))
      (and(< 47 a 58)(< 47 c 58))
      (and(> a 57)(> c 57))
             (and(> a 128)(> c 128))
             (and(> a 128)(< c 129)(/=(length d)(*(/(length d)2)2))))
      (setq a(car b)b(cdr b)c(car b)
     d(if(or(< 47 a 58)(and(= a 46)(not(member 46 d))))(cons a d)d)))
    (setq e(if d(cons(reverse d)e)e)))
  (mapcar'VL-LIST->STRING(reverse e))
  )
(defun gxl-cs:gcd (inspt height scale xsws / pt blkdef obj)
  (command "layer" "m" "GCD" "c" "1" "" "L" "CONTINUOUS" ""  "")
  (if height
    (setq height (rtos height 2 xsws))
    (setq height "")
    )
  (regapp "SOUTH")
  ;;;检查字体 "HZ" 是否存在
  (if (not (TBLOBJNAME "style" "HZ"))
    (command "style" "HZ" "rs.shx,hztxt.shx" 0 1 0 "" "" "")
    )
  ;;;检查是否存在高程点图块定义
  (if (not (tblobjname "block" "GC200"))
    (progn
      (setq blkdef (vla-add (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) (vlax-3d-point '(0 0 0)) "GC200"))
      (setq obj
             (vla-AddPolyline
               blkdef
               (vlax-make-variant
                 (vlax-safearray-fill
                   (vlax-make-safearray vlax-vbdouble (cons 0 5))
                    '(-0.2 0 0 0.2 0 0)
                   )
                 )
               )
            )
      (vla-SetBulge obj 0 1) (vla-SetBulge obj 1 1)
      (vla-put-Closed obj :vlax-true)
      (vla-put-ConstantWidth obj 0.4)
      )
    )
  ;;;插入块
  (entmake (list
             '(0 . "INSERT")
             '(100 . "AcDbEntity")
             '(100 . "AcDbBlockReference")
            '(66 . 1);;;属性跟随标志,1跟随，0不跟随
             (cons 2 "GC200")
             (cons 10 inspt)
             (cons 41 scale)
             (cons 42 scale)
             (cons 43 scale)
             '(-3 ("SOUTH" (1000 . "202101")))
           )
  )
  ;;;插入属性
    (entmake (list
            '(0 . "ATTRIB")
             '(100 . "AcDbEntity")
             '(100 . "AcDbText")
             (cons 10 (setq pt (polar inspt 0 (* 1.2 scale))))
             (cons 40 (* 2.0 scale))
            (cons 50 0)
            (cons 41 0.8)
            (cons 51 0)
             (cons 1 height)
             (cons 7 "HZ")
            (cons 72 0)
            (cons 11 pt)
             '(100 . "AcDbAttribute")
             (cons 2 "height")
             (cons 70  0)
            (cons 74 2)
           )
  )
  ;;;结束标志
(entmake '((0 . "SEQEND")))
  (princ)
  )

(defun LC:get-text-num  (E / ENT TEXT TEXT1)
  (setq ent (entget e)
    text (cdr(assoc 1 ent)))
;;;  (setq text (car(LC:STRTONUM1 text)))
  (setq text1 (atof(car(LC:STRTONUM1 text))))
)



(defun c:chym-Tqfgwgc (/ LC:TEXT-GROUP-CODE-DIFFERENCE OSMODE-BAK EN PT PD1 PT1 DX DY SS1 ENTS1 NUMLST PTLST PTLST2 ZJ STR FN FOUT FFILE I STRLST)
    (defun LC:TEXT-Group-code-Difference (en / ent)
        (setq ent (entget en))
        (if (= (strcase (cdr (assoc 0 ent))) "TEXT")
            (foreach y (list -1 210 10 11 330 5 100 410 1 220 230)
                (setq ent (vl-remove-if '(lambda (x) (= (car x) y)) ent))               
            )
        )
        ent     
    )
    (setq osmode-bak (getvar "osmode"))
    (setvar "osmode" 2084)
    (if (and (setq en (car (entsel "\n 请选择一个文字：")))
                     (setq pt (getpoint "\n 请拾取该文字平面正确位置："))                
            )
        (progn
            (setvar "osmode" osmode-bak)
            (setq pd1 (cdr (assoc 72 (entget en))))
            (setq pt1 (cdr (assoc (if (/= pd1 0) 11 10) (entget en))))
            (setq dx (- (cadr pt1) (cadr pt)) dy (- (car pt1) (car pt)))

            (setq ss1 (ssget (LC:TEXT-Group-code-Difference en)))
            (setq ents1 (try-ss2EnList ss1))
            (setq numlst (mapcar '(lambda (x) (LC:get-text-num x)) ents1)) ;数值表
            (setq ptlst (mapcar '(lambda (x) (if (/= pd1 0) (cdr (assoc 11 (entget x))) (cdr (assoc 10 (entget x))))) ents1))
            (setq ptlst2 (mapcar '(lambda (y z) (list (car y) (cadr y) z)) (mapcar '(lambda (x) (LC:Pt2XY x (- dy) (- dx))) ptlst) numlst)) ;生成后平面位置点
            (initget 6 "Y N")
            (setq ZJ (getstring "\n 是否展高程点：是[Y] / 否[N] <N>"))
            (if (or (= ZJ "") (= (strcase ZJ) "N")) () (mapcar '(lambda (x) (gxl-cs:gcd x (caddr x) 0.5 3)) ptlst2))
            (initget 6 "Y N")
            (setq STR (getstring "\n 是否提取数据文件：是[Y] / 否[N] <Y>"))
            (if (or (= STR "") (= (strcase STR) "Y"))
                (progn
                    (if (not fn) (setq Fn (getfiled "输入坐标数据文件名" (getvar "dwgprefix") "dat" 1)))
                    (setq fout (STRCAT (VL-FILENAME-DIRECTORY FN) "\\" (VL-FILENAME-BASE (getvar "dwgname"))  "标高.dat"))
                    (setq ffile (open fout "w"))
                    (setq i 0)
                    (setq strlst (mapcar '(lambda (x) (cons (itoa (setq i (1+ i))) (mapcar '(lambda (a) (rtos a 2 3)) x))) ptlst2)) ;加入序号
                    (setq strlst (mapcar '(lambda (x) (list (strcat (car x) ",," (cadr x) "," (caddr x) "," (cadddr x)))) strlst))
                    (mapcar '(lambda (x) (mapcar '(lambda (y) (write-line y ffile)) x)) strlst)
                    (close ffile)                   
                )
            )
        )       
    )
    (princ)
)
(princ "\n 提取方格网及分解后高程点数据")

(princ)