飞时达钻孔数据录入？

树櫴希德 · 发表于 2021-4-28 18:57:15

本帖最后由树櫴希德于 2021-6-7 17:17 编辑

飞时达钻孔数据录入？

;;功能：带提示、关键字、过滤表、选择错误时的提示并且会亮显所选对像的entsel
;;用法：( clh-entsel 提示信息关键字过滤表选择错误时提示)
;;举例：(clh-entsel "\n请选择一个圆：" "A B C" '((0 . "circle")) "\n所选对像不符合要求！请重新选择：")
;;说明：过滤表与ssget的过滤表相同;函数由CLH521，2009.6.7参考了一些网上资料整理编写
(defun clh-entsel (msg key fil ermsg / el ss)
(while (and (setvar "errno" 0)
(not (and (setq el (apply '(lambda (msg key) (initget key) (entsel msg)) (list msg key)))
(if (= (type el) 'str)
el
(if (setq ss (ssget (cadr el) fil))
ss
(progn (princ ermsg) (setq ss nil))
);if
);if
);and
);not
(/= (getvar "errno") 52)
);and
);while
(if (= (type el) 'list) (redraw (car el) 3));亮显选中的对像
el
)
;clh-entsel函数完毕========================================================
(defun StrType(a / b c d e);;字符串分离全角、符号、字母、数字,存在问题：连续小数点与数字相连不能精确分离数字和小数点
(setq b(vl-string->list a))
(while b
(setq a(car b)b(cdr b)c(last d))
(if(or(not d)
(and(< 0 a 32)(< 0 c 32));;非打印字符
(or(= 46 a)(= 46 c)(and(< 47 a 58)(< 47 c 58)));数字和小数点
(vl-every'(lambda(x)(vl-some'(lambda(y)(<(car y)x(cadr y)))'((31 48)(57 65)(90 98)(122 129))))(list a c));其它字符包括小数点
(vl-every'(lambda(x)(vl-some'(lambda(y)(<(car y)x(cadr y)))'((64 91)(96 123))))(list a c));;字母
(and(> a 128)(> c 128)));;全角字符
(if(> a 128)(setq d(vl-list*(car b)a d)b(cdr b))(setq d(cons a d)))
(setq e(cons(reverse d)e)d(if(> a 128)(list(car b)a)(List a))b(if(> a 128)(cdr b)b))))
(mapcar'vl-list->string(reverse(cons(reverse d)e))))
(defun 1zu ( e / )
(rtos(read (car(StrType (cdr(assoc 1(entget e))) )))2 3)
)
(defun 2zu ( e / )
(rtos(read (last(StrType (cdr(assoc 1(entget e))) )))2 0)
)
(defun 10zu ( e / )
(rtos(read (cdr(assoc 1(entget e))) )2 3)
)
;(rtos(read (car(StrType (cdr(assoc 1(entget (car(entsel))))) )))2 3)
(defun c:fsddc ( / p1 bh w1 w2 w3 w4 w5 w6 ff ffn i )
(setq ffn (getfiled "选取/建立数据导出文件" "" "ini" 1))
(setq ff (open ffn "w"))
(write-line "[TFZKDATAINFO] \n" ff)
; (setq i 1)
(while (setq p1 (getpoint "\n请在钻孔柱状图图里随便点击一下："))
(setq bh (car(entsel "\n请选择钻孔编号文字：")) )
(setq w2 (car(entsel "\n请选择钻孔北坐标文字：")) )
(setq w1 (car(entsel "\n请选择钻孔东坐标文字：")) )
(setq w3 (car(entsel "\n请选择钻孔高程文字：")) )
(setq w4 (car(entsel "\n请选择钻孔第1层土厚度文字：")) )
(setq w5 (car(entsel "\n请选择钻孔第2层土厚度文字：")) )
(setq w6 (car(entsel "\n请选择钻孔第3层土厚度文字：")) )
(write-line (strcat (2zu bh) "=" (1zu w1)";"(1zu w2)";"(1zu w3)";0;"(10zu w4)";"(10zu w5)";"(10zu w6)";" "\n" ) ff)
;(setq i (1+ i))
)
(close ff)
)
;;;;;;;;;;;;;;;;
(defun c:fsd111 ( / p1 bh w1 w2 w3 w4 w5 w6 ff ffn i )
(vl-load-com)
(setq ffn (getfiled "选取/建立数据导出文件" "" "txt" 1))
(setq ff (open ffn "w"))
(write-line (strcat "钻孔编号;" "东坐标;" "北坐标;" "高程;" "淤泥顶;" "淤泥底;" "粉质黏土底") ff)
; (setq i 1)
(while (setq p1 (getpoint "\n请在钻孔柱状图图里随便点击一下："))
; (while (= (cdr(assoc 0 (entget(setq bh (car(entsel "\n请选择钻孔编号文字：")) ) ))) "TEXT")(vla-put-Color (vlax-ename->vla-object bh) 1))
;(clh-entsel "\n请选择钻孔粉质黏土底面标高文字：" "A B C" '((0 . "TEXT")) "\n所选对像不符合要求！请重新选择：")
(setq bh (car(clh-entsel "\n请选择钻孔编号文字：" "A B C" '((0 . "TEXT")) "\n所选对像不符合要求！请重新选择：")) )
(vla-put-Color (vlax-ename->vla-object bh) 1)
(setq w2 (car(clh-entsel "\n请选择钻孔北坐标文字：" "A B C" '((0 . "TEXT")) "\n所选对像不符合要求！请重新选择：")) )
(vla-put-Color (vlax-ename->vla-object w2) 2)
(setq w1 (car(clh-entsel "\n请选择钻孔东坐标文字：" "A B C" '((0 . "TEXT")) "\n所选对像不符合要求！请重新选择：")) )
(vla-put-Color (vlax-ename->vla-object w1) 3)
(setq w3 (car(clh-entsel "\n请选择钻孔高程文字：" "A B C" '((0 . "TEXT")) "\n所选对像不符合要求！请重新选择：")) )
(vla-put-Color (vlax-ename->vla-object w3) 4)
(setq w4 (car(clh-entsel "\n请选择钻孔淤泥顶面标高文字：" "A B C" '((0 . "TEXT")) "\n所选对像不符合要求！请重新选择：")) )
(vla-put-Color (vlax-ename->vla-object w4) 5)
(setq w5 (car(clh-entsel "\n请选择钻孔淤泥底面标高文字：" "A B C" '((0 . "TEXT")) "\n所选对像不符合要求！请重新选择：")) )
(vla-put-Color (vlax-ename->vla-object w5) 6)
(setq w6 (car(clh-entsel "\n请选择钻孔粉质黏土底面标高文字：" "A B C" '((0 . "TEXT")) "\n所选对像不符合要求！请重新选择：")) )
(vla-put-Color (vlax-ename->vla-object w6) 1)
(write-line (strcat (2zu bh) ";" (1zu w1)";"(1zu w2)";"(1zu w3)";"(10zu w4)";"(10zu w5)";"(10zu w6)";" ) ff)
;(setq i (1+ i)) "\n"
)
(close ff)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:fsdzk ( / p1 bh w1 w2 w3 w4 w5 w6 ff ffn i )
(setq ffn (getfiled "选取/建立数据导出文件" "" "txt" 1))
(setq ff (open ffn "w"))
(write-line (strcat "钻孔编号;" "东坐标;" "北坐标;" "高程;" "淤泥顶;" "淤泥底;" "粉质黏土底") ff)
; (setq i 1)
(while (setq p1 (getpoint "\n请在钻孔平面图图里点击钻孔位置："))
(setq bh (getstring "\n请输入钻孔编号：") )
(setq w1 (rtos(car p1)2 3) )
(setq w2 (rtos(cadr p1)2 3) )
(setq w3 (getreal "\n请输入钻孔高程：") )
(setq w4 (getreal "\n请输入素填土埋深：") )
(setq w5 (getreal "\n请输入淤泥埋深：") )
(setq w6 (getreal "\n请输入粉质黏土埋深：") )
(write-line (strcat bh ";" w1 ";" w2 ";" (rtos w3 2 3) ";"(rtos (- w3 w4) 2 3)";"(rtos (- w3 w5) 2 3)";"(rtos (- w3 w6) 2 3)";" ) ff)
;(setq i (1+ i)) "\n"
)
(close ff)
)

;;功能：带提示、关键字、过滤表、选择错误时的提示并且会亮显所选对像的entsel 
;;用法：( clh-entsel  提示信息  关键字  过滤表  选择错误时提示) 
;;举例：(clh-entsel  "\n请选择一个圆："  "A B C"   '((0 . "circle"))  "\n所选对像不符合要求！请重新选择：") 
;;说明：过滤表与ssget的过滤表相同;函数由CLH521，2009.6.7参考了一些网上资料整理编写 
(defun clh-entsel (msg key fil ermsg / el ss) 
  (while (and (setvar "errno" 0) 
            (not (and (setq el (apply '(lambda (msg key) (initget key) (entsel msg)) (list msg key))) 
                (if (= (type el) 'str) 
                    el 
                 (if (setq ss (ssget (cadr el) fil)) 
                    ss 
                  (progn (princ ermsg) (setq ss nil)) 
                 );if 
              );if 
          );and 
        );not 
        (/= (getvar "errno") 52) 
     );and 
  );while 
  (if (= (type el) 'list) (redraw (car el) 3));亮显选中的对像 
  el 
) 
;clh-entsel函数完毕======================================================== 
 
 
 
(defun StrType(a / b c d e);;字符串分离全角、符号、字母、数字,存在问题：连续小数点与数字相连不能精确分离数字和小数点 
    (setq b(vl-string->list a)) 
    (while b 
      (setq a(car b)b(cdr b)c(last d)) 
      (if(or(not d) 
      (and(< 0 a 32)(< 0 c 32));;非打印字符 
      (or(= 46 a)(= 46 c)(and(< 47 a 58)(< 47 c 58)));数字和小数点 
      (vl-every'(lambda(x)(vl-some'(lambda(y)(<(car y)x(cadr y)))'((31 48)(57 65)(90 98)(122 129))))(list a c));其它字符包括小数点 
      (vl-every'(lambda(x)(vl-some'(lambda(y)(<(car y)x(cadr y)))'((64 91)(96 123))))(list a c));;字母 
      (and(> a 128)(> c 128)));;全角字符 
  (if(> a 128)(setq d(vl-list*(car b)a d)b(cdr b))(setq d(cons a d))) 
  (setq e(cons(reverse d)e)d(if(> a 128)(list(car b)a)(List a))b(if(> a 128)(cdr b)b)))) 
    (mapcar'vl-list->string(reverse(cons(reverse d)e)))) 
 
(defun 1zu ( e / ) 
  (rtos(read (car(StrType (cdr(assoc 1(entget e)))  )))2 3) 
  ) 
(defun 2zu ( e / ) 
  (rtos(read (last(StrType (cdr(assoc 1(entget e)))  )))2 0) 
  ) 
(defun 10zu ( e / ) 
  (rtos(read  (cdr(assoc 1(entget e)))        )2 3) 
  ) 
 
 
 
;(rtos(read (car(StrType (cdr(assoc 1(entget (car(entsel)))))  )))2 3) 
(defun c:fsddc ( / p1 bh w1 w2 w3 w4 w5 w6 ff ffn i   ) 
 
 (setq ffn (getfiled "选取/建立数据导出文件" "" "ini" 1)) 
  (setq ff (open ffn "w")) 
(write-line "[TFZKDATAINFO] \n" ff) 
 ; (setq i 1) 
 
(while (setq p1 (getpoint "\n请在钻孔柱状图图里随便点击一下：")) 
   
  (setq bh (car(entsel "\n请选择钻孔编号文字：")) ) 
  (setq w2 (car(entsel "\n请选择钻孔北坐标文字：")) ) 
  (setq w1 (car(entsel "\n请选择钻孔东坐标文字：")) ) 
    (setq w3 (car(entsel "\n请选择钻孔高程文字：")) ) 
  (setq w4 (car(entsel "\n请选择钻孔第1层土厚度文字：")) ) 
  (setq w5 (car(entsel "\n请选择钻孔第2层土厚度文字：")) ) 
  (setq w6 (car(entsel "\n请选择钻孔第3层土厚度文字：")) ) 
(write-line (strcat (2zu bh) "=" (1zu w1)";"(1zu w2)";"(1zu w3)";0;"(10zu w4)";"(10zu w5)";"(10zu w6)";" "\n"  ) ff) 
   
 
;(setq i (1+ i)) 
  ) 
 
 
 
 
 
 
(close ff) 
 
 
 ) 
;;;;;;;;;;;;;;;; 
(defun c:fsd111 ( / p1 bh w1 w2 w3 w4 w5 w6 ff ffn i   ) 
(vl-load-com) 
 (setq ffn (getfiled "选取/建立数据导出文件" "" "txt" 1)) 
  (setq ff (open ffn "w")) 
(write-line (strcat "钻孔编号;" "东坐标;" "北坐标;" "高程;" "淤泥顶;" "淤泥底;" "粉质黏土底") ff) 
 ; (setq i 1) 
 
(while (setq p1 (getpoint "\n请在钻孔柱状图图里随便点击一下：")) 
   
 ; (while (=  (cdr(assoc 0 (entget(setq bh (car(entsel "\n请选择钻孔编号文字：")) ) )))  "TEXT")(vla-put-Color (vlax-ename->vla-object bh) 1)) 
    
    ;(clh-entsel  "\n请选择钻孔 粉质黏土底 面标高文字："  "A B C"   '((0 . "TEXT"))  "\n所选对像不符合要求！请重新选择：") 
   
(setq bh (car(clh-entsel  "\n请选择钻孔编号文字："  "A B C"   '((0 . "TEXT"))  "\n所选对像不符合要求！请重新选择：")) )   
 
  (vla-put-Color (vlax-ename->vla-object bh) 1) 
   
  (setq w2 (car(clh-entsel  "\n请选择钻孔北坐标文字："  "A B C"   '((0 . "TEXT"))  "\n所选对像不符合要求！请重新选择：")) ) 
  (vla-put-Color (vlax-ename->vla-object w2) 2) 
  (setq w1 (car(clh-entsel  "\n请选择钻孔东坐标文字："  "A B C"   '((0 . "TEXT"))  "\n所选对像不符合要求！请重新选择：")) ) 
  (vla-put-Color (vlax-ename->vla-object w1) 3) 
    (setq w3 (car(clh-entsel  "\n请选择钻孔高程文字："  "A B C"   '((0 . "TEXT"))  "\n所选对像不符合要求！请重新选择：")) ) 
  (vla-put-Color (vlax-ename->vla-object w3) 4) 
  (setq w4 (car(clh-entsel  "\n请选择钻孔 淤泥顶 面标高文字："  "A B C"   '((0 . "TEXT"))  "\n所选对像不符合要求！请重新选择：")) ) 
  (vla-put-Color (vlax-ename->vla-object w4) 5) 
  (setq w5 (car(clh-entsel  "\n请选择钻孔 淤泥底 面标高文字："  "A B C"   '((0 . "TEXT"))  "\n所选对像不符合要求！请重新选择：")) ) 
  (vla-put-Color (vlax-ename->vla-object w5) 6) 
  (setq w6 (car(clh-entsel  "\n请选择钻孔 粉质黏土底 面标高文字："  "A B C"   '((0 . "TEXT"))  "\n所选对像不符合要求！请重新选择：")) ) 
  (vla-put-Color (vlax-ename->vla-object w6) 1) 
(write-line (strcat (2zu bh) ";" (1zu w1)";"(1zu w2)";"(1zu w3)";"(10zu w4)";"(10zu w5)";"(10zu w6)";"   ) ff) 
   
 
;(setq i (1+ i)) "\n" 
  ) 
 
 
 
 
 
 
(close ff) 
 
 
 ) 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
(defun c:fsdzk ( / p1 bh w1 w2 w3 w4 w5 w6 ff ffn i   ) 
 
 (setq ffn (getfiled "选取/建立数据导出文件" "" "txt" 1)) 
  (setq ff (open ffn "w")) 
(write-line (strcat "钻孔编号;" "东坐标;" "北坐标;" "高程;" "淤泥顶;" "淤泥底;" "粉质黏土底") ff) 
 ; (setq i 1) 
 
(while (setq p1 (getpoint "\n请在钻孔平面图图里点击钻孔位置：")) 
   
  (setq bh (getstring "\n请输入钻孔编号：") ) 
  (setq w1 (rtos(car p1)2 3) ) 
  (setq w2 (rtos(cadr p1)2 3) ) 
  (setq w3 (getreal "\n请输入钻孔高程：") ) 
  (setq w4 (getreal "\n请输入素填土埋深：") ) 
  (setq w5 (getreal "\n请输入淤泥埋深：") ) 
  (setq w6 (getreal "\n请输入粉质黏土埋深：") ) 
 
   
(write-line (strcat bh ";" w1 ";" w2 ";" (rtos w3 2 3) ";"(rtos (- w3 w4) 2 3)";"(rtos (- w3 w5) 2 3)";"(rtos (- w3 w6) 2 3)";"   ) ff) 
   
 
;(setq i (1+ i)) "\n" 
  ) 
 
 
 
 
 
 
(close ff) 
 
 
 )

树櫴希德 · 发表于 2021-4-28 19:09:11

;;;by Gu_xl
(defun gxl-cs:gcd (inspt height scale / pt blkdef obj);展高程点函数(inspt:插入点,heitht:高程值,scale:缩放比例,xsws:高程注记位数)
(vl-load-com) ;将 Visual LISP 扩展功能加载到 AutoLISP
(regapp "SOUTH")
(setvar "CMDECHO" 0)
(command "layer" "m" "GCD" "c" "1" "" "L" "CONTINUOUS" "" "")
(if height
(setq height (rtos height 2 3));3为高程注记位数
(setq height "")
)
(regapp "SOUTH")
;;;检查字体 "HZ" 是否存在
(if (not (tblobjname "style" "宋体"))
;(command "style" "HZ" "rs.shx,hztxt.shx" 0 1 0 "" "" "")
(command "style" "宋体" "" 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)
(list -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 "宋体")
(cons 62 3)
(cons 72 0)
(cons 11 pt)
'(100 . "AcDbAttribute")
(cons 2 "height")
(cons 70 0)
(cons 74 2)
)
)
;;;结束标志
(entmake '((0 . "SEQEND")))
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun insertgc ( e / e)
(cdr(assoc 10(entget e)))
)
(defun insertgc11 ( e / e)
(cdr(assoc 11(entget e)))
)
(defun insert1 ( e / e)
(read (cdr(assoc 1(entget e))) )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
( defun c:bgc ( / blc scale wz height zb xzb zdzb)
(setq blc (getint "\n请输入比例尺1:<500>"))
(if (= blc nil)(setq blc 500))
(setvar 'userr1 blc);设置比例尺
(setq scale (* 0.001 blc));缩放比例
(while (setq wz(car(entsel "\n请选择要转换成高程点的数字文字text:")))
(setq height (insert1 wz))
(setq zb (insertgc wz))
;(setq xzb (list (+ (car zb) 1.1661) (- (cadr zb) 0.8044) height ) );;;;;;
(setq zdzb (getpoint "\n请指定要标注高程点的位置："))
(setq xzb (list (car zdzb) (cadr zdzb) height ))
(gxl-cs:gcd xzb height scale)
)
)

;;;by Gu_xl 
(defun gxl-cs:gcd (inspt height scale / pt blkdef obj);展高程点函数(inspt:插入点,heitht:高程值,scale:缩放比例,xsws:高程注记位数) 
(vl-load-com) ;将 Visual LISP 扩展功能加载到 AutoLISP 
  (regapp "SOUTH") 
  (setvar "CMDECHO" 0) 
  (command "layer" "m" "GCD" "c" "1" "" "L" "CONTINUOUS" ""  "") 
  (if height 
    (setq height (rtos height 2 3));3为高程注记位数 
    (setq height "") 
  ) 
  (regapp "SOUTH") 
   
  ;;;检查字体 "HZ" 是否存在 
  (if (not (tblobjname "style" "宋体")) 
    ;(command "style" "HZ" "rs.shx,hztxt.shx" 0 1 0 "" "" "") 
    (command "style" "宋体" "" 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) 
              (list -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 "宋体") 
       (cons 62 3) 
              (cons 72 0) 
              (cons 11 pt) 
              '(100 . "AcDbAttribute") 
              (cons 2 "height") 
              (cons 70  0) 
              (cons 74 2) 
           ) 
   ) 
   ;;;结束标志 
   (entmake '((0 . "SEQEND"))) 
   (princ) 
) 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
(defun insertgc ( e / e) 
  (cdr(assoc 10(entget e))) 
  ) 
(defun insertgc11 ( e / e) 
  (cdr(assoc 11(entget e))) 
  ) 
 
(defun insert1 ( e / e) 
  (read (cdr(assoc 1(entget e)))  ) 
  ) 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
 
( defun c:bgc ( /  blc scale wz height zb xzb zdzb) 
 
 
 (setq blc (getint "\n请输入比例尺1:<500>")) 
  (if (= blc nil)(setq blc 500)) 
  (setvar 'userr1 blc);设置比例尺 
(setq scale (* 0.001 blc));缩放比例 
 
  (while (setq wz(car(entsel "\n请选择要转换成高程点的数字文字text:"))) 
 
  (setq height (insert1 wz)) 
    (setq zb (insertgc wz)) 
 
    ;(setq xzb (list  (+ (car zb) 1.1661) (- (cadr zb) 0.8044) height    )    );;;;;; 
   (setq zdzb (getpoint "\n请指定要标注高程点的位置：")) 
    (setq xzb  (list (car zdzb) (cadr zdzb)  height  )) 
(gxl-cs:gcd xzb height scale) 
    
   ) 
 
 
 )

树櫴希德 · 发表于 2021-4-29 17:05:19

(defun c:fsdzk ( / p1 bh w1 w2 w3 w4 w5 w6 ff ffn i )
(setq ffn (getfiled "选取/建立数据导出文件" "" "txt" 1))
(setq ff (open ffn "w"))
(write-line (strcat "钻孔编号;" "东坐标;" "北坐标;" "高程;" "淤泥顶;" "淤泥底;" "粉质黏土底") ff)
; (setq i 1)
(while (setq p1 (getpoint "\n请在钻孔平面图图里点击钻孔位置："))
(setq bh (getstring "\n请输入钻孔编号：") )
(setq w1 (rtos(car p1)2 3) )
(setq w2 (rtos(cadr p1)2 3) )
(setq w3 (getreal "\n请输入钻孔高程：") )
(setq w4 (getreal "\n请输入素填土埋深：") )
(setq w5 (getreal "\n请输入淤泥埋深：") )
(setq w6 (getreal "\n请输入粉质黏土埋深：") )
(write-line (strcat bh ";" w1 ";" w2 ";" (rtos w3 2 3) ";"(rtos (- w3 w4) 2 3)";"(rtos (- w3 w5) 2 3)";"(rtos (- w3 w6) 2 3)";" ) ff)
;(setq i (1+ i)) "\n"
)
(close ff)
)

流氓兔 · 发表于 2021-5-26 23:02:50

skg123 · 发表于 2021-6-7 01:23:59

上图演示一下，大家一块就明白，这一堆代码不直观

树櫴希德 · 发表于 2021-6-8 21:45:44

；《《《《《《《《《《《《《《《》》》》》》》》》》》》》》》

函数：;(cx-SsgetNum "测试选数字" nil "") 只选择数字的文本。
参数：msg提示字符串。
cps ：pik选项可以用：：s或者：e等关键字。
kwd ：关键字选项，可以输入1 2 3 4 （initget)

；《《《《《《《《《《《《《《《》》》》》》》》》》》》》》》
来源鱼和熊掌大神

;;带关键字的ssget(cx-ssget "选择文字[(m)多选/(d)恢复/]<结束>" "m d" '((0 . "*text")))
;;点化字串
;带过滤的超级单选。
;(cx-entsel "选择直线" "S 3" nil)
(defun cx-entsel (msg kwd fli / s)
(setq s (cx-SsgetSup msg ":s" kwd fli))
(if s
(if (= 'str (type s))
s
(ssname s 0)
)
nil
)
)
;(cx-SsgetNum "测试选数字" nil "\n选择错误，请重新选择")
(defun cx-SsgetNum (msg cps kwd)
(cx-SsgetSup msg cps kwd '((1 . "~*[~.0-9]*")))
)
;;带关键字的ssget(cx-ssget "选择文字[(m)多选/(d)恢复/]<结束>" "m d" '((0 . "*text")))
;(cx-SsgetSup "选择文字[(m)多选/(d)恢复/]<结束>" ":s" "m d" nil)
(defun cx-SsgetSup
(Msg CPS Kwd Fil / cx-entsel Kwd0 pt var cx-split Pt2Str)
(setq
*ACAD* (vlax-get-acad-object)
*DOC* (vla-get-ActiveDocument *ACAD*)
)
(defun Pt2Str (pt)
(strcat (rtos (car pt) 2 20)
","
(rtos (cadr pt) 2 20)
","
(rtos (caddr pt) 2 20)
"\n"
)
)
;分割字符串_单.(cx-split1 "123 321" " ")
(defun cx-split (str del / pos lst)
(while (setq pos (vl-string-search del str))
(setq lst (cons (substr str 1 pos) lst)
str (substr str (+ pos 1 (strlen del)))
)
)
;(vl-remove "" (reverse (cons str lst)))
(if (= " " Del)
(vl-remove "" (reverse (cons str lst)))
(reverse (cons str lst))
)
)
(defun cx-ents (msg filter)
(setq enp (entsel msg))
(if (or (= (type enp) 'str)
(and enp (ssget (cadr enp) filter))
)
enp
)
)
(cond ((cadr (ssgetfirst)))
(t
(setq Kwd0 "W L C BOX ALL F WP CP G A R M P U AU SI")
(initget (strcat Kwd0 " " kwd))
(cond ((and (listp (setq var (cx-ents Msg Fil)))
(/= 52 (getvar "errno"))
)
(vla-sendcommand *doc* (Pt2Str (cadr (grread t))))
(if cps
(ssget CPS Fil)
(ssget Fil)
)
)
((member var (cx-split Kwd0 " "))
(vla-sendcommand *doc* (strcat var "\n"))
(if cps
(ssget CPS Fil)
(ssget Fil)
)
)
(t var)
)
)
)
)
(defun cx-ssget (msg kwd fli)
(cx-SsgetSup msg nil kwd fli)
)

;;带关键字的ssget(cx-ssget "选择文字[(m)多选/(d)恢复/]<结束>" "m d"  '((0 . "*text"))) 
 
 
 
 
;;点化字串 
 
 ;带过滤的超级单选。 
 ;(cx-entsel "选择直线" "S 3" nil) 
(defun cx-entsel (msg kwd fli / s) 
  (setq s (cx-SsgetSup msg ":s" kwd fli)) 
  (if s 
    (if  (= 'str (type s)) 
      s 
      (ssname s 0) 
    ) 
    nil 
  ) 
) 
 ;(cx-SsgetNum "测试选数字" nil "\n选择错误，请重新选择") 
(defun cx-SsgetNum (msg cps kwd) 
  (cx-SsgetSup msg cps kwd '((1 . "~*[~.0-9]*"))) 
) 
 
;;带关键字的ssget(cx-ssget "选择文字[(m)多选/(d)恢复/]<结束>" "m d"  '((0 . "*text"))) 
 ;(cx-SsgetSup "选择文字[(m)多选/(d)恢复/]<结束>" ":s"  "m d"  nil) 
(defun cx-SsgetSup 
       (Msg CPS Kwd Fil / cx-entsel Kwd0 pt var cx-split Pt2Str) 
  (setq 
    *ACAD* (vlax-get-acad-object) 
    *DOC*  (vla-get-ActiveDocument *ACAD*) 
  ) 
  (defun Pt2Str  (pt) 
    (strcat (rtos (car pt) 2 20) 
      "," 
      (rtos (cadr pt) 2 20) 
      "," 
      (rtos (caddr pt) 2 20) 
      "\n" 
    ) 
  ) 
 ;分割字符串_单.(cx-split1 "123 321" " ") 
  (defun cx-split (str del / pos lst) 
    (while (setq pos (vl-string-search del str)) 
      (setq lst  (cons (substr str 1 pos) lst) 
      str  (substr str (+ pos 1 (strlen del))) 
      ) 
    ) 
 ;(vl-remove "" (reverse (cons str lst))) 
 
    (if  (= " " Del) 
      (vl-remove "" (reverse (cons str lst))) 
      (reverse (cons str lst)) 
    ) 
  ) 
 
  (defun cx-ents (msg filter) 
    (setq enp (entsel msg)) 
    (if  (or (= (type enp) 'str) 
      (and enp (ssget (cadr enp) filter)) 
  ) 
      enp 
    ) 
  ) 
  (cond  ((cadr (ssgetfirst))) 
  (t 
   (setq Kwd0 "W L C BOX ALL F WP CP G A R M P U AU SI") 
   (initget (strcat Kwd0 " " kwd)) 
   (cond ((and (listp (setq var (cx-ents Msg Fil))) 
         (/= 52 (getvar "errno")) 
    ) 
    (vla-sendcommand *doc* (Pt2Str (cadr (grread t)))) 
    (if cps 
      (ssget CPS Fil) 
      (ssget Fil) 
    ) 
         ) 
         ((member var (cx-split Kwd0 " ")) 
    (vla-sendcommand *doc* (strcat var "\n")) 
    (if cps 
      (ssget CPS Fil) 
      (ssget Fil) 
    ) 
         ) 
         (t var) 
   ) 
  ) 
  ) 
) 
(defun cx-ssget  (msg kwd fli) 
  (cx-SsgetSup msg nil kwd fli) 
)

函数：;;带关键字的ssget(cx-ssget "选择文字[(m)多选/(d)恢复/]<结束>" "m d" '((0 . "*text")))
说明：来自飞总的原来的函数。

；《《《《《《《《《《《《《《《》》》》》》》》》》》》》》》

;带过滤的超级单选。
;(cx-entsel "选择直线" "S 3" nil)
参数1：msg提示信息
参数2：关键字 S 或者3（initget）
参数3：过滤选项如：'((0 . "LINE"))

；《《《《《《《《《《《《《《《》》》》》》》》》》》》》》》

;函数;(cx-SsgetSup "选择文字[(m)多选/(d)恢复/]<结束>" ":s" "m d" nil)
;参数1：提示信息
;参数2 : ：S :E 等CPS选项
;参数3：关键字
;参数4：过滤

技术工作室 · 发表于 2022-10-9 10:42:10

留个座位，支持一下

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

飞时达钻孔数据录入？

本帖子中包含更多资源