Đến nội dung


Hình ảnh
- - - - -

Không Thống Kê Được Text Và Mtext Có Font Tiếng Việt


  • Please log in to reply
19 replies to this topic

#1 Kieu Tan

Kieu Tan

    biết vẽ rectang

  • Members
  • PipPip
  • 87 Bài viết
Điểm đánh giá: -23 (kém)

Đã gửi 18 August 2016 - 09:04 PM

Mình có 1 lsp dùng để thống kê TEXT VÀ MTEXT nhưng nó chỉ thống kê được TEXT VÀ MTEXT không có dấu, nếu font có dấu thì sau khi thống kê nó bị lỗi font(font tiếng việt bị lỗi font). Mong mọi người giúp đỡ. Thanks các bạn! 

(defun c:tkt  (/ lst msp pt ss str txtsiz-0 txtsiz doc)
  (vl-load-com)
  (if (setq ss (ssget (list (cons 0 "*TEXT"))))
    (progn (foreach e  (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
             (setq str      (vla-get-TextString e)
                   txtsiz-0 (vla-get-height e))
             (if (not (assoc str lst))
               (setq lst (cons (cons str 1) lst))
               (setq lst (subst (cons str (1+ (cdr (assoc str lst)))) (assoc str lst) lst))))
           (or (setq txtsiz (getreal (strcat "\nChieu cao Text trong bang thong ke <" (rtos txtsiz-0 2 2) ">: ")))
               (setq txtsiz txtsiz-0))
           (setq lst (vl-sort lst '(lambda (x y) (< (cdr x) (cdr y))))
                 pt  (getpoint "\nDiem dat Bang :")
                 doc (vla-get-ActiveDocument (vlax-get-Acad-Object))
                 msp (if (zerop (vla-get-activespace doc))
                       (if (= (vla-get-mspace doc) :vlax-true)
                         (vla-get-modelspace doc)
                         (vla-get-paperspace doc))
                       (vla-get-modelspace doc)))
           (foreach e  lst
             (vla-addtext msp (cdr e) (vlax-3d-point pt) txtsiz)
             (vla-addtext msp (car e) (vlax-3d-point (polar pt 0 (* 5 txtsiz))) txtsiz)
             (setq pt (polar pt (/ pi -2) (* 1.5 txtsiz)))))
    (alert "Khong chon duoc Text."))
  (princ))​


  • -1

#2 Kieu Tan

Kieu Tan

    biết vẽ rectang

  • Members
  • PipPip
  • 87 Bài viết
Điểm đánh giá: -23 (kém)

Đã gửi 20 August 2016 - 06:59 PM

Giúp mình với mọi người ơi!
  • 0

#3 tien2005

tien2005

    biết lệnh properties

  • Members
  • PipPipPipPip
  • 257 Bài viết
Điểm đánh giá: 94 (tàm tạm)

Đã gửi 20 August 2016 - 08:16 PM

đổi về font vni hay tcvn3 rồi thống kê


  • 0

#4 Kieu Tan

Kieu Tan

    biết vẽ rectang

  • Members
  • PipPip
  • 87 Bài viết
Điểm đánh giá: -23 (kém)

Đã gửi 20 August 2016 - 09:14 PM

đổi về font vni hay tcvn3 rồi thống kê

Cái này ví dụ là:

ta có 1 dãy danh sách *text vừa có dấu và không có dấu, bây giờ ta muốn thống kê nó ra bao nhiêu loại thôi

Nếu 1 dãy danh sách này ở font gì thì lsp thống kê cho ra font đó. 


  • 0

#5 quocmanh04tt

quocmanh04tt

    biết lệnh imageclip

  • Members
  • PipPipPipPipPipPipPip
  • 665 Bài viết
Điểm đánh giá: 312 (khá)

Đã gửi 20 August 2016 - 10:17 PM

Các bác ngại viết ấy mà, thử viết lại cho chủ top cái, không biết có ổn không đây!???
(defun c:tt (/ make-Text hei lst pt ss str sty)
(defun make-Text (pt hgt str sty)
(entmakex (list (cons 0 "TEXT") (cons 7 sty) (cons 10 pt) (cons 40 hgt) (cons 1 str))))
(and (vl-load-com)
(princ "\nQuet chon Text, Mtext de thong ke...!")
(setq ss (ssget (list (cons 0 "*TEXT"))))
(foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
(setq str (cdr (assoc 1 (entget e)))
hei (cdr (assoc 40 (entget e))))
(if (not (assoc str lst))
(setq lst (cons (cons str (list (cons 1 e))) lst))
(setq lst (subst (cons str (list (cons (1+ (caadr (assoc str lst))) e))) (assoc str lst) lst))))
(setq hei (cond ((getreal (strcat "\nChieu cao Text trong bang thong ke <" (rtos hei 2 2) ">: ")))
(hei)))
(setq pt (getpoint "\nDiem dat Bang: "))
(foreach e (vl-sort lst '(lambda (x y) (< (caadr x) (caadr y))))
(make-Text pt hei (itoa (caadr e)) (setq sty (cdr (assoc 7 (entget (cdadr e))))))
(make-Text (polar pt 0 (* 5 hei)) hei (car e) sty)
(setq pt (polar pt (* pi 1.5) (* 1.75 hei)))))
(princ))

  • 0

#6 Kieu Tan

Kieu Tan

    biết vẽ rectang

  • Members
  • PipPip
  • 87 Bài viết
Điểm đánh giá: -23 (kém)

Đã gửi 21 August 2016 - 11:05 AM

Các bác ngại viết ấy mà, thử viết lại cho chủ top cái, không biết có ổn không đây!???

(defun c:tt (/ make-Text hei lst pt ss str sty)
(defun make-Text (pt hgt str sty)
(entmakex (list (cons 0 "TEXT") (cons 7 sty) (cons 10 pt) (cons 40 hgt) (cons 1 str))))
(and (vl-load-com)
(princ "\nQuet chon Text, Mtext de thong ke...!")
(setq ss (ssget (list (cons 0 "*TEXT"))))
(foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
(setq str (cdr (assoc 1 (entget e)))
hei (cdr (assoc 40 (entget e))))
(if (not (assoc str lst))
(setq lst (cons (cons str (list (cons 1 e))) lst))
(setq lst (subst (cons str (list (cons (1+ (caadr (assoc str lst))) e))) (assoc str lst) lst))))
(setq hei (cond ((getreal (strcat "\nChieu cao Text trong bang thong ke <" (rtos hei 2 2) ">: ")))
(hei)))
(setq pt (getpoint "\nDiem dat Bang: "))
(foreach e (vl-sort lst '(lambda (x y) (< (caadr x) (caadr y))))
(make-Text pt hei (itoa (caadr e)) (setq sty (cdr (assoc 7 (entget (cdadr e))))))
(make-Text (polar pt 0 (* 5 hei)) hei (car e) sty)
(setq pt (polar pt (* pi 1.5) (* 1.75 hei)))))
(princ))

145520_untitled.jpgBạn quocmanh04tt  ơi ! 

Đối với text thì ok rồi

nhưng sao đối với mtext thì có lúc được lúc không

Mình có gởi file đính kèm để bạn xem thử nha ! 

http://www.cadviet.c...45520_tkt_1.dwg


  • 0

#7 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 5447 Bài viết
Điểm đánh giá: 2624 (tuyệt vời)

Đã gửi 21 August 2016 - 11:31 AM

Tôi đã nói ở trên rồi nhưng bạn quocmanh04tt  đã viết lisp nên phải xóa bài. Xuất text tiếng Việt (thường là bị sửa font) không đơn giản. LM có lisp về nó đấy.


  • 0

* Chỉ nên yêu cầu Lisp khi bạn làm việc đó mất cả ngày nhưng họ chỉ viết 1 giờ. Đừng nêu yêu cầu Lisp khi bạn chỉ làm 1 giờ nhưng bắt họ phải mất cả ngày.

* Nhờ viết lisp cũng như đi khám bệnh. Chỉ gởi căn cước và than sắp chết thì không bác sỹ nào cứu sống được.


#8 quocmanh04tt

quocmanh04tt

    biết lệnh imageclip

  • Members
  • PipPipPipPipPipPipPip
  • 665 Bài viết
Điểm đánh giá: 312 (khá)

Đã gửi 21 August 2016 - 04:15 PM

Trường hợp này đã nghĩ đến rồi, nhưng hôm qua vội chưa kịp đưa vào, sẽ nghiên cứu bổ sung.

@bác Hạ, chú đã từng áp dụng cái của LM để làm 1 lsp khác riêng cho mình rồi.


  • 0

#9 Kieu Tan

Kieu Tan

    biết vẽ rectang

  • Members
  • PipPip
  • 87 Bài viết
Điểm đánh giá: -23 (kém)

Đã gửi 21 August 2016 - 05:18 PM

Trường hợp này đã nghĩ đến rồi, nhưng hôm qua vội chưa kịp đưa vào, sẽ nghiên cứu bổ sung.

@bác Hạ, chú đã từng áp dụng cái của LM để làm 1 lsp khác riêng cho mình rồi.

Mong tin bác! 


  • 0

#10 quocmanh04tt

quocmanh04tt

    biết lệnh imageclip

  • Members
  • PipPipPipPipPipPipPip
  • 665 Bài viết
Điểm đánh giá: 312 (khá)

Đã gửi 21 August 2016 - 05:48 PM

@Chủ top! giải quyết tạm theo cách sau:
Bước 1: copy lsp ở dưới paste vào lsp trên, đầu hay cuối lsp đều được.
Bước 2: Thay đoạn này (trong lsp trên): (cdr (assoc 1 (entget e))) bởi: (LM:UnFormat (cdr (assoc 1 (entget e))) nil)
​Nếu có lỗi khác thì post lên!
(defun LM:UnFormat (str mtx / _replace rx)
(defun _replace (new old str) (vlax-put-property rx 'pattern old) (vlax-invoke rx 'replace str new))
(if (setq rx (vlax-get-or-create-object "VBScript.RegExp"))
(progn (setq str (vl-catch-all-apply
(function
(lambda ()
(vlax-put-property rx 'global actrue)
(vlax-put-property rx 'multiline actrue)
(vlax-put-property rx 'ignorecase acfalse)
(foreach pair '(("\032" . "\\\\\\\\")
(" " . "\\\\P|\\n|\\t")
("$1" . "\\\\(\\\\[ACcFfHLlOopQTW])|\\\\[ACcFfHLlOopQTW][^\\\\;]*;|\\\\[ACcFfHLlOopQTW]")
("$1$2/$3" . "([^\\\\])\\\\S([^;]*)[/#\\^]([^;]*);")
("$1$2" . "\\\\(\\\\S)|[\\\\](})|}")
("$1" . "[\\\\]({)|{"))
(setq str (_replace (car pair) (cdr pair) str)))
(if mtx
(_replace "\\\\" "\032" (_replace "\\$1$2$3" "(\\\\[ACcFfHLlOoPpQSTW])|({)|(})" str))
(_replace "\\" "\032" str))))))
(vlax-release-object rx)
(if (null (vl-catch-all-error-p str))
str))))

  • 0

#11 Kieu Tan

Kieu Tan

    biết vẽ rectang

  • Members
  • PipPip
  • 87 Bài viết
Điểm đánh giá: -23 (kém)

Đã gửi 21 August 2016 - 06:29 PM

@Chủ top! giải quyết tạm theo cách sau:
Bước 1: copy lsp ở dưới paste vào lsp trên, đầu hay cuối lsp đều được.
Bước 2: Thay đoạn này (trong lsp trên): (cdr (assoc 1 (entget e))) bởi: (LM:UnFormat (cdr (assoc 1 (entget e))) nil)
​Nếu có lỗi khác thì post lên!

(defun LM:UnFormat (str mtx / _replace rx)
(defun _replace (new old str) (vlax-put-property rx 'pattern old) (vlax-invoke rx 'replace str new))
(if (setq rx (vlax-get-or-create-object "VBScript.RegExp"))
(progn (setq str (vl-catch-all-apply
(function
(lambda ()
(vlax-put-property rx 'global actrue)
(vlax-put-property rx 'multiline actrue)
(vlax-put-property rx 'ignorecase acfalse)
(foreach pair '(("\032" . "\\\\\\\\")
(" " . "\\\\P|\\n|\\t")
("$1" . "\\\\(\\\\[ACcFfHLlOopQTW])|\\\\[ACcFfHLlOopQTW][^\\\\;]*;|\\\\[ACcFfHLlOopQTW]")
("$1$2/$3" . "([^\\\\])\\\\S([^;]*)[/#\\^]([^;]*);")
("$1$2" . "\\\\(\\\\S)|[\\\\](})|}")
("$1" . "[\\\\]({)|{"))
(setq str (_replace (car pair) (cdr pair) str)))
(if mtx
(_replace "\\\\" "\032" (_replace "\\$1$2$3" "(\\\\[ACcFfHLlOoPpQSTW])|({)|(})" str))
(_replace "\\" "\032" str))))))
(vlax-release-object rx)
(if (null (vl-catch-all-error-p str))
str))))

Đã tải về và làm theo hướng dẫn của bạn, nhưng sau khi chọn đối tượng rồi enter thì nó xuất hiện bảng sau :145520_untitled1.jpg


  • 0

#12 quocmanh04tt

quocmanh04tt

    biết lệnh imageclip

  • Members
  • PipPipPipPipPipPipPip
  • 665 Bài viết
Điểm đánh giá: 312 (khá)

Đã gửi 21 August 2016 - 07:59 PM

Bắt bệnh và hướng giải quyết:

1. Làm chưa đúng theo hướng dẫn (kiểm tra dấu đóng mở () cho đầy đủ, chính xác).

2. Hoặc: Ở lsp thứ 2, copy đừng download vì nó có nhiều ký tự đặc biệt, loằng ngoằng, do chức năng của diễn đàn dễ dẫn đến lỗi lsp.

3. Nếu làm 2 việc ở trên vẫn không xong thì post cái không xong lên đây.


  • 0

#13 Kieu Tan

Kieu Tan

    biết vẽ rectang

  • Members
  • PipPip
  • 87 Bài viết
Điểm đánh giá: -23 (kém)

Đã gửi 21 August 2016 - 08:14 PM

Bắt bệnh và hướng giải quyết:

1. Làm chưa đúng theo hướng dẫn (kiểm tra dấu đóng mở () cho đầy đủ, chính xác).

2. Hoặc: Ở lsp thứ 2, copy đừng download vì nó có nhiều ký tự đặc biệt, loằng ngoằng, do chức năng của diễn đàn dễ dẫn đến lỗi lsp.

3. Nếu làm 2 việc ở trên vẫn không xong thì post cái không xong lên đây.

Đã làm theo hướng dẫn của bạn, nhưng:

145520_untitled_2.jpg

145520_untitled1_2.jpg


  • 0

#14 quocmanh04tt

quocmanh04tt

    biết lệnh imageclip

  • Members
  • PipPipPipPipPipPipPip
  • 665 Bài viết
Điểm đánh giá: 312 (khá)

Đã gửi 21 August 2016 - 08:24 PM

Thử tải cái này về chạy thử xem sao (lệnh TKT):

http://www.cadviet.c.../141736_tkt.rar

141736_tkt.jpg


  • 1

#15 Kieu Tan

Kieu Tan

    biết vẽ rectang

  • Members
  • PipPip
  • 87 Bài viết
Điểm đánh giá: -23 (kém)

Đã gửi 21 August 2016 - 08:48 PM

Thử tải cái này về chạy thử xem sao (lệnh TKT):

http://www.cadviet.c.../141736_tkt.rar

141736_tkt.jpg

Tuyệt vời rồi bạn quocmanh04tt ơi !

Thật vất vã cho bạn quá !

Cảm ơn bạn nhiều lắm ! 


  • 0

#16 quocmanh04tt

quocmanh04tt

    biết lệnh imageclip

  • Members
  • PipPipPipPipPipPipPip
  • 665 Bài viết
Điểm đánh giá: 312 (khá)

Đã gửi 21 August 2016 - 09:00 PM

Vậy là làm không đúng theo hướng dẫn, file ở trên chỉ chuyển sang fas, còn nội dung vẫn như đã nói ở trên.


  • 0

#17 Kieu Tan

Kieu Tan

    biết vẽ rectang

  • Members
  • PipPip
  • 87 Bài viết
Điểm đánh giá: -23 (kém)

Đã gửi 21 August 2016 - 09:37 PM

Vậy là làm không đúng theo hướng dẫn, file ở trên chỉ chuyển sang fas, còn nội dung vẫn như đã nói ở trên.

Không phải đâu bạn ơi ! 

Làm theo hứơng dẫn nhưng nó cho dầu ra sai mà. 


  • 0

#18 quocmanh04tt

quocmanh04tt

    biết lệnh imageclip

  • Members
  • PipPipPipPipPipPipPip
  • 665 Bài viết
Điểm đánh giá: 312 (khá)

Đã gửi 21 August 2016 - 09:50 PM

Post cái lisp bạn đã sửa lên, tôi sẽ chỉ cho bạn chỗ không đúng theo hướng dẫn.

Hoặc copy cái này rồi chạy và so sánh:

(defun LM:UnFormat  (str mtx / _replace rx)
 (defun _replace (new old str) (vlax-put-property rx 'pattern old) (vlax-invoke rx 'replace str new))
 (if (setq rx (vlax-get-or-create-object "VBScript.RegExp"))
  (progn (setq str (vl-catch-all-apply
                    (function
                     (lambda ()
                      (vlax-put-property rx 'global actrue)
                      (vlax-put-property rx 'multiline actrue)
                      (vlax-put-property rx 'ignorecase acfalse)
                      (foreach pair  '(("\032" . "\\\\\\\\")
                                       (" " . "\\\\P|\\n|\\t")
                                       ("$1" . "\\\\(\\\\[ACcFfHLlOopQTW])|\\\\[ACcFfHLlOopQTW][^\\\\;]*;|\\\\[ACcFfHLlOopQTW]")
                                       ("$1$2/$3" . "([^\\\\])\\\\S([^;]*)[/#\\^]([^;]*);")
                                       ("$1$2" . "\\\\(\\\\S)|[\\\\](})|}")
                                       ("$1" . "[\\\\]({)|{"))
                       (setq str (_replace (car pair) (cdr pair) str)))
                      (if mtx
                       (_replace "\\\\" "\032" (_replace "\\$1$2$3" "(\\\\[ACcFfHLlOoPpQSTW])|({)|(})" str))
                       (_replace "\\" "\032" str))))))
         (vlax-release-object rx)
         (if (null (vl-catch-all-error-p str))
          str))))
(defun c:tkt  (/ make-Text hei lst pt ss str sty)
 (defun make-Text  (pt hgt str sty)
  (entmakex (list (cons 0 "TEXT") (cons 7 sty) (cons 10 pt) (cons 40 hgt) (cons 1 str))))
 (and (vl-load-com)
      (princ "\nQuet chon Text, Mtext de thong ke...!")
      (setq ss (ssget (list (cons 0 "*TEXT"))))
      (foreach e  (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
       (setq str (LM:UnFormat (cdr (assoc 1 (entget e))) nil)
             hei (cdr (assoc 40 (entget e))))
       (if (not (assoc str lst))
        (setq lst (cons (cons str (list (cons 1 e))) lst))
        (setq lst (subst (cons str (list (cons (1+ (caadr (assoc str lst))) e))) (assoc str lst) lst))))
      (setq hei (cond ((getreal (strcat "\nChieu cao Text trong bang thong ke <" (rtos hei 2 2) ">: ")))
                      (hei)))
      (setq pt (getpoint "\nDiem dat Bang: "))
      (foreach e  (vl-sort lst '(lambda (x y) (< (caadr x) (caadr y))))
       (make-Text pt hei (itoa (caadr e)) (setq sty (cdr (assoc 7 (entget (cdadr e))))))
       (make-Text (polar pt 0 (* 5 hei)) hei (car e) sty)
       (setq pt (polar pt (* pi 1.5) (* 1.75 hei)))))
 (princ))


  • 0

#19 Kieu Tan

Kieu Tan

    biết vẽ rectang

  • Members
  • PipPip
  • 87 Bài viết
Điểm đánh giá: -23 (kém)

Đã gửi 21 August 2016 - 10:03 PM

(defun c:tkt1 (/ make-Text hei lst pt ss str sty)

(defun make-Text (pt hgt str sty)

(entmakex (list (cons 0 "TEXT") (cons 7 sty) (cons 10 pt) (cons 40 hgt) (cons 1 str))))

(and (vl-load-com)

(princ "\nQuet chon Text, Mtext de thong ke...!")

(setq ss (ssget (list (cons 0 "*TEXT"))))

(foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))

(setq str (LM:UnFormat (cdr (assoc 1 (entget e))) nil)

hei (cdr (assoc 40 (entget e))))

(if (not (assoc str lst))

(setq lst (cons (cons str (list (cons 1 e))) lst))

(setq lst (subst (cons str (list (cons (1+ (caadr (assoc str lst))) e))) (assoc str lst) lst))))

(setq hei (cond ((getreal (strcat "\nChieu cao Text trong bang thong ke <" (rtos hei 2 2) ">: ")))

(hei)))

(setq pt (getpoint "\nDiem dat Bang: "))

(foreach e (vl-sort lst '(lambda (x y) (< (caadr x) (caadr y))))

(make-Text pt hei (itoa (caadr e)) (setq sty (cdr (assoc 7 (entget (cdadr e))))))

(make-Text (polar pt 0 (* 5 hei)) hei (car e) sty)

(setq pt (polar pt (* pi 1.5) (* 1.75 hei)))))

(princ))



(defun LM:UnFormat (str mtx / _replace rx)
(defun _replace (new old str) (vlax-put-property rx 'pattern old) (vlax-invoke rx 'replace str new))
(if (setq rx (vlax-get-or-create-object "VBScript.RegExp"))
(progn (setq str (vl-catch-all-apply
(function
(lambda ()
(vlax-put-property rx 'global actrue)
(vlax-put-property rx 'multiline actrue)
(vlax-put-property rx 'ignorecase acfalse)
(foreach pair '(("\032" . "\\\\\\\\")
(" " . "")
("" . "\\\\(\\\\[ACcFfHLlOopQTW]);]*;|\\\\[ACcFfHLlOopQTW]")
("$1$2/$3" . "([^\\\\])\\\\S([^;]*)[/#\\^]([^;]*);")
("$1$2" . "\\\\(\\\\S)|[\\\\](})|}")
("$1" . "[\\\\]({)|{"))
(setq str (_replace (car pair) (cdr pair) str)))
(if mtx
(_replace "\\\\" "" (_replace "" "(\\\\[ACcFfHLlOoPpQSTW])|({)|(})" str))
(_replace "" "" str))))))
(vlax-release-object rx)
(if (null (vl-catch-all-error-p str))
str)))) 

Post cái lisp bạn đã sửa lên, tôi sẽ chỉ cho bạn chỗ không đúng theo hướng dẫn.

Hoặc copy cái này rồi chạy và so sánh:

(defun LM:UnFormat  (str mtx / _replace rx)
 (defun _replace (new old str) (vlax-put-property rx 'pattern old) (vlax-invoke rx 'replace str new))
 (if (setq rx (vlax-get-or-create-object "VBScript.RegExp"))
  (progn (setq str (vl-catch-all-apply
                    (function
                     (lambda ()
                      (vlax-put-property rx 'global actrue)
                      (vlax-put-property rx 'multiline actrue)
                      (vlax-put-property rx 'ignorecase acfalse)
                      (foreach pair  '(("\032" . "\\\\\\\\")
                                       (" " . "\\\\P|\\n|\\t")
                                       ("$1" . "\\\\(\\\\[ACcFfHLlOopQTW])|\\\\[ACcFfHLlOopQTW][^\\\\;]*;|\\\\[ACcFfHLlOopQTW]")
                                       ("$1$2/$3" . "([^\\\\])\\\\S([^;]*)[/#\\^]([^;]*);")
                                       ("$1$2" . "\\\\(\\\\S)|[\\\\](})|}")
                                       ("$1" . "[\\\\]({)|{"))
                       (setq str (_replace (car pair) (cdr pair) str)))
                      (if mtx
                       (_replace "\\\\" "\032" (_replace "\\$1$2$3" "(\\\\[ACcFfHLlOoPpQSTW])|({)|(})" str))
                       (_replace "\\" "\032" str))))))
         (vlax-release-object rx)
         (if (null (vl-catch-all-error-p str))
          str))))
(defun c:tkt  (/ make-Text hei lst pt ss str sty)
 (defun make-Text  (pt hgt str sty)
  (entmakex (list (cons 0 "TEXT") (cons 7 sty) (cons 10 pt) (cons 40 hgt) (cons 1 str))))
 (and (vl-load-com)
      (princ "\nQuet chon Text, Mtext de thong ke...!")
      (setq ss (ssget (list (cons 0 "*TEXT"))))
      (foreach e  (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
       (setq str (LM:UnFormat (cdr (assoc 1 (entget e))) nil)
             hei (cdr (assoc 40 (entget e))))
       (if (not (assoc str lst))
        (setq lst (cons (cons str (list (cons 1 e))) lst))
        (setq lst (subst (cons str (list (cons (1+ (caadr (assoc str lst))) e))) (assoc str lst) lst))))
      (setq hei (cond ((getreal (strcat "\nChieu cao Text trong bang thong ke <" (rtos hei 2 2) ">: ")))
                      (hei)))
      (setq pt (getpoint "\nDiem dat Bang: "))
      (foreach e  (vl-sort lst '(lambda (x y) (< (caadr x) (caadr y))))
       (make-Text pt hei (itoa (caadr e)) (setq sty (cdr (assoc 7 (entget (cdadr e))))))
       (make-Text (polar pt 0 (* 5 hei)) hei (car e) sty)
       (setq pt (polar pt (* pi 1.5) (* 1.75 hei)))))
 (princ))

Coppy cái của bạn về cũng không ổn

Và cái của mình đây và nó cũng không được luôn:

 

(defun c:tkt1 (/ make-Text hei lst pt ss str sty)
 
(defun make-Text (pt hgt str sty)
 
(entmakex (list (cons 0 "TEXT") (cons 7 sty) (cons 10 pt) (cons 40 hgt) (cons 1 str))))
 
(and (vl-load-com)
 
(princ "\nQuet chon Text, Mtext de thong ke...!")
 
(setq ss (ssget (list (cons 0 "*TEXT"))))
 
(foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
 
(setq str (LM:UnFormat (cdr (assoc 1 (entget e))) nil)
 
hei (cdr (assoc 40 (entget e))))
 
(if (not (assoc str lst))
 
(setq lst (cons (cons str (list (cons 1 e))) lst))
 
(setq lst (subst (cons str (list (cons (1+ (caadr (assoc str lst))) e))) (assoc str lst) lst))))
 
(setq hei (cond ((getreal (strcat "\nChieu cao Text trong bang thong ke <" (rtos hei 2 2) ">: ")))
 
(hei)))
 
(setq pt (getpoint "\nDiem dat Bang: "))
 
(foreach e (vl-sort lst '(lambda (x y) (< (caadr x) (caadr y))))
 
(make-Text pt hei (itoa (caadr e)) (setq sty (cdr (assoc 7 (entget (cdadr e))))))
 
(make-Text (polar pt 0 (* 5 hei)) hei (car e) sty)
 
(setq pt (polar pt (* pi 1.5) (* 1.75 hei)))))
 
(princ))
 
 
 
(defun LM:UnFormat (str mtx / _replace rx)
(defun _replace (new old str) (vlax-put-property rx 'pattern old) (vlax-invoke rx 'replace str new))
(if (setq rx (vlax-get-or-create-object "VBScript.RegExp"))
(progn (setq str (vl-catch-all-apply
(function
(lambda ()
(vlax-put-property rx 'global actrue)
(vlax-put-property rx 'multiline actrue)
(vlax-put-property rx 'ignorecase acfalse)
(foreach pair '(("\032" . "\\\\\\\\")
(" " . "")
("" . "\\\\(\\\\[ACcFfHLlOopQTW]);]*;|\\\\[ACcFfHLlOopQTW]")
("$1$2/$3" . "([^\\\\])\\\\S([^;]*)[/#\\^]([^;]*);")
("$1$2" . "\\\\(\\\\S)|[\\\\](})|}")
("$1" . "[\\\\]({)|{"))
(setq str (_replace (car pair) (cdr pair) str)))
(if mtx
(_replace "\\\\" "" (_replace "" "(\\\\[ACcFfHLlOoPpQSTW])|({)|(})" str))
(_replace "" "" str))))))
(vlax-release-object rx)
(if (null (vl-catch-all-error-p str))
str))))

Bài viết đã được chỉnh sửa nội dung bởi Kieu Tan: 21 August 2016 - 10:11 PM

  • 0

#20 quocmanh04tt

quocmanh04tt

    biết lệnh imageclip

  • Members
  • PipPipPipPipPipPipPip
  • 665 Bài viết
Điểm đánh giá: 312 (khá)

Đã gửi 21 August 2016 - 10:27 PM

Post cái lisp bạn đã sửa lên, tôi sẽ chỉ cho bạn chỗ không đúng theo hướng dẫn.

Hoặc copy cái này rồi chạy và so sánh:

(defun LM:UnFormat  (str mtx / _replace rx)
 (defun _replace (new old str) (vlax-put-property rx 'pattern old) (vlax-invoke rx 'replace str new))
 (if (setq rx (vlax-get-or-create-object "VBScript.RegExp"))
  (progn (setq str (vl-catch-all-apply
                    (function
                     (lambda ()
                      (vlax-put-property rx 'global actrue)
                      (vlax-put-property rx 'multiline actrue)
                      (vlax-put-property rx 'ignorecase acfalse)
                      (foreach pair  '(("\032" . "\\\\\\\\")
                                       (" " . "\\\\P|\\n|\\t")
                                       ("$1" . "\\\\(\\\\[ACcFfHLlOopQTW])|\\\\[ACcFfHLlOopQTW][^\\\\;]*;|\\\\[ACcFfHLlOopQTW]")
                                       ("$1$2/$3" . "([^\\\\])\\\\S([^;]*)[/#\\^]([^;]*);")
                                       ("$1$2" . "\\\\(\\\\S)|[\\\\](})|}")
                                       ("$1" . "[\\\\]({)|{"))
                       (setq str (_replace (car pair) (cdr pair) str)))
                      (if mtx
                       (_replace "\\\\" "\032" (_replace "\\$1$2$3" "(\\\\[ACcFfHLlOoPpQSTW])|({)|(})" str))
                       (_replace "\\" "\032" str))))))
         (vlax-release-object rx)
         (if (null (vl-catch-all-error-p str))
          str))))
(defun c:tkt  (/ make-Text hei lst pt ss str sty)
 (defun make-Text  (pt hgt str sty)
  (entmakex (list (cons 0 "TEXT") (cons 7 sty) (cons 10 pt) (cons 40 hgt) (cons 1 str))))
 (and (vl-load-com)
      (princ "\nQuet chon Text, Mtext de thong ke...!")
      (setq ss (ssget (list (cons 0 "*TEXT"))))
      (foreach e  (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
       (setq str (LM:UnFormat (cdr (assoc 1 (entget e))) nil)
             hei (cdr (assoc 40 (entget e))))
       (if (not (assoc str lst))
        (setq lst (cons (cons str (list (cons 1 e))) lst))
        (setq lst (subst (cons str (list (cons (1+ (caadr (assoc str lst))) e))) (assoc str lst) lst))))
      (setq hei (cond ((getreal (strcat "\nChieu cao Text trong bang thong ke <" (rtos hei 2 2) ">: ")))
                      (hei)))
      (setq pt (getpoint "\nDiem dat Bang: "))
      (foreach e  (vl-sort lst '(lambda (x y) (< (caadr x) (caadr y))))
       (make-Text pt hei (itoa (caadr e)) (setq sty (cdr (assoc 7 (entget (cdadr e))))))
       (make-Text (polar pt 0 (* 5 hei)) hei (car e) sty)
       (setq pt (polar pt (* pi 1.5) (* 1.75 hei)))))
 (princ))

Thử so sánh lisp của bạn với lsp gốc dòng được đánh dấu màu đỏ có không hay có giống không?

Hoặc vào đây: http://www.lee-mac.c...rmatstring.htmltải hàm của LM về.


  • 0