Jump to content
InfoFile
Tác giả: Doan Nguyen Van
Bài viết gốc: 432627
Tên lệnh: xx
CẢI TIẾN LISP GÁN CONTENT CHO TEXT

(defun c:xx (/ e a txt1 txt2 txt3 txtt txt noidung)

(vl-load-com
>>
(defun c:xx (/ e a txt1 txt2 txt3 txtt txt noidung)

(vl-load-com)

(while (setq e (car (entsel "\n Chon pline can ghi chieu dai ")))

  (or *dot* (setq *dot* 1.0))

(or (setq dot (getint (strcat "\nNhap NUMBER de chuyen vi tri dau phay <" (rtos *dot* 2 0) ">")))

    (setq dot *dot*)

);_ end or

(setq *dot* dot)

  (Setq     a "1")

  (repeat dot

    (setq a (strcat "0" a)))

       (setq txt1 (substr a 1 1)

     txt2 (substr a 2)

     txt3 (strcat txt1 "." txt2))

      (setq txtt (strcat "%<\\AcObjProp Object(%<\\_ObjId "

              (itoa (vla-get-ObjectID (vlax-ename->vla-object e)))   

              ">%).Length \\f \"%lu6%ct8\">%"))

      (setq txt (car (entsel "\n Chon text can ghi bo xung gia tri chieu dai polyline"))

      noidung (strcat " L= " txtt ))

(vla-put-textstring (vlax-ename->vla-object txt) noidung)

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

Em mới test lips của Bro xong, Tình hình là đã ok. Nhưng trong quá trình làm thì cái  phần :"\nNhap NUMBER de chuyen vi tri dau phay:")
Phần này thì Bro @Doan Nguyen Van có thể lượt bỏ qua mấy lần sau được không? ví  dụ như chỉ hỏi 1 lần, lần sau thì cứ lấy giống như lần trước để khỏi tốn thời gian Lips hỏi cho từng cái, sau muốn thay đổi thì nhập lại chứ lần nào cũng hỏi ("\nNhap NUMBER de chuyen vi tri dau phay:") thì em thấy nó lặp đi, lặp lại hơi tốn thời gian xíu ạ.

 

Thanks bro!

Bạn test lại cái này nhé! 

Trong quá trình sử dụng nếu số Number lặp lại giống nhau thì nhấn "Space" hoặc "Enter" là được


<<

Filename: 432627_xx.lsp
Tác giả: jangboko
Bài viết gốc: 432651
Tên lệnh: wr wof wo2pl
Lisp không sử dụng được trên cad 2018
(defun luuos ()
(setq
DUY_OSMODE (getvar "OSMODE")
DUY_AUTOSNAP (getvar "AUTOSNAP")
DUY_LAYERHH (getvar "CLAYER")
DUY_THANGXEOHH (getvar "ORTHO")
DUY_filletrad (getvar "FILLETRAD")
DUY_TEXTSTYLE (getvar "TEXTSTYLE")
)
)
(defun traos ()
(if DUY_OSMODE
(setvar "OSMODE" DUY_OSMODE)
)
(if DUY_LAYERHH
(setvar "CLAYER" DUY_LAYERHH)
)
(if DUY_THANGXEOHH
(setvar "ORTHO" DUY_THANGXEOHH)
)
(if DUY_AUTOSNAP
(setvar "AUTOSNAP"...
>>
(defun luuos ()
(setq
DUY_OSMODE (getvar "OSMODE")
DUY_AUTOSNAP (getvar "AUTOSNAP")
DUY_LAYERHH (getvar "CLAYER")
DUY_THANGXEOHH (getvar "ORTHO")
DUY_filletrad (getvar "FILLETRAD")
DUY_TEXTSTYLE (getvar "TEXTSTYLE")
)
)
(defun traos ()
(if DUY_OSMODE
(setvar "OSMODE" DUY_OSMODE)
)
(if DUY_LAYERHH
(setvar "CLAYER" DUY_LAYERHH)
)
(if DUY_THANGXEOHH
(setvar "ORTHO" DUY_THANGXEOHH)
)
(if DUY_AUTOSNAP
(setvar "AUTOSNAP" DUY_AUTOSNAP)
)
(if DUY_filletrad
(setvar "FILLETRAD" DUY_filletrad)
)
(if DUY_TEXTSTYLE
(setvar "TEXTSTYLE" DUY_TEXTSTYLE)
)
)

;;; OB2WO (gile) -Gilles Chanteau- 10/03/07
;;; UPDATE BY KETXU
;;; Creates a "Wipeout" from an object (circle, ellipse, or polyline with arcs)
;;; Works whatever the current ucs and object OCS

(defun c:wr (/ ent lst nor ss)
  (vl-load-com)
  (if  (setq ss (ssget (list (cons 0 "CIRCLE,ELLIPSE,LWPOLYLINE"))))    
    (progn
      (vla-StartundoMark
    (vla-get-ActiveDocument (vlax-get-acad-object))
      )
        (initget "Yes No")      
        (setq ans (getkword "\nDelete source object?  <No>: "))      
      (foreach ent (ST:Ss->ListEnt ss)
        (setq lst (ent2ptlst ent))
        (setq nor (cdr (assoc 210 (entget ent))))    
        (makeWipeout lst nor)
        (if (or (not ans) (wcmatch (strcase ans) "YES"))(entdel ent))
      )
      (vla-EndundoMark
    (vla-get-ActiveDocument (vlax-get-acad-object))
      )
    )
  )
)


;; WOF (gile)
;; Toggles wipeout frames
(defun c:wof (/ elst)
  (cond
    ((and
        (setq elst (dictsearch (namedobjdict) "ACAD_WIPEOUT_VARS"))
        (ssget "x" '((0 . "WIPEOUT,INSERT")))
    )
    (entmod    (subst    (cons 70 (boole 6 (cdr (assoc 70 elst)) 1))    (assoc 70 elst)    elst))
    (vlax-for obj (vla-get-activeselectionset (vla-get-activedocument (vlax-get-acad-object)))
        (vla-update obj)
    )
  )
    (T (princ "\nHave no wipeout object !"))
    )
  (princ)
)

;; WO2PL (gile)
;; Re-creates a wipeout boundary (lwpolyline)
(defun c:wo2pl (/ ss n wo elst pts norm ans)
  (if (setq ss (ssget '((0 . "WIPEOUT"))))
  (progn
    (initget "Yes No")      
    (setq ans (getkword "\nDelete source object?  <No>: "))     
    (foreach wo    (ST:Ss->ListEnt ss)    
      (setq 
        elst (entget wo)
        norm (vunit (v^v (cdr (assoc 11 elst)) (cdr (assoc 12 elst))))
        pts     (wipeout2plst wo)
      )
      (entmake
    (append
      (list    '(0 . "LWPOLYLINE")
        '(100 . "AcDbEntity")
        '(100 . "AcDbPolyline")
        (cons 90 (length pts))
        (cons 38 (caddr (trans (car pts) 0 norm)))
        '(70 . 1)
        (cons 210 norm)
      )
      (mapcar '(lambda (pt)
             (setq pt (trans pt 0 norm))
             (list 10 (car pt) (cadr pt))
           )
          pts
      )
    )
      )
      (if (or (not ans) (wcmatch (strcase ans) "YES"))(entdel wo))
(princ)      
  )))  
)

;;==================SUB ROUTINES==================;;

;; returns the wipeout point list (WCS)
(defun wipeout2plst (wo / elst u v mat)
  (setq    elst (entget wo)
    u    (cdr (assoc 11 elst))
    v    (cdr (assoc 12 elst))
    mat  (list u (mapcar '- v) '(0. 0. 1.))
  )
  (mapcar
    '(lambda (p)
       (mapcar '+
           (mxv (trp mat) p)
           (mapcar '(lambda (x y) (/ (+ x y) 2.)) u v)
           (cdr (assoc 10 elst))
       )
     )
    (cdr
      (mapcar 'cdr
          (vl-remove-if-not '(lambda (x) (= (car x) 14)) elst)
      )
    )
  )
)

;; Transpose a matrix Doug Wilson
(defun trp (m)
  (apply 'mapcar (cons 'list m))
)

;; Apply a transformation matrix to a vector by Vladimir Nesterovsky
(defun mxv (m v)
  (mapcar '(lambda (r) (apply '+ (mapcar '* r v))) m)
)

;; V^V
;; Returns the cross product of 2 vectors
(defun v^v (v1 v2)
  (list    (- (* (cadr v1) (caddr v2)) (* (caddr v1) (cadr v2)))
    (- (* (caddr v1) (car v2)) (* (car v1) (caddr v2)))
    (- (* (car v1) (cadr v2)) (* (cadr v1) (car v2)))
  )
)

;; VUNIT
;; Returns the single unit vector
(defun vunit (v)
  ((lambda (l)
     (if (/= 0 l)
       (mapcar (function (lambda (x) (/ x l))) v)
     )
   )
    (distance '(0 0 0) v)
  )
)


;;; ENT2PTLST
;;; Returns the vertices list of the polygon figuring the curve object
;;; Coordinates defined in OCS

(defun ent2ptlst (ent / obj dist n lst p_lst prec)
  (vl-load-com)
  (if (= (type ent) 'ENAME)
    (setq obj (vlax-ename->vla-object ent))
  )
  (cond
    ((member (cdr (assoc 0 (entget ent))) '("CIRCLE" "ELLIPSE"))
     (setq dist    (/ (vlax-curve-getDistAtParam
             obj
             (vlax-curve-getEndParam obj)
           )
           50
        )
       n    0
     )
     (repeat 50
       (setq
     lst
      (cons
        (trans
          (vlax-curve-getPointAtDist obj (* dist (setq n (1+ n))))
          0
          (vlax-get obj 'Normal)
        )
        lst
      )
       )
     )
    )
    (T
     (setq p_lst (vl-remove-if-not
           '(lambda (x)
              (or (= (car x) 10)
              (= (car x) 42)
              )
            )
           (entget ent)
         )
     )
     (while p_lst
       (setq
     lst
      (cons
        (append (cdr (assoc 10 p_lst))
            (list (cdr (assoc 38 (entget ent))))
        )
        lst
      )
       )
       (if (/= 0 (cdadr p_lst))
     (progn
       (setq prec (1+ (fix (* 25 (sqrt (abs (cdadr p_lst))))))
         dist (/ (- (if    (cdaddr p_lst)
                  (vlax-curve-getDistAtPoint
                obj
                (trans (cdaddr p_lst) ent 0)
                  )
                  (vlax-curve-getDistAtParam
                obj
                (vlax-curve-getEndParam obj)
                  )
                )
                (vlax-curve-getDistAtPoint
                  obj
                  (trans (cdar p_lst) ent 0)
                )
             )
             prec
              )
         n    0
       )
       (repeat (1- prec)
         (setq
           lst (cons
             (trans
               (vlax-curve-getPointAtDist
             obj
             (+ (vlax-curve-getDistAtPoint
                  obj
                  (trans (cdar p_lst) ent 0)
                )
                (* dist (setq n (1+ n)))
             )
               )
               0
               ent
             )
             lst
           )
         )
       )
     )
       )
       (setq p_lst (cddr p_lst))
     )
    )
  )
  lst
)


;;; MakeWipeout creates a "wipeout" from a points list and the normal vector of the object

(defun MakeWipeout (pt_lst nor / dxf10 max_dist cen dxf_14)
  (if (not (member "acwipeout.arx" (arx)))
    (arxload "acwipeout.arx")
  )
  (setq    dxf10 (list (apply 'min (mapcar 'car pt_lst))
            (apply 'min (mapcar 'cadr pt_lst))
            (caddar pt_lst)
          )
  )
  (setq
    max_dist
     (float
       (apply 'max
          (mapcar '- (apply 'mapcar (cons 'max pt_lst)) dxf10)
       )
     )
  )
  (setq cen (mapcar '+ dxf10 (list (/ max_dist 2) (/ max_dist 2) 0.0)))
  (setq
    dxf14 (mapcar
        '(lambda (p)
           (mapcar '/
               (mapcar '- p cen)
               (list max_dist (- max_dist) 1.0)
           )
         )
        pt_lst
      )
  )
  (setq dxf14 (reverse (cons (car dxf14) (reverse dxf14))))
  (entmake (append (list '(0 . "WIPEOUT")
             '(100 . "AcDbEntity")
             '(100 . "AcDbWipeout")
             '(90 . 0)
             (cons 10 (trans dxf10 nor 0))
             (cons 11 (trans (list max_dist 0.0 0.0) nor 0))
             (cons 12 (trans (list 0.0 max_dist 0.0) nor 0))
             '(13 1.0 1.0 0.0)
             '(70 . 7)
             '(280 . 1)
             '(71 . 2)
             (cons 91 (length dxf14))
           )
           (mapcar '(lambda (p) (cons 14 p)) dxf14)
       )
  )
)

(defun ST:Ss->ListEnt (ss / n e l)
  (setq n (sslength ss))
  (while (setq e (ssname ss (setq n (1- n))))
    (setq l (cons e l))
  )  
)

Lisp trên của mình sử dụng trên các bản cad 2007, 2010, 2012 ( những bản cad của mình đã từng dùng) nhưng không hiểu sao sang bản cad 2018 lại không sử dụng được, nó hiện ra lỗi: " error: ARXLOAD failed" Nhờ mọi người giúp mình để lisp trên sử dụng được cho cad 2018. Xin chân thành cảm ơn.

lệnh lisp : WR ( dùng để tạo ra các wipeout cho đối tượng  là polyline)


<<

Filename: 432651_wr_wof_wo2pl.lsp
Tác giả: babyjulio
Bài viết gốc: 420011
Tên lệnh: cps
Xin Lisp Setup Muilti-Plot Trong Layout

;; Copy current layout page setup to all layout tabs
(vl-load-com)
(defun c:CPS (/ Adoc Layts clyt)
  (setq aDoc ...
>>
;; Copy current layout page setup to all layout tabs
(vl-load-com)
(defun c:CPS (/ Adoc Layts clyt)
  (setq aDoc  (vla-get-activedocument (vlax-get-acad-object))
 Layts (vla-get-layouts aDoc)
 clyt  (vla-get-activelayout aDoc)
  )
  (foreach
     itm
        (vl-remove (vla-get-name clyt) (layoutlist))
    (vla-copyfrom (vla-item Layts itm) clyt)
  )
  (princ)
)

Lượm lặt được, copy từ Page Setup trong Layout hiện hành tới tất cả Layout.

 

cảm ơn bác, nhưng sao m load vào gõ lệnh mà nó ko chạy nhỉ.


<<

Filename: 420011_cps.lsp
Tác giả: pphung183
Bài viết gốc: 397279
Tên lệnh: us
Chữ Trong Block Bị Ngược Khi Copy Sang Chỗ Khác!

vậy là không có cách nào đơn giản hơn nhỉ, ông a của e chỉ cho dùng lệnh UCS ở cả 2 file cad rồi copy sang, thử 1 phát thì...

>>

vậy là không có cách nào đơn giản hơn nhỉ, ông a của e chỉ cho dùng lệnh UCS ở cả 2 file cad rồi copy sang, thử 1 phát thì copy được, nhưng đến lúc em làm thì lại không được, với cả bác nói rõ cái BIND được ko ạ

Có đấy :D ... xài Cad 2013 trở lên là Ctrl+C & Ctrl+V vô tư . Nếu Cad 2008 chắc phải làm nhiêu khê :wub:

Bạn chưa từng dùng Xref à :blink: . xài tới nó là biết Bind là gì.

Cái UCS của bạn đang là World thì dùng đến nó làm gì nua , chỉ là ông anh bạn múa cho vui thoi vì chắc là xài Cad Version khác 2008 thôi :D

Đoạn Code nhỏ kiểm tra UCS có phải là Word ko đây :

(defun c:us ()
(if (eq (getvar 'worlducs) 1) (alert "\nUCS is world...") (alert "\nUCS not World!!!")) )


<<

Filename: 397279_us.lsp
Tác giả: Doan Nguyen Van
Bài viết gốc: 432691
Tên lệnh: dad
nhờ các bác viết lisp copy và xoay đối tượng hướng về nhau
6 giờ trước, tranloi12c đã nói:

dạ cảm ơn bác đã bỏ thời...

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

dạ cảm ơn bác đã bỏ thời gian ra viết lisp giúp e . Ở đây ý e muốn như vd trong ảnh, khi ta chọn copy  block mũi tên ra vị trí bất kì sau đó ta pick điểm 1, 2 thì hai đầu mũi tên sẽ quay về nhau và cứ liên tục như thế cho các điểm tiếp theo ý ạk. thanks bác ^^

anh.gif

(defun c:dad (/ s p1 p2 p3 p4 ang a oldos s1 p31 s2 p41)
  (setq s (entsel "\nPick block can copy")
	p1 (getpoint "\nPick diem goc copy")
	p2 (getpoint p1 "\nPick huong")
	ang (angle p1 p2)
	a (distance p1 p2))
  (setq oldos (getvar "osmode"))
  (setq p3 (getpoint "\nPick diem dau"))
  (while (setq p4 (getpoint p3 "\n Pick diem tiep theo <Enter hoac ESC de ket thuc>"))
    (progn
     (setvar "osmode" 0)
      (command "copy" s "" p1 p3 "")
      (setq s1 (entlast)
	    p31 (polar p3 ang a))
      (command "rotate" s1 "" p3 "r" p3 p31 p4)
      (command "copy" s "" p1 p4 "")
      (setq s2 (entlast)
	    p41 (polar p4 ang a))
      (command "rotate" s2 "" p4 "r" p4 p41 p3)
      (setq p3 p4)
     (setvar "osmode" oldos)
	    
      )))

Code cho bạn đây, nhưng theo video thì chẳng phải bạn đã có lisp đó rồi hay sao?  


<<

Filename: 432691_dad.lsp
Tác giả: duy782006
Bài viết gốc: 432692
Tên lệnh: ccblq
nhờ các bác viết lisp copy và xoay đối tượng hướng về nhau
(defun c:ccblq ()

(princ "\nChon mot block")
(setq dchon (entsel))
(while
(or
(null (car dchon))
(and (/= "INSERT" (cdr (assoc 0 (entget (car dchon)))))
)
)
(princ "\nChon block khong thanh cong. Chon lai Block!")
(setq dchon (entsel))
)

(setq dchond (car dchon))
(setq diemdcl (getpoint "Diem chuan"))

(setq diemdclm (getpoint diemdcl"\nDiem thu nhat"))
(command ".copy" dchond "" "_non" diemdcl "_non" diemdclm...
>>
(defun c:ccblq ()

(princ "\nChon mot block")
(setq dchon (entsel))
(while
(or
(null (car dchon))
(and (/= "INSERT" (cdr (assoc 0 (entget (car dchon)))))
)
)
(princ "\nChon block khong thanh cong. Chon lai Block!")
(setq dchon (entsel))
)

(setq dchond (car dchon))
(setq diemdcl (getpoint "Diem chuan"))

(setq diemdclm (getpoint diemdcl"\nDiem thu nhat"))
(command ".copy" dchond "" "_non" diemdcl "_non" diemdclm "")
(setq diemdclh (getpoint diemdclm"\nDiem thu hai"))
(setq gocbl (angle diemdclh diemdclm))
(setq DTMs (subst (cons 50 (+ (/ pi 2) gocbl)) (assoc 50 (entget (entlast))) (entget (entlast))))
(entmod DTMs)

(command ".copy" dchond "" "_non" diemdcl "_non" diemdclh "")
(setq DTMs (subst (cons 50 (+ (/ (* 3 pi) 2) gocbl)) (assoc 50 (entget (entlast))) (entget (entlast))))
(entmod DTMs)

(setq diemdclm diemdclh)

(while (setq diemdclh (getpoint diemdclm"\nDiem tiep theo <Enter de ket thuc>!"))

(command ".copy" dchond "" "_non" diemdcl "_non" diemdclm "")
(setq gocbl (angle diemdclh diemdclm))
(setq DTMs (subst (cons 50 (+ (/ pi 2) gocbl)) (assoc 50 (entget (entlast))) (entget (entlast))))
(entmod DTMs)

(command ".copy" dchond "" "_non" diemdcl "_non" diemdclh "")
(setq DTMs (subst (cons 50 (+ (/ (* 3 pi) 2) gocbl)) (assoc 50 (entget (entlast))) (entget (entlast))))
(entmod DTMs)

(setq diemdclm diemdclh)

)
(princ))
(defun c:ccblq ()

(princ "\nChon mot block")
(setq dchon (entsel))
(while
(or
(null (car dchon))
(and (/= "INSERT" (cdr (assoc 0 (entget (car dchon)))))
)
)
(princ "\nChon block khong thanh cong. Chon lai Block!")
(setq dchon (entsel))
)

(setq dchond (car dchon))
(setq diemdcl (getpoint "Diem chuan"))

(setq diemdclm (getpoint diemdcl"\nDiem thu nhat"))
(command ".copy" dchond "" "_non" diemdcl "_non" diemdclm "")
(setq diemdclh (getpoint diemdclm"\nDiem thu hai"))
(setq gocbl (angle diemdclh diemdclm))
(setq DTMs (subst (cons 50 (+ (/ pi 2) gocbl)) (assoc 50 (entget (entlast))) (entget (entlast))))
(entmod DTMs)

(command ".copy" dchond "" "_non" diemdcl "_non" diemdclh "")
(setq DTMs (subst (cons 50 (+ (/ (* 3 pi) 2) gocbl)) (assoc 50 (entget (entlast))) (entget (entlast))))
(entmod DTMs)

(setq diemdclm diemdclh)

(while (setq diemdclh (getpoint diemdclm"\nDiem tiep theo <Enter de ket thuc>!"))

(command ".copy" dchond "" "_non" diemdcl "_non" diemdclm "")
(setq gocbl (angle diemdclh diemdclm))
(setq DTMs (subst (cons 50 (+ (/ pi 2) gocbl)) (assoc 50 (entget (entlast))) (entget (entlast))))
(entmod DTMs)

(command ".copy" dchond "" "_non" diemdcl "_non" diemdclh "")
(setq DTMs (subst (cons 50 (+ (/ (* 3 pi) 2) gocbl)) (assoc 50 (entget (entlast))) (entget (entlast))))
(entmod DTMs)

(setq diemdclm diemdclh)

)
(princ))

Viết xong mới thấy có rồi. Tiếc công nên cũng up lên. Lệnh CCBLQ

 

 


<<

Filename: 432692_ccblq.lsp
Tác giả: thanhduan2407
Bài viết gốc: 164102
Tên lệnh: brd
Lisp cắt đối tượng

Ồ, bạn dậy sớm vậy ^^

P/s : có lẽ do mình chậm hiểu quá nên hiểu sai ý bạn ^^. Sai 1 li, đi 1 dặm, code lại rối rắm hơn :(...

>>

Ồ, bạn dậy sớm vậy ^^

P/s : có lẽ do mình chậm hiểu quá nên hiểu sai ý bạn ^^. Sai 1 li, đi 1 dặm, code lại rối rắm hơn :(

(defun c:brd (/ lst_tmp lst_ss_bicat lst_ss_cat lst ST:Ent-Length ST:Ss->ListEnt ST:Ent-IntersObj ST:Ent-BrkLPSLine)

;;;;;;;; Local Functions
(defun ST:Ent-Length(e) (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)))
(defun ST:Ss->ListEnt (ss / n e l)
 (setq n (sslength ss))
 (while (setq e (ssname ss (setq n (1- n))))
   (setq l (cons e l))
 )  
)
(defun ST:Ent-IntersObj (e1 e2  / ob1 ob2 g L i kq) ;objExtend : doi tuong keo dai
(vl-load-com)
(setq
   ob1 (vlax-ename->vla-object e1)
   ob2 (vlax-ename->vla-object e2))	
(setq g (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendNone)))
(if (/= (vlax-safearray-get-u-bound g 1) -1) (setq L (vlax-safearray->list g)))
(setq i 0)
(repeat (/ (length L) 3)
   (setq kq (append (list (list (nth i L) (nth (+ i 1) L) (nth (+ i 2) L))) kq))
   (setq i (+ i 3))
)
kq
)
(defun ST:Ent-BrkLPSLine (obj LineDo / lstInters);ename
(if (setq lstInters (ST:Ent-IntersObj obj LineDo))
(progn
(foreach x lstInters
(command "_break" obj "_non" x "@")
)
)
)
)

(grtext -1 "Free Break and Del *Line @Ketxu Cadviet.com")
(command "undo"  "begin")
(setq ss_new (ssadd))
(prompt "\nCh\U+1ECDn c\U+00E1c Line, Pline, SLine.. b\U+1ECB c\U+1EAFt :")
(setq lst_ss_bicat (ST:Ss->ListEnt (ssget)))
(prompt "\nCh\U+1ECDn c\U+00E1c Line, Pline, SLine...c\U+1EAFt :")
(setq lst_ss_cat (ST:Ss->ListEnt (ssget)))
(foreach obj lst_ss_bicat 
(foreach Linedo lst_ss_cat
	(ST:Ent-BrkLPSLine obj Linedo)
	(setq ss_new (ssadd (entlast) ss_new)) 
)
(setq lst_tmp (ST:Ss->ListEnt (ssadd obj ss_new)))
(command "erase" (nth (vl-position (apply 'min (setq lst (mapcar 'ST:Ent-Length lst_tmp))) lst) lst_tmp) "") ;Bo dong nay neu khong muon xoa duong ngan nhat
(setq lst_tmp nil ss_new (ssadd))
;(while (setq EL (entnext EL)) (setq lst_ss_bicat (cons EL lst_ss_bicat)))
;(setq EL (entlast))
)

(command "undo" "end")
)

 

Còn phần bắt lỗi bắt lủng, nếu bạn làm bình thường thì chắc chẳng cần đâu, chứ bắt hết lỗi thì chắc đến già mất, nên bỏ qua thao tác đó :D. Bạn đợi được nhưng mình thì phải đi công trường bây giờ rồi, hem đợi được. Gluck ^_^

Hình như toàn Ractor hay sao ý. Hii. Trước khi đi công trường vẫn không quên mải mê viết code. Tặng ketxu 1 thanks. Hiii


<<

Filename: 164102_brd.lsp
Tác giả: Kỹ sư
Bài viết gốc: 221466
Tên lệnh: thu1 thu2
Lisp ghi kích thước Polyline ra text

Hix, học hành bét nhé như e chưa ra được anh ạ, mấy hôm tiếp thì lại bận rồi, còn list thử của em mỗi yêu cầu, bác bỏ ra làm lệnh...

>>

Hix, học hành bét nhé như e chưa ra được anh ạ, mấy hôm tiếp thì lại bận rồi, còn list thử của em mỗi yêu cầu, bác bỏ ra làm lệnh đều được mà,

;;cac ham con
 ;;-----
 (defun xuly_nhaptay (a1 / b1_user)
(setq b1_user (getreal "\nNhap chieu dai mong muon"))
( / a1 b1_user )
)
 ;;-----
 (defun xuly_picktext (a1 Tex / b1)
(If (= (type (atof(cdr(assoc 1 (entget(car Tex))))) ) (type 3.4))
 	(progn
(if (/= "" (cdr(assoc 1 (entget(car Tex)))))
  (setq b1 (atof(cdr(assoc 1 (entget(car Tex))))))
  (setq b1 (cdr(assoc 42 (entget(car Tex))))) )
)
 	)
(if b1
 	( / a1 b1 )
 	;(xuly_nhaptay)
)
)
 ;;-----
 (defun xuly_yeucau_pI_xdtyle( / dt ent_dt a1)
(while (or (null dt)
   	(/= "LINE" (cdr (assoc 0 (entget (car dt))))) )
 	(setq dt (entsel"\nChon LINE")))
(setq ent_dt (entget (car dt)))
(setq a1 (distance (cdr(assoc 10 ent_dt)) (cdr(assoc 11 ent_dt)) ))
;;chon text chua gia tri fake dim hoac nhap tay
(if (setq picktext (entsel "\nPick chon Text la so"))
 	(setq ##tyle## (xuly_picktext a1 picktext))
 	(setq ##tyle## (xuly_nhaptay a1))
 	)
(princ (strcat "Tyle ban ve hien xac dinh duoc la : " (rtos ##tyle## 2 5 ) "\n"))
(princ)
)
 ;;-----
 ;;-----
 (defun xuly_yeucau_PII ( / ss i entdt_ss a2 giatri_new)
(prompt "\nChon cac duong DIM de converst")
(princ)
(setq ss (ssget (list (cons 0 "DIMENSION"))))
(setq i -1)
(repeat (sslength ss)
 	(command "undo" "begin")
 	(setq i (1+ i))
 	(setq entdt_ss (entget(ssname ss i)))
 	(princ)
 	;;xac dinh gia tri thuc a2 cua dim
 	(setq a2 (distance (cdr(assoc 13 entdt_ss)) (cdr(assoc 14 entdt_ss)) ))
 	;; ket thuc a2 xac dinh gia tri moi bang a2/x (x la tyle o phan I)
 	(setq giatri_new (rtos (/ a2 ##tyle##)))
 	(entmod (subst (cons 1 giatri_new) (assoc 1 entdt_ss) entdt_ss))
 	(command "undo" "end")
 	);end_repeat
)
 ;;CHUONG TRINH CHINH
(defun c:thu1 ()
 (xuly_yeucau_pI_xdtyle)
 )
(defun c:thu2 ()
 (setvar "cmdecho" 0)
 ;(xuly_yeucau_pI_xdtyle)
 (xuly_yeucau_PII)
 (setvar "cmdecho" 1)
 (princ (strcat "Tyle ban ve hien xac dinh duoc la : " (rtos ##tyle## 2 5 ) "\n"))
 (princ)
 )

List của bác em trước xem rồi, nhưng mà đã nói bác up file bác không up thì em chịu hông viết được, bác up file lên đi

Mấu chốt là các DIM của bác đã bị Scale thì mỗi dim ở tỷ lệ khác nhau có Arrow khác nhau mà đúng không

 

Sory, mấy hôm rồi mình có việc, h mới về HN nên mới online cảm ơn bạn đc.

cái lisp của bạn mình dùng okie rồi. Chỉ có không dùng được cho ordinate dimension thôi, Mà thực ra Ordinate dim cũng ít dùng nên cũng không cần thiết lắm

 

Mình k0 up file là vì 2 lí do:

1./ MÌnh mà muốn up file thì phải lên công ty, gửi qua email rồi tối về mới up đc, rất mất công. Công ty mình chặn k0 cho xài internet mà.

2./ Thực ra thì bản vẽ cũng k0 có j đặc biệt, nhất là chỗ liên quan đến cái lisp này. Chỉ là vẽ chi tiết các tấm thép, và các đường kích thước chỉ là line và text, thế thôi.

Chân thành cảm ơn bạn đã nhiệt tình giúp mình.

Chúc bạn sức khỏe và thành công trong học tập cũng như công việc!


<<

Filename: 221466_thu1_thu2.lsp
Tác giả: ndtnv
Bài viết gốc: 432797
Tên lệnh: ipt
Import text từ text file vào autocad

Vì không gửi file cad nên tôi chỉ viết phần xuất text, phần kẻ khung bạn tự làm.

Tên lệnh và các thông số chiều cao text, kc hàng. .. bạn tự sửa trong lisp cho phù hợp.

(defun eText (p h s u v) (entmake (list '(0 . "TEXT") (cons 10 p)(cons 11 p) (cons 1 s)
                                                                 (cons 40 h)(cons 72 u)(cons 73...
>>

Vì không gửi file cad nên tôi chỉ viết phần xuất text, phần kẻ khung bạn tự làm.

Tên lệnh và các thông số chiều cao text, kc hàng. .. bạn tự sửa trong lisp cho phù hợp.

(defun eText (p h s u v) (entmake (list '(0 . "TEXT") (cons 10 p)(cons 11 p) (cons 1 s)
                                                                 (cons 40 h)(cons 72 u)(cons 73 v))))
(defun C:IPT( / file h i line n p r s x y)
    (setq s (getfiled "\nFile text:" "" "txt" 0))
    (setq h 3 ; cao text
                r 5 ; kc hang
                n '(3 2 5 6)
                x '(20 40 60 80 )) ; vi tri
    (setq file (open s "r") p (getpoint "\nVi tri: ") y (cadr p))
    (while (setq s (read-line file))
        (setq line (read (strcat "(" s ")")))
        (if (>= (length line) 7)
            (progn
                (setq i 0 y (- y r))
                (repeat 4
                    (eText (list (+ (car p) (nth i x)) y) h (itoa(nth (nth i n) line)) 2 1)
                    (setq i (1+ i))
    ) ) ) )
    (close file)
)

Uống cafe thì mất time di chuyển, thay vào đó, nếu thấy lisp có giá trị, bạn nhắn tin từ thiện rồi chụp ảnh post lên

http://1400.vn/tin-tuc


<<

Filename: 432797_ipt.lsp
Tác giả: cocobubu
Bài viết gốc: 193734
Tên lệnh: ha
Vẽ đường gióng của mặt cắt ngang khi nhập tọa độ

Đây bạn!

(defun C:HA( / po xo yo yg ab)
(command "ucs" "w")
(setq po (getpoint "\nPick diem goc: "))
(setq xo (car po) yo...
>>

Đây bạn!

(defun C:HA( / po xo yo yg ab)
(command "ucs" "w")
(setq po (getpoint "\nPick diem goc: "))
(setq xo (car po) yo (cadr po))
(setq yg (cadr (cdr (assoc 10 (entget (car (entsel "\nChon Line de lam duong giong: ")))))))
(while (setq ab (getpoint "\nNhap toa do: "))
 (command "line" "non" (list (+ xo (car ab)) (+ yo (cadr ab))) "non" (list (+ xo (car ab)) yg) ""))
(princ)

Anh xem giúp em,load vào cad rồi nhưng lại ko sử dụng được!


<<

Filename: 193734_ha.lsp
Tác giả: Đinh Cường
Bài viết gốc: 390640
Tên lệnh: tn
Nhờ diễn đàn sửa lisp ghi khoảng cách, cao độ trên cắt ngang

Đây là lisp mình đã rút gọn lại. đồng thời sửa thêm một số chi tiết về nhập số liệu và chế độ bắt điểm để...

>>

Đây là lisp mình đã rút gọn lại. đồng thời sửa thêm một số chi tiết về nhập số liệu và chế độ bắt điểm để thuận tiện hơn khi sử dụng. Lisp cũng đã tự động load các block cần thiết. bạn chỉ cần copy bản vẽ này vào thư mục D:\Lisp CAD là OK.

(Chú ý là không sử dụng bản vẽ BV1 của bạn nữa nhé. vì các block hơi xấu khi canh lề text, đông thời bản vẽ đó có mấy block không sử dụng nhưng mình không có cách gì purge nó đi được nên lisp load rất chậm)

(defun DXF (code elist)
  (cdr (assoc code elist))
)

(defun c:tn (); / DZ pt y ptside ang OT sc1 scale)
  (vl-load-com)
  (setvar "cmdecho" 0)

(if (not scale) (setq scale 1))
(setq sc1 (getreal (strcat "\n Cao text <"(rtos scale 2 0)">:")))
(if sc1 (setq scale sc1))
(SETQ OSLAST (getvar "OSMODE"))
(setq DZ (getvar "DIMZIN"))
(setvar "DIMZIN" 0)
(setq OT (getvar "ORTHOMODE"))
(setvar "ORTHOMODE" 0)
(command "osmode" 99)
(setq pt0 (osnap (getpoint "Diem tim TN tu nhien <end of> : ") "end")) (print)
(setq x0 (car pt0) y0 (cadr pt0))
(setq ed (entget (car (entsel "\nChon cao do tim: "))))
(setq H0 (read (DXF 1 ed)))	
(command "osmode" 15359) 
(setq pt (getpoint "\nDiem chen: "))

(While (/= pt nil)
(Progn
(setq ptside (getpoint "\nPhia chen:" pt)
ang (angle pt ptside))
(setq y (- (cadr pt) y0 (- H0)))
(setq x (- (car pt) x0))
		 
(cond ((> x 0) (setq x (strcat "" (rtos x 2 2))))
		 ((< x 0) (setq x (rtos (abs x) 2 2)))
		 ((= x 0) (setq x "0.00"))		 )
(cond ((> y 0) (setq y (strcat "+" (rtos y 2 2))))
		 ((< y 0) (setq y (rtos y 2 2)))
		 ((= y 0) (setq y "%%p0.00")))
;(setq x (ustr 0 "Khoang cach: " x T))
;(setq y (ustr 0 "Cao do: " y T))

(if (not (tblsearch "block" "LCD1"))
(progn (command "insert" "D:\\Lisp CAD\\BVTN.dwg" "" "" "" "")
(command "erase" (entlast) "")))

( if (AND (>= ang 0) (< ang 1.5708)) (command "INSERT" "LCD1" pt scale scale "0" x y))
( if (AND (>= ang 1.5708) (< ang 3.1416)) (command "INSERT" "LCD2" pt scale scale "0" y x))
( if (AND (>= ang 3.1416) (< ang 4.7124)) (command "INSERT" "LCD3" pt scale scale "0" x y))
( if (AND (>= ang 4.7124) (< ang 6.2832)) (command "INSERT" "LCD4" pt scale scale "0" y x))

(setq pt (getpoint "\nDiem chen: "))
);pro
);while 
(setvar "OSMODE" OSLAST)
(setvar "DIMZIN" DZ)
(setvar "ORTHOMODE" OT))
;---------------------------------------------------------------------------

Không down được file cad bác ạ


<<

Filename: 390640_tn.lsp
Tác giả: Đinh Cường
Bài viết gốc: 390776
Tên lệnh: tn
Nhờ diễn đàn sửa lisp ghi khoảng cách, cao độ trên cắt ngang

 

>>

 

Đây là lisp mình đã rút gọn lại. đồng thời sửa thêm một số chi tiết về nhập số liệu và chế độ bắt điểm để thuận tiện hơn khi sử dụng. Lisp cũng đã tự động load các block cần thiết. bạn chỉ cần copy bản vẽ này vào thư mục D:\Lisp CAD là OK.

(Chú ý là không sử dụng bản vẽ BV1 của bạn nữa nhé. vì các block hơi xấu khi canh lề text, đông thời bản vẽ đó có mấy block không sử dụng nhưng mình không có cách gì purge nó đi được nên lisp load rất chậm)

(defun DXF (code elist)
  (cdr (assoc code elist))
)

(defun c:tn (); / DZ pt y ptside ang OT sc1 scale)
  (vl-load-com)
  (setvar "cmdecho" 0)

(if (not scale) (setq scale 1))
(setq sc1 (getreal (strcat "\n Cao text <"(rtos scale 2 0)">:")))
(if sc1 (setq scale sc1))
(SETQ OSLAST (getvar "OSMODE"))
(setq DZ (getvar "DIMZIN"))
(setvar "DIMZIN" 0)
(setq OT (getvar "ORTHOMODE"))
(setvar "ORTHOMODE" 0)
(command "osmode" 99)
(setq pt0 (osnap (getpoint "Diem tim TN tu nhien <end of> : ") "end")) (print)
(setq x0 (car pt0) y0 (cadr pt0))
(setq ed (entget (car (entsel "\nChon cao do tim: "))))
(setq H0 (read (DXF 1 ed)))	
(command "osmode" 15359) 
(setq pt (getpoint "\nDiem chen: "))

(While (/= pt nil)
(Progn
(setq ptside (getpoint "\nPhia chen:" pt)
ang (angle pt ptside))
(setq y (- (cadr pt) y0 (- H0)))
(setq x (- (car pt) x0))
		 
(cond ((> x 0) (setq x (strcat "" (rtos x 2 2))))
		 ((< x 0) (setq x (rtos (abs x) 2 2)))
		 ((= x 0) (setq x "0.00"))		 )
(cond ((> y 0) (setq y (strcat "+" (rtos y 2 2))))
		 ((< y 0) (setq y (rtos y 2 2)))
		 ((= y 0) (setq y "%%p0.00")))
;(setq x (ustr 0 "Khoang cach: " x T))
;(setq y (ustr 0 "Cao do: " y T))

(if (not (tblsearch "block" "LCD1"))
(progn (command "insert" "D:\\Lisp CAD\\BVTN.dwg" "" "" "" "")
(command "erase" (entlast) "")))

( if (AND (>= ang 0) (< ang 1.5708)) (command "INSERT" "LCD1" pt scale scale "0" x y))
( if (AND (>= ang 1.5708) (< ang 3.1416)) (command "INSERT" "LCD2" pt scale scale "0" y x))
( if (AND (>= ang 3.1416) (< ang 4.7124)) (command "INSERT" "LCD3" pt scale scale "0" x y))
( if (AND (>= ang 4.7124) (< ang 6.2832)) (command "INSERT" "LCD4" pt scale scale "0" y x))

(setq pt (getpoint "\nDiem chen: "))
);pro
);while 
(setvar "OSMODE" OSLAST)
(setvar "DIMZIN" DZ)
(setvar "ORTHOMODE" OT))
;---------------------------------------------------------------------------

Không down được file cad bác ạ

 

bác nào đã down được file block thì up lại được không ?


<<

Filename: 390776_tn.lsp
Tác giả: hugo007
Bài viết gốc: 162173
Tên lệnh: moc
Lisp vẽ đai móc

Này thì yêu cầu của Hugo :)

Lệnh : moc

(defun c:moc ()
 (entmake '(
(0 . "LWPOLYLINE") 
(100 . "AcDbEntity") 
(67 . 0) 
(8 ....
>>

Này thì yêu cầu của Hugo :)

Lệnh : moc

(defun c:moc ()
 (entmake '(
(0 . "LWPOLYLINE") 
(100 . "AcDbEntity") 
(67 . 0) 
(8 . "0")
(100 . "AcDbPolyline") 
(90 . 5) 
(70 . 0) 
(43 . 0.0) 
(38 . 0.0) 
(39 . 0.0) 
(10 20.06813351996104 4.918288816158338)
(40 . 0.0) (41 . 0.0) (42 . 0.0) 
(10 -4.515341367645868 96.66506612330090) 
(40 . 0.0) 
(41 . 0.0)
(42 . 0.0) 
(10 196.7878331603434 96.66506612330090)
(40 . 0.0)
(41 . 0.0) 
(42 . -0.955352130863200)
(10 195.4199538710784 66.72756612330090)
(40 . 0.0) 
(41 . 0.0) 
(42 . 0.0)
(10 165.4199538710784 66.72756612330090) 
(40 . 0.0) 
(41 . 0.0) 
(42 . 0.0)))
 (princ)
)

Xin lỗi bạn,phiền bạn làm cho hình này scale lên 5 lần giùm với vì bạn viết bằng cách này mình không hiểu để sửa và bạn thêm giùm mình chọn điểm chèn và chỗ góc 75 độ bo góc có bán kính 75 luôn nha,nếu muốn gán cho nó là layer DAI MOC thì làm như thế nào?.Thanks.


<<

Filename: 162173_moc.lsp
Tác giả: ndtnv
Bài viết gốc: 432814
Tên lệnh: ipt
Import text từ text file vào autocad

Chắc bạn bấm nút để download lisp, cách này hay bị lỗi.

Hãy copy code, past vào file text rồi save thành file .lsp

code mới có vẽ khung


(defun eText (p h s u v) (entmake (list '(0 . "TEXT") (cons 10 p)(cons 11 p) (cons 1 s)
                                                                 (cons 40 h)(cons 72 u)(cons 73 v))))
(defun...
>>

Chắc bạn bấm nút để download lisp, cách này hay bị lỗi.

Hãy copy code, past vào file text rồi save thành file .lsp

code mới có vẽ khung


(defun eText (p h s u v) (entmake (list '(0 . "TEXT") (cons 10 p)(cons 11 p) (cons 1 s)
                                                                 (cons 40 h)(cons 72 u)(cons 73 v))))
(defun ekLine (p q) (entmake (list '(0 . "LINE") (cons 10 p) (cons 11 q))))
(defun C:IPT( / file h i line n p r s title x x0 xn y y0)
    (setq s (getfiled "\nFile text:" "" "txt" 0))
    (setq h 2.2 ; cao text
                r 5 ; kc hang
                n '(3 2 5 6)
                x '(0 25 50 80 100);
                title '("JOINT NO." "SIZE" "DIA INCH." "QUANTITY."))
    (setq file (open s "r") p (getpoint "\nVi tri: "))
    (setq x0 (car p) y0 (cadr p) y (- y0 6)i 0 xn (+ x0 (last x)))
    (repeat 4
        (eText (list (+ x0 (* 0.5 (+ (nth i x) (nth (1+ i) x)))) y) h (nth i title) 1 1)
        (setq i (1+ i))
    )
    (ekLine p (mapcar '+ p (list (last x) 0 )))
    (setq y (- y 2))
    (ekLine (list x0 y) (list xn y))
    (while (setq s (read-line file))
        (setq line (read (strcat "(" s ")")))
        (if (>= (length line) 6)
            (progn
                (setq i 0 y (- y r))
                (repeat 4
                    (eText (list (+ x0 -10 (nth (1+ i) x)) y) h (itoa(nth (nth i n) line)) 2 1)
                    (setq i (1+ i))
    ) ) ) )
    (close file)
    (setq y (- y 2))
    (ekLine (list x0 y) (list xn y))
    (foreach e x
        (ekLine (list (+ e x0) y0) (list (+ e x0) y))    )
)


<<

Filename: 432814_ipt.lsp
Tác giả: whatcholingon
Bài viết gốc: 197367
Tên lệnh: gifpr
viết lisp lấy tọa độ điểm và tên điểm

Giảm thao tác Undo và cmdecho thì sẽ giảm được 1 nửa time :)

(defun c:gifpr (/ ss n plst i en el p ma k tmp fw val)
(defun...
>>

Giảm thao tác Undo và cmdecho thì sẽ giảm được 1 nửa time :)

(defun c:gifpr (/ ss n plst i en el p ma k tmp fw val)
(defun val (a e)(cdr (assoc a (entget e))))
(defun cont(e / tmp)(substr (setq tmp (val 1 e)) (+ 4 (vl-string-search "\\l" tmp))))
(vl-load-com)
(setq Start (getvar "Millisecs"))
(setvar 'cmdecho 0)
(command "undo" "Mark")
(setq ss (ssget (list (cons 0 "acad_proxy_entity")))
     	n (sslength ss)
     	plst (list)
     	i -1
 tmp (getfiled "Chon file xuat Text goc" (getvar "dwgprefix") "csv" 1)
 fw (open tmp "w")
)
(while (< i n)    
(setq en (entlast))
(command "explode" (ssname ss (setq i (1+ i))))
(while (setq en (entnext en))  
  (cond  ((= (val 0 en) "CIRCLE") (setq p (val 10 en)))
(T (if (= (val 62 en) 2)(setq num (cont en))(setq nm (cont en))))
  )  
 )
  (write-line (strcat num (chr 44) nm (chr 44) (apply 'strcat (mapcar '(lambda(x)(strcat (rtos x 2 2) (chr 44))) p))) fw)

)
(close fw)
(command "undo" "back")
(setq End (getvar "Millisecs"))
(alert (vl-princ-to-string (* (- end start) 0.001)))
(princ)
)

 

Ketxu xem lại lsp:

Sao khi Lấy text ghi chú thì nó lại bỏ mất ký tự ở trước là lý do gì vậy. ( vd: BD thì chỉ có D, LS thì chỉ có S)

STT cũng chạy lung tung nữa, Ket sửa lại giùm nhé.

Thanks!


<<

Filename: 197367_gifpr.lsp
Tác giả: hhhhgggg
Bài viết gốc: 77687
Tên lệnh: mat
Lisp MATTEXT bị lỗi ???
Lisp Match Text : đối tượng đích sẽ có giá trị (hay chiều dài) của đối tượng nguồn

- đối tượng nguồn : TEXT, MTEXT, DIMENSION, MULTILEADER,...

>>
Lisp Match Text : đối tượng đích sẽ có giá trị (hay chiều dài) của đối tượng nguồn

- đối tượng nguồn : TEXT, MTEXT, DIMENSION, MULTILEADER, ATTDEF, ATTRIB, LINE, PLINE, ARC, CIRCLE, ELLIPSE

+ với đối tượng TEXT, MTEXT, DIMENSION, MULTILEADER, ATTDEF, ATTRIB : lấy giá trị Text của đối tượng nguồn

+ với đối tượng LINE, PLINE, ARC, CIRCLE, ELLIPSE : lấy chiều dài của đối tượng nguồn (làm tròn đến hàng đơn vị)

 

- đối tượng đích : TEXT, MTEXT, DIMENSION, MULTILEADER, ATTDEF

 

Chú ý : khi chọn đối tuợng nguồn là DIMENSION hay ATTRIB nếu muốn lấy giá trị Text bạn phải pick vào Text đó, t/hợp bạn pick vào đuờng gióng của DIMENSION, Lisp sẽ lấy chiều dài của đuờng gióng đó.

(defun C:mat(/ ent typ nd ss)
 (command "_.undo" "_begin")
 (or vlax-ename->vla-object (vl-load-com))
 (while
   (not
     (and (setq ent (car (nentsel "\nChon doi tuong de lay Text hay Chieu dai :")))
   (setq ent (vlax-ename->vla-object ent))
   (setq typ (vla-get-ObjectName ent))
   (cond
     ((wcmatch typ "*Text,*MLeader,*Attribute")
      (setq nd (vla-get-TextString ent)) )
     ((wcmatch typ "*AttributeDefinition")
      (setq nd (vla-get-TagString ent)) )
     ((wcmatch typ "*Line,*Arc,*Circle,*Ellipse")
      (setq nd (rtos (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent)) 2 0)) )
     (t nil)
     ); cond
   ))
   (princ "\nDoi tuong chon khong hop le, Chon lai : "))  
 (princ (strcat"\nChon doi tuong de thay the gia tri Text <" nd "> :" ))
 (if (setq ss (ssget (list (cons 0 "*TEXT,*DIMENSION,MULTILEADER,ATTDEF")) ))
   (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
     (setq ent (vlax-ename->vla-object ent)
    typ (vla-get-ObjectName ent))
     (cond
((wcmatch typ "*Text,*MLeader")	      (vla-put-TextString ent nd) )
((wcmatch typ "*Dimension*")          (vla-put-TextOverride ent nd) )
((wcmatch typ "*AttributeDefinition") (vla-put-TagString ent nd) )
); cond
     )
   )
 (command "_.undo" "_end")
 (princ)
)

Bác GIA_BACH chình lisp khá là hoàn thiện, nhưng mà với Line,ARC, PL thì nó lấy độ dài và ko lấy đằng sau dấu phẩy 1 số nào, như thế thì kém chính xác, Lisp này em thấy rất bồ kết sau khi bác GIA_Bach chỉnh lại.Bác chỉnh thêm phần làm tròn 2 chữ số sau dấu phẩy ?


<<

Filename: 77687_mat.lsp
Tác giả: binhyenlinh
Bài viết gốc: 95030
Tên lệnh: mat
Lisp MATTEXT bị lỗi ???
Update theo yêu cầu: số số lẻ do nguời dùng nhập.

(defun C:mat(/ ent typ nd ss ssle)
 (command "_.undo" "_begin")
 (or vlax-ename->vla-object...
>>
Update theo yêu cầu: số số lẻ do nguời dùng nhập.

(defun C:mat(/ ent typ nd ss ssle)
 (command "_.undo" "_begin")
 (or vlax-ename->vla-object (vl-load-com))
 (while
   (not
     (and (setq ent (car (nentsel "\nChon doi tuong de lay Text hay Chieu dai :")))
   (setq ent (vlax-ename->vla-object ent))
   (setq typ (vla-get-ObjectName ent))
   (cond
     ((wcmatch typ "*Text,*MLeader,*Attribute")
      (setq nd (vla-get-TextString ent)) )
     ((wcmatch typ "*AttributeDefinition")
      (setq nd (vla-get-TagString ent)) )
     ((wcmatch typ "*Line,*Spline,*Polyline,*Arc,*Circle,*Ellipse")
      (or *ssle* (setq *ssle* 0))
      (initget 4)
      (setq ssle (getint (strcat "\nSo so le <" (itoa *ssle*) ">: ")))
      (if ssle (setq *ssle* ssle))
      (setq nd (rtos (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent)) 2 *ssle*)) )
     (t nil)
     ); cond
   ))
   (princ "\nDoi tuong chon khong hop le, Chon lai : "))  
 (princ (strcat"\nChon doi tuong de thay the gia tri Text <" nd "> :" ))
 (if (setq ss (ssget (list (cons 0 "*TEXT,*DIMENSION,MULTILEADER,ATTDEF")) ))
   (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
     (setq ent (vlax-ename->vla-object ent)
    typ (vla-get-ObjectName ent))
     (cond
((wcmatch typ "*Text,*MLeader")	      (vla-put-TextString ent nd) )
((wcmatch typ "*Dimension*")          (vla-put-TextOverride ent nd) )
((wcmatch typ "*AttributeDefinition") (vla-put-TagString ent nd) )
); cond
     )
   )
 (command "_.undo" "_end")
 (princ)
)

Thank you very much.....!!! mình tìm cái líp này vất vả từ lâu. làm kết cấu tuyệt vời.hi


<<

Filename: 95030_mat.lsp
Tác giả: txquychk51
Bài viết gốc: 403708
Tên lệnh: tt%C2%A0
Nhờ Mọi Người Sửa Hộ Lisp Leader.

 

Điểm C chỉ là để lấy khoảng cách và góc hợp giữa đoạn thẳng nối A-C với khúc đầu của leader. Hướng rải...

>>

 

Điểm C chỉ là để lấy khoảng cách và góc hợp giữa đoạn thẳng nối A-C với khúc đầu của leader. Hướng rải luôn theo hướng mũi tên leader, nếu góc ở trên < 90 thì rải giật lùi và ngược lại.

(defun c:tt  (/ ang apt dis ele ent i lea len lsc lsm lsp pt pt1 pt2)
 (vl-load-com)
 (vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
 (if (and (setq ele (ssget "_+.:E:S" '((0 . "LEADER"))))
          (setq ent (ssname ele 0)
                lsp (vl-remove-if-not '(lambda (x) (member (car x) '(10))) (entget ent))
                lsc (vlax-get-property (vlax-ename->vla-object ent) 'ScaleFactor))
          (setq pt1 (cdr (car lsp)))
          (setq dis (getdist "\nKhoang cach giua cac Leader: " pt1))
          (setq pt2 (getpoint "\nDiem ket thuc: " pt1)))
  (progn (setq lsm (vl-remove-if '(lambda (x) (member (car x) '(-1 5 10 330 340))) (entget ent))
               ang (angle pt1 (cdr (cadr lsp)))
               len (distance pt1 pt2)
               i   0)
         (setq apt (angle pt1 pt2))
         (if (or (< (- apt ang) (* 0.5 pi)) (> (- apt ang) (* 1.5 pi)))
          (setq ang ang)
          (setq ang (+ ang pi)))
         (repeat (fix (/ len dis))
          (setq pt (polar pt1 ang (* dis (setq i (1+ i)))))
          (setq lea (entmakex (append lsm (subst (cons 10 pt) (assoc 10 lsp) lsp))))
          (vlax-put-property (vlax-ename->vla-object lea) 'ScaleFactor lsc))))
 (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
 (princ))

rất cảm ơn bác đã nhiệt tình giúp đỡ. hiện tại máy e đang bị lỗi nên chưa thử được. khi nào thử được e phản hồi lại ạ. cảm ơn


<<

Filename: 403708_tt%C2%A0.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 432950
Tên lệnh: ha
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

Cám ơn bạn NgoKiet với mã 42 mà mình tìm mãi chưa ra!

Gởi mọi người ai cần thì dùng: lisp saveas 1 file excel nhiều sheets sang các files Unicode Text (TXT) tương ứng.

Nhờ chuyển XLS sang TXT mà việc đọc và ghi file Excel Unicode dễ dàng và tốc độ.


(defun C:HA()
 (setq fn (getfiled "Chon file Excel de Saveas to Unicode Text (.TXT)" "" "xls;xlsx" 0))
 (XLS2TXT fn))
(defun...
>>

Cám ơn bạn NgoKiet với mã 42 mà mình tìm mãi chưa ra!

Gởi mọi người ai cần thì dùng: lisp saveas 1 file excel nhiều sheets sang các files Unicode Text (TXT) tương ứng.

Nhờ chuyển XLS sang TXT mà việc đọc và ghi file Excel Unicode dễ dàng và tốc độ.


(defun C:HA()
 (setq fn (getfiled "Chon file Excel de Saveas to Unicode Text (.TXT)" "" "xls;xlsx" 0))
 (XLS2TXT fn))
(defun XLS2TXT (fn / xlApp xlSho xlShe SheetName)
 (setq xlApp (vlax-get-or-create-object "Excel.Application"))
 (setq xlSho (vlax-get-property (vla-open (vlax-get-property xlApp 'Workbooks) fn) 'Sheets))
 (setq xlShe (vlax-get xlSho "count"))
 (vlax-for xlShe xlSho
  (setq SheetName (vlax-get-property xlShe "Name"))
  (vlax-invoke (vlax-get-property xlSho 'Item SheetName) "Activate")
  (vlax-invoke-method (vlax-get-property xlApp "ActiveWorkbook") "Saveas" (strcat (vl-filename-directory fn) (vl-filename-base fn) "_" SheetName ".txt") 42 "" "" :vlax-false :vlax-false nil))
 (princ))


<<

Filename: 432950_ha.lsp
Tác giả: PHAPLUONG
Bài viết gốc: 407299
Tên lệnh: clo
Lisp tạo viewport từ khung chọn bên model.

 

Của bạn đây.

 

71162_clo.jpg

 

Hướng...

>>

 

Của bạn đây.

 

71162_clo.jpg

 

Hướng dẫn: 

1. Lệnh CLO

2. Chọn máy in, khổ giấy, style...

3. Đặt tên Layout, tỉ lệ

4. Chọn các khung hình chữ nhật (Polyline) bên Model để tạo Viewport bên Layout. Khi quét chọn thì Lisp sẽ tự động căn các khung theo thứ tự từ trái sang phải.

5. Chọn Block hoặc file xref. Nếu không cần thì khỏi chọn.

6. Bấm OK, Lisp sẽ tạo mỗi bản vẽ trên một Layout.

;LISP TAO LAYOUT HANG LOAT BANG CACH CHON KHUNG VIEW BEN MODEL
(vl-load-com)
(defun Make_dcl	(/ ret)
  (if (= Printer nil) (setq Printer 0))
  (if (= Size nil) (setq Size 0))
  (if (= Style nil) (setq Style 0))
  (if (= Block nil) (setq Block 0))
  (if (= TenLayout nil) (setq TenLayout "Layout"))
  (if (= Tyle nil) (setq Tyle "1000"))
  (setq fl (vl-filename-mktemp "CLO" nil ".dcl"))
  (setq ret (open fl "w"))
  (write-line
    (strcat
      "CLO : dialog { label = \"Create Layout\";
      : column {
      : boxed_column {label = \"Page Setup\";
      : popup_list { key=\"Printer\"; label= \"Printer\";  value = \"" (itoa Printer) "\"; edit_width = 40;}
      : popup_list { key=\"PaperSize\"; label= \"Paper Size   \"; value = \"" (itoa Size) "\"; edit_width = 40;}
      : popup_list { key=\"Style\"; label= \"Style            \"; value = \"" (itoa Style) "\";edit_width = 40;}
      : edit_box {   key = \"LO_name\"; label = \"Layout Name  \"; value = \"" TenLayout "\";edit_width = 20;}
      : edit_box {   key = \"Tyle\"; label = \"Drawing Scale\"; value = \"" Tyle "\";edit_width = 20;}}
      : button { key = \"Chonkhung\"; label = \"Select Frame \"; }
      : boxed_column {
      label = \"\";
      :row {
      : button { key = \"TaoBlock\"; label = \"Create Title Block\"; is_default = false; width=30; fixed_width=true;}
      : popup_list {key=\"Block\"; label= \"Block\"; width=30; fixed_width=true; value = \"" (itoa Block) "\";}}
      : row {
      : button {key = \"Select_Xref\"; label = \"Xref Title Block\"; is_default = false; width=30; fixed_width=true;}
      : button {key = \"Remove\"; label = \"Remove Title Block\"; is_default = false; width=30; fixed_width=true;}}
      : list_box {label =\"\"; key = \"Xref_File\"; height = 3; value = \"0\";}
      }
      : boxed_row {
      : button { key = \"accept\"; label = \" OK \"; width=30; fixed_width=true; is_default = true;}
      : button { key = \"cancel\"; label = \"Cancel\"; is_default = false; is_cancel = true; width=30; fixed_width=true;}}}} "
    )
    ret
  )
  (setq ret (close ret))
)
(defun *error* (msg) (vl-file-delete fl))
(defun Chon ()
  (vl-file-delete fl)
  (setq taphop(ssget '((0 . "POLYLINE,LWPOLYLINE"))))
  (Make_dcl)
  (setq ddiag 3)
)
(defun TaoBlock (/ taphop pt)
  (vl-file-delete fl)
  (alert "Chon doi tuong de tao Block khung ten")
  (if (/= (setq taphop(ssget)) nil)
    (progn
      (setq pt(getpoint "\n Chon Base point cua Block: "))
      (setq ten(lisped "Nhap ten cua Block"))
      (while (/= (tblsearch "Block" ten) nil)
	(setq ten(lisped "Trung ten Block da co. Nhap ten khac cho Block")))
      (command "BLOCK" ten pt taphop "")
      (setq dsblock(cons "" (tablelist "Block")))
      ))
  (Make_dcl)
  (setq ddiag 3)
)
(defun Update ()
  (vla-put-ConfigName (ActLay) (nth (atoi (get_tile "Printer")) dsmayin))
  (setq dsPaper (PaperList))
  (start_list "PaperSize" 3)
  (mapcar 'add_list dsPaper)
  (end_list)
)
(defun Chon_Xref ()
  (if (not Path) (setq Path(getvar "dwgprefix")))
  (setq File(getfiled "Chon File khung ten" Path "dwg" 2))
  (if (/= File nil) (setq Path File dsFile (list File)))
  (start_list "Xref_File" 3)
  (mapcar 'add_list dsFile)
  (end_list)
  )
(defun Remove_Xref ()
  (setq File "" dsFile (list File))
  (start_list "Xref_File" 3)
  (mapcar 'add_list dsFile)
  (end_list)
  )
(defun ActLay () (vla-get-ActiveLayout(vla-get-activedocument(vlax-get-acad-object))))
(defun PlotDeviceNamesList ()
  (vla-RefreshPlotDeviceInfo (ActLay))
  (vlax-safearray->list(vlax-variant-value(vla-GetPlotDeviceNames (ActLay)))))
(defun PaperList (/ PLObj PSL)
  (setq PLObj (vla-GetCanonicalMediaNames (ActLay)))
  (foreach i (vlax-safearray->list (vlax-variant-value PLObj))
    (setq PSL (append PSL (list (vla-GetLocaleMediaName (ActLay) i))))))
(defun PlotStyleTableNamesList ()
  (vla-RefreshPlotDeviceInfo (ActLay))
  (vlax-safearray->list(vlax-variant-value(vla-GetPlotStyleTableNames(ActLay)))))
(defun tablelist (s / d r)
  (while (setq d (tblnext s (null d)))
    (setq r (cons (cdr (assoc 2 d)) r))))
(defun DeleteLayouts (/ layouts layout i)
  (vl-load-com)
  (setq	layouts	(vla-get-Layouts(vla-get-activedocument (vlax-get-acad-object))))
  (if (> (vla-get-count layouts) 2)
    (vlax-for layout layouts
      (if (= (vla-get-ModelType layout) :vlax-false)
	(if (< (vla-get-count (vla-get-block layout)) 2)
	  (vla-delete layout))))))
(setq dsmayin (PlotDeviceNamesList))
(setq dsStyle (PlotStyleTableNamesList))
(setq dsblock(cons "" (tablelist "Block")))
(defun hopthoai	()
  (setq dcl_id (load_dialog fl))
  (if (not (new_dialog "CLO" dcl_id)) (exit))
  (start_list "Printer" 3)
  (mapcar 'add_list dsmayin)
  (end_list)
  (Update)
  (action_tile "Printer" "(Update)")
  (action_tile "Chonkhung" "(setq ddiag 5)(saveVars)(done_dialog)")
  (action_tile "TaoBlock" "(setq ddiag 9)(saveVars)(done_dialog)")
  (start_list "Style" 3)
  (mapcar 'add_list dsStyle)
  (end_list)
  (start_list "Block" 3)
  (mapcar 'add_list dsBlock)
  (end_list)
  (start_list "Xref_File" 3)
  (mapcar 'add_list dsFile)
  (end_list)
  (action_tile "Select_Xref" "(Chon_Xref)")
  (action_tile "Xref_File" "(Chon_Xref)")
  (action_tile "Remove" "(Remove_Xref)")
  
  (action_tile "cancel" "(setq ddiag 1)(done_dialog)")
  (action_tile "accept" "(setq ddiag 2)(setq tieptuc 1)(saveVars)(done_dialog)" )
  (start_dialog)
  (unload_dialog dcl_id)
)
(defun saveVars	()
  (setq Printer (atoi (get_tile "Printer")))
  (setq Size (atoi (get_tile "PaperSize")))
  (setq Style (atoi (get_tile "Style")))
  (setq Tyle (get_tile "Tyle"))
  (setq Block (atoi (get_tile "Block")))
  
  (setq Printer1 (nth Printer dsmayin))
  (setq Size1 (nth Size (PaperList)))
  (setq Style1 (nth Style dsStyle))
  (setq TenLayout (get_tile "LO_name"))
  
  (setq Tyle1 (/ (atof (get_tile "Tyle")) 1000))
  (setq Block1 (nth Block dsBlock))
)
(defun C:CLO (/ os)
  (setvar "CMDECHO" 0)
  (command "UNDO" "BE")
  (setq os(getvar "OSMODE"))
  (setvar "OSMODE" 0)
  (setvar "TILEMODE" 1)
  (setq dsblock(cons "" (tablelist "Block")))
  (if (= File nil) (setq dsFile (list "")))
  (setq tieptuc 0)
  (Make_dcl)
  (setq ddiag 3)
  (while (= ddiag 3)
    (hopthoai)
    (if	(= ddiag 5) (Chon))
    (if	(= ddiag 9) (TaoBlock))
  )
  (vl-file-delete fl)
  (if (= tieptuc 1)
    (progn
      (Sapxepkhung)
      (Make_Layout)
      (DeleteLayouts)
      )
    )
  (setvar "OSMODE" os)
  (command "UNDO" "END")
  (princ)
  )
(defun Sapxepkhung(/ index khung S1 S2 D1 D2)
  (setq index 0)
  (setq lst_Khung(list))
  (setq S1 0 S2 0)
  (while (< index (sslength taphop))
    (setq khung (ssname taphop index))
    (setq lst_Khung(append lst_Khung (list(list khung S1 S2))))
    (setq index (1+ index))
    )
  (setq lst_Khung(vl-sort lst_Khung '(lambda (e1 e2) (< (cadr(assoc 10 (entget(car e1)))) (cadr(assoc 10 (entget(car e2))))))))
  )
(defun Make_Layout (/ disp index khung lst pt0 pt1 pt2 pt3 P1 P2)
  (setq disp(getenv "CreateViewports"))
  (setenv "CreateViewports" "0")
  (setq index 1)
  (foreach khung1 lst_Khung
    (setq khung (car khung1))
    (setq lst (acet-geom-vertex-list khung))
    (setq lst (vl-sort lst '(lambda(e1 e2) (if (/= (car e1) (car e2)) (< (car e1) (car e2)) (< (cadr e1) (cadr e2))))))
    (setq pt0 (nth 0 lst) pt3 (nth 3 lst))
    (if	(> (cadr (nth 1 lst)) (cadr (nth 2 lst)))
      (setq pt1	(nth 1 lst) pt2	(nth 2 lst))
      (setq pt1	(nth 2 lst) pt2	(nth 1 lst)))
    (command "LAYOUT" "N" (strcat TenLayout (itoa (+ 0 index))))
    (command "LAYOUT" "S" (strcat TenLayout (itoa (+ 0 index))))
    (command "ERASE" "ALL" "")
    (if (/= File nil) (command "xref" "A" file (list 0 0) "" "" ""))
    (if (/= Block1 "") (command "INSERT" Block1 (list 0 0) "" "" ""))
    (command "ZOOM" "E")
    (if	(> (distance pt2 pt0) (distance pt1 pt0))
      (command "RECTANG"  (list 0 0) (list (/ (distance pt2 pt0) tyle1) (/ (distance pt1 pt0) tyle1)))
      (command "RECTANG"  (list 0 0) (list (/ (distance pt1 pt0) tyle1) (/ (distance pt2 pt0) tyle1)))
      )
    (command "MVIEW" "O" (entlast))
    (command "MSPACE")
    (if	(> (distance pt2 pt0) (distance pt1 pt0))
      (command "DVIEW" khung "" "TW" (- 90 (* (/ (angle pt0 pt1) pi) 180)) "")
      (command "DVIEW" khung "" "TW" (- 0 (* (/ (angle pt0 pt1) pi) 180)) ""))
    (command "ZOOM" "W" pt0 pt3)
    (command "PSPACE")
    (command "ZOOM" "E")
    (Setq P1 (Getvar "EXTMIN") P2 (Getvar "EXTMAX"))
    (command "PLOT" "Y" "" printer1 size1 "M" "L" "N" "W" P1 P2 "1" "C" "Y" Style1 "Y" "N" "N" "N" "N" "Y" "N")
    (command "MODEL")
    (setq index (+ index 1))
  )
  (setenv "CreateViewports" disp)
  (princ)
)
(princ "\n           Type CLO to run program\n"

Cảm ơn bác!

thực sự thì lisp này rất hay rồi, tuy nhiên e vẫn muốn nhờ bác chỉnh sửa thêm một chút nữa phần tỷ lệ sao cho e để khung tên trong xref với khích thước thật khung A3 là 420x297 và khung chữ nhật ở model là 42000x29700 thì khi nhập tỷ lệ là 100 thì layout sẽ là các khung 420x297 vừa với khung xref luôn

và e cung được voi đòi hai bà Trưng nhừ bác viết giúp e 1 lisp nữa để kếp hợp với lisp trên. khi dùng lisp trên của bác e kếp hợp với đặt tên bản vẽ bằng sheetset bằng cách chèn field của sheetset name vào khung tên, như trong file e đính kèm bên dưới. Để giảm bớt thời gian cop tex giữa các layout bác có thể viết giúp e 1 lisp có tác dụng như sau: 

1. tạo mtext trong 1 layout dầu tiên

2. chạy lisp, chọn mtext vừa tạo thì tự động coppy và paste đúng tọa độ sang các layout còn lại

Cảm ơn bác trước

Link file của e: https://drive.google.com/open?id=0B42Bw9dLRUS0c0RhNzRuSzAyWms


<<

Filename: 407299_clo.lsp

Trang 284/330

284