Topic: Lisp to find all text but not working with Block

[HasanCAD]

this lisp to draw a line from matched text to point
The lisp working OK but for block not working well.

Code - Auto/Visual Lisp: [Select]

1. (defun c:fndtxt ( / A-IP A-STRNG ABLOCKS BLKDEF BLKLIST BLKOBJ
2.                  CLYR CNB CNT DOC EN I LNE
3.                  OBJ OBJ-IP OBJ-STRNG OBJ-VL ORGN P1 SS-BLK SS-TXT)
4.  
5.   (setq doc (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
6.  
7.   (if (and
8.         (setq orgn (_value "\nSelect Origin attribute/Text : "))
9.         (setq orgn (vla-get-textstring orgn))
10.         (setq orgn (LM:UnFormat orgn nil))
11.         (setq p1 (getpoint "\nPick base point for marks "))
12.         )
13.     (progn
14.       (if (foreach args
15.                '(
16.                  ( "TEMP" 8 "Continuous" 0.01 nil 0 "TEMPLATE LAYER")
17.                  )
18.         (apply 'lyrmk args)
19.         )
20.     (progn
21.       (setq clyr (getvar "CLAYER"))
22.       (setvar "CLAYER" "TEMP"))
23.     (setvar "CLAYER" "Defpoints"))
24.       (setq cnt 0)
25.       (setq cnb 0)
26.       (if (setq ss-TXT (ssget "_X" (list (cons 0 "*TEXT"))))
27.         (repeat (setq i (sslength ss-TXT))
28.           (setq obj (ssname ss-TXT cnt))
29.           (setq obj-vl (vlax-ename->vla-object obj))
30.           (setq obj-ip (vla-get-insertionpoint obj-vl))
31.           (setq obj-strng (vla-get-textstring obj-vl))
32.           (setq obj-strng (LM:UnFormat obj-strng nil))
33.           (if (eq obj-strng orgn)
34.             (progn
35.               (setq Lne (vla-AddLine doc obj-ip (vlax-3d-point p1)))
36.               (vla-put-layer Lne "TEMP")
37.               (vlax-put-property Lne "color" 256)
38.               ))
39.           (setq cnt (1+ cnt))
40.         ))
41.       (if (setq ss-BLK (ssget "_X" (list (cons 0  "INSERT"))))
42.         (progn
43.           (setq i (sslength ss-BLK))
44.           (while (setq en (ssname ss-BLK cnb))
45.             (setq blkobj (vlax-ename->vla-object en))
46.             (setq blklist (cons (vla-get-effectivename blkobj) blklist))
47.           (ssdel en ss-BLK))
48.           (repeat (length blklist)
49.             (if (not (vl-catch-all-error-p
50.                        (setq blkdef (vl-catch-all-apply 'vla-item (list ablocks (nth 0 blklist))))))
51.               (progn
52.                 (vlax-for a blkdef
53.                   (if (eq "ACDBTEXT" (strcase (vla-get-objectname a)))
54.                     (if (eq orgn (vla-get-textstring a))
55.                       (progn
56.                         (setq a-ip (vla-get-insertionpoint a))
57.                         (setq Lne (vla-AddLine doc obj-ip (vlax-3d-point p1)))
58.                         (vla-put-layer Lne "TEMP")
59.                         (vlax-put-property Lne "color" 256)
60.                         )))
61.                   8(if (eq "ACDBMTEXT" (strcase (vla-get-objectname a)))
62.                     (progn
63.                       (setq a-strng (vla-get-textstring a))
64.                       (setq a-strng (LM:UnFormat a-strng nil))
65.                       (if (eq a-strng orgn)
66.                         (progn
67.                           (setq a-ip (vla-get-insertionpoint a))
68.                           (setq Lne (vla-AddLine doc a-ip (vlax-3d-point p1)))
69.                           (vla-put-layer Lne "TEMP")
70.                           (vlax-put-property Lne "color" 256)
71.                           ))
72.                       ))
73.                   )))
74.             (setq blklist (cdr blklist))
75.             (setq cnt (1+ cnt))
76.             )
77.           (command "_attsync" "_N" "*")
78.           (command "_regenall")
79.           )
80.         )
81.       )
82.     )  
83.   )
84.  
85. (defun LM:UnFormat ( str mtx / _replace rx ) ;  mtx - T if string is for use in MText - LEE MAC
86.         (defun _replace ( new old str )
87.             (vlax-put-property rx 'pattern old)
88.             (vlax-invoke rx 'replace str new))
89.         (if (setq rx (vlax-get-or-create-object "VBScript.RegExp"))
90.             (progn
91.                 (setq str
92.                     (vl-catch-all-apply
93.                         (function
94.                             (lambda ( )
95.                                 (vlax-put-property rx 'global     actrue)
96.                                 (vlax-put-property rx 'multiline  actrue)
97.                                 (vlax-put-property rx 'ignorecase acfalse)
98.                                 (foreach pair
99.                                    '(
100.                                         ("\032"    . "\\\\\\\\")
101.                                         (" "       . "\\\\P|\\n|\\t")
102.                                         ("$1"      . "\\\\(\\\\[ACcFfHLlOopQTW])|\\\\[ACcFfHLlOopQTW][^\\\\;]*;|\\\\[ACcFfHLlOopQTW]")
103.                                         ("$1$2/$3" . "([^\\\\])\\\\S([^;]*)[/#\\^]([^;]*);")
104.                                         ("$1$2"    . "\\\\(\\\\S)|[\\\\](})|}")
105.                                         ("$1"      . "[\\\\]({)|{")
106.                                     )
107.                                     (setq str (_replace (car pair) (cdr pair) str))
108.                                 )
109.                                 (if mtx
110.                                     (_replace "\\\\" "\032" (_replace "\\$1$2$3" "(\\\\[ACcFfHLlOoPpQSTW])|({)|(})" str))
111.                                     (_replace "\\"   "\032" str))))))
112.                 (vlax-release-object rx)
113.                 (if (null (vl-catch-all-error-p str)) str))))
114.  
115. (defun _value   (str / )
116.   (while
117.     (not
118.       (if (and (setq entt (nentsel str))
119.                (setq ATTr (car entt))
120.                (member (vla-get-objectname (setq ATTr (vlax-ename->vla-object ATTr)))
121.                        '("AcDbAttribute" "AcDbText" "*DIM*" "AcDbMText")))
122.         ATTr (progn (princ str) nil))))
123.   ATTr
124.   )
125.  
126. (defun lyrmk (Nme Col lTyp lWgt Plt trns dsc / lay lyrs cmdENTVL LYRDS ) ;lee mac
127.   ;http://www.cadtutor.net/forum/showthread.php?36882-Check-create-layer-issue-in-Lisp&p=243520&viewfull=1#post243520
128.   (vl-load-com)
129.  
130.   (defun lTload (lTyp)
131.   (or (tblsearch "LTYPE" lTyp)
132.       (vla-load (vla-get-Linetypes (vla-get-ActiveDocument (vlax-get-acad-object)))
133.                 lTyp
134.                 "acad.lin")))
135.   (defun mdfy ( / )
136.                (setq entVL (vlax-ename->vla-object (tblobjname "LAYER" Nme)))
137.       (and Col (vla-put-Color entVL Col))
138.       (and lTyp (lTload lTyp) (vla-put-Linetype entVL lTyp))
139.       (and lWgt (vl-cmdf "_.-layer" "_LWeight" lWgt Nme ""))
140.       (and (not Plt) (vla-put-Plottable entVL :vlax-false))
141.       (and (setq LyrDs (vlax-put-property entVL 'Description dsc)))
142.       (vl-cmdf "_.-layer" "_TR" trns Nme "")
143.     )
144.  
145.   (setq cmd (getvar 'cmdecho))
146.   (setvar 'cmdecho 0)  
147.   (if (not (tblsearch "LAYER" Nme))
148.     (progn
149.       (setq lyrs (vla-get-layers (vla-get-ActiveDocument (vlax-get-acad-object))))
150.       (setq lay (vla-add lyrs Nme))
151.       (mdfy))
152.     (progn
153.       (mdfy)))
154.   (setvar 'cmdecho cmd))
155.  
156.  

[HasanCAD]

Let me explain again, may be there is no good explaination in previous post

Normaly we using FIND command to find similar strings but the strings areselected.
So I am coding a lisp to draw a line to each similar string.
This version working perfect with Text and Mtext.
But with block I am facing some troubles the code draw the line but not in correct location.

Thanks for help

Code - Auto/Visual Lisp: [Select]

1. (defun c:fndtxt ( / a a-ip a-strng clyr cnb cnt def doc docbl docblk
2.                  ent-ip ent-strng ent-vl i lne obj obj-ip obj-strng obj-vl orgn
3.                  p1 s ss-blk ss-txt)
4.  
5.   (vl-load-com)
6.   (setq doc (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
7.   (setq docblk (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object))))
8.        
9.   (if (and
10.         (setq orgn (_value "\nSelect Origin attribute/Text : "))
11.         (setq orgn (vla-get-textstring orgn))
12.         (setq orgn (LM:UnFormat orgn nil))
13.         (setq orgn-pnt (getpoint "\nPick base point for Gide Lines: "))
14.         (setq orgn-pnt (vlax-3d-point orgn-pnt))
15.         )
16.     (progn
17.       (if (foreach args
18.                         '(
19.                           ("TEMP" 8 "Continuous" 0.01 nil 0 "TEMPLATE LAYER")
20.                          )
21.             (apply 'lyrmk args)
22.           )
23.         (progn
24.           (setq clyr (getvar "CLAYER"))
25.           (setvar "CLAYER" "TEMP")
26.         )
27.         (setvar "CLAYER" "Defpoints")
28.       )
29.       (setq cnt 0)
30.       (setq cnb 0)
31.       (if (setq ss-TXT (ssget "_X" (list (cons 0 "*TEXT"))))
32.         (repeat (setq i (sslength ss-TXT))
33.           (setq obj (ssname ss-TXT cnt))
34.           (setq obj-vl (vlax-ename->vla-object obj))
35.           (setq obj-ip (vla-get-insertionpoint obj-vl))
36.           (setq obj-strng (vla-get-textstring obj-vl))
37.           (setq obj-strng (LM:UnFormat obj-strng nil))
38.           (if (eq obj-strng orgn)
39.             (progn
40.               (setq Lne (vla-AddLine doc obj-ip orgn-pnt))
41.               (vla-put-layer Lne "TEMP")
42.               (vlax-put-property Lne "color" 256)
43.               ))
44.           (setq cnt (1+ cnt))
45.         ))
46.       (if (setq ss-BLK (ssget "_X" (list (cons 0  "INSERT"))))
47.         (progn
48.           (repeat (setq i (sslength ss-BLK))
49.             (setq efnm (vla-get-effectivename (vlax-ename->vla-object (ssname ss-BLK cnb))))
50.             (if (not (vl-catch-all-error-p
51.                      (setq def (vl-catch-all-apply 'vla-item (list docblk efnm)))))
52.             (vlax-for obj def
53.               (if (eq "ACDBTEXT" (strcase (vla-get-objectname obj)))
54.                 (progn
55.                   (if (eq orgn (vla-get-textstring obj))
56.                   (progn
57.                     (setq obj-ipT (vla-get-insertionpoint obj))
58.                     (setq Lne (vla-AddLine doc obj-ipT orgn-pnt))
59.                     (vla-put-layer Lne "TEMP")
60.                     (vlax-put-property Lne "color" 256)
61.                     ))))
62.               (if (eq "ACDBMTEXT" (strcase (vla-get-objectname obj)))
63.                 (progn
64.                       (setq obj-strng (vla-get-textstring obj))
65.                       (setq obj-strng (LM:UnFormat obj-strng nil))
66.                       (if (eq obj-strng orgn)
67.                         (progn
68.                           (setq obj-ipMT (vla-get-insertionpoint obj-vl))
69.                           (setq Lne (vla-AddLine doc obj-ipMT orgn-pnt))
70.                           (vla-put-layer Lne "TEMP")
71.                           (vlax-put-property Lne "color" 256)
72.                           ))))
73.                 (if (eq "ACDBATTRIBUTEDEFINITION" (strcase (vla-get-objectname obj)))
74.                 (progn
75.                       (setq obj-strng (vla-get-textstring obj))
76.                       (setq obj-strng (LM:UnFormat obj-strng nil))
77.                       (if (eq obj-strng orgn)
78.                         (progn
79.                           (setq obj-ipAT (vla-get-insertionpoint obj-vl))
80.                           (setq Lne (vla-AddLine doc obj-ipAT orgn-pnt))
81.                           (vla-put-layer Lne "TEMP")
82.                           (vlax-put-property Lne "color" 256)
83.                           ))))
84.               )
85.             )      
86.             (setq cnb (1+ cnb))
87.             ))))))
88.    
89.  
90. (defun _replace ( new old str )
91.             (vlax-put-property rx 'pattern old)
92.             (vlax-invoke rx 'replace str new))
93.  
94. (defun LM:UnFormat ( str mtx / _replace rx );  mtx - T if string is for use in MText - LEE MAC
95.        
96.     (defun _replace ( new old str )
97.         (vlax-put-property rx 'pattern old)
98.         (vlax-invoke rx 'replace str new)
99.     )
100.     (if (setq rx (vlax-get-or-create-object "VBScript.RegExp"))
101.         (progn
102.             (setq str
103.                 (vl-catch-all-apply
104.                     (function
105.                         (lambda ( )
106.                             (vlax-put-property rx 'global     actrue)
107.                             (vlax-put-property rx 'multiline  actrue)
108.                             (vlax-put-property rx 'ignorecase acfalse)
109.                             (foreach pair
110.                                '(
111.                                     ("\032"    . "\\\\\\\\")
112.                                     (" "       . "\\\\P|\\n|\\t")
113.                                     ("$1"      . "\\\\(\\\\[ACcFfHLlOopQTW])|\\\\[ACcFfHLlOopQTW][^\\\\;]*;|\\\\[ACcFfHLlOopQTW]")
114.                                     ("$1$2/$3" . "([^\\\\])\\\\S([^;]*)[/#\\^]([^;]*);")
115.                                     ("$1$2"    . "\\\\(\\\\S)|[\\\\](})|}")
116.                                     ("$1"      . "[\\\\]({)|{")
117.                                 )
118.                                 (setq str (_replace (car pair) (cdr pair) str))
119.                             )
120.                             (if mtx
121.                                 (_replace "\\\\" "\032" (_replace "\\$1$2$3" "(\\\\[ACcFfHLlOoPpQSTW])|({)|(})" str))
122.                                 (_replace "\\"   "\032" str)
123.                             )
124.                         )
125.                     )
126.                 )
127.             )
128.             (vlax-release-object rx)
129.             (if (null (vl-catch-all-error-p str))
130.                 str
131.             )
132.         )
133.     )
134. )
135.  
136. (defun _value   (str / )
137.   (while
138.     (not
139.       (if (and (setq entt (nentsel str))
140.                (setq ATTr (car entt))
141.                (member (vla-get-objectname (setq ATTr (vlax-ename->vla-object ATTr)))
142.                        '("AcDbAttribute" "AcDbText" "*DIM*" "AcDbMText")))
143.         ATTr (progn (princ str) nil))))
144.   ATTr
145.   )
146.  
147. (defun lyrmk (Nme Col lTyp lWgt Plt trns dsc / lay lyrs cmdENTVL LYRDS ) ;lee mac
148.   ;http://www.cadtutor.net/forum/showthread.php?36882-Check-create-layer-issue-in-Lisp&p=243520&viewfull=1#post243520
149.    
150.   (setq cmd (getvar 'cmdecho))
151.   (setvar 'cmdecho 0)  
152.   (if (not (tblsearch "LAYER" Nme))
153.     (progn
154.       (setq lyrs (vla-get-layers (vla-get-ActiveDocument (vlax-get-acad-object))))
155.       (setq lay (vla-add lyrs Nme))
156.       (mdfy))
157.     (progn
158.       (mdfy)))
159.   (setvar 'cmdecho cmd))
160.  
161. (defun lTload (lTyp)
162.   (or (tblsearch "LTYPE" lTyp)
163.       (vla-load (vla-get-Linetypes (vla-get-ActiveDocument (vlax-get-acad-object)))
164.                 lTyp
165.                 "acad.lin")))
166.  
167. (defun mdfy ( / )
168.                (setq entVL (vlax-ename->vla-object (tblobjname "LAYER" Nme)))
169.       (and Col (vla-put-Color entVL Col))
170.       (and lTyp (lTload lTyp) (vla-put-Linetype entVL lTyp))
171.       (and lWgt (vl-cmdf "_.-layer" "_LWeight" lWgt Nme ""))
172.       (and (not Plt) (vla-put-Plottable entVL :vlax-false))
173.       (and (setq LyrDs (vlax-put-property entVL 'Description dsc)))
174.       (vl-cmdf "_.-layer" "_TR" trns Nme ""))

[kdub_nz]

This version working perfect with Text and Mtext.
But with block I am facing some troubles the code draw the line but not in correct location.

The issue can be resolved by refining the problem declaration.

Discover where the line is currently being drawn to/from ... then adjust your problem description.

[HasanCAD]

- Lisp detect TEXT and MTEXT
- Lisp does not detect TEXT and MTEXT in block
- Lisp does not detect attribute block
I belive there is a mistake in getting insertion point for the object.
Should we get the coordinate for the object add to the add to coordinate of block ?

Thanks

[Lee Mac]

The coordinate data obtained from the block definition will need to be transformed relative to each block reference which references the definition; for this, you will require a function similar to gile's RefGeom function.

[HasanCAD]

The coordinate data obtained from the block definition will need to be transformed relative to each block reference which references the definition; for this, you will require a function similar to gile's RefGeom function.

I tried to add this functuon but In fact I stucked at this point
Could some one help me at this point

[kdub_nz]

Can you please post the drawing you are using.

I'll have a look tonight when I get home if no-one else pops in first.

[HasanCAD]

Can you please post the drawing you are using.

I'll have a look tonight when I get home if no-one else pops in first.

Thanks Kerry for your valuable help

[HasanCAD]

up