Jump to content
InfoFile
Tác giả: TRUNGNGAMY
Bài viết gốc: 337790
Tên lệnh: tgpl
(Yêu cầu) Lisp tìm tất cả phần giao của polyline trong 1 polyline khác

 

Bác TrungNgaMy sử dụng Lisp này nhé:

(defun c:tgpl(/ e1 e2 Region lst-p lst-tam lst-line)
  (if (setq e1 (car...
>>

 

Bác TrungNgaMy sử dụng Lisp này nhé:

(defun c:tgpl(/ e1 e2 Region lst-p lst-tam lst-line)
  (if (setq e1 (car (entsel "\n Chon PLINE 1 :")))
    (if (setq e2 (car (entsel "\n Chon PLINE 2 :")))
      (progn
            (setq Region (vlax-invoke (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)))
                                                  'addregion (list (vlax-ename->vla-object e1) (vlax-ename->vla-object e2)))
            )
            (vla-Boolean (car region) 1 (cadr region))
            (setq lst-line (vlax-invoke (vlax-ename->vla-object (entlast)) 'explode))
            (if (/= (cdr(assoc 0 (entget (entlast)))) "LINE")
                                    (setq lst-line (mapcar '(lambda(x) (vlax-invoke x 'explode)) lst-line))
            )
            (setq lst-p nil lst-tam nil)
            (if (null (eq (type (car lst-line)) 'LIST)) (setq lst-line (list lst-line)))
            (foreach x lst-line
              (foreach y x
                (setq lst-tam (append lst-tam (list (vlax-get y 'startpoint)(vlax-get y 'endpoint))))
                (vla-highlight y :vlax-true)
              )
              (setq lst-tam (Tue-list-removetrung lst-tam))
              (setq lst-p (append lst-p (list lst-tam)) lst-tam nil)
            )
     )
     )
   )
  lst-p
)
(defun Tue-list-removetrung (lst / lst1)
  (foreach x lst
      (if (not (member x lst1)) (setq lst1 (append lst1 (list x))))
      (Progn
              (foreach y lst1
                 (if (equal y x 1.0e-8)
                    (setq lst1 (vl-remove y lst1))
                 )
               )
                        (setq lst1 (append lst1 (list x)) )
       )
    )
  lst1
)

Cám ơn Tue_NV.

Đôi lúc mình cứ băn khoăn tại sao cũng biết Lisp mà cứ hay nhờ đến các bạn. Đến khi đọc Lisp các bạn viết rồi thì giải tỏa ngay đc băn khoăn của mình. Các bạn toàn dùng những hàm mới mình chưa từng biết và cũng khá khó hiểu khi đọc nó. Mình đã thử Lisp của bạn trên cả pl toàn line và khi có arc đều đúng. Khi nào rãnh, bạn cho mình hỏi lý:

- cái danh sách tọa độ trả về đúng cho tất cả mọi trường hợp hay chỉ đúng khi pl toàn line

- nếu dùng cái danh sách đó để tính diện tích (bằng công thức tọa độ) thì có đúng kg khi pl có arc ....

- làm thế nào bạn có thể vẽ lại hình dáng của nó khi có cả arc.

** Trường hợp trong pl thứ 2 (pl thứ nhất vẫn làm chuẩn giới hạn) có 1 vài pl nhỏ (kiểu pl có lỗ thủng) thì có giải quyết đc kg bạn

 

@quangnguyen50 : mình đã xem Lisp và tham khảo đường dẫn của bạn chỉ, có lẽ mình se nghiên cứu từ từ vì trên đó chỉ có hàm nên kg thửa ngay đc. Cám ơn bạn


<<

Filename: 337790_tgpl.lsp
Tác giả: trinhngoctri
Bài viết gốc: 305662
Tên lệnh: getpr
HỎI>Cách xuất tọa độ file cad sang text

 

Hề hề hề,

Chả biết cái bạn cần có giống cái này không??? Song do bạn trình bày hơi ..... tiết kiệm nên mình...

>>

 

Hề hề hề,

Chả biết cái bạn cần có giống cái này không??? Song do bạn trình bày hơi ..... tiết kiệm nên mình chỉ có thể đoán mò, Trúng thì là hên xui, trật thì là cái để bạn có thể rút kinh nghiệm trình bày sao cho người đọc khỏi phải ..... mò.

 
(defun c:getpr (/ ssl fn fw els name lay col txt p1 p2 pt x y z x1 x2 y1 y2 z1 z2 bk )
(setq ssl (acet-ss-to-list (ssget))
          fn (getfiled "Chon file de save" "" "txt" 1)
          fw (open fn "w") )
(princ " Bang liet ke thuoc tinh co ban cua doi tuong \n " fw)
(foreach en ssl
       (setq els (entget en)
                 name (cdr (assoc 0 els))
                 lay (cdr (assoc 8 els))
                 col (if (assoc 62 els) (rtos (cdr (assoc 62 els)) 2 0) (rtos (cdr (assoc 62 (tblsearch "layer" lay))) 2 0))
                 txt (strcat name "," lay "," col )
        ) 
       (cond
               ((= name "LINE") (setq p1 (cdr (assoc 10 els))  p2 (cdr (assoc 11 els))
                                                       x1 (rtos (car p1) 2 2)  x2 (rtos (car p2) 2 2)
                                                       y1 (rtos (cadr p1) 2 2)  y2 (rtos (cadr p2) 2 2)
                                                       z1 (rtos (caddr p1) 2 2)  z2 (rtos (caddr p2) 2 2)
                                                      txt (strcat txt "," x1 "," y1 "," z1 "," x2 "," y2 "," z2) ) )
               ((= name "CIRCLE") (setq bk (rtos (cdr (assoc 40 els)) 2 2)  pt (cdr (assoc 10 els))
                                                      x (rtos (car pt) 2 2) y (rtos (cadr pt) 2 2) z (rtos (caddr pt) 2 2)
                                                      txt (strcat txt ","  bk  "," x "," y "," z) ) )
               ((= name "LWPOLYLINE") (foreach el els
                                                                    (if (= (car el) 10)
                                                                        (progn
                                                                              (setq  z (rtos (cdr (assoc 38 els)) 2 2)
                                                                                         x (rtos (cadr el) 2 2) y (rtos (caddr el) 2 2)
                                                                                        txt (strcat txt ","  x  ","  y  ","  z) )                                                                              
                                                                        )
                                                                     )
                                                                  ) )
              ((= name "POLYLINE") (setq en (entnext en))
                                                      (while (/= (cdr (assoc 0 (entget en))) "SEQEND")
                                                                 (setq x (rtos (cadr (assoc 10 (entget en))) 2 2)
                                                                           y (rtos (caddr (assoc 10 (entget en))) 2 2)
                                                                           z (rtos (cadddr (assoc 10 (entget en))) 2 2)
                                                                          txt (strcat txt ","  x  ","  y  ","  z)
                                                                          en (entget en) ) ) )
              (T nil)
        )
               
        
        (princ (strcat txt "\n") fw)
)
(close fw)
(princ)
)
      
Cái này mình cóp pi, nhặt mót của các bác trên diễn đàn, mỗi người một tí, rồi ghép lại để bạn xài tạm. Tuy chưa được ngay ngắn lắm, nhưng thôi thì của nhà trồng được, bạn hẵng xơi tạm cho đỡ nóng ruột nhé.

Hề hề hề,..

cái lisp này mình dùng ổn rồi nhưng mình cần 3 số lẻ thì làm thế nào hả các bạn


<<

Filename: 305662_getpr.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 108434
Tên lệnh: test
Có cách nào lấy dữ liệu và chỉnh sửa đối tượng PROXY
Chào VUVUZELA

Ngoài lề 1 chút, VUVUZELA có ai "chống lưng" không vậy ?

(do mở cùng một vấn đề trên nhiều topic khác nhau nhưng chẳng thấy Mod nào lên...

>>
Chào VUVUZELA

Ngoài lề 1 chút, VUVUZELA có ai "chống lưng" không vậy ?

(do mở cùng một vấn đề trên nhiều topic khác nhau nhưng chẳng thấy Mod nào lên tiếng !

hề hề : chắc sợ FIFA can thiệp ...)

 

Trở lại chủ đề chính, không phải là tui không nói sớm, mà là do cách đặt vấn đề của VUVUZELA.

- bài viết đầu tiên Vuvuzela hỏi : Có cách nào để tìm điểm gốc đặt vị trí của PROXY ? Thú thực cho đến bây giờ tôi chưa biết cách tìm điểm gốc đặt vị trí của PROXY, nên không thể trả lời đuợc.

- tuy nhiên với cách tiếp cận : tìm và xoá các đối tượng nằm gần nhau dưới 1 khoảng cách thì vấn đề lại khác.

 

Yêu cầu của bạn tuơng tự như yêu cầu : xoá text trong khoảng nhất định của NDBNGO http://www.cadviet.com/forum/index.php?showtopic=23110

Vấn đề ở đây là tìm đuờng bao của PROXY (mở rộng : tìm đuờng bao của tất cả đối tuợng).

Trên cơ sở đuờng bao của các PROXY, nếu đối tuợng có giao với đuờng bao -> xóa đối tuợng đó.

 

Vì Vuvuzela đã biết lập trình nên tôi chỉ giới thiệu hàm tính đuờng bao của PROXY (mở rộng cho tất cả đối tuợng)

Các buớc kế tiếp, tham khảo Lisp xoá text trong khoảng nhất định

 

Code hàm tính đuờng bao của đối tuợng:

(defun lstBound (ent / lst ll ur)
 (vla-GetBoundingBox (vlax-Ename->Vla-Object ent) 'll 'ur)
 (setq ll (safearray-value ll)
ur (safearray-value ur)
lst (list (list (car ll) (cadr ll))
	  (list (car ll) (cadr ur))
	  (list (car ur) (cadr ur))
	  (list (car ur) (cadr ll)))))

(defun C:test (/ ent lstRec)
 (setq ent (car (entsel "\nSelect object:"))
lstRec (lstBound ent))
 (vla-put-Closed
   (vla-AddLightWeightPolyline (vla-get-modelspace (vla-get-ActiveDocument (vlax-get-Acad-Object)))
     (vlax-make-variant
(vlax-safearray-fill
  (vlax-make-safearray vlax-vbDouble (cons 0 (1- (* 2 (length lstRec)))))
  (apply (function append) lstRec))))
   :vlax-true)
 (princ)  )

Lọc lấy layer chứa proxy

- hàm chọn tất cả các Proxy (ssget (list (cons 0 "ACAD_PROXY_ENTITY")))

có tập chọn thì việc lấy layer chứa proxy là chuyện nhỏ với Vuvuzela ?!

 

Chúc bạn thành công và tiếp tục lăn bánh Bon ... on ... n

Chào bác Gia_bach,

Cái vụ lấy boundary của ACAD_PROXY_ENTITY này có thể dùng hàm (acet-ent-geomextents ent) hay hàm (acet-geom-ss-extents-fast ss) được không bác nhỉ???

Mình chưa phân biệt được sự khác nhau giữa hai loại hàm (acet-ent-geomextents ent) và hàm (vla-getboundingbox (vlax-ename->vla-object ent))

Một điều mình muốn hỏi thêm nữa là có thể thay (vla-getboundingbox (vlax-ename->vla-object ent)) bằng hàm (vlax-get-property (vlax-ename->vla-object ent) 'boundingbox) được không bác nhỉ?????


<<

Filename: 108434_test.lsp
Tác giả: jangboko
Bài viết gốc: 406110
Tên lệnh: mul sum
Nhờ Chỉnh Sửa Lisp Cộng Giá Trị Text Của Vật Tư Ngành Nước
 (defun CheckObj(e MyType) (equal (cdr (assoc 0 (entget e))) MyType))
;;;-----------------------------------------
(defun FilObj...
>>
 (defun CheckObj(e MyType) (equal (cdr (assoc 0 (entget e))) MyType))
;;;-----------------------------------------
(defun FilObj (ss1 MyType / ss2 i e)
(setq ss2 (ssadd)
i 0
)
(repeat (sslength ss1)
(setq e (ssname ss1 i)
i (1+ i)
)
(if (CheckObj e MyType)
(ssadd e ss2)
)
)
(eval ss2)
)
;;;-----------------------------------------
(defun SelData (/ OK)
(setq OK nil)
(while (not OK)
(prompt "\tChon cac text can tinh:")
(setq ss (FilObj (ssget) "TEXT"))
(if (> (sslength ss) 0)
(setq OK T)
(princ "\nDoi tuong chon khong phai text")
)
)
)
;;;-----------------------------------------
(defun WriteRes (kq / OK e data)
(setq OK nil)
(while (not OK)
(setq e (car (entsel "\tChon text ghi ket qua:")))
(if (CheckObj e "TEXT")
(setq OK T)
(princ "\nDoi tuong chon khong phai text")
)
)
(entmod (subst (cons 1 kq) (assoc 1 (setq data (entget e)))  data))
(princ)
)
 
(defun getchar(s)
(vl-list->string (vl-remove-if '(lambda(x) (<= 48 x 57)) (vl-string->list s)))
)
;;;-----------------------------------------
(defun C:MUL (/ i m e ss vt chu dv)
(SelData)
(setq i 0
m 1.0
)
(repeat (sslength ss)
(setq e (ssname ss i)
i (1+ i))
(if (setq vt (vl-string-search "- L" (setq chu (cdr (assoc 1 (entget e))))))
(setq m (* m (atof (substr chu (+ 4 vt)))))
)
(setq dv (getchar (substr chu (+ 4 vt))))
)
(WriteRes (strcat (rtos m) dv))
)
;;;-----------------------------------------
(defun C:SUM (/ i s e ss chu vt dv)
(SelData)
(setq i 0
s 0.0
)
(repeat (sslength ss)
(setq e (ssname ss i)
i (1+ i))
(if (setq vt (vl-string-search "- L" (setq chu (cdr (assoc 1 (entget e))))))
(setq s (+ s (atof (substr chu (+ 4 vt)))))
)
(setq dv (getchar (substr chu (+ 4 vt))))
)
(WriteRes (strcat (rtos s) dv))
)
 

Lisp này có tác dụng cộng các text có dạng D32 PVC - L150m, dùng để thống kê vật tư ngành nước. 

em lấy lisp này  của bác Tot77, trong bài viết: www.cadviet.com/forum/topic/164711-nho-cac-bac-chinh-sua-lai-lisp-cong-tong-text-cho-truong-hop-cua-em/

Em thấy lisp này hoạt động được trên file cad của tác giả, em viết đoạn text có cấu trúc giống tác giả thì lisp lại không hoạt động được, và có báo lỗi 

 
Command: sum
 Chon cac text can tinh:
Select objects: 1 found
 
Select objects: Specify opposite corner: 2 found, 3 total
 
Select objects:  ; error: bad argument type: numberp: nil
 
hề hề, cứ nhờ không các bác thế này cũng ngại, em đã lục tung diễn đàn lên mà không tìm thấy lisp nào tương tự, nên đành mặt dày làm kinh động đến các bác. Mong các bác giúp em.
Em xin cảm ơn các bác, chúc các bác luôn mạnh khỏe.

 


<<

Filename: 406110_mul_sum.lsp
Tác giả: aqx8
Bài viết gốc: 162428
Tên lệnh: dem
lisp thống kê sự xuất hiện của các đoạn thẳng

Lsp thì dùng thử cái này xem (lệnh DEM):

(defun C:DEM()
(princ "Chon cac doan thang can dem: ")
(setq ss (ssget '((0 ....
>>

Lsp thì dùng thử cái này xem (lệnh DEM):

(defun C:DEM()
(princ "Chon cac doan thang can dem: ")
(setq ss (ssget '((0 . "Line"))))
(setq so (sslength ss))
(alert (strcat "So doan thang la: " (itoa so)))
(princ))

Cám ơn bạn nhé, lisp rất hay.


<<

Filename: 162428_dem.lsp
Tác giả: phamthe
Bài viết gốc: 309597
Tên lệnh: left
Nhờ các anh sửa giúp lisp chuyển vị trí text sang trái (Justifi : Left)

 

Lisp chuyển điểm chèn về Left theo yêu cầu.

(defun c:left (/ i ss obj align pt)
  ;; By : Gia_Bach 2013 ;;
 ...
>>

 

Lisp chuyển điểm chèn về Left theo yêu cầu.

(defun c:left (/ i ss obj align pt)
  ;; By : Gia_Bach 2013 ;;
  (vl-load-com)
  (if (setq i -1 ss (ssget (list(cons 0 "TEXT")) ))
    (repeat (sslength ss)
      (setq obj (vlax-Ename->Vla-Object (ssname ss (setq i (1+ i)))))
      (if (/= (setq align (vla-get-Alignment obj)) 0)
	(progn
	  (setq pt (vla-get-textalignmentpoint obj))
	  (vla-put-alignment obj 0)
	  (vla-put-insertionpoint obj pt) ))))
  (princ))

Nhờ các anh giúp sửa đoạn code trên thêm 2 dòng này vào để đổi font Text và màu đối tượng Text chọn với ạ!

(command "style" "TEXT" "romans.shx" Hst "0.8" "" "" "" "")

(COMMAND "-LAYER" "m" "TEXT" "color" 4 "" "" "" ) 

;;;(command "style" "SoThua" "romans.shx" Hst "0.8" "" "" "" "")
;;;;(COMMAND "-LAYER" "m" "Diem mia" "color" 4 "" "" "" ) 

<<

Filename: 309597_left.lsp
Tác giả: huunhantvxdts
Bài viết gốc: 430068
Tên lệnh: dbao
Lisp tạo hình chữ nhật từ hai đường thẳng song song, so le
1 giờ} trướ}c, maxthien đã nói:

Mình gởi cái hình cho bạn xem...

>>
1 giờ} trướ}c, maxthien đã nói:

Mình gởi cái hình cho bạn xem thử, bản vẽ chắc ko cần đâu, cũng dễ hiểu mà. 

HỎI LISP.PNG

Rẻng rỗi làm tí cho vui

;; Selection Set Bounding Box  -  Lee Mac
;; sel -  Selection set for which to return bounding box
(defun LM:SSBoundingBox ( ss / i l1 l2 ll ur )
(repeat (setq i (sslength ss))
(vla-getboundingbox (vlax-ename->vla-object (ssname ss (setq i (1- i)))) 'll 'ur)
(setq l1 (cons (vlax-safearray->list ll) l1)
l2 (cons (vlax-safearray->list ur) l2)
)
)
(mapcar '(lambda ( a b ) (apply 'mapcar (cons a B))) '(min max) (list l1 l2))
)
(defun C:dbao (/ bb e h)
(prompt "\nChon doi tuong trong duong bao.")
(setq bb (LM:SSBoundingBox (ssget)))
  (if (not h1) (setq h1 10))
  (setq h (getstring (strcat "\nLay rong ra moi ben <" (rtos h1 2 2) ">")))
  (if (= h "") (setq h (rtos h1 2 2)))
  (setq h1 (atof h))
(setq e (entmakex
(list
(cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 4)
(cons 70 1)
(list 10 (- (caar bb) h1) (- (cadar bb) h1))
(list 10 (+ (caadr bb) h1) (- (cadar bb) h1))
(list 10 (+ (caadr bb) h1) (+ (cadadr bb) h1))
(list 10 (- (caar bb) h1)  (+ (cadadr bb) h1))
)
))
)

 


<<

Filename: 430068_dbao.lsp
Tác giả: hanh.phuc
Bài viết gốc: 430091
Tên lệnh: offcl
Vẽ đường tâm dầm trong bản vẽ mặt bằng dầm sàn [bản vẽ xây dựng]

OFFCL?

 

>>

OFFCL?

 

note, select a part, sslength = even number (even number)

làm thế nào để đưa màu sắc?

 

 
	(setq *sd* 0.0) 
(defun c:OFFCL (/ *error* ml m sd p1 2p e1 pair l en suml meanl oe dd)
	hanhphuc 13/10/2014
 
 (defun *error* (msg)
   (if    (not (wcmatch (strcase msg) "*CANCEL*,*EXIT*"))
     (princ (strcat "\nError: " msg))
     ) 
   (if    oe
     (setvar "cmdecho" oe)
     ) 
   (princ)
   ) 
 (setq oe (getvar "cmdecho"))
 (command "_UNDO" "be")
 (setvar "cmdecho" 0)
 (mapcar 'set
  '(suml meanl)
  '(((lst / ans l)
     (setq
      ans
      (car lst)
      l
      (cdr lst)
      )
     (while
      l
      (setq
       ans
       (mapcar '(lambda (a b) (float (+ a b))) ans (car l))
       l
       (cdr l)
       )
      )
     ans
     )
    ((lst /)
     (mapcar '(lambda (c) (/ c (length lst))) (suml lst)) 
     )
    ) 
  ) 
 (grtext -1 "command: OFFCL")
 (if (and (setq e (car (entsel "\nPick matched layer entity..")))
   (setq _layer (cdr (assoc 8 (entget e))))
   ) 
   (setq sd  (getdist
    (strcat "\nIgnore short length, approx < Between 0.0 to " (rtos *sd* 2 3) " > ? : ")
    )
  m   ((lambda (lay minx / ss l 2p d ap tmp l lst mp)
     (setq ss (ssget ":L" (list '(0 . "LINE") (cons 8 lay))))
     (if ss
       (foreach line (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
         (setq l   (entget line)
           2p  (mapcar '(lambda(p) (cdr (assoc p l))) '(10 11))
           2p  (apply 'if
                  (vl-list*    (apply '<= (mapcar 'abs (cdr (reverse (apply 'mapcar (cons '- 2p))))))
                    (mapcar '(lambda(f) (vl-sort 2p '(lambda(a b) (> (f a) (f b))))) (list car cadr))
                    ) 
                  )  
           d   (apply 'distance 2p)
           tmp 
               (mapcar '(lambda (u v) (setq l (subst (cons v u) (assoc v l) l)) (entmod l)) 2p '(10 11)) 
           lst (if (> d minx)
             (cons (vl-list* line (mapcar '(lambda(a b) (* (+ a b) 0.5)) (car 2p) (cadr 2p))) lst)
             lst
             ) 
           ) 
         (if (and (<= d minx))
           (entmakex (list '(0 . "CIRCLE")
                   '(8 . "SHORT_BROKEN") 
                   '(62 . 6)
                   (cons 10 (meanl 2p))
                   (cons 40 *sd*)
                   ) 
             ) 
           ) 
         ) 
       ) 
     lst 
     ) 
    _layer 
    (setq *sd* (if sd
             sd
             *sd*
             ) 
          ) 
    ) 
  len (length m)
  ) 
   ) 
 (repeat (if (= (logand len) 1)
    (1- len)
    len
    ) 
   (setq p1   (cdr (car m)) 
  e1   (caar m) 
  pair (car (vl-sort (setq d (mapcar '(lambda (x)
                    (list (car x) 
                          (cdr x) 
                          (distance p1 (cdr x))
                          ) 
                    ) 
                     (cdr m)
                     ) 
               ) 
             '(lambda(a b) (< (caddr a) (caddr b)))
             ) 
        ) 
  ) 
   (if    (and p1 pair) 
     (setq
    m  (vl-remove-if '(lambda(x) (= (car x) (car pair))) (cdr m))
    l  (mapcar '(lambda (i) (mapcar '(lambda(e) (cdr (assoc i (entget e)))) (list e1 (car pair))))
           '(10 11)
           ) 
    en (entmakex (vl-list* '(0 . "LINE")
               '(8 . "CENTER")
               '(62 . 1)
               (mapcar '(lambda(x i) (cons i (meanl x))) l '(10 11))
               ) 
         ) 
    dd (mapcar '(lambda(e) (vla-get-length (vlax-ename->vla-object e))) (list en e1 (car pair))) 
	    ) 
     ) 
  (if (< (car dd) (* 0.25 (apply '+ (cdr dd))))
    (redraw (entmakex (list '(0 . "CIRCLE")
             '(8 . "BAD CENTER")
             '(62 . 5)
             (cons 40 (* 0.25(car dd)))
             (cons 10 (meanl (mapcar '(lambda(i) (cdr (assoc i (entget en)))) '(10 11)))) 
             ) 
           ) 
     3
     ) 
    ) 
   
     (redraw en 3)
     
   ) 
 (command "_undo" "e")
 (setvar "cmdecho" oe)
 (princ)
 ) 
	(princ "\nOffset Center Line. Command: OFFCL")
(princ)
	

 

 

offcl.gif


<<

Filename: 430091_offcl.lsp
Tác giả: whatcholingon
Bài viết gốc: 169057
Tên lệnh: demo
Lisp cộng trừ text độ, phút, giây...

Bạn thử đoạn này xem, bạn có thể dùng cho mọi định dạng.

 


(defun c:demo (/ e1 e2)
(defun s2d (str / ret)
...
>>

Bạn thử đoạn này xem, bạn có thể dùng cho mọi định dạng.

 


(defun c:demo (/ e1 e2)
(defun s2d (str / ret)
 (setq ret
 (vl-list->string
(vl-remove-if
 	'(lambda (x) (or (< x 48) (> x 57)))
 	(reverse (vl-string->list str))
)
 )
 )
 (angtof
(vl-list->string
 	(reverse
(vl-string->list
(strcat "\"" (substr ret 1 2) "'" (substr ret 3 2) "d" (substr ret 5))
   	)
 	)
)
 )
)
(if
 (and
(setq e1 (ssget "+.:S:N" '((0 . "TEXT"))))
(setq e2 (ssget "+.:S:N" '((0 . "TEXT"))))
 )
(alert  (angtos
  	(+
  	(s2d (cdr (assoc 1 (entget (ssname e1 0)))))
  	(s2d (cdr (assoc 1 (entget (ssname e2 0)))))
  	)
 	1 4)
 )
 )
 )

 

Mình text thử thấy báo như sau:

untitled_65.jpg

Hình như là kết quả ko đúng bạn à.

bạn có thể sửa: chọn text 1 ==> cộng (+) or trừ (-) ==> chọn text 2 ==> kết quả được ko?

Thanks!


<<

Filename: 169057_demo.lsp
Tác giả: vietanh2108
Bài viết gốc: 430105
Tên lệnh: find-att
Chọn các đối tượng trong lisp

Chào các bác, em tìm lisp này nhưng muốn nhờ mọi người sửa 1 chút. Lisp có chức năng tìm kiếm Att với nội dung cụ thể trong bản vẽ.

1/ Sau khi tìm được các đội tượng -> Thêm chức năng Add các đối tượng đã tìm đc vào Selection set hiện hành nếu bấm ESC để thoát lệnh.

2/ Nếu mở rộng chức năng tìm...

>>

Chào các bác, em tìm lisp này nhưng muốn nhờ mọi người sửa 1 chút. Lisp có chức năng tìm kiếm Att với nội dung cụ thể trong bản vẽ.

1/ Sau khi tìm được các đội tượng -> Thêm chức năng Add các đối tượng đã tìm đc vào Selection set hiện hành nếu bấm ESC để thoát lệnh.

2/ Nếu mở rộng chức năng tìm được cả TEXT, MTEXT thì tốt quá.

Em xin cám ơn trước!

(defun c:find-att (/ ov ss i en ed an ad ah)
  (while (not ov)
         (setq ov (getstring t "\nATTRIB Value To Search For:   ")))

  (and (setq ss (ssget "X" (list (cons 0 "INSERT")
                                 (cons 66 1)
                                 (if (getvar "CTAB")
                                     (cons 410 (getvar "CTAB"))
                                     (cons 67 (- 1 (getvar "TILEMODE")))))))
       (setq i (sslength ss))
       (while (not (minusp (setq i (1- i))))
              (setq en (ssname ss i)
                    ed (entget en)
                    an (entnext en))
              (while (/= "SEQEND" (cdr (assoc 0 (entget an))))
                     (setq ad (entget an)
                           ah (cdr (assoc 40 ad))
                           an (entnext an))
                     (if (= (strcase ov)
                            (strcase (cdr (assoc 1 ad))))
                         (progn
                            (command "_.ZOOM" "_C" (cdr (assoc 10 ed)) (* ah 66))
                            ;(redraw en 3)
                            (getstring "\nPress Enter To Continue Searching..."))))))
  ;(redraw)
  (prin1))

 


<<

Filename: 430105_find-att.lsp
Tác giả: hai49c2
Bài viết gốc: 241566
Tên lệnh: xtd
lisp xuat tọa độ có điều kiện

 

Vì không có thời gian nên không xử lý lỗi nếu chọn sai đối tượng.

Khi chọn pline, pick vào gần điểm bắt đầu

>>

 

Vì không có thời gian nên không xử lý lỗi nếu chọn sai đối tượng.

Khi chọn pline, pick vào gần điểm bắt đầu

(vl-load-com)
(defun Dxf(n e) (cdr (assoc n e)))
(defun C:XTD ( / d en es f fz g i k l lh lk ls ob p st v) ; xuat toa do
    (setq es (entsel "\nChon duong polyline ") ob (vlax-ename->vla-object (car es)) p (cadr es))
    (setq st (vlax-curve-getStartPoint ob) en (vlax-curve-getEndPoint ob))
    (setq l (vlax-curve-getDistAtParam ob (vlax-curve-getEndParam ob)) d 0)
    (setq fz 0.001) ; sai so lam tron k/c
    (if (< (distance p st) (distance p en))
        (setq d 0 k 1)
        (setq d l k -1)
    )
    (princ "\nChon text :")
    (setq ls (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "TEXT") ))))))
    (foreach e ls
        (setq g (entget e) v (list (car (Dxf 10 g)) (Dxf 1 g)))
        (if (= 0 (Dxf 50 g))
            (setq lk (cons v lk))
            (setq lh (cons v lh))
        ))
    (setq    lk (vl-sort lk (function (lambda (e1 e2) (< (car e1) (car e2))))))
    (setq    lh (vl-sort lh (function (lambda (e1 e2) (< (car e1) (car e2))))))
    (setq f (open (strcat (getvar "DWGPREFIX") "Toado.txt") "w") i 0)
    (write-line "X\tY\t\H" f)
    (while (and (nth i lh) (< d (+ l fz)) (>= d (- fz)))
        (if (equal d 0 fz) (setq p st)
            (if (equal d l fz) (setq p en)
                (setq p (vlax-curve-getPointAtDist ob d))))
        (write-line (strcat (rtos (cadr p) 2 3) "\t"(rtos (car p) 2 3) "\t" (cadr(nth i lh))) f)
        (setq d (+ d (* k (atof (cadr(nth i lk))))) i (1+ i))
    )
    (close f)
)

Cảm ơn bạn rất nhiều, Phiền bạn chỉnh giúp mình 1 chút, là chuyển về đúng toạ độ X Y của cad, trong file yêu cầu cũ  mình lại chuyển toạ độ X sang Y và Y sang X.

Chúc bạn mạnh khoẻ và hạn phúc.


<<

Filename: 241566_xtd.lsp
Tác giả: phuhvp
Bài viết gốc: 396192
Tên lệnh: tt%C2%A0
Lisp điền cao độ bị lỗi!!!

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

(defun c:tt  (/ xuat_kq elv ent lsp lst-l lst-r lsw txt x y sep)
 (defun xuat_kq  (str...
>>

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

(defun c:tt  (/ xuat_kq elv ent lsp lst-l lst-r lsw txt x y sep)
 (defun xuat_kq  (str lst / filename fn i)
  (setq i 1)
  (setq filename (strcat (getvar 'dwgprefix) (getvar 'dwgname) ".txt"))
  (or (findfile fileName) (progn (setq fn (open fileName "w")) (close fn)))
  (setq fn (open fileName "a"))
  (princ (strcat "\n" (write-line str fn)))
  (foreach x  lst
   (princ (strcat "\n" (write-line (strcat (itoa i) sep (car x) sep (cadr x)) fn)))
   (setq i (1+ i)))
  (close fn))
 (setq sep "\t")
 (while (and (setq ent (car (entsel "\nChon Pline trac ngang: ")))
             (wcmatch (cdr (assoc 0 (entget ent))) "*POLYLINE")
             (not (redraw ent 3))
             (setq txt (car (entsel "\nChon Text cao do tim duong: ")))
             (wcmatch (cdr (assoc 0 (entget txt))) "*TEXT")
             (not (redraw ent 4))
             (setq elv (distof (cdr (assoc 1 (entget txt))) 2)))
  (setq lsp (acet-geom-vertex-list ent))
  (foreach pt  lsp
   (setq x (car pt)
         y (+ (cadr pt) elv))
   (cond ((< x 0) (setq lst-l (cons (list (rtos (abs x) 2 2) (rtos y 2 2)) lst-l)))
         ((> x 0) (setq lst-r (cons (list (rtos x 2 2) (rtos y 2 2)) lst-r)))))
  (xuat_kq (strcat "\nSTT" sep "K.cach" sep "Cao do\nBen trai:") lst-l)
  (xuat_kq "Ben phai:" (reverse lst-r))
  (setq lst-l nil
        lst-r nil))
(and ent (redraw ent 4))
 (princ "\nLisp created By QuocManh04tt-CadViet.com!")
 (princ))

P/s:

1​. Lsp xuất ra file .txt nằm cùng thư mục với file .dwg hiện hành.

2. Muốn xuất file .csv thì tìm trong lsp thay ".txt" bằng ".csv", ngăn cách giữa STT, K.cach, caodo bằng dấu ";" thì thay dòng:  (setq sep "\t") bằng dòng này:  (setq sep ";").

3. => Copy sẽ tốt hơn download ...

Trước tiên xin cảm ơn bạn quocmanh04tt rất nhiều đã giúp mình

Bạn cho mình hỏi sao mình load lisp làm theo hướng dẫn rồi mà mình ko thấy có xuất ra tệp .txt nào cả, và mình cũng thử thay .scv vào mà vẫn ko thấy ra file nào cả. và mình muốn nó xuất ra csv theo dạng:

k.cách    cao độ

X1              Y1

X2              Y2

.....              ....

.....              ....

giống như file xuất ra từ lisp của mình đưa ra ở trên đó bạn, ra file .xls giống lisp mình càng tốt

Một lần nữa cảm ơn bạn rất nhiều và mong bạn bỏ ra ít thời gian chỉnh dùm mình tks


<<

Filename: 396192_tt%C2%A0.lsp
Tác giả: CUONG20051982
Bài viết gốc: 213017
Tên lệnh: stre
Lisp stretch nhóm đối tượng 2 phía vào giữa và xung quanh vào tâm

TH1 : Làm 2 lần sẽ lâu hơn làm 1 lần. Nhưng lâu hơn chẳng bao nhiêu thời gian

Nếu bạn thích thì code đây:

>>

TH1 : Làm 2 lần sẽ lâu hơn làm 1 lần. Nhưng lâu hơn chẳng bao nhiêu thời gian

Nếu bạn thích thì code đây:

(defun c:stre(/ di p1 p3)
 (setq di (getdist "\n Khoang cach dich chuyen :"))
 (command "stretch" "c"  (setq p1 (getpoint "\n P1 :")) (getcorner p1 "\n P2 :") ""
  	'(0 0 0) (list di 0 0)
  	"stretch" "c"  (setq p3 (getpoint "\n P3 :")) (getcorner p3 "\n P4 :") ""
  	'(0 0 0) (list (- di) 0 0)) )

TH2: Bạn dùng Block Dynamic hoặc dùng lệnh ARRAY của CAD2012 thì chỉ việc pick chọn, kéo và kéo là xong

Nhanh hơn cả khi viết Lisp phải chọn tâm và lọc chọn đối tượng

 

Cảm ơn Tue_NV nhiều! Lisp này của bạn đã giải quyết được vấn về tuy nhiên để hoàn thiện hơn bạn có thể sửa để khi nhập khoảng cách dịch chuyển là dương sẽ giãn ra và giá trị âm sẽ thu vào không phải phụ thuộc vào lựa chon nhóm nào trước. và có thể sử dụng stretch cho cả theo trục Y nữa thì tốt.

 

P/s: Với TH2 là quyét chọn chứ nhỉ chứ pick chọn thì chỉ chọn được từng đối tượng một thôi. Lệnh Array mà phát triển hay vậy chứ. tiếc là mình chưa cài CAD2012 để thử. nếu down về chắc nhiều file lâu lắm mà không chắc đã down được hoàn thiện.


<<

Filename: 213017_stre.lsp
Tác giả: huunhantvxdts
Bài viết gốc: 430198
Tên lệnh: cld
Em xin trợ giúp kết hợp lisp OCA, AE và TT vào một lisp
4 giờ trước, quocmanh04tt đã nói:

+ Ông chủ thì muốn ghép...

>>
4 giờ trước, quocmanh04tt đã nói:

+ Ông chủ thì muốn ghép lại thành 1 lệnh - Chức năng của lệnh: Khi copy cái Block đó đặt vào trong lô đất, được cái Block mới, có 2 att giá trị của nó thay đổi.

1 là số hiệu lô đất, 2 là diện tích lô đất.

+ Đầy tớ thì bảo dễ, copy nội dung của lisp này bỏ vào lisp khác.

+ Mình nghĩ với người mới học lisp mà làm yêu cầu trên cũng hơi vất vả.

Vất vã để học hỏi thêm 1 tí. có chi bác @quocmanh04tt giúp đở thêm 

(defun ChangeTagVal (obj tagName val)
  (setq obj(vlax-ename->vla-object obj))
  (foreach att (vlax-invoke obj 'GetAttributes)
    (if (= tagName (vla-get-tagstring att))
      (progn
	(vla-put-textstring att val)
	(vla-update att)))
  )
)
(defun C:CLD (/ STT lodat thongtin kyhieu diendat diemtruoc)
(command "undo" "be")
(setq STT1 STT2)
(if (not STT1) (setq STT1 "So lo bat dau"))
(setq STT (getstring (strcat "\nSo lo bat dau <" STT1 ">")))
(if (= STT "") (setq STT STT1))
(setq lodat (entsel "\nChon BLock dien ky hieu"))
(setq thongtin (car lodat))
(while
 	 (or
   	 (null lodat)
   	 (/= "INSERT" (cdr (assoc 0 (entget (car lodat)))))
	 )
	(princ "\nDoi tuong khong phai la Block! Chon lai")
 	(setq lodat (entsel "\nChon BLock dien ky hieu"))
	(setq thongtin (car lodat))
	)
(setq kyhieu (strcat "KL06-" STT))
(setq diendat (getpoint (cadr lodat) "\nPick diem dat:"))
(command "bhatch" diendat "")
(Command "area" "o" (entlast))
(command "_.erase" (entlast) "")
(command ".MOVE" (car lodat) "" (cadr lodat) diendat "")
(ChangeTagVal thongtin "TENLODAT" kyhieu)
(ChangeTagVal thongtin "DIENTICH" (rtos (getvar "area") 2 1))
(setq diemtruoc diendat)
(while (setq diendat (getpoint diemtruoc "\nPick diem dat:"))
(setq STT (+ (atoi STT) 1))
(setq STT2 (rtos STT 2 0))
(command "bhatch" diendat "")
(Command "area" "o" (entlast))
(command "_.erase" (entlast) "")
(command ".COPY" (car lodat) "" diemtruoc diendat "")
(setq thongtin (entlast))
(setq kyhieu (strcat "KL06-" (rtos STT 2 0)))
(ChangeTagVal thongtin "TENLODAT" kyhieu)
(ChangeTagVal thongtin "DIENTICH" (rtos (getvar "area") 2 1))
(setq STT STT2)
)
(command "undo" "end")
(princ)
)

 


<<

Filename: 430198_cld.lsp
Tác giả: proconeng86
Bài viết gốc: 310756
Tên lệnh: vps
lisp tạo tỉ lệ cho viewport bên layout

 

Quick code và không bắt lỗi, bạn dùng tạm. Có tỉ lệ nào thì bạn thêm vào mục Scale

Code có sử dụng hàm LM:Listbox của LeeMac...

>>

 

Quick code và không bắt lỗi, bạn dùng tạm. Có tỉ lệ nào thì bạn thêm vào mục Scale

Code có sử dụng hàm LM:Listbox của LeeMac cho nhanh

 

(vl-load-com)
(defun c:vps(/ l sc LM:ListBox)	
	;; Private function :
	(defun LM:ListBox ( title data multiple / file tmp dch return ) 
	  (cond
		(
		  (not
			(and (setq file (open (setq tmp (vl-filename-mktemp nil nil ".dcl")) "w"))
			  (write-line
				(strcat "listbox : dialog { label = \"" title
				  "\"; spacer; : list_box { key = \"list\"; multiple_select = "
				  (if multiple "true" "false") "; } spacer; ok_cancel;}"
				)
				file
			  )
			  (not (close file)) (< 0 (setq dch (load_dialog tmp))) (new_dialog "listbox" dch)
			)
		  )
		)
		(
		  t     
		  (start_list "list")
		  (mapcar 'add_list data) (end_list)

		  (setq return (set_tile "list" "0"))
		  (action_tile "list" "(setq return $value)")

		  (setq return
			(if (= 1 (start_dialog))
			  (mapcar '(lambda ( x ) (nth x data)) (read (strcat "(" return ")")))
			)
		  )          
		)
	  )
	  (if (< 0 dch) (unload_dialog dch))
	  (if (setq tmp (findfile tmp)) (vl-file-delete tmp))
	  return
	)
	;Main
	(ssget '((0 . "VIEWPORT")))
	(setq l '("1/2" "1/5" "1/10"))			;Scale them o day
	(setq sc (distof (car (LM:listbox "Select Scale :" l nil))))
	(vlax-for vp	(vla-get-activeselectionset (vla-get-activedocument (vlax-get-acad-object)))
		(vla-put-DisplayLocked vp 0)
		(vla-put-CustomScale vp sc)
	)
)

 

 

Mình dùng thử và thấy lisp này thế là phù hợp với mình rồi

Cám ơn bạn ketxu nhiều nhé :D


<<

Filename: 310756_vps.lsp
Tác giả: ketxu
Bài viết gốc: 430229
Tên lệnh: foo
Em xin trợ giúp kết hợp lisp OCA, AE và TT vào một lisp

Viết cho khỏi quên :( Tôi biết là với mỗi tiện ích này, các bạn sẽ làm công việc nhanh gấp trăm lần, nhưng số người quay lại tri ân anh em viết lisp chả có mấy :))

 

(defun c:foo(/ bn ld as lt 2v 3d e p p1 p2 _att a en)
(vl-load-com)
(setq bn "TKLD" ld "TENLODAT" as "DIENTICH" lt "TENBLOCK") ;Change by user
(or...
>>

Viết cho khỏi quên :( Tôi biết là với mỗi tiện ích này, các bạn sẽ làm công việc nhanh gấp trăm lần, nhưng số người quay lại tri ân anh em viết lisp chả có mấy :))

 

(defun c:foo(/ bn ld as lt 2v 3d e p p1 p2 _att a en)
(vl-load-com)
(setq bn "TKLD" ld "TENLODAT" as "DIENTICH" lt "TENBLOCK") ;Change by user
(or *st* (setq *st* 1))
(setq 2v vlax-ename->vla-object 3d vlax-3D-point)
(while (not (setq s (ssget "_+.:E:S" (list (cons 2 bn)))))(princ "\nMiss!"))
(setq 	e 		(2v (ssname s 0))
		*st* 	(cond ((getint (strcat "Start Number <" (itoa *st*) ">:")))(*st*))
		p 		(getpoint "\nBase point :")
		p1 (3d p)
		_att (lambda(b tag v / r)  
				(foreach at (vlax-invoke b 'GetAttributes)
					(if (eq tag (vla-get-TagString at))
					(setq r
						(if v (vla-put-textstring at v)
								(vla-get-textstring at)
						)
					)))
			r)
)
(while (setq p2 (acet-ss-drag-move s p "\nTo :"))
	(cond ((setq en (bpoly p2))
			(setq a (vla-get-area (2v en))) (entdel en)
			(vla-move (setq n (vla-copy e)) p1 (3d p2))
			(_att n ld 
				(strcat 
					(_att n lt nil) 
					(if (< *st* 10) "-0" "-")
					(itoa *st*)
				)
			)
			(_att n as (rtos a 2 2))
			(setq *st* (1+ *st*))
		)
	)
)
)

 


<<

Filename: 430229_foo.lsp
Tác giả: khaosat2009
Bài viết gốc: 74545
Tên lệnh: trichthua
trích do
Chào khaosat2009, Lisp cwb của bác Gia_bach viết rất tuyệt vời khi copy, xóa, move các đối tượng trong ngoài 1 vùng kín, hay giữa 2 vùng kín. Tuy nhiên, các đối tượng gốc bị...
>>
Chào khaosat2009, Lisp cwb của bác Gia_bach viết rất tuyệt vời khi copy, xóa, move các đối tượng trong ngoài 1 vùng kín, hay giữa 2 vùng kín. Tuy nhiên, các đối tượng gốc bị bẻ gãy hết. Lisp Thiep viết sau đây sẽ trích thửa bản đồ, theo 1 ô vuông có kích thước cạnh do user tự chọn.

Sau khi tạo ô vuông xong, user rê ô vuông này vào khu vực cần trích thửa, nó sẽ copy các đối tượng bên trong và giao với ô vuông (ô vuông giống như 1 nam châm). Sau đó, user rê các đối tượng này đến vị trí cần đặt, ví dụ đặt ở giữa bản vẽ TRÍCH ĐO ĐỊA CHÍNH THỬA ĐẤT. Lisp sẽ cắt bỏ những đường bên ngoài ô vuông.

;;;-----------------------
(defun SS-enlst	(ss / c L)
 (setq c -1)
 (repeat (sslength ss)
   (setq L (cons (ssname ss (setq c (1+ c))) L))
 )
 (reverse L)
)
;;;====================================================================
(defun break_with (Lstent enL /	lst masterlist ss oc break_obj intpts)
 (princ "\nCalculating Break Points, Please Wait.\n")

 ;;========================================
 ;; Break entity at break points in list
 ;;========================================

 (defun break_obj (ent	brkptlst   /	      brkobjlst	 en
		enttype	   maxparam   closedobj	 minparam
		obj	   obj2break  p1param	 p2param
		brkpt2	   dlst	      idx	 brkptS
		brkptE	   brkpt      result	 result
		ignore	   dist	      tmppt	 #ofpts
		enddist	   lastent    obj2break	 stdist
	       )
    (setq obj2break ent
   brkobjlst (list ent)
   enttype   (dxf 0 ent)
    )
   (if	(not (or (eq (dxf 0 obj2break) "TEXT")
	 (eq (dxf 0 obj2break) "MTEXT")
     )
)
     (setq closedobj (vlax-curve-isclosed obj2break))
   )
   (setq spt (vlax-curve-getstartpoint ent)
ept (vlax-curve-getendpoint ent)
brkptlst (vl-remove-if
'(lambda (x)
(or (< (distance x spt) 0.0001)
(< (distance x ept) 0.0001)
)
)
brkptlst
)
)
   (if	(and brkptlst
     (not (or (eq (dxf 0 obj2break) "TEXT")
	      (eq (dxf 0 obj2break) "MTEXT")
	  )
     )
)
     (progn
(setq brkptlst
       (mapcar
	 '(lambda (x)
	    (list
	      x
	      (vlax-curve-getdistatparam
		obj2break
		(cond
		  ((vlax-curve-getparamatpoint obj2break x)
		  )
		  ((vlax-curve-getparamatpoint
		     obj2break
		     (vlax-curve-getclosestpointto
		       obj2break
		       x
		     )
		   )
		  )
		)
	      )
	    )
	  )
	 brkptlst
       )
)

(setq
  brkptlst (vl-sort brkptlst
		    '(lambda (a1 a2) (< (cadr a1) (cadr a2)))
	   )
)

(foreach brkpt (reverse brkptlst)
    (setq brkptS (car brkpt)
	  brkptE brkptS
    )
  ;; get last entity created via break in case multiple breaks
  (if brkobjlst
    (progn
      (setq tmppt brkptS)	; use only one of the pair of breakpoints
      ;; if pt not on object x, switch objects
      (if (not (numberp	(vl-catch-all-apply
			  'vlax-curve-getdistatpoint
			  (list obj2break tmppt)
			)
	       )
	  )
	(progn			; find the one that pt is on
	  (setq idx (length brkobjlst))
	  (while
	    (and (not (minusp (setq idx (1- idx))))
		 (setq obj (nth idx brkobjlst))
		 (if (numberp (vl-catch-all-apply
				'vlax-curve-getdistatpoint
				(list obj tmppt)
			      )
		     )
		   (null (setq obj2break obj))
				; switch objects, null causes exit
		   t
		 )
	    )
	  )
	)
      )
    )
  ); end (if brkobjlst

  ;;; Handle any objects that can not be used with the Break Command
  ;;; using one point, gap of 0.000001 is used
  (if (not (or (eq (dxf 0 obj2break) "TEXT")
	       (eq (dxf 0 obj2break) "MTEXT")
	   )
      )
    (setq closedobj (vlax-curve-isclosed obj2break))
  )
;;; single breakpoint ----------------------------------------------------
    (if
      (and closedobj
	   (not	(setq
		  brkptE (vlax-curve-getPointAtDist
			   obj2break
			   (+ (vlax-curve-getdistatparam
				obj2break
				;;(vlax-curve-getparamatpoint obj2break brkpts)) 0.00001))))
				;; ver 2.0 fix
				(cond
				  ((vlax-curve-getparamatpoint
				     obj2break
				     brkpts
				   )
				  )
				  ((vlax-curve-getparamatpoint
				     obj2break
				     (vlax-curve-getclosestpointto
				       obj2break
				       brkpts
				     )
				   )
				  )
				)
			      )
			      0.00001
			   )
			 )
		)
	   )
      )
       (setq
	 brkptE	(vlax-curve-getPointAtDist
		  obj2break
		  (- (vlax-curve-getdistatparam
		       obj2break
		       (cond ((vlax-curve-getparamatpoint
				obj2break
				brkpts
			      )
			     )
			     ((vlax-curve-getparamatpoint
				obj2break
				(vlax-curve-getclosestpointto
				  obj2break
				  brkpts
				)
			      )
			     )
		       )
		     )
		     0.00001
		  )
		)
       ); end setq brkptE
    ); end fi (and closedobj

  ;; (if (null brkptE) (princ)) ; debug
  (setq LastEnt (GetLastEnt))
  (if (not (or (eq (dxf 0 obj2break) "TEXT")
	       (eq (dxf 0 obj2break) "MTEXT")
	   )
      )
    (command "._break"
	     obj2break
	     "_non"
	     (trans brkptS 0 1)
	     "_non"
	     (trans brkptE 0 1)
    )
  )
  (and (= "CIRCLE" enttype) (setq enttype "ARC"))
  (if (and (not closedobj)	; new object was created
	   (not (equal LastEnt (entlast)))
      )
    (setq brkobjlst (cons (entlast) brkobjlst))
  ); end (if (and
); end (foreach brkpt
     );end progn brkptlst
   ); end if brkptlst

 ); defun break_obj

 ;;====================================
 ;; CAB - get last entity in datatbase
 (defun GetLastEnt (/ ename result)
   (if	(setq result (entlast))
     (while (setq ename (entnext result))
(setq result ename)
     )
   )
   result
 )
 ;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 ;; S T A R T              S U B R O U T I N E             H E R E
 ;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

(if (and Lstent enL)
   (progn
     ;; CREATE a list of entity & it's break points
     (foreach en Lstent
				; check each object in Lstent
(if (not (acet-layer-locked (dxf 8 en)))
  (progn
    (setq lst nil)
    ;; check for break pts with other objects in Lstentwith
    (if	(and (not (equal en enint))
	     (setq intpts (acet-geom-intersectwith en enL 0))
	)
      (setq lst (append intpts lst))
				; entity w/ break points
    )
    (if	lst
      (setq masterlist
	     (cons (cons en lst) masterlist)
      )
    )
  )
)
     )
     (princ "\nBreaking Objects.\n")
     (if masterlist
(foreach obj2brk masterlist
  (break_obj (car obj2brk) (cdr obj2brk))
)
     )
   )
 )
);end break_with
;;===========================================================================
;; get all objects touching entities in the sscross
;; limited obj types to "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"
;; returns a list of enames
;;===========================================================================
(defun gettouching (en / ss lst lstb lstc objl)
 (and
   (setq objl (vlax-ename->vla-object en))
   (setq
     ss
      (ssget
 "_A"
 (list
   (cons 0
	 "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"
   )
   (cons 410 (getvar "ctab"))
 )
      )
   )
   (setq lst (SS-enlst ss)
    lst (mapcar 'vlax-ename->vla-object lst))
   (mapcar
     '(lambda (x)
 (if (not
       (vl-catch-all-error-p
	 (vl-catch-all-apply
	   '(lambda ()
	      (vlax-safearray->list
		(vlax-variant-value
		  (vla-intersectwith objl x acextendnone)
		)
	      )
	    )
	 )
       )
     )
   (setq lstc (cons (vlax-vla-object->ename x) lstc))
 )
      )
     lst
   )
 )
 lstc
)
;;;------------------------------------------------
(defun LWP (Lpoint *Model* / PntArr)
 (setq	PntArr (vlax-make-safearray
	 vlax-vbDouble
	 (cons 0 (1- (length Lpoint)))
       )
 )
 (vlax-safearray-fill PntArr Lpoint)
 (vla-AddLightWeightPolyline *Model* PntArr)
)
;;;------------------------------------------------
(defun DXF (code en) (cdr (assoc code (entget en))))
;;;============================================================
;;;=======================MAIN LISP============================
;;;============================================================
(defun c:trichthua (/ ss p2 encur lstss1 emin emax p3 LenssBR)
 (setq	ActDoc	(vla-get-ActiveDocument (vlax-get-acad-object))
*Model*	(vla-get-ModelSpace ActDoc)
 )
 (vla-StartUndoMark ActDoc)
 (setq	a (cond	(a)
	(50)
  )
 )
 (setq olda a)
 (setq	a (getreal (strcat "\nChon kich thuoc cat hinh vuong cat <"
			   (rtos olda 2 1)
			   "> : ")))
 (if (null a) (setq a olda))
 (setq	emin (list (car (getvar "extmin")) (cadr (getvar "extmin"))))
 (setvar "cecolor" "104")
 (setq	lstp (list (car emin)
	   (cadr emin)
	   (+ (car emin) a)
	   (cadr emin)
	   (+ (car emin) a)
	   (+ (cadr emin) a)
	   (car emin)
	   (+ (cadr emin) a)
     )
 )
 (vla-put-closed (LWP lstp *Model*) :vlax-True)
 (setq ss (ssadd (entlast) (ssadd)))
 (setq	p2 (ACET-SS-DRAG-MOVE
     ss
     (list (car emin) (cadr emin))
     "Chon vi tri bat dau trich thua: "
   )
 )
 (command ".move" ss "" emin p2)
 (setq encur (entlast)
lstp (acet-geom-VERTEX-LIST encur))
 (setq ss (ssdel encur (ssget "_CP" lstp)))
 (command ".copy" ss "" p2 p2)
 (setq	p3 (ACET-SS-DRAG-MOVE
     (ssadd encur ss)
     p2
     "Chon vi tri dat ban do trich thua: "
   )
 )
 (command ".move" ss encur "" p2 p3)
 (setvar "cecolor" "0")
 (setq encur (ssname (ssget "X" '((62 . 104))) 0))
 (setq	lstobj1	(vl-remove encur (gettouching encur))
ss	(acet-list-to-ss lstobj1)
 )
 (acet-ss-zoom-extents ss)
 (break_with  lstobj1 encur)
 (vlax-invoke-method ActDoc 'Regen acActiveViewport)
 (vla-offset (vlax-ename->vla-object encur) (* (getvar "viewsize") 0.002))
 (setq lst3 (acet-geom-vertex-list (entlast)))
 (entdel (entlast))
 (setq	LenssBR	(SS-enlst (ssget "F" lst3)))
 (foreach x LenssBR
   (if	(or (not (eq (dxf 0 x) "TEXT"))
    (not (eq (dxf 0 x) "MTEXT"))
)
     (entdel x)
   )
 )
 (vla-EndUndoMark ActDoc)
 (princ "\nChuc cac ban gat hai nhieu thanh cong. Thiep")
)

Hiên nay mình chạy Lisp Của Bạn nó lại báo lỗi này :

displacement or :

Command: ; error: bad argument type: lselsetp Mong được Bạn giúp


<<

Filename: 74545_trichthua.lsp
Tác giả: hhhhgggg
Bài viết gốc: 48558
Tên lệnh: df
Lisp đổi Font cho text được chọn tại sao lỗi với Font .vnarial narrow !!!!!!
Đây là đoạn Code đổi font của Text sang font .vnarial narrow

(defun c:df ()
(command "undo" "be")
(command "-style" "doifont" "VNARIALN.TTF" "0" "1" "0" "n" "n")
(prompt...
>>
Đây là đoạn Code đổi font của Text sang font .vnarial narrow

(defun c:df ()
(command "undo" "be")
(command "-style" "doifont" "VNARIALN.TTF" "0" "1" "0" "n" "n")
(prompt "\nChon chu muon chinh.")
(setq ss (ssget))
(setq c 0)
(if ss (setq e (ssname ss c)))
(while e
(setq e (entget e))
(if (= (cdr (assoc 0 e)) "TEXT")
(progn
(setq txt "doifont")
(setq e (subst (cons 7 txt) (assoc 7 e) e))
(entmod e)
)
)
(setq c (1+ c))
(setq e (ssname ss c))
)
(command "undo" "end")
(Prin I)
)

Còn đây là đoạn Code đổi font của Text sang font .vnarial narrowH

(defun c:df ()
(command "undo" "be")
(command "-style" "doifont" "VHARIALN.TTF" "0" "1" "0" "n" "n")
(prompt "\nChon chu muon chinh.")
(setq ss (ssget))
(setq c 0)
(if ss (setq e (ssname ss c)))
(while e
(setq e (entget e))
(if (= (cdr (assoc 0 e)) "TEXT")
(progn
(setq txt "doifont")
(setq e (subst (cons 7 txt) (assoc 7 e) e))
(entmod e)
)
)
(setq c (1+ c))
(setq e (ssname ss c))
)
(command "undo" "end")
(Prin I)
)

Chúc thành công ^_^

ko chạy được bác Tuệ af, báo lỗi : Command: ; error: no function definition: PRIN Bác sửa lại cho em đi !


<<

Filename: 48558_df.lsp
Tác giả: phuongkq
Bài viết gốc: 184673
Tên lệnh: tl
Đo chiều dài và ghi ra text

Quick code lại :

(defun C:TL( / ss L e #h)
(vl-load-com)
(defun Length1(e) (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)))
(or...
>>

Quick code lại :

(defun C:TL( / ss L e #h)
(vl-load-com)
(defun Length1(e) (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)))
(or ans (setq ans 1))
(setq
   #h 200
   L (strcat "L : "
   (vl-princ-to-string (* (getvar "dimlfac") (apply '+
       (mapcar 'Length1 (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget (list (cons 0 "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")))))))
   )))
   )
   ans (cond ((getint (strcat "\nPhuong an nhap ket qua < " (itoa ans) " > :")))(ans))
   txtObj (cond 	((= ans 1) (vlax-ename->vla-object (car (entsel "\nChon text ghi ket qua :"))))
  			     (T (vla-addtext (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) L (vlax-3d-point (getpoint "\n Chon diem nhap ket qua" )) #h ))
  	     )
)
(vla-put-TextString txtObj L)
(vla-put-Height txtObj #h)
(princ)
)

 

Các bạn ơi giúp mình với: Có thể giúp mình chỉnh sửa lisp thống kê chiều dài và xuất ra text trên theo cách sau không?

 

- Khi Cick vào chọn đối tượng lần lượt và sau khi hoàn tất việc chọn đối tượng thì xuất chiều dài đối tượng đó ra bảng theo 2 cách: xuất trong CAD và xuất ra file excel với thứ tự sẽ được liệt kê từ đối tượng được chọn đầu tiên cho đến đối tượng được chọn cuối cùng.

 

Cám ơn các bạn nhiều!


<<

Filename: 184673_tl.lsp
Tác giả: Ar_Chanwoo
Bài viết gốc: 15789
Tên lệnh: pgp2
cánh lưu lại các phím tắt AutoCAD
bạn dùng lệnh pgp2lsp sau đây để convert file pgp hiện hành của bạn thành 1 file lisp. Sau đó copy file lisp này sang máy khác rồi appload lên rồi dùng.

>>
bạn dùng lệnh pgp2lsp sau đây để convert file pgp hiện hành của bạn thành 1 file lisp. Sau đó copy file lisp này sang máy khác rồi appload lên rồi dùng.

(defun c:pgp2lsp( / )
 (setq    
   flsp (open (getfiled "PGP to lisp - free lisp from CADViet.com" "cadviet_key" "lsp" 1) "w")
   fpgp (open (findfile "acad.pgp") "r")
 )
 (while (setq curstr (read-line fpgp))
   (if (and (/= (substr curstr 1 1) ";") (setq vt (vl-string-position (ascii ",") curstr)) (> vt 0))
     (progn
(setq lenhtat (vl-string-trim " " (substr curstr 1 vt))
      lenhdu  (vl-string-trim "*" (vl-string-trim " " (substr curstr (+ vt 2))))
      lenhlsp (strcat "(defun c:" lenhtat "()(command \"" lenhdu "\"))")
       )
(if (not (vl-string-position (ascii " ") lenhdu))
(write-line lenhlsp flsp)
  )
     )
   )
 )
 (close flsp)
 (close fpgp)
 (princ)
)

Ví dụ như giờ e đã có file lisp này trong máy rồi ( file lisp sau khi đã convert file lệnh ấy ). Có cánh nào để mỗi lần sử dụng e chỉ cần dùng lệnh thì lisp sẽ đc load vào hay unload ra mà không phải dùng đến lệnh AP và laod lisp ko?


<<

Filename: 15789_pgp2.lsp

Trang 277/330

277