飞时达钻孔数据录入？
本帖最后由 树櫴希德 于 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 " \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)
) ;;;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 700)
(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)
)
)
(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)
)
上图演示一下，大家一块就明白，这一堆代码不直观 ；《《《《《《《《《《《《《《《》》》》》》》》》》》》》》》
函数：;(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)
参数1：msg提示信息
参数2：关键字 S 或者3（initget）
参数3：过滤选项 如：'((0 . "LINE"))
；《《《《《《《《《《《《《《《》》》》》》》》》》》》》》》
;函数;(cx-SsgetSup "选择文字[(m)多选/(d)恢复/]<结束>" ":s""m d"nil)
;参数1：提示信息
;参数2 :：S :E 等CPS选项
;参数3：关键字
;参数4：过滤
留个座位，支持一下
页:
[1]