求助---------宗地图批量另存(已解决)请看22楼

dalin1985

要求：1.图名为宗地号
          2.混合总宗为图名加权利人


该贴已经同步到 dalin1985的微博

dalin1985

461045462 发表于 2012-8-19 15:58
dalin1985 您好:
轻轻地请问一句，您的成果能否分享
谢谢！

dalin1985

谁知道在那里加悬赏？

Andyhon

2. 
   
3. 
   
4. ;;; [url=http://www.afralisp.net/archive/lisp/dclatt2.htm]http://www.afralisp.net/archive/lisp/dclatt2.htm[/url]
   
5. 
   
6. 
   
7. ;;; (defun getatt (enam)
   
8. (defun getatt (enam / taglist txtlist)
   
9.    ;retrieve the attributes
   
10.    (setq thelist (vlax-safearray->list
    
11.                  (variant-value
    
12.                         (vla-getattributes enam))))
    
13.          ;process each attribute
    
14.          (foreach n thelist
    
15.            ;get the tag attribute data
    
16.            (setq taglist (cons (vla-get-tagString n) taglist)
    
17.            ;get the text attribute data
    
18.                     txtlist (cons (vla-get-textString n) txtlist)
    
19.                  ;how many attributes?
    
20.                  lg (length taglist)
    
21.            );setq
    
22.          );foreach
    
23.          ;reverse the lists
    
24.          (setq taglist (reverse taglist)
    
25.                txtlist (reverse txtlist))
    
26. )
    
27. ;;; 图形必需可见
    
28. (defun W-dwg (blk / strs)
    
29.   (setq pt   (cdr (assoc 10 (entget blk)))
    
30.         p1   (mapcar '- pt '(5 12))
    
31.         p3   (mapcar '+ pt '(93 126))
    
32.         ss   (ssget "C" p1 p3)
    
33.         txts (getAtt (vlax-ename->vla-object blk))
    
34.   )
    
35.   (foreach txt txts
    
36.     (if (wcmatch txt "#########*")
    
37.       (setq strs (cons txt strs))
    
38.     )
    
39.   )
    
40.   (vl-cmdf "wblock" (car strs) "" pt ss "")
    
41. )
    
42. ;;; for test only
    
43. (vl-load-com)
    
44. (defun c:test ()
    
45.    (mapcar 'W-dwg (sslist (ssget '((2 . "tk_a4")))))
    
46. )
    
47. 
    

<br /> <br /> ;;; [url=http://www.afralisp.net/archive/lisp/dclatt2.htm]http://www.afralisp.net/archive/lisp/dclatt2.htm[/url]<br /> <br /> <br /> ;;; (defun getatt (enam)<br /> (defun getatt (enam / taglist txtlist)<br />    ;retrieve the attributes<br />    (setq thelist (vlax-safearray->list<br />                  (variant-value<br />                         (vla-getattributes enam))))<br />          ;process each attribute<br />          (foreach n thelist<br />            ;get the tag attribute data<br />            (setq taglist (cons (vla-get-tagString n) taglist)<br />            ;get the text attribute data<br />                     txtlist (cons (vla-get-textString n) txtlist)<br />                  ;how many attributes?<br />                  lg (length taglist)<br />            );setq<br />          );foreach<br />          ;reverse the lists<br />          (setq taglist (reverse taglist)<br />                txtlist (reverse txtlist))<br /> )<br /> ;;; 图形必需可见<br /> (defun W-dwg (blk / strs)<br />   (setq pt   (cdr (assoc 10 (entget blk)))<br />         p1   (mapcar '- pt '(5 12))<br />         p3   (mapcar '+ pt '(93 126))<br />         ss   (ssget "C" p1 p3)<br />         txts (getAtt (vlax-ename->vla-object blk))<br />   )<br />   (foreach txt txts<br />     (if (wcmatch txt "#########*")<br />       (setq strs (cons txt strs))<br />     )<br />   )<br />   (vl-cmdf "wblock" (car strs) "" pt ss "")<br /> )<br /> ;;; for test only<br /> (vl-load-com)<br /> (defun c:test ()<br />    (mapcar 'W-dwg (sslist (ssget '((2 . "tk_a4")))))<br /> )<br /> <br />

;;; sslist 函数 站内有

soly2006

又一苦逼测量同行.顶

dalin1985

Andyhon 发表于 2012-8-15 13:55
;;; sslist 函数 站内有

出错了
<选择集: 52>

Andyhon

另图吗?

原测试图 ===>
Command: test
Select objects: All 605 found
599 were filtered out.
Select objects:
wblock Enter name of output file: 5106030050060002006
Enter name of existing block or
[= (block=output file)/* (whole drawing)] <define new drawing>: Specify
insertion base point:
Select objects:   124 found
Select objects:
Command: wblock Enter name of output file: 5106030050060002006
Enter name of existing block or
[= (block=output file)/* (whole drawing)] <define new drawing>: Specify
insertion base point:
Select objects:   124 found
Select objects:
Command: wblock Enter name of output file: 5106030050060002005
Enter name of existing block or
[= (block=output file)/* (whole drawing)] <define new drawing>: Specify
insertion base point:
Select objects:   107 found
Select objects:
Command: wblock Enter name of output file: 5106030050060002004
Enter name of existing block or
[= (block=output file)/* (whole drawing)] <define new drawing>: Specify
insertion base point:
Select objects:   89 found
Select objects:
Command: wblock Enter name of output file: 5106030050060002003
Enter name of existing block or
[= (block=output file)/* (whole drawing)] <define new drawing>: Specify
insertion base point:
Select objects:   116 found
Select objects:
Command: wblock Enter name of output file: 5106030050060002002
Enter name of existing block or
[= (block=output file)/* (whole drawing)] <define new drawing>: Specify
insertion base point:
Select objects:   45 found
Select objects:
Command: (T T T T T T)

dalin1985

Andyhon 发表于 2012-8-15 16:45
另图吗?

原测试图 ===>

是原图，错误好像是不能判断单宗和混宗。

Andyhon

重新调试 单宗和混宗 的情况
===========================

在我的机子上卡壳了
----------------------
混合总宗为图名加权利人

图名 ==> "5106030050060002006" ==> ok

权利人 ==>
系统的回应值 ==> "\\M+5CAE6\\M+5F6C7\\M+5CBC9"

在cad内写入为字串时 OK
作为文件名时则会被打回票而过不了关 ...

不知是否有插件可套用!?

所以转了个弯,采用过渡后缀方案,聊胜于无...

2. 
   
3. 
   
4. ;;; http://www.afralisp.net/archive/lisp/dclatt2.htm
   
5. 
   
6. ;;; (defun getatt (enam)
   
7. (defun getatt (enam / taglist txtlist)
   
8. 
   
9.    ;retrieve the attributes
   
10.    (setq thelist (vlax-safearray->list
    
11.                     (variant-value
    
12.                         (vla-getattributes enam))))
    
13. 
    
14.          ;process each attribute
    
15.          (foreach n thelist
    
16. 
    
17.            ;get the tag attribute data
    
18.            (setq taglist (cons (vla-get-tagString n) taglist)
    
19. 
    
20.            ;get the text attribute data
    
21.                  txtlist (cons (vla-get-textString n) txtlist)
    
22. 
    
23.                  ;how many attributes?
    
24.                  lg (length taglist)
    
25. 
    
26.            );setq
    
27.          );foreach
    
28. 
    
29.          ;reverse the lists
    
30.          (setq taglist (reverse taglist)
    
31.                txtlist (reverse txtlist))
    
32. 
    
33. )
    
34. 
    
35. 
    
36. ;;; 宗地图批量另存
    
37. 
    
38. ;;; 手动添加后缀
    
39. (defun W-dwg_Aux (DwgName)
    
40.   (cond
    
41.    ((findfile (strcat DwgName ".Dwg"))
    
42.     (prompt "\n已有同名文件 ==> ") (princ Dwgname)
    
43.     (setq -str (getstring "\n添加临时后缀: "))
    
44.     (W-dwg_Aux (strCat DwgName -str))
    
45.    )
    
46.    (T (vl-cmdf "wblock" DwgName "" pt ss ""))
    
47.   )
    
48. )
    
49. 
    
50. ;;; 自动添加 "A" 后缀
    
51. (defun W-dwg_Aux (DwgName)
    
52.   (cond
    
53.    ((findfile (strcat DwgName ".Dwg"))
    
54.     (W-dwg_Aux (strCat DwgName "A"))
    
55.    )
    
56.    (T (vl-cmdf "wblock" DwgName "" pt ss ""))
    
57.   )
    
58. )
    
59. 
    
60. ;;; 图形必需可见
    
61. (defun W-dwg (blk / strs)
    
62.   (setq pt   (cdr (assoc 10 (entget blk)))
    
63.         p1   (mapcar '- pt '(5 12))
    
64.         p3   (mapcar '+ pt '(93 126))
    
65.         ss   (ssget "C" p1 p3)
    
66.         txts (getAtt (vlax-ename->vla-object blk))
    
67.   )
    
68. 
    
69.   (foreach txt txts
    
70.     (if (wcmatch txt "#########*")
    
71.       (setq strs (cons txt strs))
    
72.     )
    
73.   )
    
74. 
    
75.   (W-dwg_Aux (car strs))
    
76. )
    
77. 
    
78. ;;; for test only
    
79. (vl-load-com)
    
80. (defun c:test ()
    
81.    (mapcar 'W-dwg (sslist (ssget '((2 . "tk_a4")))))
    
82. )
    
83. 
    

<br /> <br /> ;;; http://www.afralisp.net/archive/lisp/dclatt2.htm<br /> <br /> ;;; (defun getatt (enam)<br /> (defun getatt (enam / taglist txtlist)<br /> <br />    ;retrieve the attributes<br />    (setq thelist (vlax-safearray->list<br />                     (variant-value<br />                         (vla-getattributes enam))))<br /> <br />          ;process each attribute<br />          (foreach n thelist<br /> <br />            ;get the tag attribute data<br />            (setq taglist (cons (vla-get-tagString n) taglist)<br /> <br />            ;get the text attribute data<br />                  txtlist (cons (vla-get-textString n) txtlist)<br /> <br />                  ;how many attributes?<br />                  lg (length taglist)<br /> <br />            );setq<br />          );foreach<br /> <br />          ;reverse the lists<br />          (setq taglist (reverse taglist)<br />                txtlist (reverse txtlist))<br /> <br /> )<br /> <br /> <br /> ;;; 宗地图批量另存<br /> <br /> ;;; 手动添加后缀<br /> (defun W-dwg_Aux (DwgName)<br />   (cond<br />    ((findfile (strcat DwgName ".Dwg"))<br />     (prompt "\n已有同名文件 ==> ") (princ Dwgname)<br />     (setq -str (getstring "\n添加临时后缀: "))<br />     (W-dwg_Aux (strCat DwgName -str))<br />    )<br />    (T (vl-cmdf "wblock" DwgName "" pt ss ""))<br />   )<br /> )<br /> <br /> ;;; 自动添加 "A" 后缀<br /> (defun W-dwg_Aux (DwgName)<br />   (cond<br />    ((findfile (strcat DwgName ".Dwg"))<br />     (W-dwg_Aux (strCat DwgName "A"))<br />    )<br />    (T (vl-cmdf "wblock" DwgName "" pt ss ""))<br />   )<br /> )<br /> <br /> ;;; 图形必需可见<br /> (defun W-dwg (blk / strs)<br />   (setq pt   (cdr (assoc 10 (entget blk)))<br />         p1   (mapcar '- pt '(5 12))<br />         p3   (mapcar '+ pt '(93 126))<br />         ss   (ssget "C" p1 p3)<br />         txts (getAtt (vlax-ename->vla-object blk))<br />   )<br /> <br />   (foreach txt txts<br />     (if (wcmatch txt "#########*")<br />       (setq strs (cons txt strs))<br />     )<br />   )<br /> <br />   (W-dwg_Aux (car strs))<br /> )<br /> <br /> ;;; for test only<br /> (vl-load-com)<br /> (defun c:test ()<br />    (mapcar 'W-dwg (sslist (ssget '((2 . "tk_a4")))))<br /> )<br /> <br />

dalin1985

Andyhon 发表于 2012-8-16 09:07
重新调试 单宗和混宗 的情况
===========================

程序完美运行了，就是不知道图存哪里了

Andyhon

;;; 自动添加 "A" 后缀
(defun W-dwg_Aux (DwgName)
  (cond
   ((findfile (strcat Path DwgName ".Dwg"))
    (W-dwg_Aux (strCat DwgName "A"))
   )
   (T (vl-cmdf "wblock" (strcat Path DwgName) "" pt ss ""))
  )
)
...
(defun c:test ()
   (setq Path (getVar "DwgPrefix"))
   (mapcar 'W-dwg (sslist (ssget '((2 . "tk_a4")))))
)