Lấy lấy kí tự

[AUTOCAD_2019 7]

Chào các anh em có file cad có text là : T 145/185.25 thì trong đó T là mã còn 145 là số thửa , còn sau dấu / là diện tích viết liền cùng một text, giờ em muốn lấy riêng số thửa ra thành một layer riêng, mong các anh giúp, đây là file cad, em cảm ơn trước...

text mau.dwg

[Bee 154]

7 giờ trước, AUTOCAD_2019 đã nói:

Chào các anh em có file cad có text là : T 145/185.25 thì trong đó T là mã còn 145 là số thửa , còn sau dấu / là diện tích viết liền cùng một text, giờ em muốn lấy riêng số thửa ra thành một layer riêng, mong các anh giúp, đây là file cad, em cảm ơn trước...

text mau.dwg

Lâu lâu nghịch chút đỡ buồn. Chủ thớt test thử nhé ^_^

(defun c:test  ()
  (if (not (tblsearch "LAYER" "@TEN"))
    (command "Layer" "M" "@TEN" "")
    )
  (if (setq ss (ssget '((0 . "TEXT"))))
    (progn
      (setq n 0)
      (repeat (sslength ss)
        (setq value (cdr (assoc 1 (entget (ssname ss n)))))
        (if (setq pos (vl-string-search "/" value 1))
          (entmake
            (list
              (cons 0 "TEXT")
              (cons 100 "AcDbText")
              (cons 10 (trans (cdr (assoc 10 (entget (ssname ss n)))) 1 0))
              (cons 40 (cdr (assoc 40 (entget (ssname ss n)))))
              (cons 1 (substr value 1 pos))
              (cons 7 (cdr (assoc 7 (entget (ssname ss n)))))
              (cons 50 (cdr (assoc 50 (entget (ssname ss n)))))
              (cons 100 "AcDbText")
              )
            )
          ) ;if
        (setq n (1+ n))
        ) ;repeat
      ) ;progn
    ) ;if
  ) ;defun

 

[AUTOCAD_2019 7]

10 giờ trước, Bee đã nói:

Lâu lâu nghịch chút đỡ buồn. Chủ thớt test thử nhé ^_^

• test.lsp
  
• [✎]
   

(defun c:test  ()
  (if (not (tblsearch "LAYER" "@TEN"))
    (command "Layer" "M" "@TEN" "")
    )
  (if (setq ss (ssget '((0 . "TEXT"))))
    (progn
      (setq n 0)
      (repeat (sslength ss)
        (setq value (cdr (assoc 1 (entget (ssname ss n)))))
        (if (setq pos (vl-string-search "/" value 1))
          (entmake
            (list
              (cons 0 "TEXT")
              (cons 100 "AcDbText")
              (cons 10 (trans (cdr (assoc 10 (entget (ssname ss n)))) 1 0))
              (cons 40 (cdr (assoc 40 (entget (ssname ss n)))))
              (cons 1 (substr value 1 pos))
              (cons 7 (cdr (assoc 7 (entget (ssname ss n)))))
              (cons 50 (cdr (assoc 50 (entget (ssname ss n)))))
              (cons 100 "AcDbText")
              )
            )
          ) ;if
        (setq n (1+ n))
        ) ;repeat
      ) ;progn
    ) ;if
  ) ;defun

 

Em cảm ơn anh! lisp dùng rất tốt nhưng mà có một điều là em muốn lấy cái số thôi còn bỏ chữ T đi có được không ạ.....vì em muốn lấy số thửa thôi còn cái mã thì em không lấy ạ

[quansla 259]

Sửa thẳng từ bài viết của  Bee

 

(defun c:test  (/ N POS SS VALUE)
  (if (not (tblsearch "LAYER" "@TEN"))
    (command "Layer" "M" "@TEN" "")
    )
  (if (setq ss (ssget (list '(0 . "TEXT")
              (cons 1 "* */*"))))
    (progn
      (setq n 0)
      (repeat (sslength ss)
        (setq value (cdr (assoc 1 (entget (ssname ss n)))))
        (if (and (setq pos1 (vl-string-search "/" value 1))
         (setq pos2 (vl-string-search " " value 1)))
          (entmake
            (list
              (cons 0 "TEXT")
              (cons 100 "AcDbText")
              (cons 10 (trans (cdr (assoc 10 (entget (ssname ss n)))) 1 0))
              (cons 40 (cdr (assoc 40 (entget (ssname ss n)))))
              (cons 1 (substr value (+ pos2 2) (- pos1 pos2 1)))
              (cons 7 (cdr (assoc 7 (entget (ssname ss n)))))
              (cons 50 (cdr (assoc 50 (entget (ssname ss n)))))
              (cons 100 "AcDbText")
              )
            )
          ) ;if
        (setq n (1+ n))
        ) ;repeat
      ) ;progn
    ) ;if
  ) ;defun

 

[\list]

[AUTOCAD_2019 7]

8 phút trước, quansla đã nói:

Sửa thẳng từ bài viết của  Bee

 

(defun c:test  (/ N POS SS VALUE)
  (if (not (tblsearch "LAYER" "@TEN"))
    (command "Layer" "M" "@TEN" "")
    )
  (if (setq ss (ssget '((0 . "TEXT"))))
    (progn
      (setq n 0)
      (repeat (sslength ss)
        (setq value (cdr (assoc 1 (entget (ssname ss n)))))
        (if (and (setq pos1 (vl-string-search "/" value 1))
         (setq pos2 (vl-string-search " " value 1)))
          (entmake
            (list
              (cons 0 "TEXT")
              (cons 100 "AcDbText")
              (cons 10 (trans (cdr (assoc 10 (entget (ssname ss n)))) 1 0))
              (cons 40 (cdr (assoc 40 (entget (ssname ss n)))))
              (cons 1 (substr value (+ pos2 2) (- pos1 pos2 1)))
              (cons 7 (cdr (assoc 7 (entget (ssname ss n)))))
              (cons 50 (cdr (assoc 50 (entget (ssname ss n)))))
              (cons 100 "AcDbText")
              )
            )
          ) ;if
        (setq n (1+ n))
        ) ;repeat
      ) ;progn
    ) ;if
  )

 

[\list]

Anh ơi lấy số thửa ra thì được nhưng anh có thể lấy nó ra riêng layer khác layer ban đầu được không vì nếu chung layer thì em xuất file không được ạ

[quansla 259]

Sao máy mình vẫn chuyển được nhỉ, nếu chắc cú hơn bạn có thể thêm cú pháp

(cons 8 "Ten_layer_muon) vào ngay sau (cons 100 "AcDbText") là được nhé (trong cú pháp của Bee hơi thừa đoạn kiểm tra layer ban đầu thì phải

Mà trong file bạn gửi, không thống nhất nhé: có có cú pháp "T 34/23.3" và cú pháp "T34/23.3) tức là có và không có khoảng trắng, có cần xử lý cái không có khoảng trắng không

[AUTOCAD_2019 7]

18 phút trước, quansla đã nói:

Sao máy mình vẫn chuyển được nhỉ, nếu chắc cú hơn bạn có thể thêm cú pháp

(cons 8 "Ten_layer_muon) vào ngay sau (cons 100 "AcDbText") là được nhé (trong cú pháp của Bee hơi thừa đoạn kiểm tra layer ban đầu thì phải

Mà trong file bạn gửi, không thống nhất nhé: có có cú pháp "T 34/23.3" và cú pháp "T34/23.3) tức là có và không có khoảng trắng, có cần xử lý cái không có khoảng trắng không

dạ tại vì lúc làm thì nhiều người làm nên họ lúc đánh có khoản cách lúc không nên em nghỉ cũng phải giải quyết luôn cái khoản cách mới bao hết vđ đc ạ

Em cảm ơn anh vì cái lisp nha ^^!

[Bee 154]

13 giờ trước, quansla đã nói:

 "T 34/23.3" và cú pháp "T34/23.3)

 

13 giờ trước, AUTOCAD_2019 đã nói:

dạ tại vì lúc làm thì nhiều người làm nên họ lúc đánh có khoản cách lúc không nên em nghỉ cũng phải giải quyết luôn cái khoản cách mới bao hết vđ đc ạ

 

Hê hê vừa đá bóng về lướt tí mà thấy vấn đề đc xử roài.

Cái khoảng trắng xử dễ thôi mà: dùng (vl-string-subst "" " " value) thêm vào code của @quansla là xong thôi. ^_^

[quansla 259]

Đây nhé bạn, lâu quá không vào diễn đàn, không biết để code vào khung nữa rồi, hix

 

 

• (defun loc_rieng_so_dautien(str / i l n vl-str)
    (setq i 0 vl-str (vl-string->list str) N (length vl-str) l '())
    (while (<= i (strlen str))
      (if (and(<= 48 (nth i vl-str)) (<= (nth i vl-str) 57))         
        (setq l (append l (list (nth i vl-str))) )
        (if (= (length l) 0)
      (setq i (1+ i))
      (setq i (strlen str)))
      )
      (setq i (1+ i))
      )
    (vl-list->string l)
    )
  
  
  (defun c:test  (/ n ss tex value)
    
    (if (setq ss (ssget (list '(0 . "TEXT")
                (cons 1 "*/*"))))
      (progn
        (setq n 0)
        (repeat (sslength ss)
          (setq value (cdr (assoc 1 (entget (ssname ss n)))))
          (if (AND(/= (setq tex (loc_rieng_so_dautien  value)) nil)
          (> (strlen tex) 0))
            (entmake
              (list
                (cons 0 "TEXT")
                (cons 100 "AcDbText")
                (cons 10 (trans (cdr (assoc 10 (entget (ssname ss n)))) 1 0))
                (cons 40 (cdr (assoc 40 (entget (ssname ss n)))))
                
  
            (cons 1 tex)
                (cons 7 (cdr (assoc 7 (entget (ssname ss n)))))
                (cons 50 (cdr (assoc 50 (entget (ssname ss n)))))
                (cons 100 "AcDbText")
            (cons 8 "UAN")
                )
              )
            )
          (setq n (1+ n))
          ) 
        )
      )
    (princ)
    )
  
  

[AUTOCAD_2019 7]

22 giờ trước, quansla đã nói:

Đây nhé bạn, lâu quá không vào diễn đàn, không biết để code vào khung nữa rồi, hix

 

 

 

• (defun loc_rieng_so_dautien(str / i l n vl-str)
    (setq i 0 vl-str (vl-string->list str) N (length vl-str) l '())
    (while (<= i (strlen str))
      (if (and(<= 48 (nth i vl-str)) (<= (nth i vl-str) 57))         
        (setq l (append l (list (nth i vl-str))) )
        (if (= (length l) 0)
      (setq i (1+ i))
      (setq i (strlen str)))
      )
      (setq i (1+ i))
      )
    (vl-list->string l)
    )
  
  
  (defun c:test  (/ n ss tex value)
    
    (if (setq ss (ssget (list '(0 . "TEXT")
                (cons 1 "*/*"))))
      (progn
        (setq n 0)
        (repeat (sslength ss)
          (setq value (cdr (assoc 1 (entget (ssname ss n)))))
          (if (AND(/= (setq tex (loc_rieng_so_dautien  value)) nil)
          (> (strlen tex) 0))
            (entmake
              (list
                (cons 0 "TEXT")
                (cons 100 "AcDbText")
                (cons 10 (trans (cdr (assoc 10 (entget (ssname ss n)))) 1 0))
                (cons 40 (cdr (assoc 40 (entget (ssname ss n)))))
                
  
            (cons 1 tex)
                (cons 7 (cdr (assoc 7 (entget (ssname ss n)))))
                (cons 50 (cdr (assoc 50 (entget (ssname ss n)))))
                (cons 100 "AcDbText")
            (cons 8 "UAN")
                )
              )
            )
          (setq n (1+ n))
          ) 
        )
      )
    (princ)
    )
   

 

hình như kết quả khi ra nó không lấy số 1 có cách nào lấy luôn số 1 không anh vì số thửa nó bao gồm số 1 ấy

[AUTOCAD_2019 7]

T184/120.3 ví dụ như những trường hợp này anh

[AUTOCAD_2019 7]

.

[Bee 154]

10 giờ trước, AUTOCAD_2019 đã nói:

.

Chủ thớt có vẻ cần ^_^

Test thử nhé.

(defun c:test  (/ ss n value pos)
  (if (not (tblsearch "LAYER" "@TEN"))
    (command "Layer" "M" "@TEN" "")
    )
  (if (setq ss (ssget '((0 . "TEXT"))))
    (progn
      (setq n 0)
      (repeat (sslength ss)
        (setq value (vl-list->string (vl-remove-if (function (lambda (u) (or (< 64 u 91) (< 96 u 123))))
                                                   (vl-string->list (vl-string-subst "" "." (vl-string-subst "" " " (cdr (assoc 1 (entget (ssname ss n)))))))
                                                   )
                                     )
              )

        (if (setq pos (vl-string-search "/" value 1))
          (entmake
            (list
              (cons 0 "TEXT")
              (cons 100 "AcDbText")
              (cons 10 (trans (cdr (assoc 10 (entget (ssname ss n)))) 1 0))
              (assoc 40 (entget (ssname ss n)))
              (cons 1 (substr value 1 pos))
              (assoc 7 (entget (ssname ss n)))
              (assoc 50 (entget (ssname ss n)))
              (cons 8 "@TEN")
              (cons 100 "AcDbText")
              )
            )
          ) ;if
        (setq n (1+ n))
        ) ;repeat
      ) ;progn
    ) ;if
  (princ)
  )

 

[AUTOCAD_2019 7]

14 giờ trước, Bee đã nói:

Chủ thớt có vẻ cần ^_^

Test thử nhé.

• test.lsp
  
• [✎]
   

(defun c:test  (/ ss n value pos)
  (if (not (tblsearch "LAYER" "@TEN"))
    (command "Layer" "M" "@TEN" "")
    )
  (if (setq ss (ssget '((0 . "TEXT"))))
    (progn
      (setq n 0)
      (repeat (sslength ss)
        (setq value (vl-list->string (vl-remove-if (function (lambda (u) (or (< 64 u 91) (< 96 u 123))))
                                                   (vl-string->list (vl-string-subst "" "." (vl-string-subst "" " " (cdr (assoc 1 (entget (ssname ss n)))))))
                                                   )
                                     )
              )

        (if (setq pos (vl-string-search "/" value 1))
          (entmake
            (list
              (cons 0 "TEXT")
              (cons 100 "AcDbText")
              (cons 10 (trans (cdr (assoc 10 (entget (ssname ss n)))) 1 0))
              (assoc 40 (entget (ssname ss n)))
              (cons 1 (substr value 1 pos))
              (assoc 7 (entget (ssname ss n)))
              (assoc 50 (entget (ssname ss n)))
              (cons 8 "@TEN")
              (cons 100 "AcDbText")
              )
            )
          ) ;if
        (setq n (1+ n))
        ) ;repeat
      ) ;progn
    ) ;if
  (princ)
  )

 

cảm ơn bạn nhiều nha ^^!

[divine kai 0]

Vào lúc 29/5/2019 tại 19:05, Bee đã nói:

 

bạn ơi, mình cũng gặp trường hợp tương tự, nhưng sao sài lisp thì không quét được nhiều đối tượng vs quét có nhiều đối tượng khác dạng line hay text khác thì lisp không chạy, bạn có thể sửa giúp mình không...( mình chỉ có thể quét rất ít đối tượng )

[divine kai 0]

du lieu 99.dwg

em xin phép gửi dữ liệu, ai có lòng tốt thì giúp em nha

[Doan Nguyen Van 491]

3 giờ trước, divine kai đã nói:

du lieu 99.dwg

em xin phép gửi dữ liệu, ai có lòng tốt thì giúp em nha

(defun c:te  (/ ss n value pos)
  (if (not (tblsearch "LAYER" "TEN"))
    (command "Layer" "M" "TEN" "")
    )
  (if (setq ss (ssget '((0 . "TEXT") (1 . "*/*"))))
    (progn
      (setq n 0)
      (repeat (sslength ss)
        (setq value (vl-list->string (vl-remove-if (function (lambda (u) (or (< 64 u 91) (< 96 u 123))))
                                                   (vl-string->list (vl-string-subst "" "." (vl-string-subst "" " "
											      (setq str (cdr (assoc 1 (entget (ssname ss n))))))))
                                                   )
                                     )
              )
        (if (setq pos (vl-string-search "/" value 1)) (progn
(setq pos1 (vl-string-search (substr value 1 pos) (cdr (assoc 1 (entget (ssname ss n)))) 1))
(make (substr str 1 pos1) 0 (ssname ss n) (cdr (assoc 10 (entget (ssname ss n)))))
(vla-getboundingbox (vlax-ename->vla-object (entlast)) 'mn 'mx)
(setq width (- (car (vlax-safearray->list mx))  (car (vlax-safearray->list mn))))
(entdel (entlast))
(make (substr value 1 pos) (cdr (assoc 50 (entget (ssname ss n)))) (ssname ss n) (polar (cdr (assoc 10 (entget (ssname ss n))))
											       (cdr (assoc 50 (entget (ssname ss n)))) width))
           )
          ) ;if
        (setq n (1+ n))
        ) ;repeat
      ) ;progn
    ) ;if
  (princ)
  )
(defun make (noidung goc ent pt)
	(entmake
            (list
              (cons 0 "TEXT")
              (cons 100 "AcDbText")
              (cons 10 (trans pt 1 0))
              (assoc 40 (entget ent))
              (cons 1 noidung)
              (assoc 7 (entget ent))
              (cons 50 goc)
              (cons 8 "TEN")
              (cons 100 "AcDbText")
              )
            )
)

Sửa theo bài của BEE

[Bee 154]

10 giờ trước, divine kai đã nói:

bạn ơi, mình cũng gặp trường hợp tương tự, nhưng sao sài lisp thì không quét được nhiều đối tượng vs quét có nhiều đối tượng khác dạng line hay text khác thì lisp không chạy, bạn có thể sửa giúp mình không...( mình chỉ có thể quét rất ít đối tượng )

Có chỉnh lại theo bản vẽ của bạn, đã test thấy chạy ok với lisp sau: sau khi gõ lệnh - TEST thì gõ all xong enter chạy bình thường ^_^ Hoặc dùng lisp Doan NV filter giá trị text cho nhanh hơn.

(defun c:test  (/ ss n value pos)
  (if (not (tblsearch "LAYER" "@TEN"))
    (command "Layer" "M" "@TEN" "")
    )
  (if (setq ss (ssget '((0 . "TEXT"))))
    (progn
      (setq n 0)
      (repeat (sslength ss)
        (if (> (strlen (cdr (assoc 1 (entget (ssname ss n))))) 6)
          (progn
            (setq value (vl-list->string
                          (vl-remove-if (function (lambda (u) (or (< 64 u 91) (< 96 u 123))))
                                        (vl-string->list
                                          (vl-string-subst "" "." (vl-string-subst "" " " (cdr (assoc 1 (entget (ssname ss n)))))))
                                        )
                          )
                  )
            (if (setq pos (vl-string-search "/" value 1))
              (entmake
                (list
                  (cons 0 "TEXT")
                  (cons 100 "AcDbText")
                  (cons 10 (trans (cdr (assoc 10 (entget (ssname ss n)))) 1 0))
                  (assoc 40 (entget (ssname ss n)))
                  (cons 1 (substr value 1 pos))
                  (assoc 7 (entget (ssname ss n)))
                  (assoc 50 (entget (ssname ss n)))
                  (cons 8 "@TEN")
                  (cons 100 "AcDbText")
                  )
                )
              ) ;if
            )
          )
        (setq n (1+ n))
        ) ;repeat

      ) ;progn
    ) ;if
 
  (princ)
  )

 

[Bee 154]

6 giờ trước, Doan Nguyen Van đã nói:

• te.lsp
  
• [✎]
   

(defun c:te  (/ ss n value pos)
  (if (not (tblsearch "LAYER" "TEN"))
    (command "Layer" "M" "TEN" "")
    )
  (if (setq ss (ssget '((0 . "TEXT") (1 . "*/*"))))
    (progn
      (setq n 0)
      (repeat (sslength ss)
        (setq value (vl-list->string (vl-remove-if (function (lambda (u) (or (< 64 u 91) (< 96 u 123))))
                                                   (vl-string->list (vl-string-subst "" "." (vl-string-subst "" " "
											      (setq str (cdr (assoc 1 (entget (ssname ss n))))))))
                                                   )
                                     )
              )
        (if (setq pos (vl-string-search "/" value 1)) (progn
(setq pos1 (vl-string-search (substr value 1 pos) (cdr (assoc 1 (entget (ssname ss n)))) 1))
(make (substr str 1 pos1) 0 (ssname ss n) (cdr (assoc 10 (entget (ssname ss n)))))
(vla-getboundingbox (vlax-ename->vla-object (entlast)) 'mn 'mx)
(setq width (- (car (vlax-safearray->list mx))  (car (vlax-safearray->list mn))))
(entdel (entlast))
(make (substr value 1 pos) (cdr (assoc 50 (entget (ssname ss n)))) (ssname ss n) (polar (cdr (assoc 10 (entget (ssname ss n))))
											       (cdr (assoc 50 (entget (ssname ss n)))) width))
           )
          ) ;if
        (setq n (1+ n))
        ) ;repeat
      ) ;progn
    ) ;if
  (princ)
  )
(defun make (noidung goc ent pt)
	(entmake
            (list
              (cons 0 "TEXT")
              (cons 100 "AcDbText")
              (cons 10 (trans pt 1 0))
              (assoc 40 (entget ent))
              (cons 1 noidung)
              (assoc 7 (entget ent))
              (cons 50 goc)
              (cons 8 "TEN")
              (cons 100 "AcDbText")
              )
            )
)

Sửa theo bài của BEE

Like ^_^

[divine kai 0]

17 giờ trước, Doan Nguyen Van đã nói:

• te.lsp
  
• [✎]
   

(defun c:te  (/ ss n value pos)
  (if (not (tblsearch "LAYER" "TEN"))
    (command "Layer" "M" "TEN" "")
    )
  (if (setq ss (ssget '((0 . "TEXT") (1 . "*/*"))))
    (progn
      (setq n 0)
      (repeat (sslength ss)
        (setq value (vl-list->string (vl-remove-if (function (lambda (u) (or (< 64 u 91) (< 96 u 123))))
                                                   (vl-string->list (vl-string-subst "" "." (vl-string-subst "" " "
											      (setq str (cdr (assoc 1 (entget (ssname ss n))))))))
                                                   )
                                     )
              )
        (if (setq pos (vl-string-search "/" value 1)) (progn
(setq pos1 (vl-string-search (substr value 1 pos) (cdr (assoc 1 (entget (ssname ss n)))) 1))
(make (substr str 1 pos1) 0 (ssname ss n) (cdr (assoc 10 (entget (ssname ss n)))))
(vla-getboundingbox (vlax-ename->vla-object (entlast)) 'mn 'mx)
(setq width (- (car (vlax-safearray->list mx))  (car (vlax-safearray->list mn))))
(entdel (entlast))
(make (substr value 1 pos) (cdr (assoc 50 (entget (ssname ss n)))) (ssname ss n) (polar (cdr (assoc 10 (entget (ssname ss n))))
											       (cdr (assoc 50 (entget (ssname ss n)))) width))
           )
          ) ;if
        (setq n (1+ n))
        ) ;repeat
      ) ;progn
    ) ;if
  (princ)
  )
(defun make (noidung goc ent pt)
	(entmake
            (list
              (cons 0 "TEXT")
              (cons 100 "AcDbText")
              (cons 10 (trans pt 1 0))
              (assoc 40 (entget ent))
              (cons 1 noidung)
              (assoc 7 (entget ent))
              (cons 50 goc)
              (cons 8 "TEN")
              (cons 100 "AcDbText")
              )
            )
)

Sửa theo bài của BEE

Em cảm ơn anh Doan

[divine kai 0]

10 giờ trước, Bee đã nói:

Có chỉnh lại theo bản vẽ của bạn, đã test thấy chạy ok với lisp sau: sau khi gõ lệnh - TEST thì gõ all xong enter chạy bình thường ^_^ Hoặc dùng lisp Doan NV filter giá trị text cho nhanh hơn.

• test.lsp
  
• [✎]
   

(defun c:test  (/ ss n value pos)
  (if (not (tblsearch "LAYER" "@TEN"))
    (command "Layer" "M" "@TEN" "")
    )
  (if (setq ss (ssget '((0 . "TEXT"))))
    (progn
      (setq n 0)
      (repeat (sslength ss)
        (if (> (strlen (cdr (assoc 1 (entget (ssname ss n))))) 6)
          (progn
            (setq value (vl-list->string
                          (vl-remove-if (function (lambda (u) (or (< 64 u 91) (< 96 u 123))))
                                        (vl-string->list
                                          (vl-string-subst "" "." (vl-string-subst "" " " (cdr (assoc 1 (entget (ssname ss n)))))))
                                        )
                          )
                  )
            (if (setq pos (vl-string-search "/" value 1))
              (entmake
                (list
                  (cons 0 "TEXT")
                  (cons 100 "AcDbText")
                  (cons 10 (trans (cdr (assoc 10 (entget (ssname ss n)))) 1 0))
                  (assoc 40 (entget (ssname ss n)))
                  (cons 1 (substr value 1 pos))
                  (assoc 7 (entget (ssname ss n)))
                  (assoc 50 (entget (ssname ss n)))
                  (cons 8 "@TEN")
                  (cons 100 "AcDbText")
                  )
                )
              ) ;if
            )
          )
        (setq n (1+ n))
        ) ;repeat

      ) ;progn
    ) ;if
 
  (princ)
  )

 

cảm ơn bạn rất nhiều nha bee

[divine kai 0]

Vào lúc 9/9/2019 tại 14:27, Doan Nguyen Van đã nói:

• te.lsp
  
• [✎]
   

(defun c:te  (/ ss n value pos)
  (if (not (tblsearch "LAYER" "TEN"))
    (command "Layer" "M" "TEN" "")
    )
  (if (setq ss (ssget '((0 . "TEXT") (1 . "*/*"))))
    (progn
      (setq n 0)
      (repeat (sslength ss)
        (setq value (vl-list->string (vl-remove-if (function (lambda (u) (or (< 64 u 91) (< 96 u 123))))
                                                   (vl-string->list (vl-string-subst "" "." (vl-string-subst "" " "
											      (setq str (cdr (assoc 1 (entget (ssname ss n))))))))
                                                   )
                                     )
              )
        (if (setq pos (vl-string-search "/" value 1)) (progn
(setq pos1 (vl-string-search (substr value 1 pos) (cdr (assoc 1 (entget (ssname ss n)))) 1))
(make (substr str 1 pos1) 0 (ssname ss n) (cdr (assoc 10 (entget (ssname ss n)))))
(vla-getboundingbox (vlax-ename->vla-object (entlast)) 'mn 'mx)
(setq width (- (car (vlax-safearray->list mx))  (car (vlax-safearray->list mn))))
(entdel (entlast))
(make (substr value 1 pos) (cdr (assoc 50 (entget (ssname ss n)))) (ssname ss n) (polar (cdr (assoc 10 (entget (ssname ss n))))
											       (cdr (assoc 50 (entget (ssname ss n)))) width))
           )
          ) ;if
        (setq n (1+ n))
        ) ;repeat
      ) ;progn
    ) ;if
  (princ)
  )
(defun make (noidung goc ent pt)
	(entmake
            (list
              (cons 0 "TEXT")
              (cons 100 "AcDbText")
              (cons 10 (trans pt 1 0))
              (assoc 40 (entget ent))
              (cons 1 noidung)
              (assoc 7 (entget ent))
              (cons 50 goc)
              (cons 8 "TEN")
              (cons 100 "AcDbText")
              )
            )
)

 

hiện tại em muốn lấy thêm dữ liệu là chỉ chữ ở đầu tiên , ví dụ như T 83/243.6 thì khi quét lisp sẽ cho ra kết quả là T, anh có thể sửa giúp em trên lisp này luôn không ạ, em cảm ơn anh

[divine kai 0]

Vào lúc 9/9/2019 tại 14:27, Doan Nguyen Van đã nói:

• te.lsp
  
• [✎]
   

(defun c:te  (/ ss n value pos)
  (if (not (tblsearch "LAYER" "TEN"))
    (command "Layer" "M" "TEN" "")
    )
  (if (setq ss (ssget '((0 . "TEXT") (1 . "*/*"))))
    (progn
      (setq n 0)
      (repeat (sslength ss)
        (setq value (vl-list->string (vl-remove-if (function (lambda (u) (or (< 64 u 91) (< 96 u 123))))
                                                   (vl-string->list (vl-string-subst "" "." (vl-string-subst "" " "
											      (setq str (cdr (assoc 1 (entget (ssname ss n))))))))
                                                   )
                                     )
              )
        (if (setq pos (vl-string-search "/" value 1)) (progn
(setq pos1 (vl-string-search (substr value 1 pos) (cdr (assoc 1 (entget (ssname ss n)))) 1))
(make (substr str 1 pos1) 0 (ssname ss n) (cdr (assoc 10 (entget (ssname ss n)))))
(vla-getboundingbox (vlax-ename->vla-object (entlast)) 'mn 'mx)
(setq width (- (car (vlax-safearray->list mx))  (car (vlax-safearray->list mn))))
(entdel (entlast))
(make (substr value 1 pos) (cdr (assoc 50 (entget (ssname ss n)))) (ssname ss n) (polar (cdr (assoc 10 (entget (ssname ss n))))
											       (cdr (assoc 50 (entget (ssname ss n)))) width))
           )
          ) ;if
        (setq n (1+ n))
        ) ;repeat
      ) ;progn
    ) ;if
  (princ)
  )
(defun make (noidung goc ent pt)
	(entmake
            (list
              (cons 0 "TEXT")
              (cons 100 "AcDbText")
              (cons 10 (trans pt 1 0))
              (assoc 40 (entget ent))
              (cons 1 noidung)
              (assoc 7 (entget ent))
              (cons 50 goc)
              (cons 8 "TEN")
              (cons 100 "AcDbText")
              )
            )
)

 

có nhiều dữ liệu bị sai khi quét lisp ví dụ như ĐM, 2L và vườn thì khi chạy nó cho ra kết quả bị sai anh có cách nào sửa không anh?

 

du lieu bi sai.dwg

[Doan Nguyen Van 491]

37 phút trước, divine kai đã nói:

hiện tại em muốn lấy thêm dữ liệu là chỉ chữ ở đầu tiên , ví dụ như T 83/243.6 thì khi quét lisp sẽ cho ra kết quả là T, anh có thể sửa giúp em trên lisp này luôn không ạ, em cảm ơn anh

 

30 phút trước, divine kai đã nói:

có nhiều dữ liệu bị sai khi quét lisp ví dụ như ĐM, 2L và vườn thì khi chạy nó cho ra kết quả bị sai anh có cách nào sửa không anh?

 

 

 

du lieu bi sai.dwg

Đã sửa 

(defun c:te  (/ ss n value pos)
  (if (not (tblsearch "LAYER" "Code"))
    (command "Layer" "M" "Code" "")
    )
  (if (not (tblsearch "LAYER" "Thua"))
    (command "Layer" "M" "Thua" "")
    )
  (if (setq ss (ssget '((0 . "TEXT") (1 . "*/*"))))
    (progn
      (setq key (keyword '("Ma" "Thua") "Thua" "Ban muon lay ket qua nao"))
      (setq n 0)
      (repeat (sslength ss)
        (setq value (substr (setq str (cdr (assoc 1 (entget (ssname ss n))))) 1 (vl-string-search "/" str)))
	(setq ma (vl-string-right-trim "0123456789" value))
	(setq thua (substr value (+ 1 (strlen ma) )))
(make ma 0 (ssname ss n) (cdr (assoc 10 (entget (ssname ss n)))) "Code")
(if (= key "Thua") (progn
(vla-getboundingbox (vlax-ename->vla-object (entlast)) 'mn 'mx)
(setq width (- (car (vlax-safearray->list mx))  (car (vlax-safearray->list mn))))
(entdel (entlast))
(make thua (cdr (assoc 50 (entget (ssname ss n)))) (ssname ss n) (polar (cdr (assoc 10 (entget (ssname ss n))))
											       (cdr (assoc 50 (entget (ssname ss n)))) width) "Thua"))
  (vla-put-rotation (vlax-ename->vla-object (entlast)) (cdr (assoc 50 (entget (ssname ss n)))) ))
           
         ; ) ;if
        (setq n (1+ n))
        ) ;repeat
      ) ;progn
    ) ;if
  (princ)
  )
(defun make (noidung goc ent pt lay)
	(entmake
            (list
              (cons 0 "TEXT")
              (cons 100 "AcDbText")
              (cons 10 (trans pt 1 0))
              (assoc 40 (entget ent))
              (cons 1 noidung)
              (assoc 7 (entget ent))
              (cons 50 goc)
              (cons 8 lay)
              (cons 100 "AcDbText")
              )
            )
)
(defun keyword (key default promp / str1 str2 str3 str4)
  (setq str1 (apply 'strcat (mapcar (function (lambda (x) (strcat x " "))) key)))
  (setq str2 (apply 'strcat (mapcar (function (lambda (x) (strcat x "/"))) key)))
  (setq str1 (substr str1 1 (1- (strlen str1))))
  (setq str2 (substr str2 1 (1- (strlen str2))))
  (initget str1)
  (setq str3 (strcat "\n" promp " [" str2 "] <" default "> "))
  (if (not (setq str4 (getkword str3)))
    default
    str4
    )
  )

 

[divine kai 0]

1 phút trước, Doan Nguyen Van đã nói:

 

Em cảm ơn anh Doan nhiều....hihihi ^^