Jump to content
InfoFile
Tác giả: Tot77
Bài viết gốc: 292562
Tên lệnh: tmp
[yêu cầu] lisp tổng hợp khối lượng

Bạn xài cái này, có điều là tôi chỉ làm phần đầu thống kê ra thôi, phần còn lại (kẻ bảng, nhập chữ, tính tổng) thi bạn tự làm.

(defun c:tmp()
  (defun LM:CountItems ( l / c x ) ;;;Lee Mac
    (if (setq x (car l))
        (progn
            (setq c (length l)
                  l (vl-remove x (cdr l)))
            (cons (cons x (- c (length...
>>

Bạn xài cái này, có điều là tôi chỉ làm phần đầu thống kê ra thôi, phần còn lại (kẻ bảng, nhập chữ, tính tổng) thi bạn tự làm.

(defun c:tmp()
  (defun LM:CountItems ( l / c x ) ;;;Lee Mac
    (if (setq x (car l))
        (progn
            (setq c (length l)
                  l (vl-remove x (cdr l)))
            (cons (cons x (- c (length l))) (LM:CountItems l))
        )
    )
  )
  (setq l nil)
  (foreach v (acet-ss-to-list (ssget '((0 . "INSERT") (66 . 1))))
    (setq item1 nil)
    (foreach item (vlax-safearray->list (vlax-variant-value
       (vla-GetAttributes (setq obj (vlax-ename->vla-object v)))))         
   (cond ((= "LOAI_HG" (vla-get-TagString item))
    (setq l (cons (list "LOAI_HG" (vla-get-TextString item)) l)))
 ((and (not item1) (/= "LOAI_HG" (vla-get-TagString item)))
    (setq item1 (list (vla-get-TagString item) (vla-get-TextString item))))
 ((and item1 (= "CHIEU_DAI" (vla-get-TagString item)))
    (setq l (cons (append item1 (list "CHIEU_DAI" (vla-get-TextString item))) l)))
 ((and item1 (= "DUONG_KINH" (vla-get-TagString item)))
    (setq l (cons (cons (list "DUONG_KINH" (vla-get-TextString item)) item1) l)))
 )
    )
  )
  (setq st "")
  (foreach v (LM:CountItems l)
     (cond ((= (caar v) "LOAI_HG") (setq st (strcat st "\nHo ga loai " (cadar v) " : " (itoa (cdr v)))))
  ((= (caar v) "DUONG_KINH") (setq st (strcat st "\nLoai cong duong kinh "
(cadar v)  " chieu dai " (last (car v)) " : " (itoa (cdr v))))) 
     )
  )
  (princ st) (textscr) (princ)
)
 
 


<<

Filename: 292562_tmp.lsp
Tác giả: Tot77
Bài viết gốc: 292507
Tên lệnh: tl
Chỉnh sửa lisp ghi kich thước text

Với yêu cầu của bạn thì cái lisp trên xem như đổi gần hết.

Chọn phương án nhập kết quả là nếu bạn nhập "1" nó sẽ ghi vào text có sẵn, còn không thì tạo text mới.

Lisp dưới đây bạn không cần nhập chiều cao chữ, font, nhưng phải có text mẫu trước,...

>>

Với yêu cầu của bạn thì cái lisp trên xem như đổi gần hết.

Chọn phương án nhập kết quả là nếu bạn nhập "1" nó sẽ ghi vào text có sẵn, còn không thì tạo text mới.

Lisp dưới đây bạn không cần nhập chiều cao chữ, font, nhưng phải có text mẫu trước, nó căn cứ trên text mẫu để tạo text mới giống y.

Sau khi chọn text mẫu, bạn nhấp vào từng đối tượng, vị trí text mới ở ngay điểm bạn nhấp, chiều thì theo hướng bạn chọn.

 
(defun C:TL (/ ss L e)
  (defun Length1 (e) (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)))
  (defun tronso(a B) (* b (if (< (rem a B) (* 0.5 B)) (fix (/ a b 1.)) (1+ (fix (/ a b 1.))))))
  (defun dxf(id v) (cdr (assoc id (entget v))))
  
  ;;==============================================;;
  
  (setq k (getvar "dimlfac")
chumau (car (entsel "Chon chu mau:"))
os (getvar 'osmode))
  
  (command "undo" "be")
  (setvar 'osmode 512)
  (vl-load-com)
  (while (setq e0 (entsel "\nChon LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE:"))  
 
    (if (vl-string-search (dxf 0 (setq e (car e0))) "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")
      (progn
(setq pt (vlax-curve-getClosestPointTo (vlax-ename->vla-object e) (last e0))
     pt1 (getpoint pt "Theo huong:"))
        (entmake (list '(0 . "TEXT") (cons 10 pt) (cons 7 (dxf 7 chumau))
      (cons 72 0) (cons 50 (angle pt pt1))
      (cons 40 (dxf 40 chumau)) (cons 1 (rtos (tronso (* k (length1 e)) 100))))))
      (alert "Khong the do chieu dai doi tuong nay!!")
    )
  )
  (setvar 'osmode os)
  (command "undo" "e")
  (princ)

 

)

 

Bạn bỏ cái dòng <span...>  ở dưới đi


<<

Filename: 292507_tl.lsp
Tác giả: Tot77
Bài viết gốc: 292592
Tên lệnh: tmp
[Yêu cầu] Lisp hoàn công cọc

Thử cái này xem sao.

(defun c:tmp()
  (defun dxf(id v) (cdr (assoc id (entget v))))
  (defun dxy(a b) (list (atoi (rtos (- (car b) (car a)) 2 0)) (atoi (rtos (- (cadr b) (cadr a)) 2 0))))
  
  (defun entmake1(name pt cao hg)
    (entmake (list '(0 . "INSERT") (cons 2 name) (cons 10 pt)
(cons 41 cao) (cons 42 cao) (cons 50 hg)))
  )
  (defun entmake2(tri pt hg...
>>

Thử cái này xem sao.

(defun c:tmp()
  (defun dxf(id v) (cdr (assoc id (entget v))))
  (defun dxy(a b) (list (atoi (rtos (- (car b) (car a)) 2 0)) (atoi (rtos (- (cadr b) (cadr a)) 2 0))))
  
  (defun entmake1(name pt cao hg)
    (entmake (list '(0 . "INSERT") (cons 2 name) (cons 10 pt)
(cons 41 cao) (cons 42 cao) (cons 50 hg)))
  )
  (defun entmake2(tri pt hg lay)
    (entmake (list '(0 . "TEXT") (cons 10 pt) (cons 11 pt) (cons 1 tri) '(40 . 250.0)
'(7 . "Style_epcoc") '(71 . 0) '(72 . 1) (cons 8 lay) (cons 50 hg)))
  )
  ;;===============================================''
  
  (setq sl (acet-ss-to-list (ssget '((0 . "POINT"))))
sl1 nil)
  (while sl
    (setq a (car sl)
 sl (cdr sl)
 sl1 (cons (cons a (setq b (cadar (vl-sort (mapcar '(lambda(x) (list (distance (dxf 10 a) (dxf 10 x)) x)) sl)
       '(lambda(x y) (< (car x) (car y))))))) sl1)
 sl (vl-remove b sl))
  )
  (setq sl1 (mapcar '(lambda(x) (if (= "01_Diemdo" (dxf 8 (car x))) (cons (cdr x) (car x)) x)) sl1)
sl1 (mapcar '(lambda(x) (cons (cdr x) (dxy (dxf 10 (car x)) (dxf 10 (cdr x)))))  sl1)
  )
  (mapcar '(lambda(x)
    (entmake1 "KYHIEUCOCEP" (dxf 10 (car x)) 500 0)
    (entmake1 "muiten" (polar (dxf 10 (car x)) (* 0.5 pi) -550) 4.92126 (if (< (cadr x) 0) pi 0))
    (entmake1 "muiten" (polar (dxf 10 (car x)) 0 -550) 4.92126 (if (< (last x) 0) (* -0.5 pi) (* 0.5 pi)))
    (entmake2 (itoa (cadr x)) (polar (dxf 10 (car x)) (* 0.5 pi) -850) 0 "03_DolechX" )
    (entmake2 (itoa (last x)) (polar (dxf 10 (car x)) 0 -600) (* 0.5 pi) "04_DolechY")) sl1)
  (princ)
)


<<

Filename: 292592_tmp.lsp
Tác giả: Tot77
Bài viết gốc: 292555
Tên lệnh: itt
Lisp Zoom và in trong Layout theo tọa độ Text

Tôi hiểu tại sao rồi, vì lệnh -boundary thì màn hình phải zoom toàn bộ thì nó mới tạo được pline.

Bạn sửa lại như sau:

(defun c:ITT ( / olmode  i ss item  temp  Tdo minp maxp  pt a2 b2 P1 P2 P3 P4 )
(vl-load-com)
(setvar "CMDECHO" 0)
(setq olmode (getvar "OSMODE"))
(setvar "OSMODE" 0)
(setq ss (ssget (list (cons 0 "TEXT"))))  
(foreach item (acet-ss-to-list...
>>

Tôi hiểu tại sao rồi, vì lệnh -boundary thì màn hình phải zoom toàn bộ thì nó mới tạo được pline.

Bạn sửa lại như sau:

(defun c:ITT ( / olmode  i ss item  temp  Tdo minp maxp  pt a2 b2 P1 P2 P3 P4 )
(vl-load-com)
(setvar "CMDECHO" 0)
(setq olmode (getvar "OSMODE"))
(setvar "OSMODE" 0)
(setq ss (ssget (list (cons 0 "TEXT"))))  
(foreach item (acet-ss-to-list ss)
        (setvar "tilemode" 1)
        (command "._zoom" "e")
(vl-cmdf "-boundary" (TD:Text-Base item) "")
(setq e (entlast))
(vla-getboundingbox (vlax-ename->vla-object e) 'minp 'maxp)
(setq minp (safearray-value minp))
(setq maxp (safearray-value maxp))
(setq pt (list (/ (+ (car minp) (car maxp)) 2) (/ (+ (cadr minp) (cadr maxp)) 2)))
(setq a2 (* (/ (- (car maxp) (car minp)) 2) 1.5))
(setq b2 (* (/ (- (cadr maxp) (cadr minp)) 2) 1.5))
(setq P1 (list (- (car pt) a2) (- (cadr pt) b2))
P2 (list (- (car pt) a2) (+ (cadr pt) b2))
P3 (list (+ (car pt) a2) (+ (cadr pt) b2))
P4 (list (+ (car pt) a2) (- (cadr pt) b2))
)
  (entdel e)
(command "._zoom" "_w" "_non" P2 "_non" P4)
(setvar "tilemode" 0)
(command "_plot" "" "" "" "" "" "" "")
)
(setvar "tilemode" 1)
(setvar "OSMODE" olmode)
(princ)
)


<<

Filename: 292555_itt.lsp
Tác giả: Tot77
Bài viết gốc: 292629
Tên lệnh: tl
Chỉnh sửa lisp ghi kich thước text

Tuyệt vời bạn ơi, cảm ơn bạn rất nhiều

Bạn có thể chỉnh thêm cho mình 1 chút nữa được không

1. Text có tới 3 chữ số 0 đằng sau mình không cần chĩnh xác đến đó ( minh chỉ cần tròn số thôi ( chẳng hạn như 1922 thành 1900 hay 2354 thanh 2400 ..)

2. Text và đường thẳng sát nhau quá có thể điều...

>>

Tuyệt vời bạn ơi, cảm ơn bạn rất nhiều

Bạn có thể chỉnh thêm cho mình 1 chút nữa được không

1. Text có tới 3 chữ số 0 đằng sau mình không cần chĩnh xác đến đó ( minh chỉ cần tròn số thôi ( chẳng hạn như 1922 thành 1900 hay 2354 thanh 2400 ..)

2. Text và đường thẳng sát nhau quá có thể điều chỉnh khoảng cách giữa text và đường thẳng được k bạn bởi sát nhau quá khi in nó bị trung nét

mà tại sao bỏ cái dòng <span...> vậy bạn

Thanks bạn

Sửa lại theo ý bạn, ở lisp này nếu bạn đã chon chữ mẫu 1 lần rồi thì nếu không muốn chọn lại thì cứ enter .

Sở dĩ bảo bạn xóa dòng span là vì dơn theo dạng giống mục #7 dễ phát sinh những ký tự lạ mà mình không muốn có, nó có thể làm lisp không chạy được.

(defun C:TL (/ k os e0 e pt pt1 chumau1)
  (defun Length1 (e) (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)))
  (defun tronso(a b) (* b (if (< (rem a b) (* 0.5 b)) (fix (/ a b 1.)) (1+ (fix (/ a b 1.))))))
  (defun dxf(id v) (cdr (assoc id (entget v))))
  
   (setq k (getvar "dimlfac")
os (getvar 'osmode))
  (setq chumau1 (car (entsel "\nChon chu mau <Enter neu khong chon lai>:")))
  (if chumau1 (setq chumau chumau1))
  
  (command "undo" "be")
  (setvar 'osmode 512)
  (vl-load-com)
  (while (setq e0 (entsel "\nChon LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE:"))  
 
    (if (vl-string-search (dxf 0 (setq e (car e0))) "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")
      (progn
(setq pt (vlax-curve-getClosestPointTo (vlax-ename->vla-object e) (last e0))
     pt1 (getpoint pt "Theo huong:"))
        (entmake (list '(0 . "TEXT") (cons 10 (polar pt (+ (angle pt pt1) (* 0.5 pi)) (* 0.2 (dxf 40 chumau))))
      (cons 7 (dxf 7 chumau))  (cons 72 0) (cons 50 (angle pt pt1))
      (cons 40 (dxf 40 chumau)) (cons 1 (rtos (tronso (* k (length1 e)) 100) 2 0)))))
      (alert "Khong the do chieu dai doi tuong nay!!")
    )
  )
  (setvar 'osmode os)
  (command "undo" "e")
  (princ)
)


<<

Filename: 292629_tl.lsp
Tác giả: Tot77
Bài viết gốc: 292710
Tên lệnh: tmp
Lisp chuyển layer và giữ nguyên màu của block

Bạn thử cái này.

(defun c:tmp()
  (vl-load-com)
  (setq v (car (entsel))
lay (cdr (assoc 8 (entget v)))
name (vla-get-effectivename (vlax-ename->vla-object v)))
  (if (tblsearch "BLOCK" name)
    (progn
      (setq en (tblobjname "BLOCK" name))
      (while (setq en (entnext en))
        (entmod (subst (cons 8 lay) (assoc 8 (entget en)) (entget...
>>

Bạn thử cái này.

(defun c:tmp()
  (vl-load-com)
  (setq v (car (entsel))
lay (cdr (assoc 8 (entget v)))
name (vla-get-effectivename (vlax-ename->vla-object v)))
  (if (tblsearch "BLOCK" name)
    (progn
      (setq en (tblobjname "BLOCK" name))
      (while (setq en (entnext en))
        (entmod (subst (cons 8 lay) (assoc 8 (entget en)) (entget en)))
        (entupd en)
      ))
  )
  (vla-regen (vla-get-ActiveDocument (vlax-get-acad-object))  acAllViewports)
)


<<

Filename: 292710_tmp.lsp
Tác giả: Tot77
Bài viết gốc: 292744
Tên lệnh: tmp
Lisp chuyển layer và giữ nguyên màu của block

Bạn dùng thử cái này có tính trường hợp bylayer, còn cái lisp của bạn chưa down được, link cadviet up được mà down không được.

(defun c:tmp()
  (defun dxf(id v) (cdr (assoc id (entget v))))
  
  (vl-load-com)
  (setq v (car (entsel))
lay (dxf 8 v)
name (vla-get-effectivename (vlax-ename->vla-object v)))
  (if (tblsearch "BLOCK" name)
   ...
>>

Bạn dùng thử cái này có tính trường hợp bylayer, còn cái lisp của bạn chưa down được, link cadviet up được mà down không được.

(defun c:tmp()
  (defun dxf(id v) (cdr (assoc id (entget v))))
  
  (vl-load-com)
  (setq v (car (entsel))
lay (dxf 8 v)
name (vla-get-effectivename (vlax-ename->vla-object v)))
  (if (tblsearch "BLOCK" name)
    (progn
      (setq en (tblobjname "BLOCK" name))
      (while (setq en (entnext en))
(if (not (dxf 62 en))
 (entmod (cons (assoc 62 (tblsearch "LAYER" (dxf 8 en))) (entget en))))
        (entmod (subst (cons 8 lay) (assoc 8 (entget en)) (entget en)))
        (entupd en)
      ))
  )
  (vla-regen (vla-get-ActiveDocument (vlax-get-acad-object))  acAllViewports)
)


<<

Filename: 292744_tmp.lsp
Tác giả: Chiron
Bài viết gốc: 223351
Tên lệnh: qsl
Xin Lisp nâng cấp của lệnh select_similar

Mình sửa lại chút xíu để dùng ở dòng lệnh, tuy không được hoàn hảo lắm nhưng vẫn xài được:

(defun c:qsl ()
(cadr (sssetfirst nil (ssget (list (cons 0 (cdr (assoc 0 (entget (car (entsel "\nSelect object and all similar: "))))))))))
(princ)
)

Filename: 223351_qsl.lsp
Tác giả: Tot77
Bài viết gốc: 293001
Tên lệnh: ffl
Could I have an application form? progestogen tablets The lock's design was refined in the mid-18th Century, with the addition of springs
loratadine desloratadine comparison support for Chinese Nationalist and South Korean “infiltration, subversion and sabotage” inside China, maritime interdiction and blockade, and “small-scale conventional air attacks” against nuclear plants.

Filename: 293001_ffl.lsp
Tác giả: Tot77
Bài viết gốc: 292997
Tên lệnh:
[YÊU CẦU] Nhờ viết LISP Isolate một nhóm Layer.

Bạn xài thử cái này.

http://www.mediafire.com/download/b73wvttcjl66q0n/pda.LSP

 

Bạn làm các bước sau:

1. Down cái lisp trên đây về, mở cad , vào lệnh ap > trong phần StartUp Suite > contents > Add > chỉ đường dẫn file mới down > close > close . Làm như vậy để mở file nào cũng load lisp này...

>>

Bạn xài thử cái này.

http://www.mediafire.com/download/b73wvttcjl66q0n/pda.LSP

 

Bạn làm các bước sau:

1. Down cái lisp trên đây về, mở cad , vào lệnh ap > trong phần StartUp Suite > contents > Add > chỉ đường dẫn file mới down > close > close . Làm như vậy để mở file nào cũng load lisp này vào.

 

2. Mở file cần group layer. Đánh lệnh "pda", Nhấn 2 chữ (thí dụ "g" "1") để tạo tên lệnh (nhấn từng chữ một rời rạc chứ không phải nhấn 1 chữ rồi giữ nhấn chữ kia giống như ctrl-1), sau khi vừa nhấn xong 2 chữ thì chọn đối tượng thuộc nhóm layer đó (vừa xong 2 chữ là chuyển liền không cần enter). Cứ chọn 2 chữ rồi chọn layer như vậy đền khi nào hết group thì enter hoặc space để dừng lệnh.

 

3.Test lại bằng cách gõ "g1", "g2"... ở dòng command.

 

4.Làm việc xong nhớ save file lại, lần sau mở ra mới có sẵn các lệnh "g1" "g2"...để xài.

 

Chú ý: Nếu bạn chọn tên trùng tên lệnh có sẵn thì lệnh cũ không dùng được nữa (phải đổi tên lệnh cũ).

3.Test lại bằng cách gõ "g1", "g2"... ở dòng command.
 
3.Test lại bằng cách gõ "g1", "g2"... ở dòng command.
4.Làm việc xong nhớ save file lại, lần sau mở ra mới có sẵn các lệnh "g1" "g2"...để xài.
3.Test lại bằng cách gõ "g1", "g2"... ở dòng command.
4.Làm việc xong nhớ save file lại, lần sau mở ra mới có sẵn các lệnh "g1" "g2"...để xài.
3.Test lại bằng cách gõ "g1", "g2"... ở dòng command.
4.Làm việc xong nhớ save file lại, lần sau mở ra mới có sẵn các lệnh "g1" "g2"...để xài.
3.Test lại bằng cách gõ "g1", "g2"... ở dòng command.
4.Làm việc xong nhớ save file lại, lần sau mở ra mới có sẵn các lệnh "g1" "g2"...để xài.
1. Down cái lisp dưới đây về, mở cad , vào lệnh ap > trong phần StartUp Suite > contents > Add > chỉ đường dẫn file mới down > close > close . Làm như vậy để mở file nào cũng load lisp này vào.
2. Mở file cần group layer. Đánh lệnh "pda", Nhấn 2 chữ (thí dụ "g" "1") để tạo tên lệnh (nhấn từng chữ một rời rạc chứ không phải nhấn 1 chữ rồi giữ nhấn chữ kia giống như ctrl-1), sau khi vừa nhấn xong 2 chữ thì chọn đối tượng thuộc nhóm layer đó (vừa xong 2 chữ là chuyển liền không cần enter). Cứ chọn 2 chữ rồi chọn layer như vậy đền khi nào hết group thì enter hoặc space để dừng lệnh.
3.Test lại bằng cách gõ "g1", "g2"... ở dòng command.
4.Làm việc xong nhớ save file lại, lần sau mở ra mới có sẵn các lệnh "g1" "g2"...để xài.
 
Chú ý: Nếu bạn chọn tên trùng tên lệnh có sẵn thì lệnh cũ không dùng được nữa (phải đổi tên lệnh cũ).
 
Bạn làm các bước sau:
1. Down cái lisp dưới đây về, mở cad , vào lệnh ap > trong phần StartUp Suite > contents > Add > chỉ đường dẫn file mới down > close > close . Làm như vậy để mở file nào cũng load lisp này vào.
2. Mở file cần group layer. Đánh lệnh "pda", Nhấn 2 chữ (thí dụ "g" "1") để tạo tên lệnh (nhấn từng chữ một rời rạc chứ không phải nhấn 1 chữ rồi giữ nhấn chữ kia giống như ctrl-1), sau khi vừa nhấn xong 2 chữ thì chọn đối tượng thuộc nhóm layer đó (vừa xong 2 chữ là chuyển liền không cần enter). Cứ chọn 2 chữ rồi chọn layer như vậy đền khi nào hết group thì enter hoặc space để dừng lệnh.
3.Test lại bằng cách gõ "g1", "g2"... ở dòng command.
4.Làm việc xong nhớ save file lại, lần sau mở ra mới có sẵn các lệnh "g1" "g2"...để xài.
 
Chú ý: Nếu bạn chọn tên trùng tên lệnh có sẵn thì lệnh cũ không dùng được nữa (phải đổi tên lệnh cũ).

<<

Filename: 292997_.lsp
Tác giả: Tot77
Bài viết gốc: 293016
Tên lệnh: ffl
[Xin] lisp chuyển màu các thuộc tính dynamic block

Vậy thì dùng cái này, bạn nhấp vào Att nào đó của block mẫu, sau đó chọn các block khác, cái nào có tag giống tag mẫu sẽ link.

 
;;;===========chen field 1 dynamic block vao dynamic block khac ======================
 
(defun C:FFL (/ v1 obj1 field ss ent i obj)
  (if (setq v1 (car (nentsel "\nChon Attribute  nguon :")))
      (setq obj1 (vlax-Ename->Vla-Object v1)
 ...
>>

Vậy thì dùng cái này, bạn nhấp vào Att nào đó của block mẫu, sau đó chọn các block khác, cái nào có tag giống tag mẫu sẽ link.

 
;;;===========chen field 1 dynamic block vao dynamic block khac ======================
 
(defun C:FFL (/ v1 obj1 field ss ent i obj)
  (if (setq v1 (car (nentsel "\nChon Attribute  nguon :")))
      (setq obj1 (vlax-Ename->Vla-Object v1)
   field (list (vla-get-TagString obj1) obj1)
      )
  )
  (princ "\nChon Dynamic Block can Link :")
  (if (setq ss (ssget (list (cons 0 "INSERT") (cons 66 1))))
    (progn
      (setq i -1)
      (while (setq ent (ssname ss (setq i (1+ i))))
(setq obj (vlax-Ename->Vla-Object ent))
(foreach v (vlax-invoke Obj 'GetAttributes)
   (if (member (vla-get-TagString v) field)
     (vla-put-TextString v (strcat "%<\\AcObjProp Object(%<\\_ObjId "
 (itoa (vla-get-Objectid obj1)) ">%).TextString>%")))))
  ))
  (vl-cmdf "regen")
  (princ)
)


<<

Filename: 293016_ffl.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 293050
Tên lệnh: ha
lisp di chuyển chuột đến chọn (pick) nét vẽ thì nét vẽ nhấp nháy

Thử cái này xem sao: các đối tượng được chọn sẽ HighLight va nhấp nháy khi di chuột.

;Doan  Van Ha - CadViet.com - ngay 13/5/2014
;Chuc nang: HighLight cac doi tuong duoc chon va nhap nhay khi di chuot.
(vl-load-com)
(defun C:HA( / rad gr code ss ss1 pt px p0 p1 p2 p3)
 (setq rad (/ (* (getvar "Viewsize") (getvar "Pickbox")) (cadr (getvar "Screensize"))) ss (ssadd))
 (princ "\nSelect objects:...
>>

Thử cái này xem sao: các đối tượng được chọn sẽ HighLight va nhấp nháy khi di chuột.

;Doan  Van Ha - CadViet.com - ngay 13/5/2014
;Chuc nang: HighLight cac doi tuong duoc chon va nhap nhay khi di chuot.
(vl-load-com)
(defun C:HA( / rad gr code ss ss1 pt px p0 p1 p2 p3)
 (setq rad (/ (* (getvar "Viewsize") (getvar "Pickbox")) (cadr (getvar "Screensize"))) ss (ssadd))
 (princ "\nSelect objects: ")
 (while (and (setq gr (grread 't 15 1) code (car gr) pt (cadr gr)) (/= code 25) (not (equal gr '(2 13))))
  (redraw)
  (Draw_Grvecs pt rad 3)
  (cond
   ((= code 3)
    (setq p0 (polar pt (/ pi -2) rad) p1 (polar p0 0 rad) p2 (polar p1 (/ pi 2) (* 2 rad)) p3 (polar p2 (/ pi -1) (* 2 rad)))
    (setq ss1 (ssget "c" p1 p3))
(if ss1
(foreach ent (#SS->List ss1) (setq ss (ssadd ent ss)))
(progn
 (redraw)
      (setq px (getcorner pt "\nSpecify opposite corner: "))
 (if px (princ "\nSelect objects: "))
 (if (> (car pt) (car px))
       (setq ss1 (ssget "c" pt px))
       (setq ss1 (ssget "w" pt px)))
 (if ss1
  (progn
     (foreach ent (#SS->List ss1) (setq ss (ssadd ent ss)))
   (HighLightObjects (#SS->Objlist ss) T))))))
   ((and (= code 5) ss (> (sslength ss) 0))
    (HighLightObjects (#SS->Objlist ss) (if (or (<= 0 (Second) 0.25) (<= 0.5 (Second) 0.75)) T nil)))))
 (if (and ss (> (sslength ss) 0)) (HighLightObjects (#SS->Objlist ss) nil))
 (redraw) (sssetfirst nil ss) (princ))
(defun Draw_Grvecs(pt rad col / p0 p1 p2 p3 p4)
 (setq p0 (polar pt (/ pi -2) rad) p1 (polar p0 0 rad) p2 (polar p1 (/ pi 2) (* 2 rad)) p3 (polar p2 (/ pi -1) (* 2 rad)) p4 (polar p3 (/ pi -2) (* 2 rad)))
 (grvecs (list col p1 p2 p2 p3 p3 p4 p4 p1)))
(defun Second( / lst)
 (load "julian.lsp")
 (setq lst (jtoc (getvar "date")))
 (- (nth 5 lst) (fix (nth 5 lst))))
(defun *error* (msg)
 (redraw)
 (if (and ss (> (sslength ss) 0)) (HighLightObjects (#SS->Objlist ss) nil))
 (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*") (princ (strcat "\n** Error: " msg " **")))
 (princ))
(defun HighLightObjects (lst h)
 ((lambda (x) (mapcar '(lambda (obj) (vla-highlight obj x)) lst))
  (if h :vlax-true :vlax-false)))
(defun #SS->Objlist (ss / i lst)
 (repeat (setq i (sslength ss))
  (setq lst (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) lst))))
(defun #SS->List (ss / i lst)
 (repeat (setq i (sslength ss)) (setq lst (cons (ssname ss (setq i (1- i))) lst))))
 


<<

Filename: 293050_ha.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 293199
Tên lệnh: vnc
Nhờ các bác viết giùm em lisp vẽ nét cắt vật thể

Đây bác ạ???

Hề hề hề,

Bạn chịu khó down lại từ đây vậy

(defun c:vnc (/ oldos p1 p2 p3 p4 p5 p6)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq p1 (getpoint "\n Chon diem dau cua net cat: ")
          p2 (getpoint p1 "\n Chon diem cuoi cua net cat: ")
          d...
>>

Đây bác ạ???

Hề hề hề,

Bạn chịu khó down lại từ đây vậy

(defun c:vnc (/ oldos p1 p2 p3 p4 p5 p6)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq p1 (getpoint "\n Chon diem dau cua net cat: ")
          p2 (getpoint p1 "\n Chon diem cuoi cua net cat: ")
          d (distance p1 p2)
          a (angle p1 p2)
) 
(command "line" p1 (setq p3 (polar p1 a (- (/ d 2) (/ d 25))))
                                   (setq p4 (polar p3 (- a (/ pi 2)) (/ d 10)))
                                   (setq p5 (polar (setq p6 (polar p2 (+ a pi) (- (/ d 2) (/ d 25)))) (+ a (/ pi 2)) (/ d 10)))
                                   p6 p2 "")
(setvar "osmde" oldos)
(princ)
)

 

Hy vọng không còn bị lỗi bởi trang download của diễn đàn cũng chưa được hoàn toàn ngon.

Chúc thành công.


<<

Filename: 293199_vnc.lsp
Tác giả: hiepttr
Bài viết gốc: 293291
Tên lệnh: test
[Hỏi]Chọn đối Tượng Pline Sau Khi Break

rảnh rỗi sinh nông nổi nên làm liều cho bạn ! :D :D :D

;lisp copy noi dung tung text nhom nay sang nhom khac
(defun c:TEST( / ss ss1 i ct)
(prompt "\nChon cac text can copy noi dung !")
(setq ss (ssget '((0 . "TEXT,MTEXT"))))
(prompt "\nChon cac text can paste noi dung !")
(setq ss1 (ssget '((0 . "TEXT,MTEXT")))
	  i 0)
(while (and ss ss1 (<= (sslength ss) (sslength ss1)) (< i (sslength ss)))
	(setq ct (assoc 1 (entget (ssname ss...
>>

rảnh rỗi sinh nông nổi nên làm liều cho bạn ! :D :D :D

;lisp copy noi dung tung text nhom nay sang nhom khac
(defun c:TEST( / ss ss1 i ct)
(prompt "\nChon cac text can copy noi dung !")
(setq ss (ssget '((0 . "TEXT,MTEXT"))))
(prompt "\nChon cac text can paste noi dung !")
(setq ss1 (ssget '((0 . "TEXT,MTEXT")))
	  i 0)
(while (and ss ss1 (<= (sslength ss) (sslength ss1)) (< i (sslength ss)))
	(setq ct (assoc 1 (entget (ssname ss i))))
	(entmod (subst ct (assoc 1 (setq info (entget (ssname ss1 i)))) info))
	(setq i (1+ i))
)
(princ)
)

<<

Filename: 293291_test.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 293719
Tên lệnh: ha
[yêu cầu] lisp scale dynamic block để áp dụng cho chuyển tỉ lệ bản vẽ

Chắc là vậy?

; Doan Van Ha - CadViet.com - ngay 16/5/2014
; Chuc nang: Scale Dynamic Blocks at Center.
(defun C:HA (/ ss ent obj i)
 (vl-load-com)
 (if (not *tl*) (setq *tl* 1.0))
 (initget 6)
 (setq tl (getreal (strcat "\nHe so Scale <" (rtos *tl* 2) ">: ")))
 (if (not tl) (setq tl *tl*) (setq *tl* tl))
 (princ "\nChon cac Block can Scale...")
 (setq ss...
>>

Chắc là vậy?

; Doan Van Ha - CadViet.com - ngay 16/5/2014
; Chuc nang: Scale Dynamic Blocks at Center.
(defun C:HA (/ ss ent obj i)
 (vl-load-com)
 (if (not *tl*) (setq *tl* 1.0))
 (initget 6)
 (setq tl (getreal (strcat "\nHe so Scale <" (rtos *tl* 2) ">: ")))
 (if (not tl) (setq tl *tl*) (setq *tl* tl))
 (princ "\nChon cac Block can Scale...")
 (setq ss (ssget '((0 . "INSERT"))) i -1)
 (while (< (setq i (1+ i)) (sslength ss))
  (setq ent (ssname ss i))
  (if (and (eq (vla-get-IsDynamicBlock (vlax-ename->vla-object ent)) :vlax-true) (/= tl 1))
   (command "scale" ent "" (cdr (assoc 10 (entget ent))) tl))))
 


<<

Filename: 293719_ha.lsp
Tác giả: thiep
Bài viết gốc: 73462
Tên lệnh: ptla
Viết lisp theo yêu cầu [phần 2]

Chào kamezoko, Lisp này, Thiep đã gộp lại:

Chúc bạn thàng công!

Filename: 73462_ptla.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 293967
Tên lệnh: ha
lisp di chuyển chuột đến chọn (pick) nét vẽ thì nét vẽ nhấp nháy

Cuối cùng cũng tìm ra được 1 giải thuật để giải quyết yêu cầu của chủ topic.

Lisp dưới đây có các chức năng sau:

- Làm đậm các đối tượng được chọn (tương tự như khi di chuột vào từng đối tượng).

- Highlight các đối tượng được chọn (tương tự như khi di chuột vào từng đối tượng).

- Làm nhấp nháy các đối tượng được chọn khi di chuột (cái này hình...

>>

Cuối cùng cũng tìm ra được 1 giải thuật để giải quyết yêu cầu của chủ topic.

Lisp dưới đây có các chức năng sau:

- Làm đậm các đối tượng được chọn (tương tự như khi di chuột vào từng đối tượng).

- Highlight các đối tượng được chọn (tương tự như khi di chuột vào từng đối tượng).

- Làm nhấp nháy các đối tượng được chọn khi di chuột (cái này hình như Cad nguyên thủy chưa thấy có?).

;Doan  Van Ha - CadViet.com - ngay 13/5/2014. Edit: 17/5/2014.
;Chuc nang: To dam va Highlight cac doi tuong duoc chon, dong thoi lam nhap nhay chung khi di chuot.
(vl-load-com)
(defun Draw_Grvecs(pt rad col / p0 p1 p2 p3 p4)
 (setq p0 (polar pt (/ pi -2) rad) p1 (polar p0 0 rad) p2 (polar p1 (/ pi 2) (* 2 rad)) p3 (polar p2 (/ pi -1) (* 2 rad)) p4 (polar p3 (/ pi -2) (* 2 rad)))
 (grvecs (list col p1 p2 p2 p3 p3 p4 p4 p1)))
(defun Second( / lst)
 (if (and (vl-position "acetutil.arx" (arx)) (not (vl-catch-all-error-p (vl-catch-all-apply (function (lambda nil (acet-sys-shift-down)))))))
  (progn
   (load "julian.lsp")
   (setq lst (jtoc (getvar "date")))
   (- (nth 5 lst) (fix (nth 5 lst))))
  (progn (alert "Chuong trinh yeu cau Ban phai cai dat Tool Express.") (exit))))
(defun *error* (msg)
 (redraw)
 (if (and ss (> (sslength ss) 0)) (HighLightObjects (#SS->Objlist ss) nil))
 (if (and ss2 (> (sslength ss2) 0)) (mapcar 'vla-Delete (#SS->Objlist ss2)))
 (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*") (princ (strcat "\n** Error: " msg " **")))
 (princ))
(defun HighLightObjects (lst h)
 ((lambda (x) (mapcar '(lambda (obj) (vla-highlight obj x)) lst))
  (if h :vlax-true :vlax-false)))
(defun #SS->Objlist (ss / i lst)
 (repeat (setq i (sslength ss))
  (setq lst (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) lst))))
(defun #SS->List (ss / i lst)
 (repeat (setq i (sslength ss)) (setq lst (cons (ssname ss (setq i (1- i))) lst))))
(defun COPYG(ss / lst ss2 obj1)
 (setq lst (#SS->Objlist ss) ss2 (ssadd))
 (foreach obj lst
  (vla-copy obj) (setq obj1 (vlax-ename->vla-object (entlast)))
  (vla-move obj1 (vlax-3d-point '(0 0)) (vlax-3d-point (list 0 (/ rad 5)))) (setq ss2 (ssadd (entlast) ss2))
  (vla-copy obj) (setq obj1 (vlax-ename->vla-object (entlast)))
  (vla-move obj1 (vlax-3d-point '(0 0)) (vlax-3d-point (list 0 (/ rad -5)))) (setq ss2 (ssadd (entlast) ss2))
  (vla-copy obj) (setq obj1 (vlax-ename->vla-object (entlast)))
  (vla-move obj1 (vlax-3d-point '(0 0)) (vlax-3d-point (list (/ rad 5) 0))) (setq ss2 (ssadd (entlast) ss2))
  (vla-copy obj) (setq obj1 (vlax-ename->vla-object (entlast)))
  (vla-move obj1 (vlax-3d-point '(0 0)) (vlax-3d-point (list (/ rad -5) 0))) (setq ss2 (ssadd (entlast) ss2)))
 ss2)
(defun C:HA( / rad gr code ss ss1 ss2 pt px p0 p1 p2 p3)
 (setq rad (/ (* (getvar "Viewsize") (getvar "Pickbox")) (cadr (getvar "Screensize"))) ss (ssadd))
 (princ "\nSelect objects: ")
 (while (and (setq gr (grread 't 15 1) code (car gr) pt (cadr gr)) (/= code 25) (not (equal gr '(2 13))))
  (redraw)
  (Draw_Grvecs pt rad 3)
  (cond
   ((= code 3)
    (setq p0 (polar pt (/ pi -2) rad) p1 (polar p0 0 rad) p2 (polar p1 (/ pi 2) (* 2 rad)) p3 (polar p2 (/ pi -1) (* 2 rad)))
    (setq ss1 (ssget "c" p1 p3))
(if ss1
(foreach ent (#SS->List ss1) (setq ss (ssadd ent ss)))
(progn
 (redraw)
      (setq px (getcorner pt "\nSpecify opposite corner: "))
 (if px (princ "\nSelect objects: "))
 (if (> (car pt) (car px))
       (setq ss1 (ssget "c" pt px))
       (setq ss1 (ssget "w" pt px)))
 (if ss1
  (progn
     (foreach ent (#SS->List ss1) (setq ss (ssadd ent ss)))
   (HighLightObjects (#SS->Objlist ss) T))))))
   ((and (= code 5) ss (> (sslength ss) 0))
    (if (and ss2 (> (sslength ss2) 0)) (mapcar 'vla-Delete (#SS->Objlist ss2)))
    (setq ss2 (copyg ss))
    (HighLightObjects (#SS->Objlist ss) (if (or (<= 0 (Second) 0.25) (<= 0.5 (Second) 0.75)) T nil)))))
 (if (and ss (> (sslength ss) 0)) (VisibleObjects (#SS->Objlist ss) T))
 (if (and ss2 (> (sslength ss2) 0)) (mapcar 'vla-Delete (#SS->Objlist ss2)))
 (redraw)
 (princ))
(princ "\nLenh su dung: HA")
(princ)
 


<<

Filename: 293967_ha.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 294097
Tên lệnh: ha
lisp di chuyển chuột đến chọn (pick) nét vẽ thì nét vẽ nhấp nháy

Nếu chủ topic chấp nhận kiểu "làm mờ các đối tượng không được chọn" như trong lisp thì sử dụng. Còn bằng không thì hãy đợi đấy, lúc nào rảnh mần tiếp.

;Doan  Van Ha - CadViet.com - ngay 13/5/2014. Edit: 17/5/2014.
;Chuc nang: To dam va Highlight cac doi tuong duoc chon, dong thoi lam nhap nhay chung khi di chuot.
(vl-load-com)
(defun #SS:Subtract (ss1 ss2 / i)
 (if (and ss2...
>>

Nếu chủ topic chấp nhận kiểu "làm mờ các đối tượng không được chọn" như trong lisp thì sử dụng. Còn bằng không thì hãy đợi đấy, lúc nào rảnh mần tiếp.

;Doan  Van Ha - CadViet.com - ngay 13/5/2014. Edit: 17/5/2014.
;Chuc nang: To dam va Highlight cac doi tuong duoc chon, dong thoi lam nhap nhay chung khi di chuot.
(vl-load-com)
(defun #SS:Subtract (ss1 ss2 / i)
 (if (and ss2 (> (sslength ss2) 0))
  (repeat (setq i (sslength ss2))
   (ssdel (ssname ss2 (setq i (1- i))) ss1)))
 ss1)
(defun VPCords()
 ((lambda (offset) ((lambda (viewctr) (list (mapcar '- viewctr offset) (mapcar '+ viewctr offset))) (getvar "viewctr")))
  ((lambda (halfHeight aspectRatio) (list (* halfHeight aspectRatio) halfHeight))
   (* 0.5 (getvar "viewsize"))
   (apply '/ (getvar "screensize")))))
(defun Draw_Grvecs(pt rad col / p0 p1 p2 p3 p4)
 (setq p0 (polar pt (/ pi -2) rad) p1 (polar p0 0 rad) p2 (polar p1 (/ pi 2) (* 2 rad)) p3 (polar p2 (/ pi -1) (* 2 rad)) p4 (polar p3 (/ pi -2) (* 2 rad)))
 (grvecs (list col p1 p2 p2 p3 p3 p4 p4 p1)))
(defun Second( / lst)
 (if (and (vl-position "acetutil.arx" (arx)) (not (vl-catch-all-error-p (vl-catch-all-apply (function (lambda nil (acet-sys-shift-down)))))))
  (progn
   (load "julian.lsp")
   (setq lst (jtoc (getvar "date")))
   (- (nth 5 lst) (fix (nth 5 lst))))
  (progn (alert "Chuong trinh yeu cau Ban phai cai dat Tool Express.") (exit))))
(defun *error* (msg)
 (redraw)
 (if (and ss (> (sslength ss) 0)) (HighLightObjects (#SS->Objlist ss) nil))
 (if (and ss2 (> (sslength ss2) 0)) (mapcar 'vla-Delete (#SS->Objlist ss2)))
 (if (and ss3 (> (sslength ss3) 0)) (HighLightObjects (#SS->Objlist ss3) nil))
 (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*") (princ (strcat "\n** Error: " msg " **")))
 (princ))
(defun HighLightObjects (lst h)
 ((lambda (x) (mapcar '(lambda (obj) (vla-highlight obj x)) lst))
  (if h :vlax-true :vlax-false)))
(defun #SS->Objlist (ss / i lst)
 (repeat (setq i (sslength ss))
  (setq lst (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) lst))))
(defun #SS->List (ss / i lst)
 (repeat (setq i (sslength ss)) (setq lst (cons (ssname ss (setq i (1- i))) lst))))
(defun COPYG(ss / lst ss2 obj1)
 (setq lst (#SS->Objlist ss) ss2 (ssadd))
 (foreach obj lst
  (vla-copy obj) (setq obj1 (vlax-ename->vla-object (entlast)))
  (vla-move obj1 (vlax-3d-point '(0 0)) (vlax-3d-point (list 0 (/ rad 5)))) (setq ss2 (ssadd (entlast) ss2))
  (vla-copy obj) (setq obj1 (vlax-ename->vla-object (entlast)))
  (vla-move obj1 (vlax-3d-point '(0 0)) (vlax-3d-point (list 0 (/ rad -5)))) (setq ss2 (ssadd (entlast) ss2))
  (vla-copy obj) (setq obj1 (vlax-ename->vla-object (entlast)))
  (vla-move obj1 (vlax-3d-point '(0 0)) (vlax-3d-point (list (/ rad 5) 0))) (setq ss2 (ssadd (entlast) ss2))
  (vla-copy obj) (setq obj1 (vlax-ename->vla-object (entlast)))
  (vla-move obj1 (vlax-3d-point '(0 0)) (vlax-3d-point (list (/ rad -5) 0))) (setq ss2 (ssadd (entlast) ss2)))
 ss2)
(defun C:HA( / rad gr code ss ss1 ss2 ss3 pt px p0 p1 p2 p3)
 (setq rad (/ (* (getvar "Viewsize") (getvar "Pickbox")) (cadr (getvar "Screensize"))) ss (ssadd))
 (princ "\nSelect objects: ")
 (while (and (setq gr (grread 't 15 1) code (car gr) pt (cadr gr)) (/= code 25) (not (equal gr '(2 13))))
  (redraw)
  (Draw_Grvecs pt rad 3)
  (cond
   ((= code 3)
    (setq p0 (polar pt (/ pi -2) rad) p1 (polar p0 0 rad) p2 (polar p1 (/ pi 2) (* 2 rad)) p3 (polar p2 (/ pi -1) (* 2 rad)))
    (setq ss1 (ssget "c" p1 p3))
(if ss1
(foreach ent (#SS->List ss1) (setq ss (ssadd ent ss)))
(progn
 (redraw)
      (setq px (getcorner pt "\nSpecify opposite corner: "))
 (if px (princ "\nSelect objects: "))
 (if (> (car pt) (car px))
       (setq ss1 (ssget "c" pt px))
       (setq ss1 (ssget "w" pt px)))
 (if ss1
  (progn
     (foreach ent (#SS->List ss1) (setq ss (ssadd ent ss)))
   (HighLightObjects (#SS->Objlist ss) T))))))
   ((and (= code 5) ss (> (sslength ss) 0))
    (if (and ss2 (> (sslength ss2) 0)) (mapcar 'vla-Delete (#SS->Objlist ss2)))
    (setq ss3 (ssget "c" (car (VPCords)) (cadr (VPCords))))
(HighLightObjects (#SS->Objlist ss3) T)
    (setq ss2 (copyg ss))
    (HighLightObjects (#SS->Objlist ss) (if (or (<= 0 (Second) 0.25) (<= 0.5 (Second) 0.75)) T nil)))))
 (if (and ss2 (> (sslength ss2) 0)) (mapcar 'vla-Delete (#SS->Objlist ss2)))
 (if (and ss3 (> (sslength ss3) 0)) (HighLightObjects (#SS->Objlist ss3) nil))
 (redraw)
 (princ))
(princ "\nLenh su dung: HA")
(princ)
 


<<

Filename: 294097_ha.lsp
Tác giả: Tot77
Bài viết gốc: 294091
Tên lệnh: tmp
[Yêu cầu] Nhờ viết Lisp Move Text vuông góc với Pline hoặc Line

Nếu chỉ move text tới "dính" vào pline hoặc line mà không cần xoay text thì dùng cái dưới đây.

Ở đây text là left, và không kéo dài line hoặc pline, nếu bạn muốn kéo dài thì tìm chỗ nào có chữ "nil" đổi thành "t".

(defun c:tmp()
  (setq obj (vlax-ename->vla-object (car (entsel "\nChon Line hoac Polyline:"))))
  (prompt "\nChon text:")
  (setq ss (ssget '((0 ....
>>

Nếu chỉ move text tới "dính" vào pline hoặc line mà không cần xoay text thì dùng cái dưới đây.

Ở đây text là left, và không kéo dài line hoặc pline, nếu bạn muốn kéo dài thì tìm chỗ nào có chữ "nil" đổi thành "t".

(defun c:tmp()
  (setq obj (vlax-ename->vla-object (car (entsel "\nChon Line hoac Polyline:"))))
  (prompt "\nChon text:")
  (setq ss (ssget '((0 . "TEXT"))))
  (mapcar '(lambda(x) (entmod (subst
(cons 10 (vlax-curve-getClosestPointTo obj (cdr (assoc 10 (entget x))) nil))
(assoc 10 (entget x)) (entget x))))  (acet-ss-to-list ss))
)

 

Chỗ nào có chữ <span> thì bạn xóa đi dùm, gửi theo kiểu này hay bị ba cái vụ đó.

Ở đây tôi hiểu "move vuông góc" tức là dời text theo hướng vuông góc với pline, chứ không phải xoay text vuông góc với pline.


<<

Filename: 294091_tmp.lsp
Tác giả: vantuan18nd
Bài viết gốc: 285813
Tên lệnh: rft
[NHỜ CHỈNH SỬA] lisp phun toạ độ lên CAD

Nhờ các member ai biết chỉnh sửa giúp mình Lisp phun tọa độ từ file TXT vào trong CAD với

- File txt mình có cáu trúc STTXYZ

- Khi chạy lisp, nó không hiển thị giá trị Z

Help !

 

;; free lisp from cadviet.com

;;; this lisp was downloaded from

Nhờ các member ai biết chỉnh sửa giúp mình Lisp phun tọa độ từ file TXT vào trong CAD với

- File txt mình có cáu trúc STTXYZ

- Khi chạy lisp, nó không hiển thị giá trị Z

Help !

 

;; free lisp from cadviet.com

;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/20044-yeu-cau-lisp-phun-toa-do-cac-diem-tu-file-txt-vao-cad/page-3
;; free lisp from cadviet.com

(defun c:RFT (/ code data f h line pt pxy spc txt stt ten)

;Read File Txt

;| By : Gia Bach, gia_bach @ www.CadViet.com |;

(vl-load-com)

(defun Split (str / i kitu line lst txtPhanbiet)

(setq i 1

txtPhanbiet

(strcat (chr 9) (chr 32) (chr 44))

)

(while (< i (strlen str))

(setq kitu (substr str i 1))

(if (vl-string-search kitu txtPhanbiet)

(progn

(if (null Lst)

(setq Lst (list (substr Str 1 (- i 1))))

(setq Lst (append Lst (list (read (substr Str 1 (- i 1))))))

)

(setq Str (substr Str (+ i 1))

i 1

)

)

(setq i (1+ i))

)

)

(setq Lst (append Lst (list Str)))

)

(or *h* (setq *h* 2))

(initget 6)

(setq h (getdist (strcat "\nNhap chieu cao Text <" (rtos *h*) "> :")

)

)

(if h

(setq *h* h)

(setq h *h*)

)

(if (setq ten (getfiled "Chon File txt" (getvar "dwgprefix") "txt" 8))

(progn

(or (tblsearch "layer" "Point")

(command "-layer" "n" "Point" "")

)

(or (tblsearch "layer" "Sothutu")

(command "-layer" "n" "Sothutu" "c" 3 "Sothutu" "")

)

(or (tblsearch "layer" "Caodo")

(command "-layer" "n" "Caodo" "c" 4 "Caodo" "")

)

(or (tblsearch "layer" "Code")

(command "-layer" "n" "Code" "c" 2 "Code" "")

)

(setq spc (vla-get-ModelSpace

(vla-get-ActiveDocument (vlax-get-Acad-Object))

)

)

(setq f (open (findfile ten) "r"))

(while (setq Line (read-line f))

(if (wcmatch

Line

(strcat "*" (chr 9) "*,*" (chr 32) "*,*`" (chr 44) "*")

)

(progn

(setq data (split Line)

code (last data)

)

(if (and

(= (vl-list-length data) 5)

(setq pt (vl-remove code (cdr data)))

(not (vl-catch-all-error-p

(vl-catch-all-apply 'vlax-3d-point pt)

)

)

)

;;;neu du lieu data co 5 bien so

(progn

(setq stt (car data)

pXY (list (car pt) (cadr pt))

)

(vla-put-Layer

(vla-addpoint spc (vlax-3d-point pXY))

"Point"

)

(vla-put-Layer

(setq txt (vla-addtext

spc

stt

(vlax-3d-point (list 0 0 0))

h

)

)

"Sothutu"

)

(vla-put-Alignment txt 8)

(vla-put-TextAlignmentPoint txt (vlax-3d-point pXY))

(vla-put-Layer

(setq txt (vla-addtext

spc

code

(vlax-3d-point (list 0 0 0))

h

)

)

"Code"

)

(vla-put-Alignment txt 6)

(vla-put-TextAlignmentPoint

txt

(vlax-3d-point (polar pXY 0 (* 0.2 h)))

)

(vla-put-Layer

(vla-addtext spc (caddr pt) (vlax-3d-point pXY) h)

"Caodo"

)

)

;;het progn list data=5

;;;neu du lieu data co 4 bien so (ban co the dung ham COND hoac if de bay loi

(progn

(setq pt (vl-remove code (cdr data)))

(not (vl-catch-all-error-p

(vl-catch-all-apply 'vlax-3d-point pt)

)

)





(setq stt (car data)

pXY (list (car pt) (cadr pt))

)

(vla-put-Layer

(vla-addpoint spc (vlax-3d-point pXY))

"Point"

)

(vla-put-Layer

(setq txt (vla-addtext

spc

stt

(vlax-3d-point (list 0 0 0))

h

)

)

"Sothutu"

)

(vla-put-Alignment txt 8)

(vla-put-TextAlignmentPoint txt (vlax-3d-point pXY))

(vla-put-Layer

(vla-addtext spc (last data) (vlax-3d-point pXY) h)

"Caodo"

)

)

;;;het progn list=4

)

)

)

)

)

)

(princ)

)


<<

Filename: 285813_rft.lsp

Trang 158/330

158