Jump to content
InfoFile
Tác giả: xuantran15
Bài viết gốc: 67784
Tên lệnh: et
viết lisp cho lệnh lentheng

Đáp ứng yêu cầu của bạn đây.

Mình mới mò về lisp nên ko rành lắm, nhưng hy vọng nó đúng như ý bạn. :s_dead:

Filename: 67784_et.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 367329
Tên lệnh: oo
Lisp Fillet nhanh
Bình thường khi muốn fillet với bán kinh r=100 (lệnh fillet trc đó R#100) thì mình sẽ phải làm tuần tữ là:
F :enter
R :enter
100 :enter
....
Giờ khi cần fillet với một bán kính R=100 thì chỉ cần gõ: R100 thì CAD sẽ hiểu là lệnh Fillet với tham số bán kính R=100 (bỏ qua 3 bước ở trên).

Filename: 367329_oo.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 367700
Tên lệnh: ha
lisp chuyển region sang pline!!

Bản edit:

; Doan Van Ha - CadViet.com - Ngay 14/6/2014, edit 15/7/2015
; Lisp: chuyen cac doi tuong *Line,Arc thanh Region, sao do chuyen tu Region qua Pline.
(defun C:HA( / cmd dob ssnho sslon ss i ent obj) 
 (vl-load-com) (setq cmd (getvar 'cmdecho) dob (getvar 'delobj)) (setvar 'cmdecho 0) (setvar 'delobj 1) (command "undo" "be")
 (setq ssnho (ssget "_X" '((0 . "REGION"))))
 (princ "\nChon cac doi tuong muon chuyen thanh...
>>

Bản edit:

; Doan Van Ha - CadViet.com - Ngay 14/6/2014, edit 15/7/2015
; Lisp: chuyen cac doi tuong *Line,Arc thanh Region, sao do chuyen tu Region qua Pline.
(defun C:HA( / cmd dob ssnho sslon ss i ent obj) 
 (vl-load-com) (setq cmd (getvar 'cmdecho) dob (getvar 'delobj)) (setvar 'cmdecho 0) (setvar 'delobj 1) (command "undo" "be")
 (setq ssnho (ssget "_X" '((0 . "REGION"))))
 (princ "\nChon cac doi tuong muon chuyen thanh Region...")
 (command "region" (ssget '((0 . "ARC,*LINE"))) "")
 (setq sslon (ssget "_X" '((0 . "REGION"))))
 (if ssnho
  (repeat (setq i (sslength ssnho))
   (ssdel (ssname ssnho (setq i (1- i))) sslon)))
 (while (setq ent (ssname sslon 0))
  (setq ss (ssadd) obj (vlax-ename->vla-object ent))
  (foreach obj (vlax-safearray->list (vlax-variant-value (vla-Explode obj)))
   (setq ss (ssadd (vlax-vla-object->ename obj) ss)))
  (command "_.PEDIT" (ssname ss 0) "_YES" "_JOIN" ss "" "")
  (ssdel ent sslon)
  (command "erase" ent ""))
 (setvar 'cmdecho cmd) (setvar 'delobj dob) (command "undo" "e") 
 (princ))

<<

Filename: 367700_ha.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 368007
Tên lệnh: ha1 ha2
[Yêu Cầu] Lisp Nhận Dạng Dim Thay Đổi Sau Khi Dùng Lệnh

Lisp đánh dấu (gán màu đỏ cho text của dim) các Dim bị thay đổi trước và sau khi dùng 1 số lệnh, như Stretch/Scale/Trim/Extened...

Xem cách sử dụng trong file lisp.

; Doan Van Ha - CadViet.com - Ngay 16/7/2015
; Lisp danh dau cac text cua dim bi thay doi truoc va sau khi dung mot so lenh, mark by red color.
; Cach dung:
; - Truoc khi thay doi: dung lenh HA1
; - Sau khi thay doi: dung lenh HA2.
; - VD:...
>>

Lisp đánh dấu (gán màu đỏ cho text của dim) các Dim bị thay đổi trước và sau khi dùng 1 số lệnh, như Stretch/Scale/Trim/Extened...

Xem cách sử dụng trong file lisp.

; Doan Van Ha - CadViet.com - Ngay 16/7/2015
; Lisp danh dau cac text cua dim bi thay doi truoc va sau khi dung mot so lenh, mark by red color.
; Cach dung:
; - Truoc khi thay doi: dung lenh HA1
; - Sau khi thay doi: dung lenh HA2.
; - VD: HA1 -> Strecth/Scale/Trim/Extend... -> HA2.
(defun C:HA1() 
 (setq lst1 (#SS->List (setq ss (ssget "_X" '((0 . "DIMENSION"))))))
 (princ))
(defun C:HA2( / lst2 i)
 (setq lst2 (#SS->List ss))
 (setq i 0)
 (repeat (length lst1)
  (if
   (and
    (equal (car (nth i lst1)) (car (nth i lst2)))
    (not (equal (cdr (nth i lst1)) (cdr (nth i lst2)))))
   (vla-put-TextColor (vlax-ename->vla-object (car (nth i lst2))) 1))
  (setq i (1+ i)))
 (setq lst1 nil) 
 (princ))
(defun #SS->List (ss / i ent lst)
 (repeat (setq i (sslength ss))
  (setq ent (ssname ss (setq i (1- i))))
  (setq lst (cons (cons ent (Get_txt ent)) lst))))
(defun Get_Txt(ent)
 (if (= "" (cdr (assoc 1 (entget ent))))
  (rtos (cdr (assoc 42 (entget ent))) 2 4)
  (cdr (assoc 1 (entget ent)))))
(vl-load-com)

<<

Filename: 368007_ha1_ha2.lsp
Tác giả: snowman.hms
Bài viết gốc: 361350
Tên lệnh: ad
Lisp đo khoảng cách các điểm trên Polyline
Tự động việc đo chiều dài chi tiết của các thanh thép.
Thanh thép là đường polyline có các cung tròn (điểm uốn thép).

Filename: 361350_ad.lsp
Tác giả: phamthe
Bài viết gốc: 369081
Tên lệnh: arrow
vẽ mũi tên trong acad

nhờ các bác giúp em sửa cái code vẽ mũi tên có thêm độ lớn của mũi tên (arrow size) là 2 giúp em với!

(defun c:Arrow (/ _group _dist lastentity p1 p2 ent obj gr coords pt)
  (vl-load-com)  (defun _group (l) 
    (if (caddr l) (cons (list (car l) (cadr l) (caddr l)) (_group (cdddr l)))))
  (defun _dist (a b) (distance (list (car a) (cadr a)) (list (car b) (cadr b))))
  (setq lastentity (entlast)) 
  (if (and (setq p1 (getpoint...
>>

nhờ các bác giúp em sửa cái code vẽ mũi tên có thêm độ lớn của mũi tên (arrow size) là 2 giúp em với!

(defun c:Arrow (/ _group _dist lastentity p1 p2 ent obj gr coords pt)
  (vl-load-com)  (defun _group (l) 
    (if (caddr l) (cons (list (car l) (cadr l) (caddr l)) (_group (cdddr l)))))
  (defun _dist (a b) (distance (list (car a) (cadr a)) (list (car b) (cadr b))))
  (setq lastentity (entlast)) 
  (if (and (setq p1 (getpoint "\nSpecify first point: "))
           (setq p2 (getpoint p1 "\nSpecity next point: "))
           (vl-cmdf "_.leader" "_non" p2 "_non" p1 "" "" "_N")
           (not (equal lastentity (setq ent (entlast))))
           (setq obj (vlax-ename->vla-object ent)))
    (while (eq 5 (car (setq gr (grread T 15 0))))
      (redraw)
      (grdraw (cadr gr)
              (trans (vlax-curve-getClosestPointTo ent (setq pt (trans (cadr gr) 1 0))) 0 1)  3  -1)
      (if  (equal (last (setq coords (_group (vlax-get obj 'Coordinates))))
          (car (vl-sort coords (function (lambda (a b) (< (_dist a pt) (_dist b pt)))))))
         (vlax-put obj 'Coordinates (apply (function append) (reverse coords))))
      (grdraw (cadr gr) (trans (car coords) 0 1) 1 -1)))  (redraw)  (princ))

<<

Filename: 369081_arrow.lsp
Tác giả: thanhduan2407
Bài viết gốc: 369192
Tên lệnh: xln xld xltcd xltpl cpl
[Yêu cầu] Lisp chọn đối tượng theo chiều dài (tương tự qselect)

Bạn tham khảo code

;;;(Alert (strcat "\n X\U+00F3a Line c\U+00F3 chi\U+1EC1u d\U+00E0i nh\U+1ECF h\U+01A1n gi\U+00E1 tr\U+1ECB nh\U+1EADp v\U+00E0o: XLN "
;;;	       "\n X\U+00F3a Line c\U+00F3 chi\U+1EC1u d\U+00E0i  b?ng v\U+1EDBi gi\U+00E1 tr\U+1ECB nh\U+1EADp v\U+00E0o: XLTCD"
;;;	       "\n X\U+00F3a Line c\U+00F3 \U+0111\U+1EC9nh n?m tr\U+00EAn Polyline: XLTPL"
;;;	)
;;;)
;;;(Prompt (strcat "\n X\U+00F3a Line c\U+00F3 chi\U+1EC1u d\U+00E0i...
>>

Bạn tham khảo code

;;;(Alert (strcat "\n X\U+00F3a Line c\U+00F3 chi\U+1EC1u d\U+00E0i nh\U+1ECF h\U+01A1n gi\U+00E1 tr\U+1ECB nh\U+1EADp v\U+00E0o: XLN "
;;;	       "\n X\U+00F3a Line c\U+00F3 chi\U+1EC1u d\U+00E0i  b?ng v\U+1EDBi gi\U+00E1 tr\U+1ECB nh\U+1EADp v\U+00E0o: XLTCD"
;;;	       "\n X\U+00F3a Line c\U+00F3 \U+0111\U+1EC9nh n?m tr\U+00EAn Polyline: XLTPL"
;;;	)
;;;)
;;;(Prompt (strcat "\n X\U+00F3a Line c\U+00F3 chi\U+1EC1u d\U+00E0i nh\U+1ECF h\U+01A1n gi\U+00E1 tr\U+1ECB nh\U+1EADp v\U+00E0o: XLN "
;;;	       "\n X\U+00F3a Line c\U+00F3 chi\U+1EC1u d\U+00E0i  b?ng v\U+1EDBi gi\U+00E1 tr\U+1ECB nh\U+1EADp v\U+00E0o: XLTCD"
;;;	       "\n X\U+00F3a Line c\U+00F3 \U+0111\U+1EC9nh n?m tr\U+00EAn Polyline: XLTPL"
;;;	)
;;;)
(defun Length1(e) (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)))
;;;--------------------------------------------------------------------
(defun C:XLN( / ss L e );;;Xoa line ngan
(or *KCNGAN* (setq *KCNGAN* 1.0))
(setq KCNGAN (getdist (strcat "\nNh\U+1EADp chi\U+1EC1u d\U+00E0i nh\U+1ECF h\U+01A1n s\U+1EBD b\U+1ECB x\U+00F3a:  <"
		  (rtos *KCNGAN* 2 2)
		 ">:  "
	  )
 )
)
(if (not KCNGAN) (setq KCNGAN *KCNGAN*) (setq *KCNGAN* KCNGAN))
(setq
    ss (ssget  (list (cons 0 "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")))
    L 0.0
)
(vl-load-com)
(setq n 0)
(foreach e (LM:ss->ent ss)
    (if (< (length1 e) KCNGAN)
      	(progn
        	(setq n (+ n 1))
        	(entdel e)
	)
    )
)
(alert (strcat "\nC\U+00F3 t\U+1EA5t c\U+1EA3: " (rtos n 2 0) " c\U+1EA1nh b\U+1ECB x\U+00F3a"))
(princ)
)

(defun C:XLD( / ss L e );;;Xoa line ngan
(or *KCDAI* (setq *KCDAI* 1.0))
(setq KCDAI (getdist (strcat "\nNh\U+1EADp chi\U+1EC1u d\U+00E0i l\U+1EDBn h\U+01A1n s\U+1EBD b\U+1ECB x\U+00F3a:  <"
		  (rtos *KCDAI* 2 2)
		 ">:  "
	  )
 )
)
(if (not KCDAI) (setq KCDAI *KCDAI*) (setq *KCDAI* KCDAI))
(setq
    ss (ssget  (list (cons 0 "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")))
    L 0.0
)
(vl-load-com)
(setq n 0)
(foreach e (LM:ss->ent ss)
    (if (> (length1 e) KCDAI)
      	(progn
        	(setq n (+ n 1))
        	(entdel e)
	)
    )
)
(alert (strcat "\nC\U+00F3 t\U+1EA5t c\U+1EA3: " (rtos n 2 0) " c\U+1EA1nh b\U+1ECB x\U+00F3a"))
(princ)
)


(defun C:XLTCD( / ss L e);;;Xoa line theo chieu dai
(setq KC (getdist "\nNhap chieu dai LINE: "))
(setq
    ss (ssget  (list (cons 0 "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")))
    L 0.0
)
(vl-load-com)
(foreach e (LM:ss->ent ss)
    (if (equal (length1 e) KC 0.01)
        (entdel e)
    )
)
(princ)
)



(defun c:XLTPL();;;xoa line tren Pline
(setq obj (vlax-ename->vla-object (car (entsel "\nChon Line hoac Polyline:"))))
(Alert "\nQuet chon Line")
(setq ss (ssget '((0 . "LINE"))))
(setq LtsEnameLine (LM:ss->ent ss))
(foreach EnameL LtsEnameLine
	(setq P1 (cdr (assoc 10 (entget EnameL))))
  	(setq P2 (cdr (assoc 11 (entget EnameL))))
	(setq PVG1 (vlax-curve-getClosestPointTo obj P1 T))
	(setq PVG2 (vlax-curve-getClosestPointTo obj P2 T))
  	(if (or  (equal P1 PVG1 0.0001)  (equal P2 PVG1 0.0001))
	    (entdel EnameL)
	)
)
(princ)
)



(defun C:CPL( / ss L e);;Chon Pline
(MakeLayer_ "PlVang" 2)
(or *KC* (setq *KC* 10.0))
(setq KC (getreal (strcat "\nNhap chieu dai: <"
			  (rtos *KC* 2 2)
			 "> :"
		  )
	 )
)
(if (not KC) (setq KC *KC*) (setq *KC* KC))

(setq
    ss (ssget  (list (cons 0 "*POLYLINE,LWPOLYLINE,LINE")(cons 62 2 )))
    L 0.0
)
(vl-load-com)
(foreach e (LM:ss->ent ss)
    (if (> (length1 e) KC)
        (PUTLAYER e "PlVang")
    )
)
(princ)
)

(defun MakeLayer_ ( name colour /)
    (if (null (tblsearch "LAYER" name))
        (entmake
            (list
               '(0 . "LAYER")
               '(100 . "AcDbSymbolTableRecord")
               '(100 . "AcDbLayerTableRecord")
               '(70 . 0)
                (cons 2 name)
                (cons 62 colour)
            )
        )
    )
)

(defun PUTLAYER (ent NameLayer / s)
   (setq s (vlax-ename->vla-object ent) )
   (vla-put-layer s NameLayer )
)

(defun LM:ss->ent ( ss / i l )
    (if ss
        (repeat (setq i (sslength ss))
            (setq l (cons (ssname ss (setq i (1- i))) l))
        )
    )
)

<<

Filename: 369192_xln_xld_xltcd_xltpl_cpl.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 371031
Tên lệnh: ha
Lisp lọc các block cùng tên
Chọn một block từ bản vẽ, chọn vùng lọc, sau đó lọc các block có cùng tên với block được chọn

Filename: 371031_ha.lsp
Tác giả: Nguyen Hoanh
Bài viết gốc: 6023
Tên lệnh: %3Cspan+clas
Viết Lisp theo yêu cầu
Lệnh CINVIS dưới đây giống lệnh INVIS ở trên nhưng ẩn đối tượng theo màu.


Filename: 6023_%3Cspan+clas.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 372418
Tên lệnh: eco
Lisp Boundary Thành 1 Hình.

Chọn điểm bên trong miền kín. Sau đo hàm tự tạo thành các pline kín thành region kín và ghép lại với nhau

Filename: 372418_eco.lsp
Tác giả: Tr.CongSon
Bài viết gốc: 372669
Tên lệnh: tbv
Lisp tách khung và đối tượng trong khung đó ra thành các bản vẽ riêng biệt
Mô tả:
- Chạy lisp
- Chọn các khung muốn tách thành bản vẽ riêng biệt (Chọn Polyline1,2 và Block1 như hình dưới)
- Lisp sẽ tự động tách khung có đường polyline1, polyline2, block1 cùng các đối tượng bên trong khung thành các bản vẽ có đường dẫn theo đường dẫn file gốc hiện hành. Tên file mới có thể là: "tên file gốc + số thứ tự tăng dần)

Filename: 372669_tbv.lsp
Tác giả: NguyenNgocSon
Bài viết gốc: 372760
Tên lệnh: bi
Lisp Tạo Boundary Từ Đối Tượng Chọn
(defun c:bi ()
(setq ss (ssget '((0 . "PolyLINE"))))
(command "BOUNDARY" "N" ss (getpoint "\nPick axis crossing lines to edit: ")) ;extend line or...
)

Xin hỏi code trên sai chỗ nào ?

Báo lỗi: 2D point or option keyword required.

Phải pick thêm một lần mới tạo được Boundary

Trân trọng cám ơn !


Filename: 372760_bi.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 372940
Tên lệnh: lk ul lkk
[Yêu Cầu] Sửa Lisp Lock Layer Cho Cad 2015.
Bạn thử cái này xem:
(defun lock_ulock_lay (lock / LayerTable ss)
(vl-load-com)
(setq LayerTable (vla-get-layers (vla-get-activedocument (vlax-get-Acad-Object))))
(if (ssget)
(progn (setq ss (vla-get-activeselectionset (vla-get-activedocument (vlax-get-acad-object))))
(if opt
(progn (vlax-for each LayerTable (vla-put-lock each :vlax-true))
(vlax-for obj ss (vla-put-lock (vla-item LayerTable (vla-get-layer obj)) :vlax-false)))
(vlax-for obj ss
(vla-put-lock...
>>
Bạn thử cái này xem:
(defun lock_ulock_lay (lock / LayerTable ss)
(vl-load-com)
(setq LayerTable (vla-get-layers (vla-get-activedocument (vlax-get-Acad-Object))))
(if (ssget)
(progn (setq ss (vla-get-activeselectionset (vla-get-activedocument (vlax-get-acad-object))))
(if opt
(progn (vlax-for each LayerTable (vla-put-lock each :vlax-true))
(vlax-for obj ss (vla-put-lock (vla-item LayerTable (vla-get-layer obj)) :vlax-false)))
(vlax-for obj ss
(vla-put-lock (vla-item LayerTable (vla-get-layer obj))
(if lock
:vlax-true
:vlax-false))))
(vla-delete ss))
(vlax-for each LayerTable
(vla-put-lock each
(if lock
:vlax-true
:vlax-false))))
(princ))
(defun c:lk (/ lock) (setq lock t) (lock_ulock_lay lock))
(defun c:ul (/ lock) (setq lock nil) (lock_ulock_lay lock))
(defun c:lkk (/ lock opt) (setq lock nil opt t) (lock_ulock_lay lock))
<<

Filename: 372940_lk_ul_lkk.lsp
Tác giả: vanhunguct
Bài viết gốc: 372963
Tên lệnh: btk
[Nhờ Chỉnh Sửa] Lisp Đo Chiều Dài Line Và Xuất Sang Excel

Mình search thì thấy lisp này nhưng chưa đúng với nhu cầu nên nhờ các bác sửa giúp. Thanks các bác trước nhé :wub:

 

Lisp này phải click chọn từng line một và line được chọn ko mờ đi như khi chọn bình thường nên khó nhìn ra cái nào chọn rồi cái nào chưa. Nhờ chỉnh sửa giúp thành 2 lựa chọn:

+ một là có thể chọn line bằng cách click từng line nhưng line được chọn thì...

>>

Mình search thì thấy lisp này nhưng chưa đúng với nhu cầu nên nhờ các bác sửa giúp. Thanks các bác trước nhé :wub:

 

Lisp này phải click chọn từng line một và line được chọn ko mờ đi như khi chọn bình thường nên khó nhìn ra cái nào chọn rồi cái nào chưa. Nhờ chỉnh sửa giúp thành 2 lựa chọn:

+ một là có thể chọn line bằng cách click từng line nhưng line được chọn thì mờ đi để dễ nhìn

+ hai là chọn line bằng cách quét chọn đối tượng, sắp xếp theo thứ tự quét chọn

 

Cuối cùng vẫn xuất ra file excel bình thường


(defun c:btk ( / plst e p0 p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 n i obj els pa pf ps len txt fn fw ans)
(vl-load-com)
(command "undo" "be")
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq plst (list)  i 0)
(alert "\n Chon cac doan can thong ke")
(setq e  (entsel "\n Chon doan can thong ke"))
(While e
        (princ (strcat " 1 found. " (rtos (1+ i) 2 0) "total"))
        (setq plst (cons e plst)
                  e (entsel "\n Chon doan tiep theo")
                  i (1+ i)
        )
)
(setq plst (reverse plst))
(setq p1 (getpoint "\n Chon diem dat bang thong ke")
          p2 (polar p1 0 2.5)
          p3 (polar p2 0 5.5)
          p4 (polar p3 0 5.5)
          p5 (polar p4 0 5.5)
          n (length plst)
          p6 (polar p1 (* 1.5 pi) (* (1+ n) 1.5))
          p7 (polar p2 (* 1.5 pi) (* (1+ n) 1.5))
          p8 (polar p3 (* 1.5 pi) (* (1+ n) 1.5))
          p9 (polar p4 (* 1.5 pi) (* (1+ n) 1.5))
          p10 (polar p5 (* 1.5 pi) (* (1+ n) 1.5))
)
(command "line" p1 p5 p10 p6 p1 "")
(command "line" p2 p7 "")
(command "line" p3 p8 "")
(command "line" p4 p9 "")
(styleset)
(command "text" "j" "mc" (list (+ (car p1) 1.25) (- (cadr p1) 0.75)) 0.3 0 "TT  &#208;O\\U+1EA0N" )
(command "text" "j" "mc" (list (+ (car p2) 2.75) (- (cadr p1) 0.75)) 0.3 0 "T\\U+1EEA  &#208;I\\U+1EC2M" )
(command "text" "j" "mc" (list (+ (car p3) 2.75) (- (cadr p1) 0.75)) 0.3 0 "T\\U+1EDAI  &#208;I\\U+1EC2M" )
(command "text" "j" "mc" (list (+ (car p4) 2.75) (- (cadr p1) 0.75)) 0.3 0 "CHI\\U+1EC0U  D&#192;I")
(command "text" "j" "mc" (list (+ (car p1) 9.5) (+ (cadr p1) 0.5 )) 0.5 0 "B\\U+1EA2NG XU\\U+1EA4T RA K\\U+1EBET QU\\U+1EA2")
(setq ans (getstring "\n Ban muon luu sang file cvs khong?? <Y or N>: "))
(if (= (strcase ans) "Y")
    (progn
            (setq fn (getfiled "Chon file de save" "" "csv" 1)
   	       fw (open fn "w"))
       	(princ  "BANG XUAT TOA DO RA FILE CSV \n" fw)
                  (princ " TT doan , Tu diem , Toi diem , Chieu dai \n" fw)
   )
)
(setq i 0)
(foreach a plst
   	(setq i (1+ i)
                obj (vlax-ename->vla-object (car a))
                els (entget (car a))
                p0 (polar p1 (* 1.5 pi) 1.5)
                p1 p0
   	)
   	(cond
         	( (or (= (cdr (assoc 0 els)) "LWPOLYLINE") (= (cdr (assoc 0 els)) "POLYLINE"))
                  (setq pa (vlax-curve-getparamatpoint obj (vlax-curve-getclosestpointto obj (cadr a)))
                            pf (vlax-curve-getpointatparam obj (fix pa))
                            ps (vlax-curve-getpointatparam obj (1+ (fix pa)))
                            len (- (vlax-curve-getdistatpoint obj ps) (vlax-curve-getdistatpoint obj pf))                          
                  ) )
         	( (= (cdr (assoc 0 els)) "LINE")
                  (setq pf (cdr (assoc 10 els))
                       	ps (cdr (assoc 11 els))
                       	len (distance pf ps)
                  ) )
         	( (or (= (cdr (assoc 0 els)) "SPLINE") (=  (cdr (assoc 0 els)) "ARC") )
                  (setq pf (vlax-curve-getstartpoint obj)
                       	ps (vlax-curve-getendpoint obj)
                       	len (vlax-curve-getdistatpoint obj ps)
                  ) )
         	(T nil)
   	)
   	(setq txt (strcat (rtos i 2 0) "," "X=" (rtos (car pf) 2 4) "  Y=" (rtos (cadr pf) 2 4) "," "X=" (rtos (car ps) 2 4) "  Y=" (rtos (cadr ps) 2 4) "," (rtos len 2 4) "\n"))
   	(command "line" p0 (polar p0 0 19) "")
   	(command "text" "j" "mc" (list (+ (car p0) 1.25) (- (cadr p0) 0.75)) 0.2 0 (rtos i 2 0) )
   	(command "text" "j" "mc" (list (+ (car p0) 5.25) (- (cadr p1) 0.75)) 0.2 0 (strcat "X=" (rtos (car pf) 2 4) "  Y=" (rtos (cadr pf) 2 4)) )
   	(command "text" "j" "mc" (list (+ (car p0) 10.75) (- (cadr p1) 0.75)) 0.2 0 (strcat "X=" (rtos (car ps) 2 4) "  Y=" (rtos (cadr ps) 2 4)) )
   	(command "text" "j" "mc" (list (+ (car p0) 16.25) (- (cadr p1) 0.75)) 0.2 0 (rtos len 2 4))
   	(if (= (strcase ans) "Y")
       	(princ txt fw)
   	)
)
(if fw
   (close fw)
)
(setvar "osmode" oldos)
(command "undo" "e")
(princ)
)
 
(defun styleset ()
(setq stl (getvar "textstyle")
     	h (getvar "textsize"))
(if (/= h 0) (command "style" stl "" 0 "" "" "" "" ""))
)                  



<<

Filename: 372963_btk.lsp
Tác giả: Tr.CongSon
Bài viết gốc: 373716
Tên lệnh: sa
Lisp Save as nhanh nhiều bản vẽ cũng lúc

Lúc nãy mình gởi code rồi sao ko thấy hè

Bạn apload rồi dung nhé

Lệnh: SA

(defun c:SA (/ gfile lstdwg n path scr)
(grtext
-1
"CT Ch\U+1EA1y H\U+00E0ng Lo\U+1EA1t B\U+1EA3n V\U+1EBD...!!! @ Tr\U+1EA7n S\U+01A1n-Detail"
)
(setq gfile (getfiled
"Ch\U+1ECDn FileDWG t\U+00F9y \U+00FD trong Folder :"
""
"dwg"
0
)
path (vl-filename-directory gfile)
lstdwg (vl-directory-files path "*dwg")
pathscr (strcat path...

>>

Lúc nãy mình gởi code rồi sao ko thấy hè

Bạn apload rồi dung nhé

Lệnh: SA

(defun c:SA (/ gfile lstdwg n path scr)
(grtext
-1
"CT Ch\U+1EA1y H\U+00E0ng Lo\U+1EA1t B\U+1EA3n V\U+1EBD...!!! @ Tr\U+1EA7n S\U+01A1n-Detail"
)
(setq gfile (getfiled
"Ch\U+1ECDn FileDWG t\U+00F9y \U+00FD trong Folder :"
""
"dwg"
0
)
path (vl-filename-directory gfile)
lstdwg (vl-directory-files path "*dwg")
pathscr (strcat path "\\" "RunAll.scr")
scr (open pathscr "w")
)
(foreach x lstdwg
(write-line (strcat "OPEN " "\"" path "\\" x "\"" " QSAVE CLOSE ") scr)
)
(close scr)
(command "script" pathscr)
(princ)
)


<<

Filename: 373716_sa.lsp
Tác giả: Tr.CongSon
Bài viết gốc: 373661
Tên lệnh: btk
Tạo Bảng Thống Kê

Comment hồi sang chừ mà không thấy chủ thớt hồi âm luôn .Buồn that !

Đã code xong cho  anh rồi đây

Anh xem thử đúng chưa nhé!

 

(defun TS:Getboundary (ent / ll ur)
(vla-getboundingbox (vlax-ename->vla-object ent) 'll 'ur)
(mapcar 'vlax-safearray->list (list ll ur))
)
;;;---------------------
(defun TS:sel (/ ent)
(while
(progn
(setvar 'errno 0)
(setq ent (entsel "\nCh\U+1ECDn Block...

>>

Comment hồi sang chừ mà không thấy chủ thớt hồi âm luôn .Buồn that !

Đã code xong cho  anh rồi đây

Anh xem thử đúng chưa nhé!

 

(defun TS:Getboundary (ent / ll ur)
(vla-getboundingbox (vlax-ename->vla-object ent) 'll 'ur)
(mapcar 'vlax-safearray->list (list ll ur))
)
;;;---------------------
(defun TS:sel (/ ent)
(while
(progn
(setvar 'errno 0)
(setq ent (entsel "\nCh\U+1ECDn Block \U+0111\U+1EC3 th\U+1ED1ng k\U+00EA : "))
(cond
((= 7 (getvar 'errno)) (princ "\nCh\U+1ECDn l\U+1ED7i.Vui l\U+00F2ng l\U+1EA1i."))
((= 'ename (type (car ent)))
(if (wcmatch (cdr (assoc 0 (entget (car ent))))
"INSERT"
)
(progn (setq ent (car ent))
nil
)
(princ "\n\U+0110\U+1ED1i t\U+01B0\U+1EE3ng ch\U+1ECDn kh\U+00F4ng ph\U+1EA3i Block.")
)
)
)
)
)
ent
)
;;;---------------------
(defun TS:eText (pt justify txt / Lst)
(setq Lst (list (cons 0 "TEXT")
(cons 8 "TAREA")
(cons 7 "Arial")
(cons 10 pt)
(cons 40 31.5)
(cons 41 1)
(cons 71 0)
(cons 1 txt)
)
)
(cond ((= justify "C")
(setq Lst (append Lst (list (cons 72 1) (cons 73 2) (cons 11 pt))))
)
((= justify "L")
(setq Lst (append Lst (list (cons 72 0) (cons 73 2) (cons 11 pt))))
)
)
(entmakex lst)
)
;;;---------------------
(defun TS:Eline (p1 p2)
(entmakex
(list
(cons 0 "LINE")
(cons 8 "TAREA")
(cons 10 p1)
(cons 11 p2)
)
)
)

;;;---------------------
(defun TS:MakeBTK (point / p1 p2 p3 p4 p5 p6)
(setq p1 (list (+ (car point) 68) (+ (cadr point) 30))
p2 (list (+ (car point) 274) (+ (cadr point) 30))
p3 (list (+ (car point) 424) (+ (cadr point) 30))
p4 (list (+ (car point) 1545) (+ (cadr point) 30))
p5 (list (car pt) (+ (cadr pt) 60))
p6 (list (+ (car pt) 1305) (+ (cadr pt) 60))
)
(TS:Eline p5 p6)
(mapcar 'TS:eText
(list p1 p2 p3 p4)
(list "C" "C" "L" "L")
(list (nth 1 lsttxt) (nth 0 lsttxt) txt_PL item))
)

;;;;;;;------------------;;;;;;;;;;
(defun c:BTK (/ entblk i item ll lsttxt osm pt pt1 pt2 pt3 pt4 pt5 sstxt txt_pl ur)
(setvar "Modemacro" "@ Tr\U+1EA7n C\U+00F4ng S\U+01A1n _ Detail SS")
(setvar "cmdecho" 0)
(command "Undo" "Be")
(setq osm (getvar "osmode"))
(setvar "osmode" 1)
(setq pt (getpoint
"\nCh\U+1ECDn \U+0111i\U+1EC3m ch\U+00E8n B\U+1EA3ng Th\U+1ED1ng K\U+00EA : "
)
i 0
)
(while (setq entblk (TS:sel))
(setq ll (car (TS:Getboundary entblk))
ur (cadr (TS:Getboundary entblk))
item (cdr (assoc 1
(entget (ssname (ssget "W"
ll
ur
(list (cons 0 "TEXT")
(cons 8 "0")
(cons 62 2)
(cons 1 "@*")
)
)
0
)
)
)
)
sstxt (acet-ss-to-list
(ssget "W"
ll
ur
(list (cons 0 "TEXT")
(cons 8 "0")
(cons 62 2)
(cons 1 "#*")
)
)
)
sstxt (vl-sort sstxt
'(lambda (x1 x2)
(< (cadr (assoc 10 (entget x1)))
(cadr (assoc 10 (entget x2)))
)
)
)
lsttxt (mapcar '(lambda (x) (cdr (assoc 1 (entget x)))) sstxt)
txt_PL (strcat "PL" (nth 3 lsttxt) "x" (nth 4 lsttxt) "x" (nth 2 lsttxt))
)
(TS:MakeBTK pt)
(setq pt (list (car pt) (+ (cadr pt) 60)))
(setq i (1+ i))
)
(setq pt1 (list (+ (car pt) 135) (cadr pt))
pt2 (list (+ (car pt) 412) (cadr pt))
pt3 (list (+ (car pt) 885) (cadr pt))
pt4 (list (+ (car pt) 1095) (cadr pt))
pt5 (list (+ (car pt) 1305) (cadr pt))
)
(TS:Eline pt1 (list (car pt1) (- (cadr pt1) (* i 60))))
(setvar "osmode" 0)
(command "_.copy" (entlast) "" "M" pt1 pt2 pt3 pt4 pt5 "")
(setvar "osmode" osm)
(command "Undo" "End")
(setvar "cmdecho" 1)
(princ)
)


<<

Filename: 373661_btk.lsp
Tác giả: nhoclangbac
Bài viết gốc: 374249
Tên lệnh: amo
Bạn Nào Giúp Mình Viết Clisp Nội Suy Giữa Hai Đường Spline Và Xóa Phần Không Được Chọn

"không ra cái hình gì" là có thể do lisp sử lý lấy 2 điểm đầu "bờ sông" phải gần nhau. Còn nếu 2 điểm này: anh ở thượng em ở hạ thì kiểu gì cũng tạo ra 1 đường rối.

Thanhduan 2407 sửa lại 1 chút là được. Còn muốn dùng li sp này bạn nên dùng lệnh reverse để đổi chiều 1 trong 2 bờ sông...

>>

"không ra cái hình gì" là có thể do lisp sử lý lấy 2 điểm đầu "bờ sông" phải gần nhau. Còn nếu 2 điểm này: anh ở thượng em ở hạ thì kiểu gì cũng tạo ra 1 đường rối.

Thanhduan 2407 sửa lại 1 chút là được. Còn muốn dùng li sp này bạn nên dùng lệnh reverse để đổi chiều 1 trong 2 bờ sông nhé

Nhoc thay bác tiền bối chỉ điểm mà không ra tay :( , Nhoc thử viết xem (không dấu code nhé :D )... nhờ bác tiền bối kiểm tra xem sao bị lỗi với bản vẽ chủ topic :wub:

(defun c:amo (/ os pl1 pl2 i pa1 p1 p2 ptb lstp)
(command "undo" "be") 
(setq os (getvar "osmode")) (setvar "osmode" 0)
(setq pl1 (car (entsel "\n Chon duong Polyline thu nhat :")))
(setq pl2 (car (entsel "\n Chon duong Polyline thu hai :")))
(setq pa1 (vlax-curve-getEndParam pl1) i 0) 
(while (<= i pa1) (setq p1 (vlax-curve-getPointAtParam pl1 i))
(setq p2 (vlax-curve-getClosestPointTo pl2 p1)) 
(setq ptb (list (/ (+ (car p1) (car p2)) 2) (/ (+ (cadr p1) (cadr p2)) 2) 0))
(setq lstp (cons ptb lstp)) (setq i (+ i 1))	) 
(command "pline")
(foreach x lstp (command x)) (command "")
(setvar "osmode" os) 
(Command "undo" "e") 
(princ))


<<

Filename: 374249_amo.lsp
Tác giả: sans_amour
Bài viết gốc: 372487
Tên lệnh: caltxt
Lisp tính toán công thức toán học của đối tượng text
Thích hợp cho việc thống kê cốt thép
Lisp dạng giống như bảng tính như trong Excel, chỉ cần nhập hai hoặc ba cột dữ liệu ban đầu, còn các cột còn lại sẽ tự link và thống kê lại từng loại thép.


Filename: 372487_caltxt.lsp
Tác giả: quansla
Bài viết gốc: 375612
Tên lệnh: cadviet
Nhờ Viêt Lisp Di Chuyển Đối Tượng Với Khoảng Cách Đều
bạn có thể dùng thử

(defun c:cadviet(/ A ANG B DELTA DI DT
DT_CUOI DT_DAU K LST N P1 P2 R SS)
(vl-load-com)
(setvar "cmdecho" 0)
(defun trongtam_Donut(dt)
(setq ent (entget dt))
(setq ls10 (vl-remove-if '(lambda(x)(/= (car x)10)) ent))
(mapcar '(lambda(x y)
(* 0.5 (+ x y)))
(cdr (car ls10))(cdr (last ls10))))

(setq ss (ssget '((0 . "LWPOLYLINE")(70 . 1)(90 . 2))))
(setq lst (vl-sort (acet-ss-to-list ss)
'(lambda (x y)
(if (not...
>>
bạn có thể dùng thử

(defun c:cadviet(/ A ANG B DELTA DI DT
DT_CUOI DT_DAU K LST N P1 P2 R SS)
(vl-load-com)
(setvar "cmdecho" 0)
(defun trongtam_Donut(dt)
(setq ent (entget dt))
(setq ls10 (vl-remove-if '(lambda(x)(/= (car x)10)) ent))
(mapcar '(lambda(x y)
(* 0.5 (+ x y)))
(cdr (car ls10))(cdr (last ls10))))

(setq ss (ssget '((0 . "LWPOLYLINE")(70 . 1)(90 . 2))))
(setq lst (vl-sort (acet-ss-to-list ss)
'(lambda (x y)
(if (not (equal
(car (setq Gx (trongtam_Donut x)))
(car (setq Gy (trongtam_Donut y)))
1E-3))
(< (cadr Gx) (cadr Gy))
(< (car Gx) (car Gy))
)
)
))
(setq dt_dau (car lst)
dt_cuoi (last lst)
N (- (length lst) 1)
di (distance (trongtam_Donut dt_dau)(trongtam_Donut dt_cuoi))
ang (angle (trongtam_Donut dt_dau)(trongtam_Donut dt_cuoi))
delta (/ di N 1.000)
r '()
k -1)
(foreach dt lst
(setq r (append r (list
(list
dt
(trongtam_Donut dt)
(polar (trongtam_Donut dt_dau) ang (* (setq k (1+ k)) delta))
)))))
(setq dt (car r))
(command "undo" "begin")
(foreach dt r
(command "move" (car dt) "" "_non" (cadr dt) "_non" (last dt)))
(command "undo" "end")
(setvar "cmdecho" 1)
(princ)
)

<<

Filename: 375612_cadviet.lsp
Tác giả: Tr.CongSon
Bài viết gốc: 375647
Tên lệnh: gg
Xin Trợ Giúp Về Lisp Ghi Độ Dài Đường Thẳng Ra Block Att

Tr.CongSon đã nhiệt tình giúp đỡ e. e đã gửi mail cho bác. mong bác sớm hồi âm, . Thanks all.

 

Đã Code xong cho anh rồi đây :)

Anh dùng xem sao nhé ^^

;;;------------------------------
;;;-----by MENZI ENGINEERING ----
(defun SetAtt (obj lst / attval)
(mapcar '(lambda (att)
(if (setq attval (cdr...

>>

Tr.CongSon đã nhiệt tình giúp đỡ e. e đã gửi mail cho bác. mong bác sớm hồi âm, . Thanks all.

 

Đã Code xong cho anh rồi đây :)

Anh dùng xem sao nhé ^^

;;;------------------------------
;;;-----by MENZI ENGINEERING ----
(defun SetAtt (obj lst / attval)
(mapcar '(lambda (att)
(if (setq attval (cdr (assoc (vla-get-TagString att) lst)))
(vla-put-TextString att attval)
)
)
(vlax-invoke obj 'GetAttributes)
)
(vla-update obj)
)
;;;------------------------------
(defun TS:select (/ ent)
(while
(progn
(setvar 'errno 0)
(setq ent (entsel "\nCh\U+1ECDn Line,Pline,SPline \U+0111\U+1EC3 l\U+1EA5y chi\U+1EC1u d\U+00E0i :"))
(cond
((= 7 (getvar 'errno))
(princ "\nCh\U+1ECDn l\U+1ED7i.Vui l\U+00F2ng l\U+1EA1i.")
)
((= 'ename (type (car ent)))
(if (wcmatch (cdr (assoc 0 (entget (car ent))))
"*LINE"
)
(progn (setq ent (car ent))
nil
)
(princ
"\n\U+0110\U+1ED1i t\U+01B0\U+1EE3ng ch\U+1ECDn kh\U+00F4ng ph\U+1EA3i LINE,PLINE,SPLINE."
)
)
)
)
)
)
ent
)
;;;-------------------------------
(defun GetLen (ent / len)
(setq len (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent)))
(if (>= len 0)
(fix (+ len 0.5))
(fix (- len 0.5))
)
)
;;;-------------------------------
(defun GetDxf (n elist) (cdr (assoc n elist)))
;;;-------------------------------
(defun c:GG (/ *error* blkatt ent len)
(vl-load-com)
(setvar "Modemacro" "@ Tr\U+1EA7n C\U+00F4ng S\U+01A1n _ XDDD & CN")
(defun *error* (msg)
(if ent
(redraw ent 4)
)
(if (not (wcmatch (strcase msg) "*BREAK,*EXIT*,*CANCEL*"))
(princ (strcat "\n** Error: " msg " **"))
)
(princ)
)
(while (setq ent (TS:select))
(redraw ent 3)
(setq Len (itoa (GetLen ent)))
(if (and (setq BlkATT (car (entsel "\nChon Block ATT:")))
(wcmatch (GetDxf 0 (entget BlkATT)) "INSERT")
(= (GetDxf 66 (entget BlkATT)) 1)
)
(SetAtt (vlax-ename->Vla-Object BlkATT) (list (cons "CHIEUDAI" Len)))
(alert
"\n\U+0110\U+1ED1i t\U+01B0\U+1EE3ng ch\U+1ECDn kh\U+00F4ng ph\U+1EA3i Block ATTribute."
)
)
(redraw ent 4)
)
(princ)
)

 

Em viết Lisp mà được người khác khen và Tick Thanks (nút xanh) là em thấy vui rồi :) :) :)

Hơn nữa viết nhiều mới mau lên tay được nên a yên tâm,vì quan điểm của e là : giúp người=giúp ta mà :)

Thôi,hết giờ làm rồi,ra làm ly bia cho nó mát  mát ruột đã .hehe

Hẹn gặp lại sau !

Chào thân ái !


<<

Filename: 375647_gg.lsp

Trang 195/304

195