;;说明:压力管道焊缝编号辅统工具 V1.1(2020.9.5)(defun c:SWED(/ abnum al-insertblock alst blst cdnum clformat clst config dir diris dlst drarec inpt inptis isaorb linecode obtstr pt putpt ss ssgetpy swedfile swedpath wedsum weldsort)(vl-load-com);;说明:生成或修改配置文件(defun config(/ ab abwedtpy cd cdwedtpy file filepath tn tnum)(if (setq filepath (findfile "swedconfig.txt"))(progn(mapcar (function (lambda(x y) (set (read x) y))) (list "abwedtpy" "cdwedtpy" "tnum") (read (read-line (setq file (open filepath "r")))))(close file))(setq filepath (strcat (vla-get-Path (vlax-get-acad-object)) "\\Support\\swedconfig.txt") abwedtpy "100%RT" cdwedtpy "100%PT" tnum 30))(write-line(vl-prin1-to-string(list(if (and (/= nil (setq ab (getstring (strcat "\n请输入对接焊缝检测类型，默认<" abwedtpy ">：")))) (/= "" ab)) ab abwedtpy)(if (and (/= nil (setq cd (getstring (strcat "\n请输入C、D类焊缝检测类型，默认<" cdwedtpy ">：")))) (/= "" cd)) cd cdwedtpy)(if (and (/= nil (setq tn (getint (strcat "\n请输入当前管线总页数，默认<" (rtos tnum) ">：")))) (/= "" tn)) tn tnum)))(setq file (open filepath "w")))(close file)(prin1))(princ "\n确认配置无误后，再进行下一步操作！！！")(if (setq swedpath (findfile "swedconfig.txt"))(progn(progn;;;自定义函数！;;说明:获取文字或快属性文字;;返回:字符串(obtstr);;(SETQ pikstr "\n请拾取原图当前页号：")(defun obtstr(pikstr / edata ent etype pt str tpy)(if (and (/= (setq ent (entsel pikstr)) "") (/= ent nil))(progn(while (and (/= (setq tpy (cdr (assoc 0 (entget (car ent))))) "MTEXT") (/= tpy "TEXT") (/= tpy "INSERT")) (setq ent (entsel "\n选择不为文字或块内文字、块属性，请重新选择择提取的对象：")))(if (= tpy "INSERT")(while (and (/= (setq tpy (cdr (assoc 0 (entget (car (nentselp (cadr ent))))))) "ATTRIB") (/= tpy "MTEXT") (/= tpy "TEXT") (/= tpy "INSERT"))(setq ent (entsel "\n选择不为文字或块内文字、块属性，请重新选择择提取的对象："))))(setq edata (entget (car ent)) pt (cadr ent) etype (cdr (assoc 0 edata)))(cond((or (= etype "TEXT") (= etype "MTEXT")) (setq str (clformat (cdr (assoc 1 edata)))))((= etype "INSERT") (setq str (clformat (cdr (assoc 1 (entget (car (nentselp pt)))))))))))str)(defun ssgetpy(ssall weldtpy)(vl-cmdf "SELECT" ssall "")(ssget "P" (list (cons 1 weldtpy))))(defun drarec(lst)(entmakex (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 62 1) (cons 90 (length lst)) (cons 70 1)) (mapcar '(lambda (pt) (cons 10 pt)) lst))));;说明:生成焊缝汇总;;参数:wedlst:焊缝类表;;参数:pt:汇总放置区左上角点(defun wedSum(weldlst pt isdir isinpt lcode / center1 center2 disc1x disc1y disc2x disc2y disex disey dissx dissy hdisx hdisy n pt0 pte pts wedlst)(setqpt0 (if isdir(cond((equal isinpt "LD") (list (car pt) (+ (cadr pt) 22)))((equal isinpt "RT") (list (- (car pt) 44) (cadr pt)))((equal isinpt "RD") (list (- (car pt) 44) (+ (cadr pt) 22)))(T pt))(cond((equal isinpt "LD") (list (car pt) (+ (cadr pt) 103)))((equal isinpt "RT") (list (- (car pt) 22) (cadr pt)))((equal isinpt "RD") (list (- (car pt) 22) (+ (cadr pt) 103)))(T pt)))hdisx 22 hdisy 22 n 1);(setq n (1+ n))(repeat 6(if (<= n 2)(progn(drarec (list pt0 (list (+ (car pt0) hdisx) (cadr pt0)) (list (+ (car pt0) hdisx) (- (cadr pt0) hdisy)) (list (car pt0) (- (cadr pt0) hdisy))))(entmake(append(list '(0 . "MTEXT") '(100 . "AcDbEntity") '(100 . "AcDbMText") (cons 10 (list (+ (car pt0) 11) (- (cadr pt0) 11))) '(41 . 22) '(46 . 22) '(71 . 5) '(72 . 5))(cond((= n 1) (list (cons 1 "{\\fSimSun|b0|i0|c134|p2;\\W0.8;管线代\\P用编码}") '(7 . "Standard") '(40 . 4.5) '(62 . 1)))((= n 2) (list (cons 1 (strcat "{\\fSimSun|b1|i1|c134|p2;" lcode "}")) '(7 . "宋体") '(40 . 8.0))))))(if (= n 2)(if isdir(cond((equal isinpt "LD") (setq pt0 (list (+ (car pt0) 22) (cadr pt0))))((equal isinpt "RT") (setq pt0 (list (- (car pt) 103) (cadr pt))))((equal isinpt "RD") (setq pt0 (list (- (car pt) 103) (+ (cadr pt) 22))))(T (setq pt0 (list (+ (car pt0) hdisx) (cadr pt0)))))(cond((equal isinpt "LD") (setq pt0 (list (car pt) (+ (cadr pt) 59))))((equal isinpt "RT") (setq pt0 (list (car pt0) (- (cadr pt0) hdisy))))((equal isinpt "RD") (setq pt0 (list (- (car pt) 22) (+ (cadr pt) 59))))(T (setq pt0 (list (car pt0) (- (cadr pt0) hdisy))))))(if isdir(setq pt0 (list (+ (car pt0) hdisx) (cadr pt0)))(setq pt0 (list (car pt0) (- (cadr pt0) hdisy))))));;(SETQ pt0 (GETPOINT))(progn(if isdir(setq hdisx 29.5 hdisy 11 disc1x 6.75 disc1y -5.5 dissx 5.5 dissy 0 disex 5 disey 0 disc2x 5.5 disc2y 0pt0 (if (= n 5) (list (- (car pt0) hdisx hdisx) (- (cadr pt0) hdisy)) pt0))(setq hdisx 11 hdisy 29.5 disc1x 5.5 disc1y -6.75 dissx 0 dissy -5.5 disex 0 disey -5 disc2x 0 disc2y -5.5pt0 (if (= n 5) (list (- (car pt0) hdisx hdisx) (- (cadr pt0) hdisy)) pt0)))(drarec (list pt0 (list (+ (car pt0) hdisx) (cadr pt0)) (list (+ (car pt0) hdisx) (- (cadr pt0) hdisy)) (list (car pt0) (- (cadr pt0) hdisy))))(if (setq wedlst (nth (- n 3) weldlst))(progn(setqcenter1 (list (+ (car pt0) disc1x) (+ (cadr pt0) disc1y))pts (list (+ (car center1) dissx) (+ (cadr center1) dissy))pte (list (+ (car pts) disex) (+ (cadr pts) disey))center2 (list (+ (car pte) disc2x) (+ (cadr pte) disc2y)))(entmake (list '(0 . "circle") (cons 10 center1) '(40 . 4.5) '(8 . "0") '(62 . 1)))(entmake (list '(0 . "MTEXT") '(100 . "AcDbEntity") '(100 . "AcDbMText") (cons 1 (car wedlst)) '(7 . "宋 宽0.7 高3") (cons 10 center1) '(40 . 4.5) '(8 . "0") '(40 . 4.0) '(41 . 12.0) '(71 . 5) '(72 . 5)))(if (> (length wedlst) 1)(progn(entmake (list '(0 . "LINE") (cons 10 pts) (cons 11 pte) '(62 . 1)))(entmake (list '(0 . "circle") (cons 10 center2) '(40 . 4.5) '(8 . "0") '(62 . 1)))(entmake (list '(0 . "MTEXT") '(100 . "AcDbEntity") '(100 . "AcDbMText") (cons 1 (last wedlst)) '(7 . "宋 宽0.7 高3") (cons 10 center2) '(40 . 4.5) '(8 . "0") '(40 . 4.0) '(41 . 12.0) '(71 . 5) '(72 . 5)))))))(setq pt0 (list (+ (car pt0) hdisx) (cadr pt0)))))(setq n (1+ n))));;说明:插入焊缝无损检测记录卡;;参数:abn:A、B焊缝个数;;参数:abwedtpy:A、B类检测类型;;参数:cdn:C、D焊缝个数;;参数:cdwedtpy:C、D类检测类型;;参数:rown:每列最大个数;;参数:discol:列间距;;参数:pt:记录卡插入点(x , y+50);;参数:pagstr:当前页码-正整型;;参数:tostr:共多少页-正整型;;参数:lcstr:管线代用编码-正整型;;参数:pnstr:产品编号;;参数:lnmstr:管线号;;参数:lnstr:管线名称(defun al-insertblock(abn abwedtpy cdn cdwedtpy rown discol pt pagstr tostr lcstr pnstr lnmstr lnstr / bf-list-exist blk col count exlst gettableitems i makewedtest mspace n page pts0 str tpt znum)(setqcount (+ (if abwedtpy abn 0) (if cdwedtpy cdn 0))page (cond((< 0 count 47) 1)((> count 46) (+ 2 (fix (/ (- count 46) 46.0))))(t 0)) ;;计算页数);; tpt (list (+ (car pts0) 7.5) (cadr pts0));;说明:获取检索符号表所有子项名;;参数:table:索符号表名;;返回:子项名表(defun gettableitems(table / a b)(while (setq a (tblnext table (null a)))(if (not (or (wcmatch (cdr (assoc 2 a)) "`**,*|*") (and (= "layer" (strcase table t)) (= 4 (logand 4 (cdr (assoc 70 a)))))))(setq b (cons (cdr (assoc 2 a)) b))))(acad_strlsort b));;;name:BF-list-exist;;;desc:判断item是否在列表内，;;;arg:lst:列表，任意嵌套表;;;arg:item:被检查的元素;;;return:存在t，反之nil;;;example:(BF-list-exist '(1 2 3 4) 3)(defun BF-list-exist (lst item)(apply'or(cons(vl-position item lst)(mapcar '(lambda (x) (BF-list-exist x item))(vl-remove-if 'atom lst)))));;说明:创建焊缝检测文字;;参数:wedtype:焊缝检测类型;;参数:tpt:起始插入点(defun makewedtest(wedtype tpt cnum)(if wedtype(progn(entmake (list '(0 . "TEXT") (cons 1 wedtype) '(7 . "宋体") (cons 10 tpt) (cons 11 tpt) '(40 . 3.0) (cons 62 cnum) '(71 . 0) '(72 . 1) '(73 . 2)))(entmake (list '(0 . "TEXT") (cons 1 "固口") '(7 . "宋体") (cons 10 (list (+ (car tpt) 24) (cadr tpt))) (cons 11 (list (+ (car tpt) 24) (cadr tpt))) '(40 . 3.0) (cons 62 cnum) '(71 . 0) '(72 . 1) '(73 . 2)))(entmake (list '(0 . "TEXT") (cons 1 "转口") '(7 . "宋体") (cons 10 (list (+ (car tpt) 34) (cadr tpt))) (cons 11 (list (+ (car tpt) 34) (cadr tpt))) '(40 . 3.0) (cons 62 cnum) '(71 . 0) '(72 . 1) '(73 . 2))))))(if (> page 0)(if (and (BF-list-exist (gettableitems "block") "RecordCard") (BF-list-exist (gettableitems "block") "RecordCardSub"))(progn(setq n 0 str "")(while (<= (setq n (1+ n)) page)(if (and pt (set (read (strcat "pts" (rtos n))) (list (+ (car pt) (* (1- n) 260)) (- (cadr pt) 50))));;;(getpoint (strcat "\n请拾取【第" (rtos n) "页】无损检测记录中第一行无损检测方法的左上角点："))(progn(setq mspace (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))(setq blk (vla-InsertBlock mspace (vlax-3D-point (eval (read (strcat "pts" (rtos n))))) "RecordCard" 1 1 1 0))(setq exlst (vlax-safearray->list (vlax-variant-value (vla-Explode blk))))(vla-Delete blk)(if (and (equal (vla-get-ObjectName (car exlst)) "AcDbBlockReference") (equal (vla-get-Name (car exlst) ) "RecordCardSub"))(setq blk (car exlst))(setq blk (cadr exlst)))(setq x (nth 2 (vlax-SafeArray->list (vlax-Variant-Value (vla-GetAttributes blk)))))(foreach x (vlax-SafeArray->list (vlax-Variant-Value (vla-GetAttributes blk)));属性集合(cond;;("TOTAL" "PAGE" "LINECODE" "LINENAME" "LINENO." "PRONO.")((equal (strcase (vla-Get-TagString x)) "PAGE") (vla-put-TextString x (if (= nil pagstr) "" (strcat (rtos pagstr) "-" (rtos n)))));;第几页((equal (strcase (vla-Get-TagString x)) "TOTAL") (vla-put-TextString x (if (= nil tostr) "" (rtos tostr))));;共几页((equal (strcase (vla-Get-TagString x)) "LINECODE") (vla-put-TextString x (if (= nil lcstr) "" (rtos lcstr))));;管线代用编码((equal (strcase (vla-Get-TagString x)) "PRONO.") (vla-put-TextString x (if (= nil pnstr) "" pnstr)));;产品编号((equal (strcase (vla-Get-TagString x)) "LINENO.") (vla-put-TextString x (if (= nil lnmstr) "" lnmstr)));;管线号((equal (strcase (vla-Get-TagString x)) "LINENAME") (vla-put-TextString x (if (= nil lnstr) "" lnstr)));;管线名称))(setqpts0 (list (+ (car (eval (read (strcat "pts" (rtos n))))) 41) (- (cadr (eval (read (strcat "pts" (rtos n))))) 109))i 0 znum (* rown 2));;(makewedtxt abnum "100%RT" cdnum "100%PT" 26 97.5 23 99.5)(while (and (<= (setq i (1+ i)) (- count 46 (* (- n 2) znum))) (<= i znum))(if (> (fix (/ i (1+ rown))) 0) (setq col 1) (setq col 0))(setq tpt (list (+ (car pts0) 7.5 (* col discol)) (+ (- (cadr pts0) (+ (* (- i 1) 7) 3.5)) (* col rown 7))))(if (<= (+ i 46 (* (- n 2) 46)) abn)(makewedtest abwedtpy tpt 40)(makewedtest cdwedtpy tpt 4))))))(setq n 0)(while (<= (setq n (1+ n)) page) (set (read (strcat "pts" (rtos n))) nil)))))(prin1));;说明:清除多行文字格式;;参数:str:需要清除格式的字符串;;返回:清除格式后的字符串(defun clformat(str / regex);;自制(setq regex (vlax-create-object "Vbscript.RegExp")) ;引用正则表达式控件(if regex(progn(vlax-put-property regex "IgnoreCase" 0) ;不忽略大小写(vlax-put-property regex "Global" 1) ;匹配方式，全文字匹配(foreach x(list(list "\\\\\\\\" (chr 1));替换\\字符(list "\\\\{" (chr 2));替换\{字符(list "\\\\}" (chr 1));替换\}字符(list "\\\\pi(.[^;]*);" "");删除段落缩进格式(list "\\\\pt(.[^;]*);" "");删除制表符格式(list "\\\\S(.[^;]*)(\\^|#|\\\\)(.[^;]*);" "");删除堆迭格式(list "(\\\\F|\\\\f|\\\\C|\\\\H|\\\\\T|\\\\Q|\\\\W|\\\\A)(.[^;]*);" "");删除字体、颜色、字高、字距、倾斜、字宽、对齐格式(list "(\\\\L|\\\\O|\\\\l|\\\\o)" "");删除下划线、删除线格式(list "\\\\~" "");删除不间断空格格式(list "\\\\P" "\r\n");删除换行符格式(list "({|})" "");删除{}(list "\\\\pql;" "");删除\pql;(list "\\\\pqc;" "");删除\pqc;(list "\\\\pqr;" "");删除\pqr;(list "\\\\pxqc;" "");删除\pxqc;(list "\\x01" "\\");替换回\\,\{,\}字符(list "\\x02" "{");替换回\\,\{,\}字符(list "\\x03" "}");替换回\\,\{,\}字符)(vlax-put-property regex "Pattern" (car x))(setq str (vlax-invoke-method regex "Replace" str (cadr x))))))str);;说明:焊缝排序;;参数:weldss:焊缝选择集;;返回:排序后的表(defun weldsort(weldss / bf-enamep bf-pickset->list getentstr);;;name:BF-enamep;;;desc:判断是否图元?;;;arg:arg:图元名;;;return:图元名为t，其他为nil;;;example:(BF-enamep obj)(defun BF-enamep (arg) (equal (type arg) 'ename));;;name:BF-pickset->list;;;desc:选择集->图元列表;;;arg:SS:选择集;;;return:图元列表;;;example:(BF-pickset->list (ssget))(defun BF-pickset->list (ssf)(vl-remove-if-not 'BF-enamep (mapcar 'cadr (ssnamex ssf))))(defun getentstr(entlst / strlst wdstr)(setq strlst nil)(if entlst(foreach x (BF-pickset->list entlst) (if (not (vl-position (setq wdstr (clformat (cdr (assoc 1 (entget x))))) strlst)) (setq strlst (cons wdstr strlst)))))(reverse strlst))(if weldss (vl-sort (getentstr weldss) (function (lambda(x y) (< (atoi (substr x 2)) (atoi (substr y 2)))))))))(if (setq ss (ssget '((0 . "*TEXT") (1 . "A*,B*,C*,D*") (7 . "宋 宽0.7 高3,宋 宽0.75 高3"))))(progn(setqalst (weldsort (ssgetpy ss "A*"))blst (weldsort (ssgetpy ss "B*"))clst (weldsort (ssgetpy ss "C*"))dlst (weldsort (ssgetpy ss "D*"))abnum (+(if (> (length alst) 1)(+ (- (atoi (substr (last alst) 2)) (atoi (substr (car alst) 2))) 1)(length alst))(if (> (length blst) 1)(+ (- (atoi (substr (last blst) 2)) (atoi (substr (car blst) 2))) 1)(length blst)))cdnum (+(if (> (length clst) 1)(+ (- (atoi (substr (last clst) 2)) (atoi (substr (car clst) 2))) 1)(length clst))(if (> (length dlst) 1)(+ (- (atoi (substr (last dlst) 2)) (atoi (substr (car dlst) 2))) 1)(length dlst)))isaorb nildir "横向"diris Tinpt "右上"inptis "RT")(initget "Q q A a W w S s E e D d")(setq putpt (getpoint (strcat "\n请选择[方向变换(Q)/修改配置(A)/左上插入点(W)/左下插入点(S)/右上插入点(E)/右下插入点(D)]当前【" dir "-" inpt "】：")))(while (= 'str (type putpt))(setq putpt (strcase putpt))(cond((equal putpt "Q") (if diris (setq dir "竖向" diris nil) (setq dir "横向" diris T)))((equal putpt "A") (config))((equal putpt "W") (setq inpt "左上" inptis "LT"))((equal putpt "S") (setq inpt "左下" inptis "LD"))((equal putpt "E") (setq inpt "右上" inptis "RT"))((equal putpt "D") (setq inpt "右下" inptis "RD")))(initget "Q q A a W w S s E e D d")(setq putpt (getpoint (strcat "\n请选择[方向变换(Q)/修改配置(A)/左上插入点(W)/左下插入点(S)/右上插入点(E)/右下插入点(D)]当前【" dir "-" inpt "】："))))(if (= 'list (type putpt))(wedSum (list alst blst clst dlst) putpt diris inptis (rtos (setq LineCode (getint "\n请输入管线代用编码：")))))(if (setq pt (getpoint "\n请拾取记录卡距离左上角上方距离50的点："))(progn(if (setq swedpath (findfile "swedconfig.txt"))(progn(mapcar (function (lambda(x y) (set (read x) y))) (list "abwedtpy" "cdwedtpy" "tnum") (read (read-line (setq swedfile (open swedpath "r")))))(close swedfile);;abwedtpy cdn cdwedtpy rown discol pt pagstr tostr(al-insertblock abnum abwedtpy cdnum cdwedtpy 23 99.5 pt (getint "\n请输入当前页号：") tnum LineCode "" (obtstr "\n请拾取原图【管线号】：") (obtstr "\n请拾取原图【管线名称】："));(setq; abn abnum; abwedtpy abwedtpy; cdn cdnum; cdwedtpy cdwedtpy; rown 23; discol 99.5; pt pt; pagstr (getint "\n请输入当前页号："); tostr tnum; lcstr LineCode; pnstr ""; lnmstr (getstring "\n请输入管线号："); lnstr (getstring "\n请输入管线名称：");)))))))(princ (strcat "\nA类焊缝有：" (if (> (length alst) 1) (rtos (+ (- (atoi (substr (last alst) 2)) (atoi (substr (car alst) 2))) 1)) (rtos (length alst))) "个；B类焊缝有：" (if (> (length blst) 1) (rtos (+ (- (atoi (substr (last blst) 2)) (atoi (substr (car blst) 2))) 1)) (rtos (length blst))) "个；\nC类焊缝有：" (if (> (length clst) 1) (rtos (+ (- (atoi (substr (last clst) 2)) (atoi (substr (car clst) 2))) 1)) (rtos (length clst))) "个；D类焊缝有：" (if (> (length dlst) 1) (rtos (+ (- (atoi (substr (last dlst) 2)) (atoi (substr (car dlst) 2))) 1)) (rtos (length dlst))) "个！\n共计：" (rtos (+ abnum cdnum)) "个！")))(progn(alert "\n未找到配置文件，请依次输入以下参数进行配置！！！")(config)))(prin1))
若有收获，就点个赞吧
0 人点赞
