看人家写关于PKPM层高表程序 求大神给看看 为什么不能运行啊 ！！！
;;cg 生成层高表;;函数 (del_space_k1 str) 多个连续空格变成1个
;;===============================================
;;cg 生成层高表
(defun c:CG ()
;;(标准层号 颜色)
(setq layer_color
'((1 10)(2 2) (3 3) (4 4)
(5 152) (6 6) (7 81) (8 40)
(9 14)(10 10)(11 11)(12 14)
(13 14)
)
)
;;设置顶部3层的名称
;;(setq up_3_fl (mapcar 'list (list "屋面" "机房" "天面")))
;;(setq up_3_fl nil)
;;|;对话框，外部文件
;;---------------------- (read_txt_cg)
(defun read_txt_cg ()
(setq fn_cg (findfile "层高表_外部文件.txt") )
(setq lst-file_0 '("-6.2" "1" "d:\\2012\\" "屋面 机房 天面"))
(setq lst-file_1 (file->lst fn_cg))
;;返回： lst-file
(if (null lst-file_1)
(setq lst-file lst-file_0)
(setq
lst-file
(mapcar
'(lambda (n)
(setq lo (vl-string-search ":" n))
(substr n (+ 2 lo))
)
lst-file_1
)
)
)
(if (or (member nil lst-file) (< (length lst-file) 4))
(setq lst-file lst-file_0)
)
;;---------------
(setq csbg_CG (atof (car lst-file)))
(SETQ dxs_cg (atoi (cadr lst-file)))
(IF (< dxs_cg 0)
(SETQ dxs_cg (atoi (cadr lst-file_0)))
)
(SETQ path_sel (nth 2 lst-file))
(SETQ up_3_fl (mapcar 'list (fsxm-split (nth 3 lst-file) " ")))
)
;;---------------------- (write_txt_cg)
(defun write_txt_cg ()
(setq up_3_write (fsxm-join (mapcar 'car up_3_fl) " "))
;;(setq csbg_CG0 -6.2) ;_
(setq lst-write0
(list (rtos csbg_CG0 2 3)
(itoa dxs_cg)
path_sel
up_3_write
)
)
(setq lst-pre '("底板标高" "地下室层数" "初始路径" "顶部三层"))
(setq lst-write (mapcar '(lambda (x y)
(strcat x ":" y)
)
lst-pre
lst-write0
)
)
(setq f (open fn_cg "w"));_ fn_cg 接力read_txt_cg
(mapcar '(lambda (x) (write-line x f)) lst-write)
(close f)
)
(command "undo" "be")
(mkla-c "Defpoints" 190)
(mkla-c "层高表" 7)
;;==============================
;;设置全局变量
;;csbg_CG0 dxs_cgpath_sel
;;--------------
;;以下，2选1
;;;(setq csbg_CG csbg_CG0)
;;;(if (null csbg_CG)
;;; (setq csbg_CG -6.2)
;;;);首层底标高
(read_txt_cg)
;;(setq csbg_CG (atof 变量))
;;--------------
;;(if (null dxs_cg) (setq dxs_cg 1));地下室层数
;;==============================
;;主程序开始---------------------------------------------------
(PXT_ER)
(setq xtblm '("osmode" "clayer" "cecolor" "orthomode" "plinewid")
xtblz (mapcar 'getvar xtblm)
)
(setvar "osmode" 0)
;;设置路径---------------------------
;;参考字宽.lsp 注意CFGPATH文件无后缀
;;设置PKPM可能的安装路径，最常用的放在前面
;;(setq fn-lst (list "C:\\PKPM\\CFG\\" "CFGPATH"))
(setq fn-lst (list
'("C:\\PKPM\\CFG\\" "CFGPATH")
'("d:\\PKPM\\CFG\\" "CFGPATH")
'("c:\\PKPM_2011\\CFG\\" "CFGPATH")
'("D:\\PKPM_2011\\CFG\\" "CFGPATH")
)
)
(setq i 0)
(setq fn (strcat (car (nth i fn-lst)) (cadr (nth i fn-lst))))
(setq yn (findfile fn))
(while (and (not yn) (nth (1+ i) fn-lst))
;; findfile未找到，同时下一个元素存在(nth (1+ i)
(setq i (1+ i))
(setq fn (strcat (car (nth i fn-lst)) (cadr (nth i fn-lst))))
(setq yn (findfile fn))
)
(if (null yn)
;;如果PKPM安装路径不在fn-lst中
(progn
(setq path "d:\\")
(setq fn (getfiled "选择wmass文件" (strcat path "wmass") "OUT" 8)
path (vl-string-right-trim "WMASS.OUT" fn))
)
(progn
(setq txt-lst (file->lst-jss fn)
pathlst (cdr (member "WORK" txt-lst))
path (strcat (car pathlst) "\\")
) ;_用PKPM的目录
(setq fn (STRCAT PATH "WMASS.OUT"))
;;如果未找到WMASS.OUT
(IF (NOT (FINDFILE FN))
(setq
fn (getfiled "选择wmass文件" (strcat path "wmass") "OUT" 8)
path (vl-string-right-trim "WMASS.OUT" fn)
)
)
)
)
;; 返回 path fn
;;----------------------------
;;(setq fn "D:\\2012\\中山坦洲\\PM\\PM-1栋\\WMASS.OUT")
;;-------------------------- (get_lst0_cg)
;;返回：lst0
(defun get_lst0_cg (fn)
(setq re nil
i1
)
(setq f (open fn "r"))
(while (setq line (read-line f))
(if (wcmatch line "*#(#)*,*##(#)*,*#( ##)*,*##( ##)*")
(progn
(setq re (cons line re))
)
)
(setq i (1+ i))
)
(close f)
(setq re (reverse re))
;;(楼层号 标准层号 层高)
(setq
lst-fu (mapcar '(lambda (n)
(setq lst (string_to_numbers n))
(list (car lst) (cadr lst) (last (!last lst)))
)
re
)
)
;;;(SETQ A
;;; " 1(1) 1 111(30/ 360) 31(40/ 360) 75(40/ 360) 1.000 1.000"
;;;)
;;;(SETQ A1 (vl-string-trim " " A))
(setq
lst-fu
(mapcar
'(lambda (n)
(del_space_k1 (vl-string-trim " " n))
)
re
)
)
(setq
lst0
(mapcar
'(lambda (n)
(setq ab (string_to_numbers n))
(list (nth 0 ab) ;层号
(nth 1 ab) ;标准层号
(nth 4 ab) ;梁砼
(nth 7 ab) ;柱砼
(nth 10 ab) ;墙砼
(rtos (atof (nth 12 ab)) 2 2) ;层高
)
)
lst-fu
)
)
)
;;返回：lst0
;;--------------------------
(get_lst0_cg fn)
(princ (strcat"\n地下室层数_" (itoa dxs_cg)))
(princ (strcat"当前路径_" path))
(setq pt nil)
;;;(while (not pt)
;;; (initget "F P")
;;; (setq pt (getpoint "\n文字插入点:"))
;;;)
(initget "F P")
(setq pt (getpoint "\n文字插入点:"))
;;;(if (null path_sel)
;;; (setq path_sel "d:\\2012\\")
;;;)
(while (member pt '("F" "P" nil))
(COND
((= pt "P")
(setq fn
(getfiled "选择wmass文件" (strcat path_sel "wmass") "OUT" 8)
path (vl-string-right-trim "WMASS.OUT" fn)
)
(if fn
(progn
(setq path_sel (substr fn 1 (- (strlen fn) 9)))
(get_lst0_cg fn))
)
)
((= pt "F")
(setq
dxs2
(getint (strcat "\n请输入地下室层数<" (itoa dxs_cg) ">"))
)
(while (and dxs2 (< dxs2 0))
(setq
dxs2 (getint (strcat "\n非法输入，请输入地下室层数<"
(itoa dxs_cg)
">"
)
)
)
)
(if dxs2
(setq dxs_cg dxs2)
(setq dxs_cg dxs_cg)
)
)
)
(princ (strcat"\n地下室层数_" (itoa dxs_cg)))
(princ (strcat"当前路径_" path))
(initget "F P")
(setq pt (getpoint "\n文字插入点:"))
);_ while
(setq csbg2 (getreal (strcat "\n底层面标高<" (rtos csbg_CG 2 3) ">:")))
(setq csbg_CG (if csbg2
csbg2
csbg_CG
)
)
(setq csbg_CG3 (- csbg_CG (atof (last (car lst0)))))
(setq csbg_CG0 csbg_CG)
(setq
bglst2
(mapcar
'(lambda (n) (setq csbg_CG3 (+ csbg_CG3 (atof (last n)))))
lst0
)
)
(setq bglst (mapcar '(lambda (n) (list (rtos n 2 3))) bglst2))
(setq
bglst (mapcar '(lambda (n)
(if (equal n '("0.000"))
(setq n '("%%p0.000"))
n
)
)
bglst
)
)
;;-------------
;;加入建筑层号
(setq dxs dxs_cg
i_taolou 0
i_dxs 0
jzch_lst nil
)
(repeat (- (length lst0) dxs)
(setq jzch_lst (cons (setq i_taolou (1+ i_taolou)) jzch_lst))
)
(repeat dxs
(setq jzch_lst (append jzch_lst (list (setq i_dxs (1- i_dxs)))))
)
(setq jzch_lst (reverse jzch_lst)
jzch_lst (mapcar '(lambda (n) (list (itoa n))) jzch_lst)
)
;;----------------------------------------------
;当结构层数≥6时，替换顶三层为：屋面、机房、天面
(if (>= (length jzch_lst) 6)
(progn
(setq jzch_lst (reverse jzch_lst))
(repeat (length UP_3_FL) (setq jzch_lst (cdr jzch_lst)))
(setq jzch_lst (reverse jzch_lst))
(setq jzch_lst (append jzch_lst UP_3_FL))
)
)
;;----------------------------------------------
;;(setq lst1 (mapcar '(lambda (x y) (append x y)) lst0 bglst))
;;(setq lst2 (mapcar '(lambda (x y) (append x y)) lst1 jzch_lst))
;;注释以上两行，增加下行
(setq lst2 (mapcar '(lambda (x y z) (append x y z)) lst0 bglst jzch_lst))
;;加入建筑层号
;;-------------
(setq lst (mapcar '(lambda (n)
(setq iii -1)
(mapcar '(lambda (ii)
(setq iii (1+ III))
(cond
((member iii '(2 3 4))
(strcat "C" II)
)
((member iii '(0))
(strcat "PL" II)
)
((member iii '(1))
(strcat "标准层" II)
)
(t II)
)
)
n
)
)
lst2
)
)
(setq pt0 (polar pt (* 0.5 pi) 800))
;;lst= ("PL1" "标准层1" "C35" "C30" "C45" "1.50" "-4.700" "-1")
(SETQ WZLST (LIST "标准层" "结构层" "层号" "梁板面标高(m)"
"层高(m)" "柱砼" "墙砼" "梁板砼"
)
)
(setq i 0)
(setq zg 275 gap 450)
;;剪力墙，柱
(setq wall t column nil)
(setq wall t column t)
(foreach n lst
(setq p1 (polar pt0 _pi2 (* i 450)))
(setq p2 (polar p1 0 1100)
p3 (polar p2 0 1000)
p4 (polar p3 0 1000)
p5 (polar p4 0 1400)
p6 (polar p5 0 1200)
p7(polar p6 0 800)
)
(if (or (not wall) (not column))
(setq p7 p6)
)
(setq p8(polar p7 0 800)
p88 (polar p8 (* 1.5 pi) 250)
p77 (polar p7 (* 1.5 pi) (if (= i 0) 370 450));原先为450
p55 (polar p5 (* 1.5 pi) (if (= i 0) 370 450))
p66 (polar p6 (* 1.5 pi) (if (= i 0) 370 450))
)
(entmake (list '(0 . "LINE")
(cons 10 (polar p3 (* 1.5 pi) 100))
(cons 11 (polar p8 (* 1.5 pi) 100))
)
)
;;(setq ptlst nil)
;; 1层号2标准层号 3梁砼4柱砼 5墙砼6层高7标高 8建筑层号
;;("PL31" "标准层10""C30" "C30" "C30" "1.80" "87.500" "建筑层号")
(cond
((and wall (not column))
(setq p66 nil)
)
((and column (not wall))
(setq p77 nil)
)
)
(setq ptlst (list p2 p1p88 p66p77 p55p4p3 ))
;(setq ptlst (list p2 p1p88 nilp77 p55p4p3 ));仅剪力墙
;(setq ptlst (list p2 p1p88 p66nil p55p4p3 ));仅柱
;; 1层号 2标准层号 3建筑层号 4梁砼 5柱砼 6墙砼 7层高 8标高
(setq ptlst_head (list p1 p2 p3 (polar p4 pi 300) p5 p6 p7 p8))
;;写表头
(IF (= I 0)
(progn
(mapcar
'(lambda (x y)
(if (member x '("标准层" "结构层"))
(setvar "clayer" "Defpoints")
)
(maketext x y 0 zg 0.7 0 "L" "Tssd_rein")
(if (member x '("标准层" "结构层"))
(setvar "clayer" "层高表")
)
)
WZLST
(mapcar '(lambda (n%) (POLAR n% (* 1.5 pi) 600)) ptlst_head)
)
(entmake (list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 2)
(cons 43 50)
(cons 10 (polar p3 (* 1.5 pi) 700))
(cons 10 (polar (polar p8 0 550) (* 1.5 pi) 700))
)
)
(SETQ STR_BT "楼层结构标高、层高"
INT_BT (polar p5 (* 1.5 pi) 1000)
)
(maketext STR_BT INT_BT 0 400 0.85 0 "M" "Tssd_rein")
(setvar "clayer" "Defpoints")
(maketext path (polar p3 (* 1.5 pi)1600) 0 400 0.85 0 "L" "Tssd_rein")
)
)
(setq dis_Line (list 700 1400 1100))
(cond
((= I 0)
(setq p3_ (polar p3 (* 1.5 pi) 100))
(setq pa1 (polar p3_ 0 (car dis_Line))
pa2 (polar pa1 0 (cadr dis_Line))
pa3 (polar pa2 0 (caddr dis_Line))
)
)
((= I (1- (length lst)))
(setq p3_ (polar p3 (* 1.5 pi) 100))
(setq pb1 (polar p3_ 0 (car dis_Line))
pb2 (polar pb1 0 (cadr dis_Line))
pb3 (polar pb2 0 (caddr dis_Line))
)
)
)
;;(dim-lst ptlst)
(setq strlst n)
;;strlst= ("PL31" "标准层10" "C30" "C30" "C30" "1.80" "87.500" "30")
;; 2 1 88 66 77 5 4 3
(setq iii -1)
(mapcar '(lambda (x y)
(setq iii (1+ III))
(cond
((member iii '(0 1 2 3 4 7))
;;与"标准层10"对应
(setq color (substr (cadr strlst) 7))
(if (setq colst (assoc (atoi color) layer_color))
(setvar "cecolor" (itoa (cadr colst)))
)
)
(t (setvar "cecolor" "BYLAYER"))
)
(cond ((member iii '(0 1)) (setvar "clayer" "Defpoints"))
((and (= i 0) (member iii '(3 4 5)))
(setvar "clayer" "Defpoints")
)
)
(if y(maketext x y 0 zg 0.75 0 "L" "Tssd_rein"))
(cond ((member iii '(0 1)) (setvar "clayer" "层高表"))
((and (= i 0) (member iii '(3 4 5)))
(setvar "clayer" "层高表")
)
)
(setvar "cecolor" "BYLAYER")
)
strlst
ptlst
)
(setq i (1+ i))
);_ foreach n lst
(if (>= (length lst) 2)
(progn
(entmake (list '(0 . "LINE") (cons 10 pa1) (cons 11 pb1)))
(entmake (list '(0 . "LINE") (cons 10 pa2) (cons 11 pb2)))
(entmake (list '(0 . "LINE") (cons 10 pa3) (cons 11 pb3)))
)
)
(write_txt_cg)
(mapcar 'setvar xtblm xtblz)
(command "undo" "e")
(princ)
)
;;main
;;--------------------------------
;|
(SETQ str "1(1) 1 111(30/ 360) 31(40/ 360) 75(40/ 360) 1.000 1.000")
;;(del_space_k1 str) 多个连续空格变成1个
;;返回："1( 1) 1 111(30/ 360) 31(40/ 360) 75(40/ 360) 1.000 1.000"
|;
(defun del_space_k1 (str / Return_cg I_del_kg Full_Str Char_kg)
(setq Return_cg ""
I_del_kg 1
)
(setq Full_Str str)
(while (<= I_del_kg (strlen Full_Str))
(setq Char_kg (substr Full_Str I_del_kg 1))
(IF (= Char_kg " ")
(IF (/= (substr Full_Str (1- I_del_kg) 1) " ")
(setq Return_cg (strcat Return_cg Char_kg))
)
(setq Return_cg (strcat Return_cg Char_kg))
)
(setq I_del_kg (+ I_del_kg 1))
)
Return_cg
)
看了一下，缺少子程序，括号也不匹配 如何修改呢求指教啊
页:
[1]