高速读取属性块的数据，还有比这更快的吗？

dcl1214

1. (defun $get-b-vs-p1-p2$  (PT1   PT3   km-str   lst   /
   
2.        acadobj datavalue   doc   ents
   
3.        gpcode   p1   p2   ss
   
4.       )
   
5.   ;高速读取图纸属性块数据
   
6.   ;专门为dcjx写的提速函数，用于快速读取图纸中的属性块数据20210705
   
7.   (AND
   
8.     PT1
   
9.     PT3
   
10.     (vla-ZoomWindow
    
11.       (vlax-get-acad-object)
    
12.       (vlax-3d-point PT1)
    
13.       (vlax-3d-point PT3)
    
14.     )
    
15.   )
    
16.   (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
    
17.   (vl-Catch-All-Apply
    
18.     'vla-delete
    
19.     (LIST (vl-Catch-All-Apply
    
20.       'vla-item
    
21.       (list (vla-get-SelectionSets doc) "SSET")
    
22.     )
    
23.     )
    
24.   )
    
25.   (setq acadObj (vlax-get-acad-object))
    
26.   (setq doc (vla-get-ActiveDocument acadObj))
    
27.   (setq SS (vla-Add (vla-get-SelectionSets doc) "SSET"))
    
28.   (SETQ P1 (vl-Catch-All-Apply 'vlax-3d-point (list PT1)))
    
29.   (SETQ P2 (vl-Catch-All-Apply 'vlax-3d-point (list PT3)))
    
30.   (vl-catch-all-apply 'vla-Clear (list SS))
    
31.   (setq gpCode (vlax-make-safearray vlax-vbInteger '(0 . 0)))
    
32.   (vl-Catch-All-Apply
    
33.     'vlax-safearray-put-element
    
34.     (list gpCode 0 0)
    
35.   )
    
36.   (setq dataValue (vlax-make-safearray vlax-vbVariant '(0 . 0)))
    
37.   (vl-Catch-All-Apply
    
38.     'vlax-safearray-put-element
    
39.     (list dataValue 0 "INSERT")
    
40.   )
    
41.   (vl-Catch-All-Apply
    
42.     'vla-Select
    
43.     (list
    
44.       SS acSelectionSetCrossing  P1 P2 gpCode dataValue)
    
45.   )
    
46.   (if (vl-catch-all-error-p ss)
    
47.     (progn (vl-catch-all-apply 'vla-Clear (list SS))
    
48.      (setq ss nil)
    
49.     )
    
50.   )
    
51.   (SETQ vss NIL)
    
52.   (if ss
    
53.     (vlax-for obj ss
    
54.       (setq km nil)
    
55.       (setq arr nil)
    
56.       (setq tbl nil)
    
57.       (setq jb nil)
    
58.       (setq p nil)
    
59.       (setq vs nil)
    
60.       (setq km (vl-catch-all-apply
    
61.      'vla-get-effectivename
    
62.      (list obj)
    
63.          )
    
64.       )
    
65.       (AND (vl-catch-all-error-p KM)
    
66.      (setq KM (vl-catch-all-apply 'vla-get-name (list obj)))
    
67.       )
    
68.       (if
    
69.   (or (not km-str)
    
70.       (and km km-str (wcmatch km (strcat "[," km-str ",]")))
    
71.   )
    
72.    (AND
    
73.      (setq arr
    
74.       (vl-catch-all-apply
    
75.         'vlax-variant-value
    
76.         (list (vla-GetAttributes obj))
    
77.       )
    
78.      )
    
79.      (not (vl-catch-all-error-p arr))
    
80.      (setq tbl (vl-catch-all-apply
    
81.            'vlax-safearray->list
    
82.            (list arr)
    
83.          )
    
84.      )
    
85.      (not (vl-catch-all-error-p tbl))
    
86.      (setq jb (vla-get-handle obj))
    
87.      (setq p (vl-catch-all-apply
    
88.          'vlax-safearray->list
    
89.          (list (vlax-variant-value
    
90.            (vla-get-insertionpoint
    
91.              obj
    
92.            )
    
93.          )
    
94.          )
    
95.        )
    
96.      )
    
97.      (setq
    
98.        vs  (mapcar
    
99.       (function
    
100.         (lambda (x / v tag t-v)
     
101.           (setq v (vla-get-textstring x))
     
102.           (if (wcmatch v "`  *")
     
103.       (setq v (vl-string-left-trim "  " v))
     
104.           )      ;前面有tab空格  
     
105.           (if (wcmatch v "` *")
     
106.       (setq v (vl-string-left-trim " " v))
     
107.           )      ;前面有空格  
     
108.           (if (wcmatch v "*`  ")
     
109.       (setq v (vl-string-right-trim "  " v))
     
110.           )
     
111.           ;尾巴上有tab空格  
     
112.           (if (wcmatch v "*` ")
     
113.       (setq v (vl-string-right-trim " " v))
     
114.           )      ;后面有空格  
     
115.           (if (or (= v "") (= v " ") (= v "  "))
     
116.       nil
     
117.       (progn (setq tag (vla-get-tagstring x))
     
118.              (if (= tag "选项_001")
     
119.          (setq tag "选项")
     
120.              )
     
121.              (setq t-v (cons tag v))
     
122.       )
     
123.           )
     
124.           t-v
     
125.         )
     
126.       )
     
127.       tbl
     
128.     )
     
129.      )     
     
130.      (setq vs (vl-remove nil vs))
     
131.      (setq vs (cons (cons "句柄" jb) vs))
     
132.      (setq vs (cons (cons "Ha-Dl" jb) vs))
     
133.      (setq vs (cons (cons "插入点Y" (rtos (CADR P) 2 2)) vs))
     
134.      (setq vs (cons (cons "插入点X" (rtos (CAR P) 2 2)) vs))
     
135.      (setq vs (cons (cons "插入点" p) vs))
     
136.      (setq vs (cons (cons "块名" km) vs))
     
137.      (setq vs (vl-remove nil vs))
     
138.      (set 'vss (cons vs vss))
     
139.    )
     
140.       )
     
141.     )
     
142.   )
     
143.   (vl-catch-all-apply 'vla-Clear (list SS))
     
144.   vss
     
145. )

(defun $get-b-vs-p1-p2$  (PT1   PT3   km-str   lst   /<br />        acadobj datavalue   doc   ents<br />        gpcode   p1   p2   ss<br />       )<br />   ;高速读取图纸属性块数据<br />   ;专门为dcjx写的提速函数，用于快速读取图纸中的属性块数据20210705<br />   (AND<br />     PT1<br />     PT3<br />     (vla-ZoomWindow<br />       (vlax-get-acad-object)<br />       (vlax-3d-point PT1)<br />       (vlax-3d-point PT3)<br />     )<br />   )<br />   (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))<br />   (vl-Catch-All-Apply<br />     'vla-delete<br />     (LIST (vl-Catch-All-Apply<br />       'vla-item<br />       (list (vla-get-SelectionSets doc) "SSET")<br />     )<br />     )<br />   )<br />   (setq acadObj (vlax-get-acad-object))<br />   (setq doc (vla-get-ActiveDocument acadObj))<br />   (setq SS (vla-Add (vla-get-SelectionSets doc) "SSET"))<br />   (SETQ P1 (vl-Catch-All-Apply 'vlax-3d-point (list PT1)))<br />   (SETQ P2 (vl-Catch-All-Apply 'vlax-3d-point (list PT3)))<br />   (vl-catch-all-apply 'vla-Clear (list SS))<br />   (setq gpCode (vlax-make-safearray vlax-vbInteger '(0 . 0)))<br />   (vl-Catch-All-Apply<br />     'vlax-safearray-put-element<br />     (list gpCode 0 0)<br />   )<br />   (setq dataValue (vlax-make-safearray vlax-vbVariant '(0 . 0)))<br />   (vl-Catch-All-Apply<br />     'vlax-safearray-put-element<br />     (list dataValue 0 "INSERT")<br />   )<br />   (vl-Catch-All-Apply<br />     'vla-Select<br />     (list<br />       SS acSelectionSetCrossing  P1 P2 gpCode dataValue)<br />   )<br />   (if (vl-catch-all-error-p ss)<br />     (progn (vl-catch-all-apply 'vla-Clear (list SS))<br />      (setq ss nil)<br />     )<br />   )<br />   (SETQ vss NIL)<br />   (if ss<br />     (vlax-for obj ss<br />       (setq km nil)<br />       (setq arr nil)<br />       (setq tbl nil)<br />       (setq jb nil)<br />       (setq p nil)<br />       (setq vs nil)<br />       (setq km (vl-catch-all-apply<br />      'vla-get-effectivename<br />      (list obj)<br />          )<br />       )<br />       (AND (vl-catch-all-error-p KM)<br />      (setq KM (vl-catch-all-apply 'vla-get-name (list obj)))<br />       )<br />       (if<br />   (or (not km-str)<br />       (and km km-str (wcmatch km (strcat "[," km-str ",]")))<br />   )<br />    (AND<br />      (setq arr<br />       (vl-catch-all-apply<br />         'vlax-variant-value<br />         (list (vla-GetAttributes obj))<br />       )<br />      )<br />      (not (vl-catch-all-error-p arr))<br />      (setq tbl (vl-catch-all-apply<br />            'vlax-safearray->list<br />            (list arr)<br />          )<br />      )<br />      (not (vl-catch-all-error-p tbl))<br />      (setq jb (vla-get-handle obj))<br />      (setq p (vl-catch-all-apply<br />          'vlax-safearray->list<br />          (list (vlax-variant-value<br />            (vla-get-insertionpoint<br />              obj<br />            )<br />          )<br />          )<br />        )<br />      )<br />      (setq<br />        vs  (mapcar<br />       (function<br />         (lambda (x / v tag t-v)<br />           (setq v (vla-get-textstring x))<br />           (if (wcmatch v "`  *")<br />       (setq v (vl-string-left-trim "  " v))<br />           )      ;前面有tab空格  <br />           (if (wcmatch v "` *")<br />       (setq v (vl-string-left-trim " " v))<br />           )      ;前面有空格  <br />           (if (wcmatch v "*`  ")<br />       (setq v (vl-string-right-trim "  " v))<br />           )<br />           ;尾巴上有tab空格  <br />           (if (wcmatch v "*` ")<br />       (setq v (vl-string-right-trim " " v))<br />           )      ;后面有空格  <br />           (if (or (= v "") (= v " ") (= v "  "))<br />       nil<br />       (progn (setq tag (vla-get-tagstring x))<br />              (if (= tag "选项_001")<br />          (setq tag "选项")<br />              )<br />              (setq t-v (cons tag v))<br />       )<br />           )<br />           t-v<br />         )<br />       )<br />       tbl<br />     )<br />      )     <br />      (setq vs (vl-remove nil vs))<br />      (setq vs (cons (cons "句柄" jb) vs))<br />      (setq vs (cons (cons "Ha-Dl" jb) vs))<br />      (setq vs (cons (cons "插入点Y" (rtos (CADR P) 2 2)) vs))<br />      (setq vs (cons (cons "插入点X" (rtos (CAR P) 2 2)) vs))<br />      (setq vs (cons (cons "插入点" p) vs))<br />      (setq vs (cons (cons "块名" km) vs))<br />      (setq vs (vl-remove nil vs))<br />      (set 'vss (cons vs vss))<br />    )<br />       )<br />     )<br />   )<br />   (vl-catch-all-apply 'vla-Clear (list SS))<br />   vss<br /> )

taoyi0727

参数 lst 没有用

yangjian001

做一个热心并受欢迎的人

hh_lj007

感谢分享源码，先收藏

zteykmgscqh

感谢分享源码，收藏学习一下

dyjwyqz5221

用api函数直接就读取了，非常便捷快速的