测量点DAT文件展点程序求修改

yxh1202

野外测量的DAT文件，从仪器中导出后，需要在未安装CASS的电脑上展点。找到网上前辈的帖子，如下，但是出现问题，参数类型错误。求高人指点迷津：
;;CAD读取坐标文件展点程序
(defun c:zhan_datedh ()
  ;;LISP展碎部点程序(数据添加日期属性)
  ;;坐标数据文件格式为四种
  ;;格式1:点号[任意空格]纵坐标X[任意空格]横坐标Y[任意空格]高程H[任意空格]点码
  ;;格式2:点号[,]点码[,]横坐标Y[,]纵坐标X[,]高程H
  ;;格式3:点号[任意空格]纵坐标X[任意空格]横坐标Y[任意空格]高程H
  ;;格式4:点号[,]纵坐标X[,]横坐标Y[,]高程H
  ;;(c:zhan_datedh)
  ;;保留小数位数不截零
  (initget 1 "1 2")
  (setq zhandian_lx (getkword "\n 1：展点号 /2：展高程 "))
  (setq doslibfilename (doslib_setup))
  (if (= doslibfilename nil)
    (progn (alert (strcat "\n请确认在CAD支持的路径下存在名称为["
                          doslibfilename
                          "]的ARX程序或CAD的版本低于R15!"
                  )
           )
           (exit)
    )
  )
  (if (/= (getvar "pdmode") 33)
    (progn (setvar "pdmode" 33) (setvar "pdsize" 0.15))
  )
  (setvar "DIMZIN" 0)
  (dingblc)                                ;定义图形比例尺及参数置
  (setq        fhb           nil
        t0           (getvar "cdate")
        cm           (getvar "cmdecho")
        os           (getvar "osmode")
        dtextgao   (* stsca 0.5)
        dtextcolor (+ (atoi (substr (rtos t0 2 0) 3 2))
                      (atoi (substr (rtos t0 2 0) 5 2))
                      (atoi (substr (rtos t0 2 0) 7 2))
                   )
        dtext_date (strcat (substr (rtos t0 2 0) 1 4)
                           "-"
                           (substr (rtos t0 2 0) 5 2)
                           "-"
                           (substr (rtos t0 2 0) 7 2)
                   )
        gcd_lay           "GCD"
        gcd_thk           1610000.0
        gcd_zigao  (* stsca 2.0)
        gcd_xsws   2
  )
  (setvar "cmdecho" 0)
  (setvar "osmode" 0)
  (cond        ((= zhandian_lx "1")
         (progn        (setq zdh_layer        (dos_combolist
                                  "展点图层设置对话框"
                                  "请选择展点的图层"
                                  '("ZDH" "TCJC")
                                )
                )
                (if (= zdh_layer nil)
                  (setq zdh_layer "ZDH")
                )
         )
        )
        ((= zhandian_lx "2") (setq zdh_layer "ZDH"))
        (t nil)
  )
  (setq        zdhpeizhi (list        (cons "展点图层" zdh_layer)
                        (cons "点号注记字高" (rtos dtextgao 2 2))
                        (cons "颜色设置" (itoa dtextcolor))
                        (cons "展点标注日期" dtext_date)
                        (cons "高程点图层" gcd_lay)
                        (cons "高程点厚度值" (rtos gcd_thk 2 0))
                        (cons "高程点字高" (rtos gcd_zigao 2 2))
                        (cons "高程注记小数位数" (itoa gcd_xsws))
                  )
  )
  (setq        zdhpeizhi (dos_proplist
                    "展点配置对话框"
                    "请核实以下展点配置"
                    zdhpeizhi
                  )
  )
  (while (or (= (distof (cdr (nth 1 zdhpeizhi))) nil)
             (= (distof (cdr (nth 2 zdhpeizhi))) nil)
         )
    (cond
      ((= (distof (cdr (nth 1 zdhpeizhi))) nil)
       (alert "点号注记字高应为数值,请核实!")
      )
      ((= (distof (cdr (nth 2 zdhpeizhi))) nil)
       (alert "颜色设置应为数值,请核实!")
      )
      ((= (distof (cdr (nth 5 zdhpeizhi))) nil)
       (alert "高程点厚度值应为数值,请核实!")
      )
      ((= (distof (cdr (nth 6 zdhpeizhi))) nil)
       (alert "高程注记字高应为数值,请核实!")
      )
      (t nil)
    )
    (setq zdhpeizhi (list (cons "展点图层" zdh_layer)
                          (cons "点号注记字高" (rtos dtextgao 2 2))
                          (cons "颜色设置" (itoa dtextcolor))
                          (cons "展点标注日期" dtext_date)
                          (cons "高程点图层" gcd_lay)
                          (cons "高程点厚度值" (rtos gcd_thk 2 0))
                          (cons "高程点字高" (rtos gcd_zigao 2 2))
                          (cons "高程注记小数位数" (itoa gcd_xsws))
                    )
    )
    (setq zdhpeizhi (dos_proplist
                      "展点配置对话框"
                      "请核实以下展点配置"
                      zdhpeizhi
                    )
    )
  )
  (if (/= zdhpeizhi nil)
    (progn
      (setq zdh_layer  (cdr (nth 0 zdhpeizhi))
            dtextgao   (distof (cdr (nth 1 zdhpeizhi)))
            dtextcolor (fix (distof (cdr (nth 2 zdhpeizhi))))
            dtext_date (cdr (nth 3 zdhpeizhi))
            gcd_lay    (cdr (nth 4 zdhpeizhi))
            gcd_thk    (atof (cdr (nth 5 zdhpeizhi)))
            gcd_zigao  (distof (cdr (nth 6 zdhpeizhi)))
            gcd_xsws   (fix (distof (cdr (nth 7 zdhpeizhi))))
      )
      (if (or (< dtextcolor 0) (> dtextcolor 255))
        (setq dtextcolor
               (+ (atoi (substr (rtos t0 2 0) 3 2))
                  (atoi (substr (rtos t0 2 0) 5 2))
                  (atoi (substr (rtos t0 2 0) 7 2))
               )
        )
      )
      (cond ((= zhandian_lx "1") (jcszlayer zdh_layer nil))
            ((= zhandian_lx "2") (jcszlayer gcd_lay nil))
            (t nil)
      )
      (setq zdshujugs
             (dos_listbox
               "展点数据格式选择"
               "请选择一种坐标文件数据格式"
               '("空格分隔坐标格式(点号 纵坐标X 横坐标Y 高程H 点码)"
                 "CASS坐标格式(点号,点码,横坐标Y,纵坐标X,高程H)"
                 "标准坐标格式(点号 横坐标Y 纵坐标X 高程H)"
                 "标准坐标格式(点号,横坐标Y,纵坐标X,高程H)"
                )
             )
      )
      (cond
        ((= zdshujugs
            "空格分隔坐标格式(点号 纵坐标X 横坐标Y 高程H 点码)"
         )
         (setq zbgs 1)
        )
        ((= zdshujugs
            "CASS坐标格式(点号,点码,横坐标Y,纵坐标X,高程H)"
         )
         (setq zbgs 2)
        )
        ((= zdshujugs "标准坐标格式(点号 横坐标Y 纵坐标X 高程H)")
         (setq zbgs 3)
        )
        ((= zdshujugs "标准坐标格式(点号,横坐标Y,纵坐标X,高程H)")
         (setq zbgs 4)
        )
        (t (progn (alert "展点数据文件格式非标准!") (exit)))
      )
      (if (= (type filepath) 'STR)
        (progn
          (cond        ((and (= (substr filepath (strlen filepath)) "\\")
                      (= (substr filepath 2 2) ":\\")
                 )
                 (setq filepath1 filepath)
                )
                (t
                 (setq filepath1 (getvar "TEMPPREFIX")
                       filepath         filepath1
                 )
                )
          )
        )
        (setq filepath1        (getvar "TEMPPREFIX")
              filepath        filepath1
        )
      )
      (setq file (dos_getfiled
                   "请选择展点坐标文件"
                   filepath1
                   "文本文件 (*.dat)|*.dat|All files (*.*)|*.*||"
                 )
      )
      (if (/= file nil)
        (progn
          (setq filepath file)
          (while (/= (substr filepath (strlen filepath)) "\\")
            (setq filepath (substr filepath 1 (1- (strlen filepath))))
          )
        )
        (exit)
      )
      (cond ;;读取雷生碎部点格式文件
            ((= zbgs 1) (setq zdsj_list (read_lssbdcgb file)))
            ;;读取CASS格式坐标文件
            ((= zbgs 2) (setq zdsj_list (read_casscgb file)))
            ;;读取标准坐标文件(空格分隔)
            ((= zbgs 3) (setq zdsj_list (read_biaozhuncgb1 file)))
            ;;读取标准坐标文件(逗号分隔)
            ((= zbgs 4) (setq zdsj_list (read_biaozhuncgb2 file)))
            (t (progn (alert "数据非法") (exit)))
      )
      (setq t1 (getvar "cdate"))
      ;;开始展点
      (cond ;;展点号
            ((= zhandian_lx "1")
             (progn (regapp "ZD_Date")
                    (setq pointlay   zdh_layer
                          pointthk   0.0
                          pointcolor dtextcolor
                          textlay    zdh_layer
                          textzg     dtextgao
                          textcolor  dtextcolor
                          textdmh    2
                    )
             )
            )
            ;;展高程
            ((= zhandian_lx "2")
             (progn (setq pointlay gcd_lay
                          pointthk gcd_thk
                          pointcolor
                           nil
                          textlay gcd_lay
                          textzg gcd_zigao
                          textcolor nil
                          textdmh 2
                    )
             )
            )
            (t nil)
      )
      (setq zbzd_i    0
            textthk   0.0
            textro    0.0
            textkuan  1.0
            textlcr   0
            textstyle "STANDARD"
      )
      (while (< zbzd_i (length zdsj_list))
        (setq pointpt (nth 1 (nth zbzd_i zdsj_list)))
        (cond ;;展点号
              ((= zhandian_lx "1")
               (setq textnr         (nth 0 (nth zbzd_i zdsj_list))
                     pointkzsx         (list
                                   (cons
                                     '"ZD_Date"
                                     (list
                                       (cons '1000 (strcat dtext_date "/" textnr))
                                     )
                                   )
                                 )
                     zhandian_yn T
               )
              )
              ;;展高程
              ((= zhandian_lx "2")
               (progn (setq pointkzsx nil
                            textnr    (rtos (nth 2 pointpt) 2 gcd_xsws)
                      )
                      (if (= (nth 2 pointpt) 0.0)
                        (setq zhandian_yn nil)
                        (setq zhandian_yn T)
                      )
               )
              )
              (t nil)
        )
        (if (= zhandian_yn T)
          (progn (setq
                   pointst (emakepoint
                             pointlay pointthk pointpt pointcolor
                             pointkzsx)
                 )
                 (setq textpt10        (mapcar '+ pointpt (list (* 0.5 stsca) 0.0 0.0))
                       textpt11        textpt10
                 )
                 (cond ;;展点号
                       ((= zhandian_lx "1")
                        (setq dtext_bj (strcat dtext_date
                                               "/"
                                               (rtos (nth 0 pointpt) 2 3)
                                               "#"
                                               (rtos (nth 1 pointpt) 2 3)
                                               "#"
                                               (rtos (nth 2 pointpt) 2 3)
                                       )
                              textkzsx (list (cons '"ZD_Date"
                                                   (list (cons '1000 dtext_bj))
                                             )
                                       )
                        )
                       )
                       ;;展高程
                       ((= zhandian_lx "2") (setq textkzsx nil))
                       (t nil)
                 )
                 (setq textst (emaketext textlay     textnr
                                         textthk     textpt10
                                         textzg             textro
                                         textkuan    textqxie
                                         textcolor   textstyle
                                         textlcr     textdmh
                                         textpt11    textkzsx
                                        )
                 )
          )
        )
        (setq zbzd_i (1+ zbzd_i))
        (printbar_jd "正在展绘碎部点" (length zdsj_list) zbzd_i)
      )
      (Example_ZoomExtents)
      (setq t2 (getvar "cdate"))
    )
  )
  ;|(setq t3 (getvar "cdate")
       dt1 (* 1000000 (- t1 t0))
       dt2 (* 1000000 (- t3 t2)))
(alert (strcat "\n读入数据共耗时："
   (rtos dt1 2 3)
   "秒"
   "\n展点共耗时"
   (rtos dt2 2 3)
   "秒"
   "\n展点数："
   (itoa (length zdsj_list))
   "个"
   "\n 每展一点耗时："
   (rtos (/ dt2 (length zdsj_list)) 2 10)
   "秒"))|;
  (setvar "cmdecho" cm)
  (setvar "osmode" os)
  (princ)
)
;;-----------------------------------------------------------
(defun dingblc ()
  ;;(dingblc)
  ;;定义图形比例尺及参数设置
  ;; (getvar "USERR1")--图形比例尺系统变量
  ;; (getvar"LTSCALE")--线型比例系数
  (while (<= (getvar "USERR1") 0.0)
    (progn (initget 4)
           (setq kah (getreal "\n请输入测图比例尺<500>:"))
           (if (= kah nil)
             (setq kah 500.0)
           )
           (setvar "userr1" kah)
           (setvar "ltscale" (/ kah 1000.0))
    )
    (setvar "ltscale" (/ (getvar "USERR1") 1000.0))
  )
  (setq stsca (getvar "ltscale"))
  (cond        ;;1:500
        ((= (getvar "userr1") 500.0) (setq dtblc 1))
        ;;1:1000
        ((= (getvar "userr1") 1000.0) (setq dtblc 2))
        ;;1:2000
        ((= (getvar "userr1") 2000.0) (setq dtblc 3))
        ;;1:5000
        ((= (getvar "userr1") 5000.0) (setq dtblc 4))
        ;;任意比例尺
        (t (setq dtblc 10))
  )
)
;;-----------------------------------------------------------
(defun read_biaozhuncgb1 (biaozhuncgb)
  ;;读取标准坐标文件(空格分隔)
  ;;(read_biaozhuncgb1 biaozhuncgb)
  ;;"标准坐标格式(点号 横坐标Y 纵坐标X 高程H)"
  (setq zhandian_list nil)
  (setq ls_file (open casscgbfile "r"))
  (setq p (read-line ls_file))
  (while (/= p nil)
    (progn (while (= (substr p 1 1) " ") (setq p (substr p 2)))
           (while (= (substr p (strlen p)) " ")
             (setq p (substr p 1 (1- (strlen p))))
           )
           (while (/= (strlen p) (strlen (vl-string-subst " " " " p)))
             (setq p (vl-string-subst " " " " p))
           )
           (setq ppp (string_strlist1 p " "))
           (if (and (= (length ppp) 4)
                    (/= (distof (nth 1 ppp)) nil)
                    (/= (distof (nth 2 ppp)) nil)
                    (/= (distof (nth 3 ppp)) nil)
               )
             (progn (setq pp (nth 0 ppp)
                          px (atof (nth 1 ppp))
                          py (atof (nth 2 ppp))
                          ph (atof (nth 3 ppp))
                    )
                    (setq pt (list px py ph))
                    (setq zhandian_list
                           (append zhandian_list (list (list pp pt)))
                    )
             )
           )
           (setq p (read-line ls_file))
    )
  )
  (close ls_file)
  zhandian_list
)
;;--------------------------------------------------
(defun read_biaozhuncgb2 (biaozhuncgb)
  ;;读取标准坐标文件(逗号分隔)
  ;;(read_biaozhuncgb2 biaozhuncgb)
  ;;"标准坐标格式(点号,横坐标Y,纵坐标X,高程H)"
  (setq zhandian_list nil)
  (setq ls_file (open casscgbfile "r"))
  (setq p (read-line ls_file))
  (while (/= p nil)
    (progn
      (setq ppp (string_strlist1 p ","))
      (if (and (= (length ppp) 4)
               (/= (distof (nth 1 ppp)) nil)
               (/= (distof (nth 2 ppp)) nil)
               (/= (distof (nth 3 ppp)) nil)
          )
        (progn (setq pp (nth 0 ppp))
               (while (= (substr pp 1 1) " ") (setq pp (substr pp 2)))
               (while (= (substr pp (strlen pp)) " ")
                 (setq pp (substr pp 1 (1- (strlen pp))))
               )
               (setq px        (atof (nth 1 ppp))
                     py        (atof (nth 2 ppp))
                     ph        (atof (nth 3 ppp))
               )
               (setq pt (list px py ph))
               (setq zhandian_list
                      (append zhandian_list (list (list pp pt)))
               )
        )
      )
      (setq p (read-line ls_file))
    )
  )
  (close ls_file)
  zhandian_list
)
;;--------------------------------------------------
(defun read_casscgb (casscgbfile / p pp ppp)
  ;;读取CASS格式坐标文件
  ;;(read_casscgb casscgbfile)
  ;;"CASS坐标格式(点号,点码,横坐标Y,纵坐标X,高程H)"
  (setq zhandian_list nil)
  (setq ls_file (open casscgbfile "r"))
  (setq p (read-line ls_file))
  (while (/= p nil)
    (progn
      (setq ppp (string_strlist1 p ","))
      (if (and (= (length ppp) 5)
               (/= (distof (nth 2 ppp)) nil)
               (/= (distof (nth 3 ppp)) nil)
               (/= (distof (nth 4 ppp)) nil)
          )
        (progn (setq pp (nth 0 ppp))
               (while (= (substr pp 1 1) " ") (setq pp (substr pp 2)))
               (while (= (substr pp (strlen pp)) " ")
                 (setq pp (substr pp 1 (1- (strlen pp))))
               )
               (setq pcode (nth 1 ppp)
                     px           (atof (nth 2 ppp))
                     py           (atof (nth 3 ppp))
                     ph           (atof (nth 4 ppp))
               )
               (setq pt (list px py ph))
               (setq zhandian_list
                      (append zhandian_list (list (list pp pt)))
               )
        )
      )
      (setq p (read-line ls_file))
    )
  )
  (close ls_file)
  zhandian_list
)
;;--------------------------------------------------
(defun read_lssbdcgb (sbdcgbfile / p pp)
  ;;读取雷生碎部点成果表转换为展点格式列表
  ;;(read_lssbdcgb sbdcgbfile)
  ;;"雷生坐标格式(点号 纵坐标X 横坐标Y 高程H 点码)"
  ;;sbdcgbfile--雷生格式碎部点成果表包含路径的完整文件名
  (setq zhandian_list nil)
  (setq ls_file (open sbdcgbfile "r"))
  (setq p (read-line ls_file))
  (while (/= p nil)
    (progn (while (= (substr p 1 1) " ") (setq p (substr p 2)))
           (while (= (substr p (strlen p)) " ")
             (setq p (substr p 1 (1- (strlen p))))
           )
           (while (/= (strlen p) (strlen (vl-string-subst " " " " p)))
             (setq p (vl-string-subst " " " " p))
           )
           (setq ppp (string_strlist1 p " "))
           (if (and (= (length ppp) 5)
                    (/= (distof (nth 1 ppp)) nil)
                    (/= (distof (nth 2 ppp)) nil)
                    (/= (distof (nth 3 ppp)) nil)
               )
             (progn (setq pp (nth 0 ppp))
                    (setq py        (atof (nth 1 ppp))
                          px        (atof (nth 2 ppp))
                          ph        (atof (nth 3 ppp))
                          pcode        (nth 4 ppp)
                    )
                    (if        (or (= pcode "103") (= pcode "108"))
                      (setq pt (list px py 0.0))
                      (setq pt (list px py ph))
                    )
                    (setq zhandian_list
                           (append zhandian_list (list (list pp pt)))
                    )
             )
           )
           (setq p (read-line ls_file))
    )
  )
  (close ls_file)
  zhandian_list
)
;;-----------------------------------------------------------
(defun jcszlayer (layname laycolor)
  ;;(jcszlayer layname laycolor)
  ;;检查设置所操作图层是否存在，如果不存在则新建，否则解锁、解冻、打开
  (vl-load-com)
  (setq        acadobject1   (vlax-get-acad-object)
        acaddocument1 (vla-get-activedocument acadobject1)
        mspace1              (vla-get-modelspace acaddocument1)
  )
  (setq LayerSel (vla-get-Layers AcadDocument1))
  (setq LayerObj (vla-add LayerSel layname))
  (if (/= nil (tblsearch "layer" layname))
    (progn ;;解锁
           (if (= (vla-get-lock layerobj) :vlax-true)
             (vla-put-Lock LayerObj :vlax-false)
           )
           ;;解冻
           (if (= (vla-get-Freeze layerobj) :vlax-true)
             (vla-put-Freeze LayerObj :vlax-false)
           )
           ;;打开
           (if (= (vla-get-layeron layerobj) :vlax-false)
             (vla-put-layeron LayerObj :vlax-true)
           )
           ;;设为当前层
           (vla-put-activelayer AcadDocument1 LayerObj)
           ;;设置图层颜色
           (if (/= nil laycolor)
             (vla-put-color LayerObj laycolor)
           )
    )
    (progn ;;新建图层
           (vla-get-activelayer AcadDocument1 LayerObj)
           ;;设置图层颜色
           (if (/= nil laycolor)
             (vla-put-color LayerObj laycolor)
           )
    )
  )
)
;;-----------------------------------------------------------
(defun emaketext (textlay     textnr          textthk     textpt10
                  textzg      textro          textkuan    textqxie
                  textcolor   textstyle          textlcr     textdmh
                  textpt11    textkzsx
                 )
  ;; (emaketext textlay textnr textthk textpt10 textzg textro
  ;; textkuan
  ;; textqxie textcolor textstyle textlcr textdmh textpt11
  ;; textkzsx)
  ;;用entmake方法添加文字注记实体
  ;; textlay--注记图层 textnr---注记内容 textthk---注记厚值
  ;; textzg---注记字高textro---注记旋转方向 textkuan---注记宽度系数
  ;; textqxie---注记倾斜角度 textstyle---注记文字样式
  ;; textcolor---注记颜色
  ;; textlcr--注记左中右对齐方式(0,1,2,nil)
  ;; textdmh--注记上中下对齐方式(3,2,1,nil)
  ;; textpt10---注记点坐标10 textpt11---注记点坐标11
  ;; textkzsx--扩展属性
  ;;加载(vl-load-com)环境
  (vl-load-com)
  (setq        acadobject1   (vlax-get-acad-object)
        acaddocument1 (vla-get-activedocument acadobject1)
        mspace1              (vla-get-modelspace acaddocument1)
  )
  ;;注记位置textpt10和字高textzg
  (setq textst_name nil)
  (setq insertionpnt (vlax-make-safearray vlax-vbdouble '(0 . 2)))
  (if (= (length textpt10) 2)
    (setq textpt10 (list (nth 0 textpt10) (nth 1 textpt10) 0.0))
  )
  (vlax-safearray-fill insertionpnt textpt10)
  (setq textobj (vla-addtext mspace1 textnr insertionpnt textzg))
  ;; textlcr--注记左中右对齐方式(0,1,2,nil)
  ;; textdmh--注记上中下对齐方式(3,2,1,nil)
  (cond        ;;左上
        ((and (= textlcr 0) (= textdmh 3))
         (vla-put-alignment textobj acalignmenttopleft)
        )
        ;;左中
        ((and (= textlcr 0) (= textdmh 2))
         (vla-put-alignment textobj acalignmentmiddleleft)
        )
        ;;左下
        ((and (= textlcr 0) (= textdmh 1))
         (vla-put-alignment textobj acalignmentbottomleft)
        )
        ;;中上
        ((and (= textlcr 1) (= textdmh 3))
         (vla-put-alignment textobj acalignmenttopcenter)
        )
        ;;中中
        ((and (= textlcr 1) (= textdmh 2))
         (vla-put-alignment textobj acalignmentmiddlecenter)
        )
        ;;中下
        ((and (= textlcr 1) (= textdmh 1))
         (vla-put-alignment textobj acalignmentbottomcenter)
        )
        ;;右上
        ((and (= textlcr 2) (= textdmh 3))
         (vla-put-alignment textobj acalignmenttopright)
        )
        ;;右中
        ((and (= textlcr 2) (= textdmh 2))
         (vla-put-alignment textobj acalignmentmiddleright)
        )
        ;;右下
        ((and (= textlcr 2) (= textdmh 1))
         (vla-put-alignment textobj acalignmentbottomright)
        )
        ;;默认
        (t (vla-put-alignment textobj acalignmentleft))
  )
  (if (and (/= textlcr nil) (/= textdmh nil))
    (vla-put-textalignmentpoint textobj insertionpnt)
  )
  ;;注记颜色textcolor
  (if (/= nil textcolor)
    (vla-put-color textobj textcolor)
    (vla-put-color textobj acbylayer)
  )
  ;;注记字型样式textstyle
  (if (and (/= textstyle (vla-get-stylename textobj))
           (/= (tblsearch "style" textstyle) nil)
      )
    (vla-put-stylename textobj textstyle)
  )
  ;;注记厚度textthk
  (if (/= textthk nil)
    (vla-put-thickness textobj textthk)
    (vla-put-thickness textobj 0.0)
  )
  ;;注记旋转角度textro
  (if (/= nil textro)
    (vla-put-rotation textobj textro)
    (vla-put-rotation textobj 0.0)
  )
  ;;注记图层textlay
  (if (= (tblsearch "layer" textlay) nil)
    (progn (setq layersel (vla-get-layers acaddocument1))
           (setq layerobj (vla-add layersel textlay))
    )
  )
  (vla-put-layer textobj textlay)
  ;;注记的宽度系数textkuan
  (if (/= textkuan nil)
    (vla-put-ScaleFactor TextObj textkuan)
    (vla-put-ScaleFactor TextObj 1.0)
  )
  ;;注记的倾斜系数textqxie
  (if (/= textqxie nil)
    (vla-put-ObliqueAngle TextObj textqxie)
    (vla-put-ObliqueAngle TextObj 0.0)
  )
  (setq textst_name (vlax-vla-object->ename TextObj))
  ;;注记的扩展属性textkzsx
  (if (/= textkzsx nil)
    (progn (setq textst_ss (entget textst_name (list "*")))
           (setq textst_ss (append textst_ss (list (cons -3 textkzsx))))
           (entmod textst_ss)
           (entupd textst_name)
    )
  )
  textst_name
)
;;-----------------------------------------------------------
(defun emakepoint (pointlay pointthk pointpt pointcolor pointkzsx)
  ;;(emakepoint pointlay pointthk pointpt pointcolor pointkzsx)
  ;;用entmake方法添加点实体
  ;;pointlay-图层 pointthk-厚度值 pointpt-3D插入点
  ;;pointcolor-颜色   pointkzsx-扩展属性
  (vl-load-com)
  (setq        acadobject1   (vlax-get-acad-object)
        acaddocument1 (vla-get-activedocument acadobject1)
        mspace1              (vla-get-modelspace acaddocument1)
  )
  (setq point_point (vlax-3d-point pointpt))
  (setq pointobj (vla-addpoint mspace1 point_point))
  ;;point的图层blklay
  (if (= (tblsearch "layer" pointlay) nil)
    (progn (setq layersel (vla-get-layers acaddocument1))
           (setq layerobj (vla-add layersel blklay))
    )
  )
  (vla-put-layer pointobj pointlay)
  ;;厚度pointthinkness
  (if (and (/= (type pointthk) 'REAL) (/= (type pointthk) 'INT))
    (setq pointthk 0.0)
  )
  (vla-put-Thickness pointobj pointthk)
  ;;颜色pointcolor
  (if (/= nil pointcolor)
    (vla-put-color pointobj pointcolor)
    (vla-put-color pointobj acbylayer)
  )
  (setq pointst_name (vlax-vla-object->ename pointobj))
  ;;point的扩展属性pointkzsx
  (if (/= pointkzsx nil)
    (progn (setq pointst_ss (entget pointst_name (list "*")))
           (setq pointst_ss (append pointst_ss (list (cons -3 pointkzsx))))
           (entmod pointst_ss)
           (entupd pointst_name)
    )
  )
  pointst_name
)
;;-----------------------------------------------------------
(defun Example_ZoomExtents ()
  ;;当前图形缩放(command "zoom" "e")
  ;;(Example_ZoomExtents)
  (vl-load-com)
  (setq        acadobject1   (vlax-get-acad-object)
        acaddocument1 (vla-get-activedocument acadobject1)
        mspace1              (vla-get-modelspace acaddocument1)
  )
  (setq application1 (vla-get-application acaddocument1))
  (vla-zoomextents application1)
  (princ)
)
;;-----------------------------------------------------------
(defun string_strlist1
       (stringstr stringfgf / shujui shujuj strlst shujustr1)
  ;;(string_strlist1 stringstr stringfgf)
  ;;将输入的分隔符分隔的字符串数据转换为包含数据列信息的字符串列表子程序
  ;;stringstr--以分隔符分隔的字符串 stringfgf--字符串的分隔符
  ;;测试: (string_strlist1 "Hello,2World,12,5456.1568," ",")
  ;;    = ("Hello" "2World" "12" "5456.1568")
  (setq        shujui 0
        shujuj 1
        shujustr1 ""
        strlst nil
  )
  (cond
    ((/= (strlen stringstr) 0)
     (progn
       (if (/= (substr stringstr (strlen stringstr) 1) stringfgf)
         (setq stringstr (strcat stringstr stringfgf))
       )
       (while
         (/= ""
             (setq
               shujulist (substr stringstr (setq shujui (1+ shujui)) 1)
             )
         )
          (cond
            ((/= stringfgf shujulist)
             (setq shujustr1 (strcat shujustr1 shujulist))
            )
            (T
             (setq strlst    (append strlst (list shujustr1))
                   shujustr1 ""
                   shujuj    (1+ shujuj)
             )
            )
          )
       )
       (if (/= shujustr1 "")
         (append strlst (list shujustr1))
         strlst
       )
     )
    )
    (t (setq strlst (list "")))
  )
  strlst
)
;;-----------------------------------------------------------
(defun printbar_jd (jdstr s_fm s_fz)
  ;;在状态兰显示程序运行进度
  ;;(printbar_jd jdstr s_fm s_fz)
  ;;jdstr--显示进度的文字说明 s_fm--进度总数 s_fz--当前的个数
  (if (/= s_fm 1)
    (progn
      (cond
        ((or (= s_fz 1) (= s_fz 0))
         (dos_progbar (strcat jdstr ",请稍候...") s_fm)
        )
        ((and (> s_fz 1) (< s_fz s_fm)) (dos_progbar -1))
        ((>= s_fz s_fm) (dos_progbar))
        (t nil)
      )
    )
  )
)
;;-----------------------------------------------------------
(defun doslib_setup ()
  ;;测试Doslib工具是否被安装
  ;;(doslib_setup)
  (setq cadver (substr (getvar "ACADVER") 1 2))
  (setq        newarx nil
        arx_i 0
        doslibfile nil
  )
  (while (< arx_i (length (arx)))
    (setq newarx (append newarx (list (strcase (nth arx_i (arx))))))
    (setq arx_i (1+ arx_i))
  )
  (cond        ((and (= cadver "15")
              (= (member (strcase "doslib2k.arx") newarx) nil)
         )
         (setq doslibfile     (arxload (findfile "doslib2k.arx"))
               doslibfilename "doslib2k.arx"
         )
        )
        ((and (= cadver "15")
              (/= (member (strcase "doslib2k.arx") newarx) nil)
         )
         (setq doslibfilename "doslib2k.arx")
        )
        ((and (= cadver "16")
              (= (member (strcase "doslib2004.arx") newarx) nil)
         )
         (setq doslibfile     (arxload (findfile "doslib2004.arx"))
               doslibfilename "doslib2004.arx"
         )
        )
        ((and (= cadver "16")
              (/= (member (strcase "doslib2004.arx") newarx) nil)
         )
         (setq doslibfilename "doslib2004.arx")
        )
        ((and (= cadver "17")
              (= (member (strcase "DOSLib17.arx") newarx) nil)
         )
         (setq doslibfile     (arxload (findfile "DOSLib17.arx"))
               doslibfilename "DOSLib17.arx"
         )
        )
        ((and (= cadver "17")
              (/= (member (strcase "DOSLib17.arx") newarx) nil)
         )
         (setq doslibfilename "DOSLib17.arx")
        )
        (t nil)
  )
  doslibfilename
)

陈伟

llsheng_73 发表于 2013-12-26 04:00
不敢说完全跟CASS的高程点一样，但用CASS肯定能认识它，用CASS进它进行打散、建DTM，计算方量等肯定 ...

  展点成功，但没任何显示，不知道是哪点出错了    WIN7 X64  CAD2020

leedun

跟楼上是一样的，展点成功，但是没有结果

f4800

下载下来学习一下

yshf

问题出在doslib_setup函数中，首先你要有相应的版本Doslib工具，其次将放CAD的默认搜索路径的文件夹内。

newbuser

展个点干嘛这么麻烦？你非要做到跟南方一样吗？这个确实有点难度。

yxh1202

newbuser 发表于 2013-12-25 07:51
展个点干嘛这么麻烦？你非要做到跟南方一样吗？这个确实有点难度。

关键的是南方CASS基本是测量行业的标准软件。能指点下吗

newbuser

你把导出的数据直接在Excel里面改成你需要的或者cass能够识别的格式再展点不就行了吗？
你的仪器总共有四种格式，如果要程序来判断恐怕太麻烦了吧。不值得这么大费周章啊。

xiabin68

还不如，你直接安一个CASS展了点，再把软件删了，也比这个快，，，，

llsheng_73

虽然 cass可以算是测绘行业的标准软件，但它的展点号并没有CASS属性数据，不管是点位还是表示点号的文字，只有展高程点时用GC200作为了高程点的点们符号，给了一个它一个202101的CASS编码，另外在gc200这个块后边加了一个名为height的ATTRIB来注记高程值，所以就算要做得跟南方CASS一个样子也不至于需要多复杂的，至少用不着楼主贴出来的那么多代码

llsheng_73

yxh1202 发表于 2013-12-25 17:12
关键的是南方CASS基本是测量行业的标准软件。能指点下吗

1. (defun c:casszgcd(/ blc ly m ignore fe a b d i n dh makegcd)
   
2.   (Defun makegcd(p m scale ly sty)
   
3.     (Entmake(List'(0 . "Insert")'(100 . "Acdbentity")'(100 . "Acdbblockreference")'(66 . 1)'(2 . "GC200")
   
4.    (Cons 10 P)(Cons 8 ly)(Cons 41 Scale)(Cons 42 Scale)(Cons 43 Scale)'(-3 ("South" (1000 . "202101")))))
   
5.     (Entmake(List'(0 . "Attrib")'(100 . "Acdbentity")'(100 . "Acdbtext")(list 10(+(car p)(* 1.2 Scale))(cadr p)(last p))
   
6.    (Cons 40 (* 2.0 Scale))'(50 . 0)'(41 . 0.8)(cons 1(rtos(last p)2 m))(cons 7 sty)'(72 . 0)(cons 11 p)
   
7.    '(100 . "Acdbattribute")'(2 . "Height")'(70 . 0)'(74 . 2)))
   
8.     (Entmake '((0 . "SEQEND"))))
   
9.    (regapp "south")
   
10.   (if(null(tblsearch"block""gc200"))
    
11.     (progn
    
12.       (entmake'((0 . "block")(2 . "gc200")(70 . 0)(10 0 0 0)))
    
13.       (entmake'((0 . "LWPOLYLINE")(100 . "AcDbEntity")(8 . "0")(100 . "AcDbPolyline")
    
14.   (90 . 2)(70 . 1)(43 . 0.2)(10 -0.1 0)(42 . 1.0)(10 0.1 0)(42 . 1.0)))
    
15.       (entmake'((0 . "ENDBLK")))))
    
16.   (if(null(tblsearch"style""Hz"))
    
17.     (entmake'((0 . "STYLE")(100 . "AcDbSymbolTableRecord")(100 . "AcDbTextStyleTableRecord")
    
18.        (2 . "HZ")(70 . 0)(40 . 0)(41 . 0.8)(3 . "rs.shx")(4 . "hztxt.shx"))))
    
19.   (setq blc(if(>(Getvar "Userr1")0)(Getvar "Userr1")(getreal"图形比例尺1:<500>")))
    
20.   (setvar"USerr1"(setq blc(if blc blc 500)))
    
21.   (setvar"modemacro"(strcat"比例 1:"(rtos blc 2 0)))
    
22.   (setq blc(/ blc 1000.))
    
23.   (setq ly(getstring"展点图层<GCD>"))
    
24.   (if(null(tblsearch"layer"(setq ly(if(=""ly)"GCD"ly))))
    
25.     (ENTMAKE(list'(0 . "LAYER")'(100 . "AcDbSymbolTableRecord")'(100 . "AcDbLayerTableRecord")
    
26.    (cons 2 ly)'(70 . 0)'(62 . 1)'(6 . "CONTINUOUS"))))
    
27.   (initget"1 2 3")
    
28.   (setq m(atoi(getkword"小数位数(1,2,3):")))
    
29.   (initget"A I")
    
30.   (setq ignore(if(=(getkword"全部A;忽略0高程I:")"I")t nil))
    
31.   (setq i 0 fe(getfiled "打开坐标数据文件(序号,<编码>,y,x,z)" "" "txt;dat" 4)
    
32. fe(if(findfile fe)(open fe"r")))
    
33.   (if fe(progn
    
34.    (while(setq i(1+ i)a(read-line fe));;;直接(read(strcat"("a")"))当有中文时经常会弄错数据,所以下边处理虽然麻烦却也必要,当然处理方式可以更简单
    
35.      (setq d(vl-string-trim " \t\n"(VL-STRING-TRANSLATE "\t\n,; ""     " a)))
    
36.      (if(and(vl-string-search" "d)
    
37.      (=(length(setq dh(substr d 1(vl-string-search" "d))
    
38.       d(substr d(+(vl-string-search" "d)2))
    
39.       dh(list dh(substr d 1(vl-string-search" "d)))
    
40.       d(substr d(+(vl-string-search" "d)2))
    
41.       a(append dh(read(strcat"("d")")))))5))
    
42.        (setq b(cons a b))
    
43.        (alert(strcat"第"(itoa i)"行数据无效被忽略\n"a))))
    
44.    (close fe)
    
45.    (setq a(if ignore(vl-remove-if'(lambda(x)(=(last x)0))b)b)
    
46.   n(length a)i -1)
    
47.    (if(>(-(length b)(length a))0)(alert(strcat(itoa(-(length b)(length a)))"个0高程点将被忽略")))
    
48.    (while(<(setq i(1+ i))n)
    
49.      (makegcd(cddr(nth i a))m blc ly "HZ"))
    
50.    (vla-zoomextents (vlax-get-acad-object))
    
51.    (alert(strcat"共读入"(itoa(length b))"个坐标数据\n共展绘"(itoa n)"个有效高程点")))
    
52.     (alert"没有选择数据文件"))
    
53.   (setvar"modemacro"(strcat"比例 1:"(rtos(Getvar "Userr1")2 0)))
    
54.   (princ))

(defun c:casszgcd(/ blc ly m ignore fe a b d i n dh makegcd)<br />   (Defun makegcd(p m scale ly sty)<br />     (Entmake(List'(0 . "Insert")'(100 . "Acdbentity")'(100 . "Acdbblockreference")'(66 . 1)'(2 . "GC200")<br />    (Cons 10 P)(Cons 8 ly)(Cons 41 Scale)(Cons 42 Scale)(Cons 43 Scale)'(-3 ("South" (1000 . "202101")))))<br />     (Entmake(List'(0 . "Attrib")'(100 . "Acdbentity")'(100 . "Acdbtext")(list 10(+(car p)(* 1.2 Scale))(cadr p)(last p))<br />    (Cons 40 (* 2.0 Scale))'(50 . 0)'(41 . 0.8)(cons 1(rtos(last p)2 m))(cons 7 sty)'(72 . 0)(cons 11 p)<br />    '(100 . "Acdbattribute")'(2 . "Height")'(70 . 0)'(74 . 2)))<br />     (Entmake '((0 . "SEQEND"))))<br />    (regapp "south")<br />   (if(null(tblsearch"block""gc200"))<br />     (progn<br />       (entmake'((0 . "block")(2 . "gc200")(70 . 0)(10 0 0 0)))<br />       (entmake'((0 . "LWPOLYLINE")(100 . "AcDbEntity")(8 . "0")(100 . "AcDbPolyline")<br />   (90 . 2)(70 . 1)(43 . 0.2)(10 -0.1 0)(42 . 1.0)(10 0.1 0)(42 . 1.0)))<br />       (entmake'((0 . "ENDBLK")))))<br />   (if(null(tblsearch"style""Hz"))<br />     (entmake'((0 . "STYLE")(100 . "AcDbSymbolTableRecord")(100 . "AcDbTextStyleTableRecord")<br />        (2 . "HZ")(70 . 0)(40 . 0)(41 . 0.8)(3 . "rs.shx")(4 . "hztxt.shx"))))<br />   (setq blc(if(>(Getvar "Userr1")0)(Getvar "Userr1")(getreal"图形比例尺1:<500>")))<br />   (setvar"USerr1"(setq blc(if blc blc 500)))<br />   (setvar"modemacro"(strcat"比例 1:"(rtos blc 2 0)))<br />   (setq blc(/ blc 1000.))<br />   (setq ly(getstring"展点图层<GCD>"))<br />   (if(null(tblsearch"layer"(setq ly(if(=""ly)"GCD"ly))))<br />     (ENTMAKE(list'(0 . "LAYER")'(100 . "AcDbSymbolTableRecord")'(100 . "AcDbLayerTableRecord")<br />    (cons 2 ly)'(70 . 0)'(62 . 1)'(6 . "CONTINUOUS"))))<br />   (initget"1 2 3")<br />   (setq m(atoi(getkword"小数位数(1,2,3):")))<br />   (initget"A I")<br />   (setq ignore(if(=(getkword"全部A;忽略0高程I:")"I")t nil))<br />   (setq i 0 fe(getfiled "打开坐标数据文件(序号,<编码>,y,x,z)" "" "txt;dat" 4)<br /> fe(if(findfile fe)(open fe"r")))<br />   (if fe(progn<br />    (while(setq i(1+ i)a(read-line fe));;;直接(read(strcat"("a")"))当有中文时经常会弄错数据,所以下边处理虽然麻烦却也必要,当然处理方式可以更简单<br />      (setq d(vl-string-trim " \t\n"(VL-STRING-TRANSLATE "\t\n,; ""     " a)))<br />      (if(and(vl-string-search" "d)<br />      (=(length(setq dh(substr d 1(vl-string-search" "d))<br />       d(substr d(+(vl-string-search" "d)2))<br />       dh(list dh(substr d 1(vl-string-search" "d)))<br />       d(substr d(+(vl-string-search" "d)2))<br />       a(append dh(read(strcat"("d")")))))5))<br />        (setq b(cons a b))<br />        (alert(strcat"第"(itoa i)"行数据无效被忽略\n"a))))<br />    (close fe)<br />    (setq a(if ignore(vl-remove-if'(lambda(x)(=(last x)0))b)b)<br />   n(length a)i -1)<br />    (if(>(-(length b)(length a))0)(alert(strcat(itoa(-(length b)(length a)))"个0高程点将被忽略")))<br />    (while(<(setq i(1+ i))n)<br />      (makegcd(cddr(nth i a))m blc ly "HZ"))<br />    (vla-zoomextents (vlax-get-acad-object))<br />    (alert(strcat"共读入"(itoa(length b))"个坐标数据\n共展绘"(itoa n)"个有效高程点")))<br />     (alert"没有选择数据文件"))<br />   (setvar"modemacro"(strcat"比例 1:"(rtos(Getvar "Userr1")2 0)))<br />   (princ))

不敢说完全跟CASS的高程点一样，但用CASS肯定能认识它，用CASS进它进行打散、建DTM，计算方量等肯定不会出错
其实这个也基本上没必要写程序，随便找个CASS破解版本装上就行了，0成本的

yxh1202

谢谢各位前辈的指点，受益匪浅。明经有你们真好，再次感谢

hnwcd

附近我怎么下载不来