Chuyển đến nội dung
Diễn đàn CADViet

Bee

Thành viên
 Xem Hồ Sơ  Xem hoạt động của họ

  • Số lượng nội dung

    553

  • Đã tham gia

  • Lần ghé thăm cuối

  • Ngày trúng

    37

Bài đăng được đăng bởi Bee

  1. Đã đăng · Trả lời báo cáo

    6 giờ trước, Doan Nguyen Van đã nói: 
    
(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 ^_^

  2. Đã đăng · Trả lời báo cáo

    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)
  )

     

  3. Đã đăng · Trả lời báo cáo

    6 giờ trước, jangboko đã nói:

    không đúng bạn ạ. Mình muốn sau khi gõ lệnh thì chọn vào đối tượng chứa anotative ( text, hacth,  dim, block...) thì annotation scale ( vị trí mình khoanh đỏ trên file đính kèm ) thay đổi theo annotion của đối tượng được chọn

    1.png

    Bạn thử cái này xem: 

    (defun c:test  (/ dict entsc)
  (if (and
        (setq dict (cdr (assoc 360 (entget (car (entsel "\nChon doi tuong anno: "))))))
        (setq dict (dictsearch dict "AcDbContextDataManager"))
        (setq dict (dictsearch (cdr (assoc -1 dict)) "ACDB_ANNOTATIONSCALES"))
        )
    (foreach n dict
      (if (and
            (= (car n) 350)
            (setq entsc
                   (cdr (assoc 300 (entget (cdr (assoc 340 (entget (cdr n)))))))
                  )
            );and
        (setvar "CANNOSCALE" entsc)
        )
      );foreach
    ) ;if
  (princ)
  )

     

    • Like 1

  7. Đã đăng · Trả lời báo cáo

    1 giờ trước, jangboko đã nói:

    Mình có 1 vấn đề nhờ a e trên diễn đàn giúp với. Mình sử dụng lệnh Qdim ( cad minh 2020, chắc lệnh này cad đời cao mới có) nên nó xuất hiện vài dimension có giá trị bằng 0 ( measurement =0). Và click từng cái để delete đi thì lâu, dùng lệnh FI thì không lọc được đối tượng đó. 

    - Mình muốn delete các dimension có giá trị bằng 0 đó 1 cách nhanh nhất. ( gõ lệnh 1 phát là nó tự chọn các dimension có giá trị bằng 0, chỉ việc delete đi thôi ạ )

    - Cảm ơn a e/ ( p/s: nếu lisp này đơn giản thì cho mình xin, còn nếu phức tạp thì mình xin gửi mấy cốc cafe )

    1.jpg

    Đang cafe rảnh code cho bạn không biết ok không ? Chủ thớt test nhé. 

    (defun c:test  (/)
  (vl-load-com)
  (vlax-for x  (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))
    (if (and
          (member (vla-get-ObjectName x) '("AcDbRotatedDimension"))
          (= (vla-get-measurement x) 0.0)
          )
      (vla-delete x)
      )
    )
  )

     

  11. Đã đăng · Trả lời báo cáo

    9 giờ trước, monavamonava đã nói:

    Chào các bác. Em có bản vẽ này khi xem thì bình thường nhưng thao tác các lệnh như hatch, edit text, chọn đối tượng... thì nó bị đơ và giật lag. Mong được sự hỗ trợ từ mọi người

    https://drive.google.com/open?id=1CLlmppkAKGygXEAfFNos7_myHACfg_Ww

     

    Máy mình mở vẫn bình thường không thấy hiện tượng gì. Chắc máy bạn phải nâng cấp. ^_^

  13. Đã đăng · Trả lời báo cáo

    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)
  )

     

    • Like 1

  15. Đã đăng · Trả lời báo cáo

    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. ^_^

  16. Đã đăng · Trả lời báo cáo

    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

     

    • Like 1

  17. Đã đăng · Trả lời báo cáo

    8 giờ trước, hoanq đã nói:

    Chào các bạn!

    - Mình có 1 lisp sử dụng lệnh sao chép hatch (lệnh tắt là hoc), mình chèn thêm code giới hạn 2 ngày sử dụng (copy trên mạng), tuy nhiên lisp mình vẫn thực hiện lệnh nhưng không bị giới hạn ngày sử dụng(trong lisp để mặc định giới hạn 2 ngày sử dụng). Vậy các bạn giúp đỡ mình chỉnh sửa code để giới hạn được số ngày sử dụng với!

    Mình cảm ơn(hi vọng các bạn sẽ trả lời mình hoặc giúp đỡ mail cho mình nqhoa89@gmail.com)

    hoc.lsp

    Đây là 1 hướng tham khảo:

    - Check date ngày hôm nay

    - Ktra key xem có chưa (đã write registry, hoặc trong 1 file txt nào đó...)

    - Nếu có rồi thì so sánh ngày--> thỏa mãn dk thì cho chạy program, nếu không thì không chạy program

    - Nếu chưa có thì write registry và cho chạy program.

     

    Hê hê đây là mình đọc cái lisp của bạn kết hợp thêm suy nghĩ thoai. Còn lại thì với lisp mình chẳng phải đặt cái này ^_^ , trình còi nên không phải dùng cái này.

     

    • Like 1

  20. Đã đăng · Trả lời báo cáo

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

    Do em không in Layout bao giờ nên k có bản vẽ mẫu để test bác ạ

    In model thì dùng cho biến đổi kiểu VN quy mô nhóm nhỏ sài cái Lsp thế này là được rồi. :-)

     

    In Layout sẽ kết hợp với XREF ...... hệ thống quy mô lớn khoảng vài chục đến vài trăm nhân lực cùng chạy 1 dự án. Mà cái này thì có Publish rồi nên cũng không cần viết thêm làm gì cho mất công. :)

     

     

  24. Đã đăng · Trả lời báo cáo

    8 giờ trước, Nguyễn Minh Chương đã nói:

    Xuất ra vị trí tùy ý khi mình dùng chuột chọn vị trí đó, VD: khi mình chọn xong các đường để đo, space rồi nhập chuột trái 1 vị trí bất kỳ thì text tổng độ dài nó xuất hiện ở vị trí đó.

    Còn to nhỏ thì không thành vấn đề, chỉ cần nhìn thấy là được rồi.

    Cảm ơn bạn.

    Ok đã chỉnh nhé. ^_^ 

    (defun c:cc  (/ ss tl n ent itm obj l txt)
  (setq ss (ssget)
        tl 0
        n  (1- (sslength ss)))
  (while (>= n 0)
    (setq ent (entget (setq itm (ssname ss n)))
          obj (cdr (assoc 0 ent))
          l   (cond
                ((= obj "LINE")
                 (distance (cdr (assoc 10 ent)) (cdr (assoc 11 ent))))
                ((= obj "ARC")
                 (* (cdr (assoc 40 ent))
                    (if (minusp (setq l (- (cdr (assoc 51 ent))
                                           (cdr (assoc 50 ent)))))
                      (+ pi pi l)
                      l)))
                ((or (= obj "CIRCLE")
                     (= obj "SPLINE")
                     (= obj "POLYLINE")
                     (= obj "LWPOLYLINE")
                     (= obj "ELLIPSE"))
                 (command "_.area" "_o" itm)
                 (getvar "perimeter"))
                (t 0))
          tl  (+ tl l)
          n   (1- n)))

  (entmake
    (list
      (cons 0 "TEXT")
      (cons 100 "AcDbText")
      (cons 10 (trans (getpoint "\nCh\U+1ECDn v\U+1ECB trí \U+0111\U+1EB7t text: ") 1 0))
      (cons 40 (getvar 'TEXTSIZE))
      (cons 1 (strcat "L= " (rtos tl 2 0) " mm"))
      (cons 50 0.0)
      (cons 62 4)      
      )
    )
  (princ)
  )

     

  25. Đã đăng · Trả lời báo cáo

    11 giờ trước, Nguyễn Minh Chương đã nói:

    Cảm ơn bạn "Bee" rất nhiều, mình ko biết làm sao để đính kèm bình luận trên, hjhjhj

    Bạn "Bee" cho mình hỏi tí, là làm sao để lệnh lisp đó nó xuất kết quả ra thành text luôn không cần phải ghi đè kết quả đó lên 1 text có sẵn.

    Cảm ơn bạn rất nhiều.

    Xuất thành text ở vị trí nào ? to hay nhỏ theo cỡ nào ? Phải xác định được các cái đó thì xuất text đơn giản thôi ^_^

×