Jump to content
InfoFile
Tác giả: bach1212
Bài viết gốc: 196252
Tên lệnh: ch
Chỉnh sửa nhanh Scale Hatch, đổi nhanh nhiều góc cho hàng loạt hatch

À quên. lúc đầu mình để chọn tạp nham nên phải kiểm tra nó là Hatch hay không, cho vào Filter của ssget rồi thì thôi k kiểm tra nữa, bạn...

>>

À quên. lúc đầu mình để chọn tạp nham nên phải kiểm tra nó là Hatch hay không, cho vào Filter của ssget rồi thì thôi k kiểm tra nữa, bạn sửa lại như này cho gọn :

(defun c:ch(/ a c)
(vl-load-com)
(if (and
 (ssget (list (cons 0 "HATCH")))
 (setq a (getangle "\nGoc cong them :"))
 (setq c (getreal "\nScale moi :"))
)
(vlax-for object (vla-get-ActiveSelectionSet (vla-get-ActiveDocument (vlax-get-acad-object)))
  (vla-put-PatternAngle object (+ (vla-get-PatternAngle object) a))
  (vla-put-PatternScale object c)  
)
)
)

Nên kết hợp Fi hoặc Qs để chọn ra Hatch mình cần trước rồi dùng lệnh cũng đc :)

muốn thể hiện trên dòng nhắc lệnh: Goc cong them thành Goc cong them (Goc hien tai:50) với 50 là con số thể hiện góc xoay hiện tại của hatch đó. Tương tự cho scale Scale moi thành Scale moi (10)

. Làm thế nào bác nhỉ?


<<

Filename: 196252_ch.lsp
Tác giả: quynt83
Bài viết gốc: 283614
Tên lệnh: ha
Lisp spline các điểm có tọa độ nhập từ .txt

 

Đây bạn ơi!

;Doan Van Ha - CADViet.com - Ngay 7/5/2012
;Muc dich: Ve Spline tu cac diem lay tu file...
>>

 

Đây bạn ơi!

;Doan Van Ha - CADViet.com - Ngay 7/5/2012
;Muc dich: Ve Spline tu cac diem lay tu file txt (moi diem la 1 cot, cac cot cach nhau boi 2 ky tu trang "  ").
(defun C:HA(/ pr lst1 lst2 z lst)
 (vl-load-com)
 (setq pr (open (getfiled "Chon file de lay so lieu" "" "txt" 0) "r"))
 (setq lst1 (cdr (LM:str->lst (read-line pr) "  ")))
 (setq lst2 (cdr (LM:str->lst (read-line pr) "  ")))
 (close pr)
 (setq z 0)
 (repeat (length lst1)
  (setq lst (cons (list (atof (nth z lst1)) (atof (nth z lst2))) lst))
  (setq z (1+ z)))
 (Spline lst)
 (princ))
(defun LM:str->lst (str del / pos) (if (setq pos (vl-string-search del str)) (cons (substr str 1 pos) (LM:str->lst (substr str (+ pos 1 (strlen del))) del)) (list str)))
(defun Spline (lst) (entmakex (append (list '(0 . "SPLINE") '(100 . "AcDbEntity") '(100 . "AcDbSpline") (cons 71 3) (cons 74 (length lst))) (mapcar (function (lambda (p) (cons 11 p))) lst))))

Chào anh Doan Van Ha, e có thử bài này của anh vào cad load file ha.lsp, roi dung lenh "ha" để load file txt như hướng dẫn của anh mà ko hiển thị gì, rất mong anh chỉ dẫn, cảm ơn anh nhiều


<<

Filename: 283614_ha.lsp
Tác giả: chutuan
Bài viết gốc: 209886
Tên lệnh: nn
Lisp nối Line thành Pline ?

Hề hề, có 1 dấu tick Thanks, bạn tick vào đó là được mờ.

NgocSon hãy thử code này :

Bạn pick vào 1 trong các line, arc, pline nào...

>>

Hề hề, có 1 dấu tick Thanks, bạn tick vào đó là được mờ.

NgocSon hãy thử code này :

Bạn pick vào 1 trong các line, arc, pline nào đó -> là nó tự tìm các đoạn liên kết được để nối và các đoạn này có cùng tên layer. Tên Layer này được lấy theo đối tượng mà bạn đã pick. OK?

Đây là code

(defun c:nn (/ tdt ssdt sodt index)(defun ObjName (ssdt /)(cdr (assoc '0 (entget ssdt))))(defun MoPL (ssdt /)(= (cdr (assoc '70 (entget ssdt))) 0))(defun NoiPL (ssdt /)(if (MoPL ssdt)(command ".PEDIT" ssdt "J" tdt "" "X")))(defun NoiLC (ssdt /)(command ".PEDIT" ssdt "Y" "J" tdt "" "X"))(setq ent (car(entsel "\nPick vao 1 doi tuong de noi :")))(setqtdt (ssget "X"	(list        (assoc 8 (entget ent) )	) 	)sodt (sslength tdt)index 0)(repeat sodt(setqssdt (ssname tdt index)index (1+ index))(if (or (= (Objname ssdt) "LWPOLYLINE")(= (Objname ssdt) "POLYLINE"))(NoiPL ssdt))(if (or (= (Objname ssdt) "LINE") (= (Objname ssdt) "ARC"))(NoiLC ssdt)))(princ))

Hy vọng trúng ý của bạn

 

em thấy lisp này rất hay, em thường xuyên sử dụng, nhưng mà lisp này khi chọn layer nó lại nối toàn bộ các layer trong hết 1 bản vẽ, giờ em muốn các bác chỉnh lại giúp em là chỉ nối trong 1 vùng bản vẽ mình chọn thôi, cảm ơn các bác


<<

Filename: 209886_nn.lsp
Tác giả: sucuph
Bài viết gốc: 90515
Tên lệnh: lb2
Viết lisp theo yêu cầu [phần 2]
Chào bạn Sucuph,

Sau một hồi lần sờ, mình mót được của bác phi-phi cái lisp xuất tọa độ ra file *.txt, *.csv, *.xls. Thế là đem về bổ ra xơi, thấy xơ nhiều...

>>
Chào bạn Sucuph,

Sau một hồi lần sờ, mình mót được của bác phi-phi cái lisp xuất tọa độ ra file *.txt, *.csv, *.xls. Thế là đem về bổ ra xơi, thấy xơ nhiều nạc ít, giắt răng muốn chết. Vậy nhưng cũng gặm được một chút. Nhờ đó có cái ghép vô với cái lisp lb2.lsp mà mình đã gửi bạn để cho ra được một cô em khá kháu khỉnh.

Bạn thử xài xem nhé:

(defun c:lb2 ()
(vl-load-com)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;




;;;;;;;;;;;;;;;;;
(defun text-draw (txt pnt height rotation justification)
  (if (null pnt)(command "_.-TEXT" "" txt)
  (if (= (cdr (assoc 40 (tblsearch "STYLE" (getvar "TEXTSTYLE"))))
   0.0
      ) ;_ end of =
    (progn
          (if justification
  (command "_.-TEXT" "_J" justification "_none" pnt height rotation txt)
  (command "_.-TEXT" "_none" pnt height rotation txt)
      ) ;_ end of if
    ) ;_ end of progn
    (progn
            (if justification
  (command "_.-TEXT" "_J" justification "_none" pnt rotation txt)
  (command "_.-TEXT" "_none" pnt rotation txt)
      ) ;_ end of if
    ) ;_ end of progn
  ) ;_ end of if
    )
 (entlast)
);;;;; End of defun text-draw
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun xls ( Data-list header Colhide Name_list / *aplexcel* *books-colection* Currsep
*excell-cells* *new-book* *sheet#1* *sheet-collection* col iz_listo row cell cols)
(defun Letter (N / Res TMP)(setq Res "")(while (> N 0)(setq TMP (rem N 26)
 TMP (if (zerop TMP)(setq N (1- N) TMP 26) TMP)
 Res (strcat (chr (+ 64 TMP)) Res)  N   (/ N 26))) Res)
(if (null Name_list)(setq Name_list ""))
 (setq  *AplExcel*     (vlax-get-or-create-object "Excel.Application"))
 (if (setq *New-Book*  (vlax-get-property *AplExcel* "ActiveWorkbook"))
   (setq *Books-Colection*  (vlax-get-property *AplExcel* "Workbooks")
         *Sheet-Collection* (vlax-get-property *New-Book* "Sheets")
              *Sheet#1*     (vlax-invoke-method *Sheet-Collection* "Add"))
(setq *Books-Colection*  (vlax-get-property *AplExcel* "Workbooks")
             *New-Book*     (vlax-invoke-method *Books-Colection* "Add")
         *Sheet-Collection* (vlax-get-property *New-Book* "Sheets")
              *Sheet#1*     (vlax-get-property *Sheet-Collection* "Item" 1)))
(setq *excell-cells*     (vlax-get-property *Sheet#1* "Cells"))
(setq Name_list (if (= Name_list "")
                 (vl-filename-base(getvar "DWGNAME"))
                 (strcat (vl-filename-base(getvar "DWGNAME")) "&" Name_list))
  col 0 cols nil)
(if (> (strlen Name_list) 26)
(setq Name_list (strcat (substr Name_list 1 10) "..." 
(substr Name_list (- (strlen Name_list) 13) 14))))
(vlax-for sh *Sheet-Collection* (setq cols (cons (strcase(vlax-get-property sh 'Name)) cols)))
(setq row Name_list)
(while (member (strcase row) cols)(setq row (strcat Name_list " (" (itoa(setq col (1+ col)))")")))
(setq Name_list row)
(vlax-put-property *Sheet#1* 'Name Name_list)
(setq Currsep (vlax-get-property *AplExcel* "UseSystemSeparators"))
(vlax-put-property *AplExcel* "UseSystemSeparators" :vlax-false) 
(vlax-put-property *AplExcel* "DecimalSeparator" ".")            
(vlax-put-property *AplExcel* "ThousandsSeparator" " ")          
(vla-put-visible *AplExcel* :vlax-true)(setq row 1 col 1)
(if (null header)(setq header '("X" "Y" "Z")))
(repeat (length header)(vlax-put-property *excell-cells* "Item" row col
(vl-princ-to-string (nth (1- col) header)))(setq col (1+ col)))(setq  row 2 col 1)
(repeat (length Data-list)(setq iz_listo (car Data-list))(repeat (length iz_listo)
(vlax-put-property *excell-cells* "Item" row col (vl-princ-to-string (car iz_listo)))
(setq iz_listo (cdr iz_listo) col (1+ col)))(setq Data-list (cdr Data-list))(setq col 1 row (1+ row)))
(setq col (1+(length header)) row (1+ row))
(setq cell (vlax-variant-value (vlax-invoke-method *Sheet#1* "Evaluate"
   (strcat "A1:" (letter col)(itoa row))))) ;_ end of setq
(setq cols (vlax-get-property cell  'Columns))
(vlax-invoke-method cols 'Autofit)
(vlax-release-object cols)(vlax-release-object cell)
(foreach item ColHide (if (numberp item)(setq item (letter item)))
(setq cell (vlax-variant-value (vlax-invoke-method *Sheet#1* "Evaluate"
   (strcat item "1:" item "1"))))
(setq cols (vlax-get-property cell  'Columns))
(vlax-put-property cols 'hidden 1)
(vlax-release-object cols)(vlax-release-object cell))
(vlax-put-property *AplExcel* "UseSystemSeparators" Currsep)
(mapcar 'vlax-release-object (list *excell-cells* *Sheet#1* *Sheet-Collection* 
*New-Book* *Books-Colection**AplExcel*))(setq *AplExcel* nil)(gc)(gc)(princ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(command "undo" "be")
(setq en (entsel "\n Chon pline ")
ob (vlax-ename->vla-object (car en))
n (vlax-curve-getEndParam ob)
i 0
li1 (list)
)
(setq pb (getpoint "\n Chon diem dat bang")
h (getreal "\n Nhap chieu cao chu: ")
k (getreal "\n Nhap do rong cot: ")
)
(entmake (list (cons 0 "TEXT") (cons 10 pb) (cons 40 h) (cons 1 "BANG KET QUA")))
(entmake (list (cons 0 "TEXT") (cons 10 (list (car pb) (- (cadr pb) (* 1.5 h)))) (cons 40 h) (cons 1 "STT")))
(entmake (list (cons 0 "TEXT") (cons 10 (list (+ (car pb) k) (- (cadr pb) (* 1.5 h)))) (cons 40 h) (cons 1 "X")))
(entmake (list (cons 0 "TEXT") (cons 10 (list (+ (car pb) (* 2 k)) (- (cadr pb) (* 1.5 h)))) (cons 40 h) (cons 1 

"Y")))
(entmake (list (cons 0 "TEXT") (cons 10 (list (+ (car pb) (* 3 k)) (- (cadr pb) (* 1.5 h)))) (cons 40 h) (cons 1 

"Z")))
(while (<= i n)
(setq p (vlax-curve-getPointAtParam ob i) 
li1 (append li1 (list p))
y (- (cadr pb) (* (+ 2 i) 1.5 h))
)
(entmake (list (cons 0 "TEXT") (cons 10 (list (car p) (+ (cadr p) 5))) (cons 40 1.0)
(cons 1 (strcat "X=" (rtos (car p) 2 2)))))
(entmake (list (cons 0 "TEXT") (cons 10 (list (car p) (+ (cadr p) 2.5))) (cons 40 1.0)
(cons 1 (strcat "Y=" (rtos (cadr p) 2 2)))))
(entmake (list (cons 0 "TEXT") (cons 10 (list (car p) (cadr p))) (cons 40 1.0)
(cons 1 (strcat "Z=" (rtos (caddr p) 2 2)))))
(entmake (list (cons 0 "TEXT") (cons 10 (list (car pb) y)) (cons 40 h) (cons 1  (rtos (1+ i) 2 0))))
(entmake (list (cons 0 "TEXT") (cons 10 (list (+ (car pb) k) y)) (cons 40 h) (cons 1 (rtos (car p ) 2 2))))
(entmake (list (cons 0 "TEXT") (cons 10 (list (+ (car pb) (* 2 k)) y)) (cons 40 h) (cons 1 (rtos (cadr p ) 2 2))))
(entmake (list (cons 0 "TEXT") (cons 10 (list (+ (car pb) (* 3 k)) y)) (cons 40 h) (cons 1 (rtos (caddr p) 2 2))))
(setq i (1+ i))
)
(command "undo" "e")
li1
(command "undo" "be")
(if li1 
(progn 
(setq li1 (mapcar '(lambda(x)(trans x 0 1)) li1))
(mapcar '(lambda(x) (princ (strcat "\n" (rtos(car x)) "," (rtos(cadr x))
(if (= 3(length x)) (strcat "," (rtos(nth 2 x))) "") ;;; End of if
))) li1);;; end mapcar
(setq Npt (getint"\n Chon so bat dau danh thu tu cac diem  : " )) 
(initget "Ôàéë Excel Íå Text Excel Not _Text Excel Not Text Excel Not")
(setq sFlag (getkword "\n Ban muon luu toa do vao dang file   : ")) 
(if (null sFlag)
(setq sFlag "Text")
);;;;; End of if
(setq oFlag Npt)
(if (numberp Npt)
(foreach ln li1
 (text-draw                 
   (itoa Npt)               
   (polar ln (-(/ pi 2)) 2.5)   
   (setq h 1)      
   0                        
   nil
   ) ;;;; End of text-draw
 (setq Npt (1+ Npt))
) ;;;; End of foreach
) ;;;; End of if
(setq Npt oFlag)    
(setq li1 (mapcar '(lambda(x)(mapcar 'rtos x)) li1))
(cond 
(
(and 
(= "Text" sFlag)
(setq filPath (getfiled "Save Coordinates to Text File"  "Coordinates.txt" "txt;csv" 33))
) ;;; End of and
      (setq cFile (open filPath "w"))
(foreach ln li1
(write-line 
(strcat (if (numberp Npt)(strcat (itoa Npt) ",") "")(car ln)","(cadr ln) (if (= 3 (length ln)) 
(strcat ","(nth 2 ln)))) cFile)
(if (numberp Npt)
(setq Npt (1+ Npt))
);;; End of if
);;;; End of foreach
(close cFile)
(initget "Yes No")
(setq oFlag (getkword  "\nOpen text file?   : " ))   
      (if (= oFlag "Yes") (startapp "notepad.exe" filPath))
); end condition #1
((= "Excel" sFlag)
(if (numberp Npt)
(progn
     (setq li1 (mapcar '(lambda(x) (cons (1- (setq Npt (1+ Npt))) x)) li1))
     (xls li1 '("N" "X" "Y" "Z") nil "COORN")
);;;; End of progn
     (xls li1 nil nil "COOR")) ;;;; End of if
); end condition #2
    (t nil) ;;; End of last condition
) ;;; End of cond
) ;;; End of progn
) ;;; End of if
(command "undo" "e")
(princ)
)

 

Cô em này tuy vậy nhưng với mình là khá khó trị, bác nào có nhã hứng thử tìm cách trị cho được theo ý muốn của mình đi nhé.

Cái vụ tự dưng đổi tên cái "Sheet1" thành "VD2-1&Coorn" mình vẫn chưa thể mò ra do cái hàm (xls......) nó rậm rì rắc rối và sâu hun hút, chả biết đâu mà mò. Thôi thì cứ biết khoái đến đó đã vậy.

Cái việc sau khi chạy lisp xong xuất hiện các text đánh số thứ tự của các điểm trên bản vẽ, lúc đầu mình định cắt béng nó đi, nhưng sau nghĩ lại thấy rằng âu cũng là việc cần vì đôi khi có người lại muốn đánh số thứ tự từ .... trên giời thì sao. Nếu không thích ta chỉ việc vô hiệu hóa cái hàm (text-draw .....) là ok.

Cái vụ lisp cứ tự động tắt file *.txt, *.csv sau khi ghi file rồ sau đó lại hỏi có cần mở không thực ra mình cũng thấy hơi nghịch mắt, xong cứ tôn trọng người đã viết ra nó vì có thể có cái lý ông sự ở đó. Tuy nhiên nếu không muốn quá loằng ngoằng như vậy thì các bạn có thể vô hiệu hóa cái đoạn code từ (close cFile) cho tới trước cái ngoặc (;;; end of condition #1)kết thúc điều kiện thứ nhất của hàm (cond .....).

Khi lisp chạy dừng lại để bạn chọn tên file *.txt sẽ lưu dữ liệu, mặc định là file Coordinates.txt nhưng bạn có thể đổi thành file *.txt hay *.csv thoải mái.

Túm lại ở cô em này còn nhiều điều đáng để khám phá. Tuy nhiên phải tùy vào khả năng của mỗi chiến sĩ nhà ta mà cái sự khám phá này cũng như cái sự khoái nó được nhiều hay ít. Với mình thế này là đã khoái rồi dù mới chỉ sơ sơ được một tý bên ngoài. Muốn khoái nữa chắc còn phải tích cóp ít công lực về lisp nữa mới ăn thua các bác ạ.

Chúc cả nhà vui vẻ, hề hề hề ......

Oài, cái này phức tạp ghê, bác ghép cho em vào cái lisp lb2 đi, em nhìn vào mù tịt chả biết gì, hihi


<<

Filename: 90515_lb2.lsp
Tác giả: SoftvnBin
Bài viết gốc: 207010
Tên lệnh: 1
gộp giúp em lisp lệnh bật, tắt Layer với

Lisp gộp 2 lệnh LAYOFF và LAYON thành 1 lệnh.

(defun c:1()
(cond
 ((or (not n) (= n 1))
  (c:LAYOFF)
  (setq n 2))
 ((=...
>>

Lisp gộp 2 lệnh LAYOFF và LAYON thành 1 lệnh.

(defun c:1()
(cond
 ((or (not n) (= n 1))
  (c:LAYOFF)
  (setq n 2))
 ((= n 2)
  (c:LAYON)
  (setq n 1))))

 

Từ lisp nhờ chỉnh sửa trên, em cũng xin ké tý, nhu cầu của em mong muốn nhờ các bác cũng na ná như trên, cụ thể như sau:

1. Em đã có sẵn lisp với các lệnh thực thi tương ứng là: n1, n2, n3, n4, n5

2. Nhờ các bác viết 1 lisp (ví dụ lệnh: a1)

3. Sau khi load các lisp với các lệnh n1, n2, n3, n4, n5, a1 xong

4. Gọi lệnh a1 thì lisp sẽ tự động thực hiện lệnh n1

5. Thực hiện xong lệnh n1 sẽ hiện bảng thông báo "Done to n1, space to continue, esc to stop"

6. Nếu nhấn nút space thì lisp sẽ tự động thực hiện tiếp lệnh n2, nhấn nút esc thì lisp sẽ tự động kết thức lệnh

7. Thực hiện xong lệnh n2 sẽ hiện bảng thông báo "Done to n1, space to continue, esc to stop"

8. Nếu nhấn nút space thì lisp sẽ tự động thực hiện tiếp lệnh n2, nhấn nút esc thì lisp sẽ tự động kết thức lệnh

9. Tiếp tục như thế đến hết lệnh n5 (nếu thực hiện đến n5 thì lisp tự động kết thúc lệnh và hiện lên bảng thông báo "good luck")

10. Nhấn space để hoàn thành.

 

Xin cảm ơn các bác trước!


<<

Filename: 207010_1.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 362300
Tên lệnh: apo
Nhờ viết lisp chèn nhanh point vào End_point đối tượng

Mình xin cảm ơn bác quocmanh04tt nhé. Lisp chạy ổn rồi nhưng chưa đúng ý diễn tả mình lắm. Cái mình mong muốn là end_point là cả start...

>>

Mình xin cảm ơn bác quocmanh04tt nhé. Lisp chạy ổn rồi nhưng chưa đúng ý diễn tả mình lắm. Cái mình mong muốn là end_point là cả start và end point giống như trong chế độ bắt điểm end point thôi ấy. Bác chỉnh thêm 1 chút dùm mình được không ạ?

Ôi... Cái End_point... Của bạn đây:

(defun c:APO (/ i ss ent obj S-point E-point add_point_object ename)

(defun add_point_object (obj / make_po)

(defun make_po (point)

(entmakex (list '(0 . "POINT") '(100 . "AcDbEntity") '(100 . "AcDbPoint") (cons 10 point))))

(setq obj (vlax-ename->vla-object ent)

S-point (vlax-curve-getstartpoint obj)

E-point (vlax-curve-getendpoint obj))

(cond ((or (eq ename "CIRCLE") (eq ename "ELLIPSE") (eq ename "RAY")) (make_po S-point))

(t (make_po E-point) (make_po S-point))))

;; main

(if (setq i 0

ss (ssget "_:L" '((0 . "*LINE,ARC,ELLIPSE,RAY,CIRCLE")))

n (sslength ss))

(progn (while (< i n)

(setq ent (ssname ss i)

ename (cdr (assoc 0 (entget ent))))

(add_point_object obj)

(setq i (1+ i)))))

(princ))


<<

Filename: 362300_apo.lsp
Tác giả: tbinhvn
Bài viết gốc: 258324
Tên lệnh: dlw
Làm sao để chuyển line weight trong block thành bylayer?

 

Thì sài như hướng dẫn ở trên. Cứ copy/paste vào command line thôi. Nếu muốn thành file Lisp thì dùng cái này:

>>

 

Thì sài như hướng dẫn ở trên. Cứ copy/paste vào command line thôi. Nếu muốn thành file Lisp thì dùng cái này:

(defun C:DLW()
  (vl-load-com)
  (command "UNDO" "BE")
  (vlax-for for-item (vla-get-blocks(vla-get-activedocument(vlax-get-acad-object)))
    (vlax-for item for-item
      (vla-put-Lineweight item -1)
      )
    )
  (command "UNDO" "END")
  (princ)
  )

Bác KangKung làm ơn bổ xung tính năng thay đổi Color thành Bylayer nữa ạ. Lisp của bác rất hay! Cảm ơn bác nhiều!


<<

Filename: 258324_dlw.lsp
Tác giả: quocanhxd05
Bài viết gốc: 71110
Tên lệnh: dsm
Hướng dẫn viết lisp
Xin đính chính : Cái phần tử trong PLINE mà bạn nói đến phải gọi là phân đoạn (segment)

Đây là Lisp đếm số phân đoạn (segments) mà Tue_NV viết theo ý bạn...

>>
Xin đính chính : Cái phần tử trong PLINE mà bạn nói đến phải gọi là phân đoạn (segment)

Đây là Lisp đếm số phân đoạn (segments) mà Tue_NV viết theo ý bạn :

(defun c:dsm()
(vl-load-com)
(while (setq dt (entsel "\n Pick vao Polyline can biet so phan doan segments :"))
(setq curve (car dt))
(alert (strcat "so phan doan segments cua PLine vua chon la : "
	  (rtos (vlax-curve-getEndParam curve) 2 0)
	)
)
)
(princ)
)

Hay quá , cảm ơn bác nhiều.Nếu không có diễn đàn Cadviet chắc em phải nghiên cứu tới tết công gô luôn.

Chúc cho Cadviet ngày càng lớn mạnh.


<<

Filename: 71110_dsm.lsp
Tác giả: hoangkimanh1607
Bài viết gốc: 68250
Tên lệnh: dth
tim list tính diện tích theo 2 tỷ lệ X Y khác nhau
Bạn thử cái này xem. Khi nhập tỷ lệ chỉ nhập 100, 200.. ko nhập 1/100, 1/200.

Kết quả đưa ra file ketqua.txt trong cùng thư mục với file cad.

Chú ý vì lệnh boundary chỉ...

>>
Bạn thử cái này xem. Khi nhập tỷ lệ chỉ nhập 100, 200.. ko nhập 1/100, 1/200.

Kết quả đưa ra file ketqua.txt trong cùng thư mục với file cad.

Chú ý vì lệnh boundary chỉ làm đc với đa giác kín và zoom cho thấy đủ đa giác đó (trong tầm nhìn).

Có vòng lặp cho nên nếu muốn thoát thì enter.

(defun c:dth()
 (vl-load-com)
 (setvar "cmdecho" 0)

 (if (not tln) (setq tln 100))
 (if (not tld) (setq tld 100))
 (if (not caot) (setq caot 1))
 (setq tln1 (getreal (strcat "\nCho ty le ngang < 1/" (rtos tln 2 0) " >: 1/"))
tld1 (getreal (strcat "\nCho ty le dung < 1/" (rtos tld 2 0) " >: 1/"))
caot1 (getreal (strcat "\nCao text < " (rtos caot 2 0) " >: ")))
 (if tln1 (setq tln tln1))
 (if tld1 (setq tld tld1))
 (if caot1 (setq caot caot1))

 (setq heso (/ tld tln)
file (open (strcat (getvar "dwgprefix") "Ketqua.txt") "a")
p (getpoint "\nPick a internal point:")
el (entlast))

 (while p		
   (command "boundary" p "")
   (if (not (equal el (setq el1 (entlast))))
     (progn 
       (write-line (setq chu (rtos (* heso (vla-get-Area (vlax-ename->vla-object el1))))) file)
(entdel el1)
(entmakex (list '(0 . "TEXT") (cons 40 caot) (cons 10 p) (cons 1 chu))) ))      
   (setq p (getpoint "\nPick a internal point:"))
 )
 (close file)
 (setvar "cmdecho" 1)
 (princ)
)

 

đúng cái mình đang cần

thanks bạn nhiều

dia chi mail cua minh

daihoang2001@yahoo.com

if có dịp mình cùng trao đổi cùng nhé

thanks ban lần nữa

chúc ban làm việc tốt

bạn cho mình dịa chỉ mail nhé


<<

Filename: 68250_dth.lsp
Tác giả: dunghn
Bài viết gốc: 313201
Tên lệnh: kk
Thay đổi máy in hàng loạt cho tất cả layout?

 

Lisp thay đổi máy in cho tất cả các Layout đây:

Chú ý:

1. Khi chọn máy in thì chọn số tương ứng với máy in đó. VD:...

>>

 

Lisp thay đổi máy in cho tất cả các Layout đây:

Chú ý:

1. Khi chọn máy in thì chọn số tương ứng với máy in đó. VD: Chọn 1 hoặc 2 , 3, 4 ...

2. Nhập khổ giấy phải đúng tên của khổ giấy trong máy in đó. VD: cùng là khổ giấy A0 nhưng có máy là A0 nhưng có máy lại là ISO A0.

;========LISP THAY DOI PLOTTER CHO TAT CA LAYOUT===========
;================KANGKUNG 03/04/2013=======================
(defun C:KK()
  (command "UNDO" "BE")
  (Plotter_list)
  (setq printer(getint (strcat "\n Chon may in " printer2 ":")))
  (setq printer(vl-string-trim ".pc3" (nth (- printer 1) (vl-directory-files (strcat (getvar "roamablerootprefix") "\Plotters\\") "*.pc3" 1))))
  (setq size(getstring T "\n Kho giay in <Nhap A0, A1, A2 ... hoac ISO A0, ISO A1, ISO A2 ...: "))
  (foreach layout (layoutlist)
    (command "LAYOUT" "S" layout)
    (Setq P1(Getvar "EXTMIN") P2(Getvar "EXTMAX"))
    (command "PLOT" "Y" "" printer size "M" "L" "N" "W" P1 P2 "1" "C" "Y" "" "Y" "N" "N" "N" "N" "Y" "N"))
  (command "MODEL")
  (command "UNDO" "END")
  (alert "Well Done")
  (princ)
  )
(defun Plotter_list()
  (setq lst_printer(vl-directory-files (strcat (getvar "roamablerootprefix") "\Plotters\\") "*.pc3" 1))
  (setq lst_printer2 (list))
  (setq printer2 "")
  (setq i 0)
  (foreach printer lst_printer
    (setq i(1+ i))
    (setq printer2(strcat printer2 (strcat (substr (rtos i 1 0)  1 1) "-" "\""(vl-string-trim ".pc3" printer)"\"" " ")))
    (setq lst_printer2(append lst_printer2 (list (strcat (substr (rtos i 1 0)  1 1) "-" (vl-string-trim ".pc3" printer))))))
  )
(princ "\n                Written By KangKung - 03/04/2013\n")
(princ "\n                  Nhap KK de chay chuong trinh\n")

Lisp này chạy 1 chiều thì OK, chiều ngược lại không ổn với máy tính của tôi. Nếu đặt mặc định là máy 5 thì chuyển về máy 1 rất tốt, sau đó chuyển lại máy in từ máy 1 lại máy 5 thì sai kích thước bản in. Các trường hợp khác chưa thử vì ít dùng  :)


<<

Filename: 313201_kk.lsp
Tác giả: Sony2007
Bài viết gốc: 40509
Tên lệnh: rt lft cct crt
Yêu cầu lisp căn chỉnh vị trí Text !
Đây là lisp để bạn tham khảo và có thể phát triển thêm, trước đây tôi viết chơi nhưng chẳng mấy khi dùng đến.

Lệnh rt: căn lề phải (cho các text xếp theo dạng...

>>
Đây là lisp để bạn tham khảo và có thể phát triển thêm, trước đây tôi viết chơi nhưng chẳng mấy khi dùng đến.

Lệnh rt: căn lề phải (cho các text xếp theo dạng cột)

lft: căn lề trái ( "" "" )

cct : căn giữa cho cột text

crt : căn giữa cho hàng text

Bạn có thể chỉnh sửa lại tuỳ theo yêu cầu sử dụng (căn theo x, y, z ...)

(defun myerror (s)
 (cond
   ((= s "quit / exit abort") (princ))
   ((/= s "Function cancelled") (princ (strcat "\nError: " s)))
 )
 (setvar "cmdecho" CMD)		; Restore saved modes
 (setvar "osmode" OSM)
 (setq *error* OLDERR)			; Restore old *error* handler
 (princ)
)
;;;==============================================================
;;; Can le fai text
;;;==============================================================
(defun c:rt (/ P1)
 (setq	olderr	*error*
*error*	myerror
 )
 (setvar "cmdecho" 0)

 (command "UCS" "W" "")

 (setq	sstxt (ssget '((-4 . "		       (-4 . "		       (0 . "text")
	       (0 . "Mtext")
	       (-4 . "OR>")
	       (50 . 0)
	       (-4 . "and>")
	      )
      )				;chon text
P1    (getpoint "\nChon diem canh le phai cho text")
XRtxt (car P1)
 )

 (if (not (null sstxt))
   (progn
     (setq sslen (sslength sstxt)	;dem so doi tuong chon
    ctr	  0			;Dat bien dem = 0
     )
     (command ".undo" "begin")
     (while (< ctr sslen)		;Neu bien dem < so doi tuong
(setq object (entget (ssname sstxt ctr))
      altxt  (cdr (assoc 72 object))
)

(setq object (subst (cons 72 2) (assoc 72 object) object))
(setq object (entmod object))
(setq object (subst (cons 73 1) (assoc 73 object) object))
(setq object (entmod object))
(setq Ptxt   (cdr (assoc 11 object))
      NPtxt  (list XRtxt (cadr Ptxt) ) ;(cadr Ptxt)
      object (subst (cons 11 NPtxt) (assoc 11 object) object)
)
(setq object (entmod object))
(setq ctr (1+ ctr))
     )

     (command ".undo" "end")

   )
 )

 (setq *error* olderr)

 (setvar "cmdecho" 1)
 (princ)
)

;;;=====================================================
;;; Can le trai text
(defun c:lft (/ P1)
 (setq	olderr	*error*
*error*	myerror
 )
 (setvar "cmdecho" 0)
 (command "UCS" "W" "")
 (setq	sstxt (ssget '((-4 . "		       (-4 . "		       (0 . "text")
	       (0 . "Mtext")
	       (-4 . "OR>")
	       (50 . 0)
	       (-4 . "and>")
	      )
      )				;chon text
P1    (getpoint "\nChon diem canh le trai cho text")
XRtxt (car P1)
 )

 (if (not (null sstxt))
   (progn
     (setq sslen (sslength sstxt)	;dem so doi tuong chon
    ctr	  0			;Dat bien dem = 0
     )
     (command ".undo" "begin")
     (while (< ctr sslen)		;Neu bien dem < so doi tuong
(setq object (entget (ssname sstxt ctr))
      altxt  (cdr (assoc 72 object))
)

(setq object (subst (cons 72 0) (assoc 72 object) object))
(setq object (entmod object))
(setq object (subst (cons 73 1) (assoc 73 object) object))
(setq object (entmod object))
(setq Ptxt   (cdr (assoc 11 object))
      NPtxt  (list XRtxt (cadr Ptxt) ) ;(cadr Ptxt)
      object (subst (cons 11 NPtxt) (assoc 11 object) object)
)
(setq object (entmod object))
(setq ctr (1+ ctr))
     )
     (command ".undo" "end")

   )
 )

 (setq *error* olderr)

 (setvar "cmdecho" 1)
 (princ)
)
;;;=====================================================
;;; Can giua cot text
(defun c:cct (/ P1)
 (setq	olderr	*error*
*error*	myerror
 )
 (setvar "cmdecho" 0)
 (command "UCS" "W" "")
 (setq	sstxt (ssget '((-4 . "		       (-4 . "		       (0 . "text")
	       (0 . "Mtext")
	       (-4 . "OR>")
	       (50 . 0)
	       (-4 . "and>")
	      )
      )				;chon text
P1    (getpoint "\nChon diem canh le trai cho text")
XRtxt (car P1)
 )

 (if (not (null sstxt))
   (progn
     (setq sslen (sslength sstxt)	;dem so doi tuong chon
    ctr	  0			;Dat bien dem = 0
     )
     (command ".undo" "begin")
     (while (< ctr sslen)		;Neu bien dem < so doi tuong
(setq object (entget (ssname sstxt ctr))
      altxt  (cdr (assoc 72 object))
)

(setq object (subst (cons 72 1) (assoc 72 object) object))
(setq object (entmod object))
(setq object (subst (cons 73 2) (assoc 73 object) object))
(setq object (entmod object))
(setq Ptxt   (cdr (assoc 11 object))
      NPtxt  (list XRtxt (cadr Ptxt) ) ;(cadr Ptxt)
      object (subst (cons 11 NPtxt) (assoc 11 object) object)
)
(setq object (entmod object))
(setq ctr (1+ ctr))
     )
     (command ".undo" "end")

   )
 )

 (setq *error* olderr)

 (setvar "cmdecho" 1)
 (princ)
)

;;;=====================================================
;;; Can giua hang text
(defun c:crt (/ P1)
 (setq	olderr	*error*
*error*	myerror
 )
 (setvar "cmdecho" 0)
 (command "UCS" "W" "")
 (setq	sstxt (ssget '((-4 . "		       (-4 . "		       (0 . "text")
	       (0 . "Mtext")
	       (-4 . "OR>")
	       (50 . 0)
	       (-4 . "and>")
	      )
      )				;chon text
P1    (getpoint "\nChon diem can giua cho hang text")
XRtxt (car P1)
YRtxt (cadr P1)
 )

 (if (not (null sstxt))
   (progn
     (setq sslen (sslength sstxt)	;dem so doi tuong chon
    ctr	  0			;Dat bien dem = 0
     )
     (command ".undo" "begin")
     (while (< ctr sslen)		;Neu bien dem < so doi tuong
(setq object (entget (ssname sstxt ctr))
      altxt  (cdr (assoc 72 object))
)

(setq object (subst (cons 72 1) (assoc 72 object) object))
(setq object (entmod object))
(setq object (subst (cons 73 2) (assoc 73 object) object))
(setq object (entmod object))
(setq Ptxt   (cdr (assoc 11 object))
      NPtxt  (list (car Ptxt) YRtxt  ) ;(cadr Ptxt)
      object (subst (cons 11 NPtxt) (assoc 11 object) object)
)
(setq object (entmod object))
(setq ctr (1+ ctr))
     )
     (command ".undo" "end")

   )
 )

 (setq *error* olderr)

 (setvar "cmdecho" 1)
 (princ)
)

Dạo này vào quý IV, các bác nhà mình bận Tổng kết với ...đi đòi nợ hay sao mà thấy diễn đàn ... vắng vẻ (Ít có những yêu cầu kích thích sáng tạo ) -_-

 

Chào Snowman, vừa rồi tôi có tải đoạn lisp của anh về dùng, nhưng khi sử dụng không hiểu sao các text bị văng đâu mất. Bác Hoành nói là đoạn code viết anh sửa giúp. File cad, file lisp tôi đã thể hiện ở mục http://www.cadviet.com/forum/index.php?showtopic=205&pid=40506&st=1260entry40506. Anh giúp tôi với nhé.


<<

Filename: 40509_rt_lft_cct_crt.lsp
Tác giả: dovananh.xd
Bài viết gốc: 194015
Tên lệnh: shbv
Lisp đánh số thứ tự bản vẽ tự động?

OK, mình update giúp bạn đây, hy vọng bạn vừa ý

;; free lisp from cadviet.com : ketxu update from @Tue_NV(defun c:shbv(/ dau...
>>

OK, mình update giúp bạn đây, hy vọng bạn vừa ý

;; free lisp from cadviet.com : ketxu update from @Tue_NV(defun c:shbv(/ dau tong po po1 ent i pre sotong)(prompt "\n Danh so hieu ban ve dang n/m ")(setvar "cmdecho" 0)(setq pre "< KC, CN KT>: ")(wtxt pre '(0 0 0))(command "ddedit" (entlast) "") (setq pre (cdr(assoc 1 (entget(entlast)))));(setq pre (strcat pre ": "))(entdel (entlast))(setq dau (getint "\n Danh so bat dau (n):"))(setq tong (getint "\n Danh so tong (m):") i 1)(if (< tong 10) (setq sotong (strcat "0" (itoa tong))) (setq sotong (itoa tong))) (setq po (getpoint (strcat "\n Cho diem chen cua so: " (if (< dau 10) (strcat pre "0" (itoa dau)) (itoa dau)) "/" sotong)))(wtxt (strcat (if (< dau 10) (strcat pre "0" (itoa dau)) (itoa dau)) "/" sotong) po)(Repeat (- tong dau)(setq po1 (getpoint po (strcat "\n Cho diem chen cua so: " (if (< (+ dau i) 10) (strcat pre "0" (itoa (+ dau i))) (itoa (+ dau i))) "/" sotong)))(command "copy" "L" "" po po1) (setq ent (entget(entlast)))(setq ent (subst (cons 1 (strcat (if (< (+ dau i) 10) (strcat pre "0" (itoa (+ dau i))) (itoa (+ dau i))) "/" sotong)) (assoc 1 ent) ent))(entmod ent)(setq i (1+ i))(setq po po1))(princ));(defun wtxt(txt p / sty d h1 h2 wf h) ;;;Write txt on graphic screen at p(setq    sty (getvar "textstyle")    d (tblsearch "style" sty)    h1 (cdr (assoc 40 d))    h2 (cdr (assoc 42 d))    wf (cdr (assoc 41 d)))(if (> h1 0) (setq h h1) (setq h h2))(entmake (list (cons 0 "TEXT") (cons 7 sty) (cons 40 h) (cons 41 wf)(cons 72 4)(cons 11 p) (cons 1 txt) (cons 10 p))))

Lisp này hay rồi nhưng nếu cách thức hoạt động dạng array như lisp dsbv của bác Tue_VN thì hay quá.

Mong các pro thêm phần này vào nữa.

P/S: phần số thì thay đổi theo cấp số cộng, còn phần chữ thì cố định, và tùy ý người sử dụng chọn. Vd: abc-01 hoặc xyz-01


<<

Filename: 194015_shbv.lsp
Tác giả: Danh Cong
Bài viết gốc: 408886
Tên lệnh: test
Nhờ Viết Lisp Cộng Các Số Trong Text (Hoặc Mtext) Và Output Sang Một Mtext Khác

 

MTEXT đây ^_^

(defun c:test  ()
  (if (not (setq ss (ssget '((0 . "*TEXT")))))
    (princ "\nBan da khong chon TEXT.")
   ...
>>

 

MTEXT đây ^_^

(defun c:test  ()
  (if (not (setq ss (ssget '((0 . "*TEXT")))))
    (princ "\nBan da khong chon TEXT.")
    (progn
      (setq n 0)
      (setq sum 0)
      (repeat (sslength ss)
        (setq value (cdr (assoc 1 (entget (ssname ss n)))))
        (setq value (ATOF value))
        (setq sum (+ sum value))
        (setq n (1+ n))
        ) ;progn
      (setq pt (getpoint "\nChon diem chen text: "))
      (entmake
        (list
          (cons 0 "MTEXT")
          (cons 100 "AcDbEntity")
          (cons 100 "AcDbMText") 
          (cons 10 (trans pt 1 0))
          (cons 40 (cdr (assoc 40 (entget (ssname ss 0)))))
          (cons 8 (cdr (assoc 8 (entget (ssname ss 0)))))
          (cons 7 (cdr (assoc 7 (entget (ssname ss 0)))))
          (cons 1 (rtos sum))
          (cons 50 0)
          )
        )
      )
    )
  (princ)
  )

Thiếu mất 2 dòng của bác  ^_^  ^_^  Quên cũng chưa check  thử. 

Mà hỏi bác xíu. Làm sao khi Entmake mình biết các giá trị DXF nào bắt buộc phải có khi tạo 1 đối tượng mới nhỉ  :D  :D

Ko biết thì hỏi, muốn giỏi phải học thôi @@


<<

Filename: 408886_test.lsp
Tác giả: daik50
Bài viết gốc: 141723
Tên lệnh: dc
lisp đổi màu tất cả các đường DIM ?

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

(defun C:dc()
(vl-load-com)
(foreach ent (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr...
>>

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

(defun C:dc()
(vl-load-com)
(foreach ent (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "X" '((0 . "DIMENSION,LEADER")))))))
(if (vlax-property-available-p ent 'TextColor)
(vla-put-Textcolor ent "2")
)
(if (vlax-property-available-p ent 'DimensionLinecolor)
(vla-put-DimensionLinecolor ent "30")
)
(if (vlax-property-available-p ent 'ExtensionLinecolor)
(vla-put-ExtensionLinecolor ent "30")
)
)
)

 

Thanks bác phát, cái này rất hay


<<

Filename: 141723_dc.lsp
Tác giả: cuongcv3
Bài viết gốc: 5575
Tên lệnh: ell cll mll
Tìm hiểu cấu trúc một chương trình lisp
Bạn dùng thử, nếu cần bổ sung thì cho ý kiến:

 

(defun Sel( / lay ss)
(setq lay (cdr (assoc 8 (entget (car (entsel))))))
(setq ss (ssget "X" (list (cons 8 lay))))
)
(defun...
>>
Bạn dùng thử, nếu cần bổ sung thì cho ý kiến:

 

(defun Sel( / lay ss)
(setq lay (cdr (assoc 8 (entget (car (entsel))))))
(setq ss (ssget "X" (list (cons 8 lay))))
)
(defun C:ELL() (command "erase" (sel) ""))
(defun C:CLL() (command "copy" (sel) "" pause))
(defun C:MLL() (command "move" (sel) "" pause))

 

Lệnh hoạt động rất tốt, Thank bác SSG nhiều. :unsure:


<<

Filename: 5575_ell_cll_mll.lsp
Tác giả: Danh Cong
Bài viết gốc: 425805
Tên lệnh: test
Lisp vẽ đường thẳng nối đỉnh các Polyline
1 giờ} trướ}c, haintwru đã nói:

chào bạn, mình xin nói...

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

chào bạn, mình xin nói rõ hơn 1 chút là các đường trên là polynie song song vs trục y và điểm cần nối là điểm thấp nhất ạ. Cảm ơn bạn.

+ Nhược điểm: Chỉ tạo ra line, không tạo ra được Polyline theo yêu cầu. ( Đang nghĩ cách để tạo polyline)

Vậy nên nếu sử dụng  bạn nên đặt layer hiện hành là 1 layer mới , dùng lisp, rồi nối line thành polyline .



(defun c:test ( / I J LISTPOINT NAME PT10 PT11 SSLIST SSOBJECT)
  (vl-load-com)
  (setq ssobject (ssget '(( 0 . "*LINE")))
    listpoint '()
    i 0
    j 0)
  (repeat (sslength ssobject)
          (progn
            (setq name (vlax-ename->vla-object (ssname ssobject i)))
            (setq pt10 (list (nth 0 (vlax-curve-getstartpoint name)) (nth 1 (vlax-curve-getstartpoint name)))
              pt11 (list (nth 0 (vlax-curve-getendpoint name)) (nth 1 (vlax-curve-getendpoint name)))
              i (+ i 1))
            (if   (< (cadr pt10) (cadr pt11))
              (setq listpoint (append listpoint (list pt10)))   ; ok
              (setq listpoint (append listpoint (list pt11)))   ; not ok
          )))
  (setq sslist (vl-sort-i listpoint     (function (lambda (e1 e2) (< (car e1) (car e2))))))
  (repeat (- (sslength ssobject) 1)
          (command ".line" "non" (nth (nth j sslist) listpoint) "non" (nth (nth (+ j 1) sslist) listpoint) "")
          (setq j (+ j 1))
    ); end repeat
     (princ))
 


<<

Filename: 425805_test.lsp
Tác giả: pawuta
Bài viết gốc: 345979
Tên lệnh: thkl
Nhờ viết lisp thông kê giá trị trong block ATT

 

Hề hề hề,

Bậu down lại lisp này nhé

(DEFUN C:THKL (/ ssl dtl dtt e1 e2 e3 ltt et...
>>

 

Hề hề hề,

Bậu down lại lisp này nhé

(DEFUN C:THKL (/ ssl dtl dtt e1 e2 e3 ltt et goc)
(setq ssl (acet-ss-to-list (ssget (list (cons 0 "insert") (cons 66 1)))))
(while (setq e1 (car (nentsel "\n Chon thuoc tinh loc")))
(setq dtl (cdr (assoc 1 (entget e1))))
(setq goc 0)
(setq dtt (cdr (assoc 2 (entget (setq e2 (car (nentsel "\n Chon thuoc tinh can tinh")))))))
(setq ltt (list))
(foreach e ssl
    (setq et (entnext e))
    (while (/= (cdr (assoc 0 (entget et))) "SEQEND")
            (if (and (= (cdr (assoc 1 (entget et))) dtl) (= (cdr (assoc 2 (entget et))) (cdr (assoc 2 (entget e1)))))                          
                (setq ltt (append ltt (list e)))
            )
            (setq et (entnext et))
    )
)
(foreach e ltt
     (setq et (entnext e))
     (while (/= (cdr (assoc 0 (entget et))) "SEQEND")
              (if (= (cdr (assoc  2 (entget et))) dtt)
                  (setq goc (+ goc (atof (cdr (assoc 1 (entget et))))))
              )
              (setq et (entnext et))
      )
)
(entmod (subst (cons 1 (rtos goc 2 2)) (assoc 1 (entget (setq e3 (car (nentsel "\n Chon text can thay the"))))) (entget e3)))
(entupd e3)
)
)

Oke, cảm ơn bạn nhiều nhé, bạn sửa giúp mình cái lisp của bạn bach_gia luôn y!!


<<

Filename: 345979_thkl.lsp
Tác giả: thanhlong.hygt
Bài viết gốc: 255228
Tên lệnh: ii
Lisp thêm đỉnh pline tại giao điểm của pline và các line khác

 

Lisp này chỉ dùng cho lwpolyline, vì vậy bạn dùng lệnh convert của CAD để chuyển thành lwpolyline

 

>>

 

Lisp này chỉ dùng cho lwpolyline, vì vậy bạn dùng lệnh convert của CAD để chuyển thành lwpolyline

 

(defun AppendLs (ls e)(append (if ls ls nil) (list e)))
(defun ObjInters (o1 o2 id / g ps n)
    (setq    g    (vlax-invoke o1 'IntersectWith o2 id)    ps '())
    (while g (setq    ps (AppendLs ps (list (car g) (cadr g) (caddr g))) g (cdddr g))    )    ps
)
(defun Bulge (p1 p2 r / a)
    (setq a (/ (distance p1 p2) 2 r))
    (setq a (/ (atan (/ a (sqrt (- 1 (* a a))))) 2))
    (/ (sin a) (cos a))
)

(defun C:II ( / b fz i l li lp lq ls n ob om p p1 p2 r ss) ; Insert vertex at intersections
    (setq i 0 fz 0.1) ; sai so giao diem lech so voi dinh pline
    (princ "Chon pline:")    (setq ss (ssget ":S") ob (vlax-ename->vla-object (ssname ss 0)) )
    (princ "Chon cac duong giao:")
    (setq ls (mapcar 'vlax-ename->vla-object
                                     (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "*LINE")(8 . "ENTCOC"))))))))
    (foreach o ls
        (setq p (car(ObjInters ob o acExtendNone)) lp (AppendLs lp p))    
        (setq lq (AppendLs lq (vlax-curve-getParamAtPoint ob (vlax-curve-getClosestPointTo ob p)))))
    (setq li (vl-sort-i lq '>) )
    (foreach i li
        (setq n (fix (nth i lq)) p (nth i lp))
        (setq p1 (vlax-curve-getPointAtParam ob n) p2 (vlax-curve-getPointAtParam ob (1+ n)))
        (if (and  (< fz (distance p p1)) (< fz (distance p p2)))
            (progn
                (setq b (vlax-invoke Ob 'GetBulge n))
                (vlax-invoke Ob 'AddVertex (1+ n) (list (car p)(cadr p)))
                (if (/= b 0)
                    (progn
                        (setq r (/ (distance p1 p2) 2 (sin (* 2 (atan b)))))
                        (vlax-invoke Ob 'SetBulge n (Bulge p p1 r))
                        (vlax-invoke Ob 'SetBulge (1+ n) (Bulge p p2 r))))
            )
        ))

)

Thank bác ạ. mấy hôm nay e ít thời gian quá nên giờ mới vào thank các bác được


<<

Filename: 255228_ii.lsp
Tác giả: trumlenmang
Bài viết gốc: 285113
Tên lệnh: mrlayout
Giúp hoàn thiện lisp đổi tên layout.

Đại loại nó là thế này (???):

(defun c:mrlayout (/ i laylst pe1 pe2 ss txt)
  (setq pe1 (getpoint "\ngoc tren ben trai...
>>

Đại loại nó là thế này (???):

(defun c:mrlayout (/ i laylst pe1 pe2 ss txt)
  (setq pe1 (getpoint "\ngoc tren ben trai :")
	pe2 (getcorner pe1 "\ngoc duoi ben phai :")
	i 0 layLst (layoutlist) )
  (while (< i (length layLst))
    (command "layout" "set" (nth i layLst))
    (if (setq ss (ssget "_c" pe1 pe2 (list(cons 0 "text"))))
      (progn
	(setq txt (cdr (assoc 1 (entget (ssname ss 0)))))
	(if (snvalid txt)
	  (command "layout" "r" "" txt)  )) )
    (setq i(1+ i)))
  (princ))

Cảm ơn bác, đúng ý em rồi. Thế này đổi tên vài chục bản vẽ sẽ nhanh hơn nhiều.


<<

Filename: 285113_mrlayout.lsp
Tác giả: congduy
Bài viết gốc: 207883
Tên lệnh: sldb
Lisp lấy các thông số của đối tượng line, polyline, circle .....

Hề hể hề,

Đây là code bổ sung vào lisp trên với chức năng thêm xử lý cả khi đối tượng là circle đồng thời hiển...

>>

Hề hể hề,

Đây là code bổ sung vào lisp trên với chức năng thêm xử lý cả khi đối tượng là circle đồng thời hiển thị luôn các đối tượng được chọn trên màn hình


(defun c:sldb (/ oldos ent ent1 elst ss d)
(vl-load-com)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(command "undo" "be")
(setq ent (car (entsel "\n Chon doi tuong goc")))
(command "offset" (getreal "\n Nhap khoang cach can offset: ") ent (getpoint "\n Chon phia offset ") "")
(setq ent1 (entlast)
         elst (entget ent1)  )
(if (and (= (cdr (assoc 0 elst)) "LWPOLYLINE") (= (cdr (assoc 70 elst)) 1))
   (setq ss (ssget "CP" (acet-geom-vertex-list ent1)))
)
(if (= (cdr (assoc 0 elst)) "CIRCLE")
   (setq d (getreal "\n Nhap khoang cach giua hai diem lien ke: ")
             ss (ssget "CP" (makelist ent1 d)) )
)

(command "undo" "e")
(setvar "osmode" oldos)
(sssetfirst nil ss)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;-------------------------------------------------------------
(defun makelist ( e d1 / ps pe d d2 p2);;;Make points list along curve e. Length of 1 segment = d1
(vl-load-com);;;Load Visual LISP extensions before use vlax-xxxx functions
(setq
ps (vlax-curve-getStartPoint e);;;Start point
pe (vlax-curve-getEndPoint e);;;End point
d (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e));;;Length of curve e
d2 d1;;;Init variable distance
plst (list)
)
;;;;;;;(command "pline");;;Call pline command
(setq plst (append plst (list ps)));;;Start point
(while (<= d2 d);;;While not over end point pe
(setq p2 (vlax-curve-getPointAtDist e d2));;;Variable point at d2 = length along curve
(setq plst (append plst (list p2)));;;Continue point list with current point  p2
(setq d2 (+ d2 d1));;;Increase distance d2 by d1
);;;End while
;;;;;(if (not (equal pe ps 0.01))
(setq plst (append plst (list pe)));;;Continue points list with pe and finish command
;;;;(command "c" )
;;;)
plst
)

Trong đoạn code trên có sử dụng một phần lisp biến đường tròn thành lwpolyline của bác SSG nhưng thay vì vẽ pline thì mình chuyển lại chỉ tạo points list cho đỡ phải vẽ rồi lại xóa đi.

Bạn nhớ cám ơn bác ấy nếu thấy dùng được cái lisp này nhé.

 

Cam ơn bạn nhé.


<<

Filename: 207883_sldb.lsp

Trang 264/330

264