(defun c:zhan_datedh ()
;;LISP展碎部點程序(數(shù)據(jù)添加日期屬性)
;;坐標數(shù)據(jù)文件格式為四種
;;格式1:點號[任意空格]縱坐標X[任意空格]橫坐標Y[任意空格]高程H[任意空格]點碼
;;格式2:點號[,]點碼[,]橫坐標Y[,]縱坐標X[,]高程H
;;格式3:點號[任意空格]縱坐標X[任意空格]橫坐標Y[任意空格]高程H
;;格式4:點號[,]縱坐標X[,]橫坐標Y[,]高程H
;;(c:zhan_datedh)
;;保留小數(shù)位數(shù)不截零
(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) 定義圖形比例尺及參數(shù)置
(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 "展點圖層設(shè)置對話框"
           "請選擇展點的圖層"
           '("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 "顏色設(shè)置" (itoa dtextcolor))
         (cons "展點標注日期" dtext_date)
         (cons "高程點圖層" gcd_lay)
         (cons "高程點厚度值" (rtos gcd_thk 2 0))
         (cons "高程點字高" (rtos gcd_zigao 2 2))
         (cons "高程注記小數(shù)位數(shù)" (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 "點號注記字高應(yīng)為數(shù)值,請核實!"))
   ((= (distof (cdr (nth 2 zdhpeizhi))) nil) (alert "顏色設(shè)置應(yīng)為數(shù)值,請核實!"))
   ((= (distof (cdr (nth 5 zdhpeizhi))) nil)
    (alert "高程點厚度值應(yīng)為數(shù)值,請核實!"))
   ((= (distof (cdr (nth 6 zdhpeizhi))) nil)
    (alert "高程注記字高應(yīng)為數(shù)值,請核實!"))
   (t nil))
(setq zdhpeizhi (list (cons "展點圖層" zdh_layer)
    (cons "點號注記字高" (rtos dtextgao 2 2))
    (cons "顏色設(shè)置" (itoa dtextcolor))
    (cons "展點標注日期" dtext_date)
    (cons "高程點圖層" gcd_lay)
    (cons "高程點厚度值" (rtos gcd_thk 2 0))
    (cons "高程點字高" (rtos gcd_zigao 2 2))
    (cons "高程注記小數(shù)位數(shù)" (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 "展點數(shù)據(jù)格式選擇"
        "請選擇一種坐標文件數(shù)據(jù)格式"
        '("空格分隔坐標格式(點號 縱坐標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 "展點數(shù)據(jù)文件格式非標準!") (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 "數(shù)據(jù)非法") (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讀入數(shù)據(jù)共耗時："
   (rtos dt1 2 3)
   "秒"
   "n展點共耗時"
   (rtos dt2 2 3)
   "秒"
   "n展點數(shù)："
   (itoa (length zdsj_list))
   "個"
   "n 每展一點耗時："
   (rtos (/ dt2 (length zdsj_list)) 2 10)
   "秒"))|;
(setvar "cmdecho" cm)
(setvar "osmode" os)
(princ))
;;-----------------------------------------------------------
(defun dingblc ()
;;(dingblc)
;;定義圖形比例尺及參數(shù)設(shè)置
;; (getvar "USERR1")--圖形比例尺系統(tǒng)變量
;; (getvar"LTSCALE")--線型比例系數(shù)
(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)
;;讀取雷生碎部點成果表轉(zhuǎn)換為展點格式列表
;;(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)
;;檢查設(shè)置所操作圖層是否存在，如果不存在則新建，否則解鎖、解凍、打開
(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))
;;設(shè)為當前層
(vla-put-activelayer AcadDocument1 LayerObj)
;;設(shè)置圖層顏色
(if (/= nil laycolor)
   (vla-put-color LayerObj laycolor)))
(progn,新建圖層
(vla-get-activelayer AcadDocument1 LayerObj)
;;設(shè)置圖層顏色
(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---注記內(nèi)容 textthk---注記厚值
;; textzg---注記字高textro---注記旋轉(zhuǎn)方向 textkuan---注記寬度系數(shù)
;; textqxie---注記傾斜角度 textstyle---注記文字樣式
;; textcolor---注記顏色
;; textlcr--注記左中右對齊方式(0,1,2,nil)
;; textdmh--注記上中下對齊方式(3,2,1,nil)
;; textpt10---注記點坐標10 textpt11---注記點坐標11
;; textkzsx--擴展屬性
;;加載(vl-load-com)環(huán)境
(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))
;;注記旋轉(zhuǎn)角度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)
;;注記的寬度系數(shù)textkuan
(if (/= textkuan nil)
(vla-put-ScaleFactor TextObj textkuan)
(vla-put-ScaleFactor TextObj 1.0))
;;注記的傾斜系數(shù)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)
;;將輸入的分隔符分隔的字符串數(shù)據(jù)轉(zhuǎn)換為包含數(shù)據(jù)列信息的字符串列表子程序
;;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)
;;在狀態(tài)蘭顯示程序運行進度
;;(printbar_jd jdstr s_fm s_fz)
;;jdstr--顯示進度的文字說明 s_fm--進度總數(shù) s_fz--當前的個數(shù)
(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)