Jump to content
InfoFile
Tác giả: huaductiep
Bài viết gốc: 277501
Tên lệnh: hatchkin
Nhờ viết Lisp Hatch vùng kín của các đối tượng giao nhau.

 

Hi bạn:

Em dùng lisp trên với bản Cad sau lại ko được bác DoanDuyHung ah. Em rất hay phải hatch với những đối tượng...

>>

 

Hi bạn:

Em dùng lisp trên với bản Cad sau lại ko được bác DoanDuyHung ah. Em rất hay phải hatch với những đối tượng giao với đường mặt đất tự nhiên màu tím như trong hình sau. Mặc dù em đã Extend hết để cho các đối tượng giao cắt với nhau mà vẫn ko thể Hatch được. Mong bác và diễn đàn tìm cách giúp đỡ em với nhé. Em xin chân thành cảm ơn ạ  :)

http://www.cadviet.com/upfiles/3/64997_test_hatchkin.dwg64997_screenshot_82.png

hi bạn

- 2 cái hình trong khung lần 1 đối tượng màu đỏ không giao với đường đứng màu vàng nên chỉ hatch được các phần còn lại

- 2 cái hình trong khung lần 2 thì hatch được hết.

(defun LM:Intersections ( obj1 obj2 mode / l r )
    (setq l (vlax-invoke obj1 'intersectwith obj2 mode))
    (repeat (/ (length l) 3)
        (setq r (cons (list (car l) (cadr l) (caddr l)) r)
              l (cdddr l)
        )
    )
    (reverse r)
)
(defun LM:IntersectionsInSet ( ss / a b i j l )
    (repeat (setq i (sslength ss))
        (setq a (vlax-ename->vla-object (ssname ss (setq i (1- i)))))
        (repeat (setq j i)
            (setq b (vlax-ename->vla-object (ssname ss (setq j (1- j))))
                  l (cons (LM:Intersections a b acextendnone) l)
            )
        )
    )
    (apply 'append (reverse l))
)
(defun DDH:pointtolsppoint (pointchen lsppointchen / vitrichen ii)
  (setq iii 0)
  (repeat (- (length lsppointchen) 1)
    (if (and (> (distance pointchen (nth (+ iii 1) lsppointchen)) 0.001)
	     (> (distance pointchen (nth iii lsppointchen)) 0.001)
	     )
      (progn
	(if (<= (abs (- (distance (nth iii lsppointchen) (nth (+ iii 1) lsppointchen))
			(+ (distance pointchen (nth (+ iii 1) lsppointchen))
			   (distance pointchen (nth iii lsppointchen))
			   )
			))
		     0.001)
	  (setq vitrichen (+ iii 1))
	  )
	)
      )
    (setq iii (+ iii 1))
    )
  (setq lsppointchen (LM:InsertNth pointchen vitrichen lsppointchen))
  )
(defun LM:InsertNth ( x n l )
  ((lambda ( k )
     (apply 'append
	    (mapcar '(lambda ( a ) (if (= n (setq k (1+ k))) (list x a) (list a))) l)
	    )
     )
    -1
    )
  )
(defun LM:Uniqueline ( l )
  (if l (cons (car l)
	      (LM:Uniqueline
		(vl-remove-if '(lambda (x) (or (and (equal (car x) (car (car l)))
						    (equal (cadr x) (cadr (car l))))
					       (and (equal (car x) (cadr (car l)))
						    (equal (cadr x) (car (car l))))
					       )
				 ) (cdr l))
		))))
(defun taopolyline (lst layer mau / x )
  (entmakex
    (append (list (cons 0 "LWPOLYLINE")
		  (cons 100 "AcDbEntity")
		  (cons 100 "AcDbPolyline")
		  (cons 90 (length lst))
		  (cons 70 0)
		  (cons 66 1)
		  (cons 8 layer)
		  (cons 62 mau)
		  )
	    (mapcar (function (lambda (x) (cons 10 x))) lst)
	    )
    )  
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:hatchkin(/)
  (vl-load-com)
  (princ "\nChon Cac Line, Polyline, Arc, Circle, Spline Hoac Ellipse De Tao Polyline Kin")
  (if (setq chonlinepolyline (ssget '((-4 . "<OR")(0 . "LINE")(0 . "CIRCLE")(0 . "SPLINE")(0 . "ARC")(0 . "ELLIPSE")(0 . "*POLYLINE")(-4 . "OR>"))))
    (progn   
      (setq chonpolyline (ssadd))
      (setq lsppolyline nil)
      (setq i 0)
      (repeat (sslength chonlinepolyline)
	(taopolyline (ACET-GEOM-OBJECT-POINT-LIST (ssname chonlinepolyline i)
		       (/ (vlax-curve-getdistatparam (ssname chonlinepolyline i) (vlax-curve-getendparam (ssname chonlinepolyline i)))
			  10000)) "0" 1)
	(ssadd (entlast) chonpolyline)
	(setq lsppolyline (append lsppolyline (list (ACET-GEOM-OBJECT-POINT-LIST (ssname chonlinepolyline i)
						      (/ (vlax-curve-getdistatparam (ssname chonlinepolyline i) (vlax-curve-getendparam (ssname chonlinepolyline i)))
							 10000)))))
	(setq i (+ i 1))
	)
      (setq lspgiaodiem (LM:IntersectionsInSet chonpolyline))
      (setq chonline (ssadd))
      (setq lspchonline nil)
      (setq lsp2diemline nil)
      (foreach lsp lsppolyline
	(foreach diemgiao lspgiaodiem
	  (setq lsp (DDH:pointtolsppoint diemgiao lsp))
	  )
	(setq i 0)
	(repeat (- (length lsp) 1)
	  (setq lsp2diemline (append lsp2diemline (list (list (nth i lsp) (nth (+ i 1) lsp)))))
	  (setq i (+ i 1))
	  )
	)
      (setq lsp2diemline (LM:Uniqueline lsp2diemline))
      (foreach line lsp2diemline
	(entmakex (list '(0 . "LINE")
			(cons 10 (car line))
			(cons 11 (cadr line))
			))
	(ssadd (entlast) chonline)
	(setq lspchonline (append lspchonline (list (vlax-ename->vla-object (entlast)))))
	)
      (or acDoc (setq acDoc (vla-get-activedocument (vlax-get-acad-object))))
      (setq ms (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)))
      (if (setq lsptongregion (vlax-invoke ms 'AddRegion lspchonline))
	(progn
	  (command "ERASE" chonline "")
	  (command "ERASE" chonpolyline "")
	  (setq lspxetbien nil)
	  (foreach tungregion lsptongregion
	    (setq lspxetbien (append lspxetbien (list (list (vlax-vla-object->ename tungregion) (vlax-get-property tungregion 'area)))))
	    )
	  (setq lspxetbien (vl-sort lspxetbien (function (lambda (e1 e2) (> (cadr e1) (cadr e2))))))
	  (setq dientichtong 0.00)
	  (foreach dientich (cdr lspxetbien)
	    (setq dientichtong (+ dientichtong (cadr dientich)))
	    )
	  (if (<= (abs (- (cadr (car lspxetbien)) dientichtong)) 0.0001)
	    (entdel (car (car lspxetbien)))
	    )
	  (setq mau 1)
	  (foreach xetpl (cdr lspxetbien)
	    (if (>= mau 255)
	      (setq mau 1)
	      )
	    (command "hatch" "" "" "" (car xetpl) "")
	    (command "change" (entlast) "" "p" "c" mau "")
	    (setq mau (+ mau 1))
	    )
	  
	  )
	)
      )
    )
  )

Hj hj.. Em cám ơn bác nhiều lắm. Bác có thể giúp em thêm cái phần xóa mấy cái Region được tạo ra ko ah? Tạo ra mấy cái đó gây nhiều rác trên bản vẽ quá bác ah.


<<

Filename: 277501_hatchkin.lsp
Tác giả: Doan Nguyen Van
Bài viết gốc: 441332
Tên lệnh: ii h2t h2l
tạo đối tượng text nằm trong vùng hatch

3 phút trước, tranducanh đã nói:

Cảm ơn bạn! Mình làm được...

>>
3 phút trước, tranducanh đã nói:

Cảm ơn bạn! Mình làm được số hiển thị phía sau rồi bạn. Còn chuyển dấu chấm thành dấu phẩy thì sao hả bạn?

Bạn dùng lệnh FIND để sửa nhé

25 phút trước, divine kai đã nói:

cảm ơn anh DOAN nhiều...

(alert (strcat "LISP Hatch to Text"
	       "\nNguoi viet: 3Duy"
	       "\nLenh thuc hien:"
	       "\n        H2T - Dien tich"
	       "\n        H2L - Ten layer"
	       )
)

;TEN LENH
(defun C:ii ()
  (alert (strcat "LISP Hatch to Text"
	       "\nNguoi viet: 3Duy"
	       "\nLenh thuc hien:"
	       "\n        H2T - Dien tich"
	       "\n        H2L - Ten layer"
	       )
)
  )

(vl-load-com)

;HATCH TO TEXT
(defun C:h2t ( / AREA ELST OBJ)
  (setq elst (acet-ss-to-list (ssget (list (cons 0 "HATCH")))))
  (foreach ent elst
    (if (> (vla-get-numberofloops (vlax-ename->vla-object ent)) 1) (progn
   	(setq entl (entlast))
	(command "UNDO" "BE")
	(vl-cmdf "_-HATCHEDIT" (ssadd ent) "H" "")
	(setq ss (ssadd ent))
  (while (setq entl (entnext entl))
	  (setq ss (ssadd entl ss)) )
  (setq lst (list))
  (foreach ent2 (acet-ss-to-list ss)
    (setq obj (vlax-ename->vla-object ent2))
    (if (vl-catch-all-error-p (vl-catch-all-apply (function (lambda () (setq area (vlax-get obj 'area))))))
      (setq area 0.00)
      (setq area (vlax-get obj 'area))
      )
    (setq lst (append lst (list (list (cdr (assoc 8 (entget ent2))) (rtos area 2 (getvar "LUPREC")) (car (boundingbox obj))))))
    )
    	(command "UNDO" "E")
	(command "UNDO" "1")
  (foreach lst1 lst
	  (maketext (car lst1) (cadr lst1) (caddr lst1))
	  ) ) (progn
(setq obj (vlax-ename->vla-object ent))
    (if (vl-catch-all-error-p (vl-catch-all-apply (function (lambda () (setq area (vlax-get obj 'area))))))
      (setq area 0.00)
      (setq area (vlax-get obj 'area))
      )
(maketext (cdr (assoc 8 (entget ent))) (rtos area 2 (getvar "LUPREC")) (car (boundingbox obj)))
))
    )
    
  (print)
  )
(defun C:h2l ( / ELST OBJ)
  (setq elst (acet-ss-to-list (ssget (list (cons 0 "HATCH")))))
    (foreach ent elst
    (if (> (vla-get-numberofloops (vlax-ename->vla-object ent)) 1) (progn
 	(setq entl (entlast))
	(command "UNDO" "BE")
	(vl-cmdf "_-HATCHEDIT" (ssadd ent) "H" "")
	(setq ss (ssadd ent))
	(while (setq entl (entnext entl))
	  (setq ss (ssadd entl ss)) )
	(Setq lst (list))
	       (foreach ent2 (acet-ss-to-list ss)
		 (setq lst (append lst (list (list (cdr (assoc 8 (entget ent2))) (car (boundingbox (vlax-ename->vla-object ent2)))))))
		 )
	(command "UNDO" "E")
	(command "UNDO" "1")
	(foreach lst1 lst
	  (maketext (car lst1) (car lst1) (cadr lst1))
	  )
	) (maketext (cdr (assoc 8 (entget ent))) (cdr (assoc 8 (entget ent))) (car (boundingbox (vlax-ename->vla-object ent))))
      ))
	
    
  (print)
  )

(defun boundingbox (obj / a b lst lst1)
  (if
    (and
      (vlax-method-applicable-p obj 'getboundingbox)
      (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'a 'b))))
      (setq lst (mapcar 'vlax-safearray->list (list a b)))
      )
    (setq lst1 (mapcar '(lambda ( a ) (mapcar '(lambda ( b ) ((eval b) lst)) a))
		       '((caar cadar) (caadr cadar) (caadr cadadr) (caar cadadr))
		       )
	  lst1 (append (list (list (/ (+ (car (car lst1)) (car (caddr lst1))) 2.) (/ (+ (cadr (car lst1)) (cadr (caddr lst1))) 2.))) lst1)
	  )
    )
  )
(defun maketext (lay noidung point / lay point)
(entmakex (list
		(cons 0 "TEXT")
		(cons 100 "AcDbEntity")
		(cons 100 "AcDbText")
		(cons 8 lay)
		(cons 1 noidung)
		(cons 7 (getvar "TEXTSTYLE"))
		(cons 10 point)
		(cons 11 point)
		(cons 40 (/ (getvar "VIEWSIZE") 100))
		(cons 72 4)
		))
  )

 


<<

Filename: 441332_ii_h2t_h2l.lsp
Tác giả: Doan Nguyen Van
Bài viết gốc: 441348
Tên lệnh: ii h2t h2l
tạo đối tượng text nằm trong vùng hatch
5 giờ trước, divine kai đã nói:

>>
5 giờ trước, divine kai đã nói:

image.png.1fa9d30937f9af75779e8682c0fd0e4e.png

lisp thứ 2 nó báo lỗi như thế này anh

Thôi sửa nốt cho bạn.

Cảm ơn hàm của bác @ndtnv



;TEN LENH
(defun C:ii ()
  (alert (strcat "LISP Hatch to Text"
	       "\nNguoi viet: 3Duy"
	       "\nLenh thuc hien:"
	       "\n        H2T - Dien tich"
	       "\n        H2L - Ten layer"
	       )
)
  )

(vl-load-com)

;HATCH TO TEXT
(defun C:h2t ( / AREA ELST OBJ)
  (setq elst (acet-ss-to-list (ssget (list (cons 0 "HATCH")))))
  (foreach ent elst
    (if (> (vla-get-numberofloops (vlax-ename->vla-object ent)) 1) (progn
   	(setq entl (entlast))
	(command "UNDO" "BE")
	(vl-cmdf "_-HATCHEDIT" (ssadd ent) "H" "")
	(setq ss (ssadd ent))
  (while (setq entl (entnext entl))
	  (setq ss (ssadd entl ss)) )
  (setq lst (list))
  (foreach ent2 (acet-ss-to-list ss)
    (setq obj (vlax-ename->vla-object ent2))
    (if (vl-catch-all-error-p (vl-catch-all-apply (function (lambda () (setq area (vlax-get obj 'area))))))
      (setq area 0.00)
      (setq area (vlax-get obj 'area))
      )
    (setq lst (append lst (list (list (cdr (assoc 8 (entget ent2))) (rtos area 2 (getvar "LUPREC"))  (_cen ent2)))))
    )
    	(command "UNDO" "E")
	(command "UNDO" "1")
  (foreach lst1 lst
	  (maketext (car lst1) (cadr lst1) (caddr lst1))
	  ) ) (progn
(setq obj (vlax-ename->vla-object ent))
    (if (vl-catch-all-error-p (vl-catch-all-apply (function (lambda () (setq area (vlax-get obj 'area))))))
      (setq area 0.00)
      (setq area (vlax-get obj 'area))
      )
(maketext (cdr (assoc 8 (entget ent))) (rtos area 2 (getvar "LUPREC")) (_cen ent)  )
))
    )
    
  (print)
  )
(defun C:h2l ( / ELST OBJ)
  (setq elst (acet-ss-to-list (ssget (list (cons 0 "HATCH")))))
    (foreach ent elst
    (if (> (vla-get-numberofloops (vlax-ename->vla-object ent)) 1) (progn
 	(setq entl (entlast))
	(command "UNDO" "BE")
	(vl-cmdf "_-HATCHEDIT" (ssadd ent) "H" "")
	(setq ss (ssadd ent))
	(while (setq entl (entnext entl))
	  (setq ss (ssadd entl ss)) )
	(Setq lst (list))
	       (foreach ent2 (acet-ss-to-list ss)
		 (setq lst (append lst (list (list (cdr (assoc 8 (entget ent2)))  (_cen ent2)))))
		 )
	(command "UNDO" "E")
	(command "UNDO" "1")
	(foreach lst1 lst
	  (maketext (car lst1) (car lst1) (cadr lst1))
	  )
	) (maketext (cdr (assoc 8 (entget ent))) (cdr (assoc 8 (entget ent))) (_cen ent))
      ))
	
    
  (print)
  )
(defun _cen (v / p1 p2 p u entl ssp lstp pl)
        (vla-getboundingbox  (vlax-ename->vla-object v) 'p1 'p2)
        (setq p (mapcar '* (mapcar '+ (vlax-safearray->list p1) (vlax-safearray->list p2)) '(0.5 0.5 0.5)))
    (setq u (entmakex (list '(0 . "LINE") (cons 10 p)(cons 11 (polar p (/ pi 2) 1)))))
  (setq entl (entlast))
  (vl-cmdf "_-HATCHEDIT" (ssadd v)  "B" "P" "Y" )
  (setq ssp (list))
  (while (setq entl (entnext entl)) (setq ssp (append ssp (list entl))))
  (setq lstp (list))
  (mapcar '(lambda (pl) (setq    p    (vlax-invoke (vlax-ename->vla-object pl) 'IntersectWith (vlax-ename->vla-object u) 2)    )
	     (entdel pl)
	     (while (and (car p) (cadr p) (caddr p))
	     (setq lstp (append lstp (list (list (Car p) (cadr p) (caddr p)) ) ))
	       (setq p (cdddr p)))
	       ) ssp)  
    (entdel u)
  (setq lstp (vl-sort lstp '(lambda (x y) (> (cadr x) (cadr y)))))
  (acet-geom-midpoint (car lstp) (cadr lstp))
)
(defun maketext (lay noidung point / lay point)
(entmakex (list
		(cons 0 "TEXT")
		(cons 100 "AcDbEntity")
		(cons 100 "AcDbText")
		(cons 8 lay)
		(cons 1 noidung)
		(cons 7 (getvar "TEXTSTYLE"))
		(cons 10 point)
		(cons 11 point)
		(cons 40 (getvar "TEXTSIZE"))
		(cons 72 4)
		))
  )

 


<<

Filename: 441348_ii_h2t_h2l.lsp
Tác giả: huunhantvxdts
Bài viết gốc: 441366
Tên lệnh: cse
Text từ Cad qua Excel
6 phút trước, benanphal93 đã nói:

bác chỉnh lại giúp em với...

>>
6 phút trước, benanphal93 đã nói:

bác chỉnh lại giúp em với được không ạ?

Lisp goc đây bạn

(defun c:cse ( / hangdau)
(defun sosanh (e1 e2 / p1 p2)
(setq p1 (car e1)
p2 (car e2)
)
(if (equal (car p1) (car p2) fuzz)
(> (cadr p1) (cadr p2))
(< (car p1) (car p2))
)
)
(setq
ss (ssget '((0 . "TEXT")))
lst (ss2ent ss)
lst (mapcar '(lambda (e) (cons (cdr (assoc 11 (entget e))) (cdr (assoc 1 (entget e))))) lst)
caotext (cdr (assoc 40 (entget (ssname ss 0))))
fuzz (* caotext 1.0)
lst (vl-sort lst 'sosanh)
oldy nil
fn (getfiled "Chon file de save" "" "csv" 1)
fid (open fn "w")
)

(foreach e lst
(if (equal oldy (cadr (car e)) fuzz)
(progn
;(princ "\n" fid)
(princ "," fid)
)
(progn
(if hangdau
(progn
(princ "\n" fid)
;(princ "," fid)
)
(setq hangdau t)
)
)
)
(princ (cdr e) fid)
(setq oldy (cadr (car e)))
)
(close fid)
)

(defun ss2ent (ss / sodt index lstent)
(setq
sodt (if ss
(sslength ss)
0
)
index 0
)
(repeat sodt
(setq ent (ssname ss index)
index (1+ index)
lstent (cons ent lstent)
)
)
(reverse lstent)
)

 


<<

Filename: 441366_cse.lsp
Tác giả: phamngoctukts
Bài viết gốc: 156937
Tên lệnh: ns
Không chạy được SSGET

Nhờ xem hộ tại sao không thể chạy được

 

;========================================================================

>>

Nhờ xem hộ tại sao không thể chạy được

 

;========================================================================

(defun c:ns (/ mau OS om hesodientich hesotb)
(setq chontext "txet")
(while (/= chontext "TEXT")
(while (null (setq es (entsel "\nChon TEXT thu 1:")))
  (princ "\n No object found!")
)
(setq es (car es))
(setq chontext (cdr (assoc 0 (entget es))))
)
(setq ptk1 (cdr (assoc 10 (entget es))))

(setq chontext "txet")
(while (/= chontext "TEXT")
(while (null (setq es (entsel "\nChon TEXT thu 2:")))
  (princ "\n No object found!")
)
(setq es (car es))
(setq chontext (cdr (assoc 0 (entget es))))
)
(setq ptk2 (cdr (assoc 10 (entget es))))
(setq es (cdr (assoc 1 (entget es))))

(setq chontext "txet")
(while (/= chontext "TEXT")
(while (null (setq es (entsel "\nChon TEXT thu 3:")))
  (princ "\n No object found!")
)
(setq es (car es))
(setq chontext (cdr (assoc 0 (entget es))))
)
(setq ptk3 (cdr (assoc 10 (entget es))))

(setq ss1 (ssget "wp" ptk1 ptk2 ptk3 '((0 . "point"))))
(prompt "\n Chuc mot buoi lam viec vui ve.\n")
(princ)
)

;========================================================================

bạn sửa dòng này (setq ss1 (ssget "wp" ptk1 ptk2 ptk3 '((0 . "point"))))

thành (setq ss1 (ssget "wp" (list ptk1 ptk2 ptk3) '((0 . "point"))))

vì WP là đa giác nhận 1 list point


<<

Filename: 156937_ns.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 195904
Tên lệnh: an
Đóng băng layer

Tại sao đoạn code này của em không chạy được?

(defun c:an (/ ob ss)
(
setq ss (ssget "_X" (list(cons 8 "3D")))
  ob (ssname ss...
>>

Tại sao đoạn code này của em không chạy được?

(defun c:an (/ ob ss)
(
setq ss (ssget "_X" (list(cons 8 "3D")))
  ob (ssname ss 0)
)
(command "layfrz" ob)
(princ)
)

Do layer "3D" đang current.


<<

Filename: 195904_an.lsp
Tác giả: hiepttr
Bài viết gốc: 441543
Tên lệnh: msweep
multi-sweep cad 3D

Phải chăng như vầy ? ^^

(defun c:msweep ( / BASEPOINT CNTR DELOBJVAR MESSAGE MPTH PRF SWEEPPATH)
(setq
delobjvar (getvar "delobj");Obtaining DELOBJ variable.
prf (entsel "\nPick profile to sweep: ");Select one object that would be profile of new 3D solid or 3D surface.
BasePoint (getpoint "\n Base point: ")
)
(princ "\nSelect paths to sweep along: ");Select multiple paths.
(setq
mpth (ssget)
cntr...
>>

Phải chăng như vầy ? ^^

(defun c:msweep ( / BASEPOINT CNTR DELOBJVAR MESSAGE MPTH PRF SWEEPPATH)
(setq
delobjvar (getvar "delobj");Obtaining DELOBJ variable.
prf (entsel "\nPick profile to sweep: ");Select one object that would be profile of new 3D solid or 3D surface.
BasePoint (getpoint "\n Base point: ")
)
(princ "\nSelect paths to sweep along: ");Select multiple paths.
(setq
mpth (ssget)
cntr 0
)
(princ (sslength mpth))
(princ " - Paths selected.")
(setvar "delobj" 0);Set DOLOBJ variable to 0 to remain profile and paths.
(while (< cntr (sslength mpth))
(setq
sweeppath (ssname mpth cntr)
)
(command "sweep" prf "" "b" BasePoint sweeppath)
(setq
cntr (+ cntr 1)
)
)
(setq
message " - objects created using sweep command."
)
(princ cntr)
(princ message)
(setvar "delobj" delobjvar);Restoring Your DELOBJ variable.
(princ)
)

 


<<

Filename: 441543_msweep.lsp
Tác giả: hungdlcm
Bài viết gốc: 105250
Tên lệnh: pla
Xem giúp đoạn lisp của mình vẽ pline có nhập chiều dài và góc
Bạn vẽ 2 điểm thì vẽ thế kia được nếu bạn muốn lặp lại để vẽ thì cũng được nhưng như thế kết quả thu được là những đoạn polyline rời dạc . Nên bạn...
>>
Bạn vẽ 2 điểm thì vẽ thế kia được nếu bạn muốn lặp lại để vẽ thì cũng được nhưng như thế kết quả thu được là những đoạn polyline rời dạc . Nên bạn thử dùng lsp này xem. Đáp ứng được các yêu cầu của bạn (Chú ý chỉ thoát và hoàn thành polyline khi chiều dài nhập vào là nil "Tức bạn gõ space hoặc enter", nếu bạn ấn ESC bạn phải làm lại từ đầu).

(defun c:pla (/ CHIEUDAI D2 DX DY GOC TDX TDY QUYDOI)
 (setq d1 (getpoint "\n Nhap diem dau: "))
 (setq dx (car d1) dy (cadr d1))
 (defun quydoi ()
   (setq chieudai (getreal "\n Nhap chieu dai: "))    
   (if (/= chieudai nil)(progn
     (setq goc (getangle "\n Nhap goc: "))
     (setq tdx (* (cos goc) chieudai))
     (setq tdy (* (sin goc) chieudai))
     (setq d2 (list (+ dx tdx) (+ dy tdy) 0.0))
     (setq dx (car d2) dy (cadr d2))
     )
    )
   )
 (quydoi)
 (entmake (list (cons 0 "POLYLINE")
	 (cons 6 "BYLAYER")
	 (cons 8 "net1")
	 (cons 62 1)
	 (cons 10 (list 0.0 0.0 0.0))
	 ))
 (entmake (list (cons 0 "VERTEX")
	 (cons 6 "BYLAYER")
	 (cons 8 "net1")
	 (cons 10 d1)
	 ))    
 (while (/= chieudai nil)
   (entmake (list (cons 0 "VERTEX")
	   (cons 6 "BYLAYER")
	   (cons 8 "net1")
	   (cons 10 d2)
	   ))
   (quydoi)
   )
 (entmake (list (cons 0 "SEQEND")
	 (cons 6 "BYLAYER")
	 (cons 8 "net1")))
 (princ)
 )

Chúc các bạn sức khoẻ và tích cực đóng góp nhiều lsp hơn nữa cho diễn đàn.

 

Cảm ơn bác! Vì mình đang cần viết LISP để vẽ tự động mặt bằng tuyến lưới điện (mình đang làm khâu thiết kế trong ngành Điện). Mà 1 bản vẽ mặt bằng tuyến lưới điện yêu cầu không cần cao nhưng nếu vẽ bằng tay cũng mất khá nhìu thời gian cho nên mình muốn tự động hóa bằng cách chỉ cần nhập khoảng cách và hướng góc mà đường điện sẽ đi. Mình xin mô tả về bản vẽ mặt bằng tuyến lưới điện cơ bản của mình như sau:

 

- Lưới điện cần thể hiện gồm đường dây, trụ điện và các phụ kiện khác như: neo, tiếp địa...

- Đường dây sẽ được thể hiện bằng các đường PLine nối tiếp nhau. Khoảng cách giữa 2 điểm đầu và cuối của một đường PLine chính là khoảng cách giữa 2 trụ điện.

- Trên mỗi điểm đầu và điểm cuối sẽ bố trí lên đó 1 trụ điện và sẽ có thể có thêm neo hoặc tiếp địa.

 

Chỉ đơn giản là thế nhưng mình muốn viết LISP với ý tưởng như sau:

 

- Mình sẽ tạo một Menu Box để người dùng có thể tương tác nhập số liệu trên đó.

- Tạo các Block gồm: trụ điện, neo, tiếp địa...

- Người dùng sẽ nhập vào chiều dài đường dây và góc (để vẽ đường PLine như đã làm ở trên).

- Mỗi lúc vẽ 1 đường PLine, trong Menu Box sẽ có các List Box xổ xuống để người dùng lựa chọn sẽ đặt trụ điện, neo, tiếp địa... vào các điểm nút của mỗi đường PLine (CAD sẽ đặt các block như ta đã tạo ở trên vào các điểm đầu và cuối của đường PLine).

- Tiếp tục quay lại bước nhập vào chiếu dài đường dây và góc ở trên để vẽ tiếp 1 đường PLine nối tiếp vào điểm cuối của đường PLine vừa vẽ và thực hiện các bước tiếp theo cho đến khi giá trị chiều dài đường dây là NIL.

 

Không biết ý tưởng này của mình có khả thi không các Bác nhỉ?

Mình xin up lên hình chụp 1 bản vẽ về mặt bằng tuyến lưới điện mà mình thường vẽ để các Bác dễ hình dung. Trong hình các bác thấy đường dây đi thẳng vì mình chỉ chụp 1 góc bản vẽ thui nhưng thực tế thì đưòng dây sẽ có nhiều góc nữa.

 

THANK CÁC BÁC ĐÃ NHIỆT TÌNH JÚP ĐỠ EM RẤT NHÌU!!!

 

BANVEMAU.png


<<

Filename: 105250_pla.lsp
Tác giả: duy782006
Bài viết gốc: 104305
Tên lệnh: dpl
Xem giúp đoạn lisp của mình vẽ pline có nhập chiều dài và góc
Ý tưởng của mình là viết 1 đoạn lisp để cad vẽ 1 đường PLINE, yêu cầu người dùng nhập vào: điểm đầu của đường thẳng, chiều dài đường thẳng và góc mà...
>>
Ý tưởng của mình là viết 1 đoạn lisp để cad vẽ 1 đường PLINE, yêu cầu người dùng nhập vào: điểm đầu của đường thẳng, chiều dài đường thẳng và góc mà đường thẳng đó hợp với phương mặt phẳng ngang.

 

Ví dụ: đoạn thẳng cần vẽ có chiều dài là 100 và hướng theo 1 góc xéo 45 độ. Bình thường nếu vẽ trong cad phải thao tác như sau:

- gõ lệnh pline

- click chọn điểm đầu tiên (first point)

- sau đó ở dòng lệnh second point nhập vào: @100<45

 

Và dưới đây là đoạn lisp mà mình viết nhưng không cho ra kết quả như mong muốn mà cho kết quả là "UNKNOW DPL..." (lệnh mà mình viết là DPL):

 

(defun c:dpl()
(setq P1 (getpoint "cho diem dau: "))
(setq L (getint "nhap chieu dai: "))
(setq G (getint "nhap so goc: "))
(setq P2 (list @ L < G))
(command "pline" P1 P2 "")
(princ)
)

 

Mình biết chắc là đoạn lisp trên có sai nhưng mình không biết sửa như thế nào! Mình chỉ mới tìm hiểu lisp trên diễn đàn CADVIET thui nên chưa rành lắm. Mong các bác có kinh nghiệm chỉ bảo giủp. Nếu được thì bác nào hướng dẫn cho cách viết đoạn lisp để thực hiện ý tưởng trên.

 

CẢM ƠN CÁC BÁC RẤT RẤT NHIỀU!

 

Sửa thành như này:

 

(defun c:dpl()

(setq P1 (getpoint "cho diem dau: "))

(setq L (getstring 5"nhap chieu dai: "))

(setq G (getstring 5"nhap so goc: "))

(setq P2 (strcat "@" L "<" G))

(command "pline" P1 P2 "")

(princ)

)

 

-Hai bác trên dùng hàm polar.

-Mình dùng hàm strcat cho trực quan bạn dể hiểu.

+Cách dùng hàm:

 

(setq ketqua (strcat "giatri1" bien1 "giatri2" bien2))

Trong đó strcat là hàm ghép.

Giá trị nằm trong "" là giá trị cố định.

Giá trị nằm ngoài "" là biến phải gán giá trị cho nó trước.

Các giá trị muốn ghép cách nhau 1 khoảng trắng.


<<

Filename: 104305_dpl.lsp
Tác giả: NvThanh
Bài viết gốc: 169273
Tên lệnh: test reset
code giới hạn thời gian sử dụng File lisp

Ví dụ lệnh CUA nằm trong file c:\cadviet\lisp\archanwoo.lsp nhưng người sử dụng không biết tên lệnh là CUA. Khi người sử dụng lệnh...

>>

Ví dụ lệnh CUA nằm trong file c:\cadviet\lisp\archanwoo.lsp nhưng người sử dụng không biết tên lệnh là CUA. Khi người sử dụng lệnh TEST, sẽ tương đương như lệnh CUA, nhưng chỉ được 5 lần sử dụng.

Code như sau:

(load "c:/cadviet/lisp/archanwoo.lsp");(defun c:TEST()(c:cua);;; Doc gia tri(setq tmp (getcfg "AppData/CADViet/Count")sl (cond((or (not tmp) (= tmp "")) "5")(t tmp)));;; Kiem tra va thong bao(if (/= sl "0")(progn;;; Thuc thi ma lenh(princ (strcat "\nBan con " sl " lan su dung nua"));;; Luu gia tri(setcfg "AppData/CADViet/Count" (itoa (1- (atoi sl)))))(princ "\nBan da het han su dung!"))(princ))(defun c:RESET();;; Reset lai gia tri(setcfg "AppData/CADViet/Count" "")(princ))

Chào các bác, em xin phép được hỏi lại vấn đề này

Em đã thực hiện như bác Nguyen Hoanh, sau khi có thông báo bạn đã hết hạn sử dụng hưng thực ra các lệnh vẫn thực hiện được, các bác có thể giải thích thêm được không ạ, không biết em sai chỗ nào!

Mong hồi âm !


<<

Filename: 169273_test_reset.lsp
Tác giả: nguyen tuan hung
Bài viết gốc: 136116
Tên lệnh: clear1
Nhờ viết lisp dọn mặt bằng siêu tốc

Bạn thêm 1 dòng thôi là được. Tối r mình ngại upload quá, bạn chịu khó chép code nhé

 

(defun c:clear1()
;free...
>>

Bạn thêm 1 dòng thôi là được. Tối r mình ngại upload quá, bạn chịu khó chép code nhé

 

(defun c:clear1()
;free lisp from CADviet.com @ketxu
(vl-load-com)
(command "undo" "be")
(command "change" (ssget "X") "" "p" "c" "8" "")
(if (ssget "x" '((0 . "INSERT")(66 . 1)))
 (progn
	(setq adoc (vla-get-activedocument (vlax-get-acad-object))
		  ss (vla-get-activeselectionset adoc)
	)
    (vlax-for block (vla-get-blocks adoc)	
		(if (not (wcmatch (strcase (vla-get-name block) t) "*_space*")) 
			(vlax-for   ent block 
				(progn			
				(vla-put-color ent "8")					
				)    
			) 
		) 
	)
	(vlax-for attblock ss
		(setq atts (vlax-invoke attblock 'getattributes))
		(foreach att atts
			(vla-put-color att 8)				
		)
	)   
  );end progn
 );end if
(acet-sysvar-set (list "dimclrt" 8 "dimclre" 8 "dimclrd" 8 "cmdecho" 0 "INSUNITS" 4 "INSUNITSDEFSOURCE" 4 "INSUNITSDEFTARGET" 4)) 
(command "dim1" "update" (ssget "X" '((0 . "Leader"))) "")
(command "-layer" "c" "8" "*" "")	
(vla-regen adoc acactiveviewport) 
(command "-purge" "a" "" "N")
(command "undo" "e") 
(princ))

chuẩn không cần chỉnh.

thank bác nhiều.


<<

Filename: 136116_clear1.lsp
Tác giả: hhhhgggg
Bài viết gốc: 71342
Tên lệnh: tdn
Lisp ghi tọa độ rất hay mà bị lỗi!
Hi vọng bạn đã hài lòng với code này.

- Cho phép lựa chọn ghi tên điểm tọa độ tự động (giống lisp trước) hay thủ công (Pick chuột vào text có sẵn - tên cọc...

>>
Hi vọng bạn đã hài lòng với code này.

- Cho phép lựa chọn ghi tên điểm tọa độ tự động (giống lisp trước) hay thủ công (Pick chuột vào text có sẵn - tên cọc trên tuyến chẳng hạn)

- Cho phép ghi text tọa độ theo một góc xiên bất kỳ

- Cho phép lựa chọn có xuất bảng tọa độ hay không.

(prompt"\n - THONG KE TOA DO by Thaistreetz - huuthais@yahoo.com\n")
----------------------------------------------
(defun C:tdn ()
(setvar "cmdecho" 0 )
(command "Undo" "Begin")  
(setq om (getvar "osmode"))
(if (not h) (setq h 1))
(setq caot1 (getreal (strcat "\nCao text < " (rtos h 2 2) " >:")))
(if caot1 (setq h caot1))
(setq tapx '() tapy '() stt '())

(setq bit1 (cond (bit1) ("Yes")))
(initget "Yes No")
(setq	Tmp1 (strcat "\nTu dong ghi ten nut?  <" bit1 ">: ")
bit1 (cond ((getkword Tmp1)) (bit1)))
(if (eq bit1 "Yes")
(progn 
(setq ten (getstring "\nTen Nut:"))
(if (not i) (setq i 1))
(setq i1  (getreal (strcat"\nSTT cua nut bat dau < " (rtos i 2 0) " >: ")))
(if i1 (setq i i1))

(setvar "osmode" 125)
(setq lacol (getvar "CEColor") k (- i 1))
(While
(setq D1 (getpoint (strcat"\nPick diem thu "(rtos (+ k 1) 2 0)"")))
(Progn
 (setvar "osmode" 0)
 (setq DX (getpoint (strcat"\nDiem dat text thu "(rtos (+ k 1) 2 0)"") D1)
DY (getpoint (strcat"\nHuong goc nghieng cua text "(rtos (+ k 1) 2 0)"") Dx)
angr (angle Dx Dy)
angd (/ (* 180 angr) pi)
       x   (rtos (car D1) 2 4)
       y   (rtos (cadr D1) 2 4)
TX (strcat "X:"(rtos (Car D1) 2 4))
TY (strcat "Y:"(rtos (Cadr D1) 2 4))
      tapx (append tapx (list x))
      tapy (append tapy (list y))
k   (+ 1 k)
       N   (strcat ten (rtos k 2 0))
       stt (append stt (list N))
 );setq
 (if (>= (car DY) (car DX)) 
 (progn
(setq D2 (polar Dx angr (* 0.7 h)))  	   
   	(command "text" "BL" D2 h angd tX)
 	(setq   TB  (textbox (entget(entlast)))
   		LC  (car TB)
  		RC  (cadr TB)
   		di  (distance LC RC)
	PT3 (polar D2 angr (+ di (* 0.4 h)))
	pt4 (polar D2 (- angr (* pi 0.5)) (* 1.35 h))
	pt5 (polar pt4 angr di)		
	C   (polar PT3 0 (* 1.5 h))
);setq
(command "text" "F" PT4 PT5 h ty
          	 "pline" D1 DX PT3 ""
          	 "circle" (polar PT3 angr (* 1.5 h)) (* 1.5 h)
          	 "text" "m" (polar PT3 angr (* 1.5 h)) h angd N 
          	 "CECOLOR" 8
	 "circle" (polar PT3 angr (* 1.5 h)) (* 1.35 h)
);command
(setvar "CECOLOR" lacol)
 );progn
 );if
 (if (< (car DY) (car DX)) 
(progn
(setq D2 (polar Dx angr (* 0.7 h)))	   
 	(command "text" "BR" D2 h (+ angd 180) tx)
 	(setq   TB  (textbox (entget(entlast)))
	LC  (car TB)
	RC  (cadr TB)
	di  (distance LC RC)
	PT3 (polar D2 angr (+ di (* 0.4 h)))
	pt4 (polar D2 (+ angr (* pi 0.5)) (* 1.35 h))
	pt5 (polar pt4 angr di)		
	C   (polar PT3 0 (* 1.5 h))
);setq
(command "text" "F" PT5 PT4 h TY
	"pline" D1 DX PT3 ""
	"circle" (polar PT3 angr (* 1.5 h)) (* 1.5 h)
	"text" "m" (polar PT3 angr (* 1.5 h)) h (+ angd 180) N 
	"CECOLOR" 8
	"circle" (polar PT3 angr (* 1.5 h)) (* 1.35 h)
);command
(setvar "CECOLOR" lacol)
);progn
 );if
);progn
(setvar "osmode" 125)
);while
(setq i (+ k 1))
);progn
);if
(if (eq bit1 "No")
(progn 
(setvar "osmode" 125)
(setq lacol (getvar "CEColor") i 1 k (- i 1))
(While
(setq D1 (getpoint (strcat"\nPick diem thu "(rtos (+ k 1) 2 0)"")))
(Progn
(setvar "osmode" 0)
 (progn
 (setq LOOP T)
 (while (= LOOP T)
 (while (null (setq ten (nentsel "\nChon mot text lam ten nut: ")))
(princ "\nChua tim thay doi tuong la text, chon lai !"));while
 (setq Source_text (entget (car ten)))
 (if	(or (= (cdr (assoc '0 Source_text)) "TEXT")
    (= (cdr (assoc '0 Source_text)) "MTEXT")
    (= (cdr (assoc '0 Source_text)) "ATTRIB"));or
(progn
(setq N (cdr (assoc 1 Source_text)))
(setq LOOP nil));progn
(progn
(princ "Phai chon mot text lam ten nut !")
(setq LOOP T));progn
 )if
 );while
 );progn
(setq 	DX (getpoint (strcat"\nDiem dat text cua nut "N"") D1)
DY (getpoint (strcat"\nHuong goc nghieng cua text") Dx)
angr (angle Dx Dy))	
(setq	angd (/ (* 180 angr) pi)
       x   (rtos (car D1) 2 4)
       y   (rtos (cadr D1) 2 4)
TX (strcat "X:"(rtos (Car D1) 2 4))
TY (strcat "Y:"(rtos (Cadr D1) 2 4))
      tapx (append tapx (list x))
      tapy (append tapy (list y))
k   (+ 1 k)
       stt (append stt (list N))
);setq
 (if (>= (car DY) (car DX)) 
(progn
(setq D2 (polar Dx angr (* 0.7 h)))  	   
   	(command "text" "BL" D2 h angd tX)
 	(setq   TB  (textbox (entget(entlast)))
   		LC  (car TB)
  		RC  (cadr TB)
   		di  (distance LC RC)
	PT3 (polar D2 angr (+ di (* 0.4 h)))
	pt4 (polar D2 (- angr (* pi 0.5)) (* 1.35 h))
	pt5 (polar pt4 angr di)		
	C   (polar PT3 0 (* 1.5 h))
);setq
(command "text" "F" PT4 PT5 h ty
          	 "pline" D1 DX PT3 ""
          	 "circle" (polar PT3 angr (* 1.5 h)) (* 1.5 h)
          	 "text" "m" (polar PT3 angr (* 1.5 h)) h angd N 
          	 "CECOLOR" 8
	 "circle" (polar PT3 angr (* 1.5 h)) (* 1.35 h)
);command
(setvar "CECOLOR" lacol)
);progn
 );if
 (if (< (car DY) (car DX)) 
(progn
(setq D2 (polar Dx angr (* 0.7 h)))	   
 	(command "text" "BR" D2 h (+ angd 180) tx)
 	(setq   TB  (textbox (entget(entlast)))
	LC  (car TB)
	RC  (cadr TB)
	di  (distance LC RC)
	PT3 (polar D2 angr (+ di (* 0.4 h)))
	pt4 (polar D2 (+ angr (* pi 0.5)) (* 1.35 h))
	pt5 (polar pt4 angr di)		
	C   (polar PT3 0 (* 1.5 h))
);setq
(command "text" "F" PT5 PT4 h TY
	"pline" D1 DX PT3 ""
	"circle" (polar PT3 angr (* 1.5 h)) (* 1.5 h)
	"text" "m" (polar PT3 angr (* 1.5 h)) h (+ angd 180) N 
	"CECOLOR" 8
	"circle" (polar PT3 angr (* 1.5 h)) (* 1.35 h)
);command
(setvar "CECOLOR" lacol)
);progn
 );if
);progn
(setvar "osmode" 125)
);while
(setq i (+ k 1))
);progn 
);if
(setq bit (cond (bit) ("Yes")))
(initget "Yes No")
(setq	Tmp (strcat "\nXuât Bang Toa Ðô?  <" bit ">: ")
bit (cond ((getkword Tmp)) (bit)))
(if (eq bit "Yes")
(progn
(setq	di (- di (* 0.4 h))
kc (* 2 di)
       PT (getpoint"\nVi tri dat bang")
   	PTC (list (+ (* 2 kc) (- di h h h h) (car PT)) (cadr PT))  
     	p1 (list (car PT) (+ (cadr PT)(* 2 h)))
     	p2 (list (car PTC) (+ (cadr PTC)(* 2 h)))
     	p3 (list (car p1) (+ (cadr p1)(* 2 h)))
     	p4 (list (car p2) (+ (cadr p2)(* 2 h)))
    	PTD (list (+ (/ di 2) (car PT))  (+ h (cadr PT)))
    	PTX (list (+ di (/ di 2) (- 0 h) (car PTD)) (cadr PTD))
    	PTY (list (+ kc (- h h h h) (car PTX)) (cadr PTX))
     	p11 (list (+ (/ di 2) (car p1))  (+ (* 1.1 h) (cadr p1)))
     	p22 (list (+ di (/ di 2) (- 0 h) (car p11)) (- (cadr p11) (* 0.1 h)))
     	p33 (list (+ kc (- h h h h) (car p22)) (cadr p22))
     	L1 (list (+ di (car p3))(cadr p3))
     	L2 (list (+ kc (- 0 h h)(car L1))(cadr L1))
PTB (list (+ (- (* 2 h)) (* 0.5 (+ (* 2 kc) di)) (car PT)) (+ (cadr P3) (* 1.8 h)))
    	n (length tapx)
    	k 0
);setq
(setvar "osmode" 0)
(command "CECOLOR" 3 "line" p1 p2 "" "line" p3 p4 "" "CECOLOR" 2
      	"text" "m" p11 h 0 "Tªn Nót" 
      	"text" "m" p22 h 0 "Täa ®é X" 
      	"text" "m" p33 h 0 "Täa ®é Y"
      	"text" "m" pTB (* 1.3 h) 0 "%%UB¶ng thèng kª täa ®é nót")    
(while (< k n) 
(setq xx (nth k tapx) yy (nth k tapy) tstt(nth k stt))
(command "CECOLOR" 2
 "text" "m" PTD h 0 tstt 
        "text" "m" PTX h 0 xx 
        "text" "m" PTY h 0 yy
 "CECOLOR" 3 
        "line" PT PTC "")    
(setq 	PT (list (car PT) (- (cadr PT)(* 2 h)))
PTC (list (+ (* 2 kc) (- di h h h h) (car PT)) (cadr PT))
PTD (list (+ (/ di 2) (car PT))  (+ h (cadr PT)))
PTX (list (+ di (/ di 2) (- 0 h) (car PTD)) (cadr PTD))
PTY (list (+ kc (- h h h h) (car PTX)) (cadr PTX))
k (+ 1 k));setq
);while
(if (= k n)
(setq 	PT (list (car PT) (+ (cadr PT)(* 2 h)))
PTC (list (+ (* 2 kc) (- di h h h h) (car PT)) (cadr PT))
L11 (list (+ di (car PT))(cadr PT))
L22 (list (+ kc (- 0 h h) (car L11))(cadr L11))
);setq
);if
(command "CECOLOR" 3
"line" p3 PT ""
"line" p4 PTC ""
"line" L1 L11 ""
"line" L2 L22 "")
);progn
);if
(setvar "CECOLOR" lacol)
(setvar "osmode" om)
(prompt"\n by Thaistreetz - huuthais@yahoo.com\n")
(command "Undo" "End")
(setvar "cmdecho" 1)
(princ)
);DONG toa do

ok ! Thật tuyệt vời bạn à . Nhưng mình góp ý là bạn nên thêm dòng lệnh này vào đầu tiên :

(command "layer" "N" "caodococ" "S" "caodococ" "color" 3 "" "")


<<

Filename: 71342_tdn.lsp
Tác giả: mrphuocvie
Bài viết gốc: 394026
Tên lệnh: mc
Chuyển Dtext Thành Mtext Và Setp Justify Cho Mtext Vừa Chuyển

 

Quick code.

- Đánh dấu entlast e cuối cùng trước khi thực hiện lệnh txt2mtxt

- Sau khi thực hiện lệnh txt2mtxt thì tìm...

>>

 

Quick code.

- Đánh dấu entlast e cuối cùng trước khi thực hiện lệnh txt2mtxt

- Sau khi thực hiện lệnh txt2mtxt thì tìm tất cả các entity mới sinh bằng hàm _getNews (entnext từ e đến hết)

- Put align point của Mtext mới thành 5 (Middle center)

- À mình sửa dòng command để biến tất cả thành 1 Mtext, nếu bạn thích biến từng text một thì giữ nguyên dòng command nhé

(defun c:mc(/ ss e _getNews)
	;Quick collect after e :
	(defun _getNews (e / l)
		(cond (e (while (setq e (entnext e))(setq l (cons e l)))))
	)
	(setq ss (ssget '((0 . "*TEXT"))) e (entlast))   
    (command "_txt2mtxt" ss "")	
	(foreach e (mapcar 'vlax-ename->vla-object  (_getNews e))
		(vla-put-AttachmentPoint e 5)
	)
)

Thật làm phiền anh quá! Nhờ a sửa lại giúp. Em muốn chuyển từng text một.


<<

Filename: 394026_mc.lsp
Tác giả: lohado
Bài viết gốc: 405436
Tên lệnh: a1
Lisp Thay Đổi Giá Trị Att Theo Điều Kiện

 

gửi bạn. lệnh là a1

Bạn xem rồi sửa lại các điều kiện biên cho đúng (bản vẽ điều kiện <, yêu cầu trên 4r...

>>

 

gửi bạn. lệnh là a1

Bạn xem rồi sửa lại các điều kiện biên cho đúng (bản vẽ điều kiện <, yêu cầu trên 4r lại là <= )

(defun c:a1( / k CV:ss-to-list)
  (defun CV:ss-to-list (ss vla / n e l)
    (if	ss
      (progn
	(setq n (sslength ss))
	(while (setq e (ssname ss (setq n (1- n))))
	  (setq	l (cons	(if vla
			  (vlax-ename->vla-object e)
			  e
			)
			l
		  )
	  )
	)
      )
    )
  )
  (command ".undo" "be")
  (mapcar '(lambda (y)
	      (mapcar '(lambda (x)
			 (if (and (= (vla-get-tagstring x) "E")
				  (distof(setq k (vla-get-textstring x)))
				  )
			   (progn
			     (setq k (atof k))
			     (cond
			       ((<= k 40)(vla-put-textstring x "F07"))
			       ((<= k 95)(vla-put-textstring x "F12"))
			       ((<= k 150)(vla-put-textstring x "F18"))
			       ((<= k 200)(vla-put-textstring x "F23"))
			       )
			     )
			   )
			 
			 )(vlax-invoke y 'GetAttributes))
	      )
	   (CV:ss-to-list (SSGET (list (cons 0  "INSERT")(cons 2 "HABA")(cons 66 1))) t)
   )
  (command ".undo" "en")
  (princ)
  )

Cảm ơn bác rất nhiều.bác có thể ghi chú từng dòng trong lisp giúp e xem nó có ý nghĩa ntn đc ko?e đang mày mò về lisp,nên muốn hiểu mấy cái thực tế như thế này.hì


<<

Filename: 405436_a1.lsp
Tác giả: hai_1401
Bài viết gốc: 76416
Tên lệnh: m um
Lisp đưa đối tượng về vị trí cũ sau khi move?
Chào bạn thiep và hai1401

Tue_NV có ý như thế này :

 

1. Trong ACAD bạn đặt lệnh tắt của lệnh MoveM (trong file...

>>
Chào bạn thiep và hai1401

Tue_NV có ý như thế này :

 

1. Trong ACAD bạn đặt lệnh tắt của lệnh MoveM (trong file acad.pgp) -> Nay mình xây dựng lệnh M của Lisp có tính năng giống y như lệnh MOVE của CAD (lần này thì giống lệnh MOVE của CAD y như 2 giọt nước đấy bạn Hai1401 à)

-> Như vậy bạn sử dụng lệnh M (để MOVE) nhé

 

2. Tue_NV xây dựng lại Lisp UM (unmove) -> có chức năng đưa đối tượng về vị trí cũ sau khi move

Lisp này xây dựng dựa trên cơ sở là : khi ta move thì tên (ename) của Entity không đổi (nội dung về điểm chèn thay đổi nhưng tên (ename) thì không đổi trước và sau khi Move -> dựa vào đặc điểm này ta có thể UM (unmove) đối tượng làm nhiều lần trên ý tưởng của Tue_NV :

 

Tức là ta UM (unmove cho đến khi nào) mà số phần tử trong tập hợp chọn SS2 bằng 0 thì không thể UM được nữa -> Cái này theo đúng như ý của User. Hơn nữa, khi Un (unmove) các đối tượng không bị move nhầm thì các đối tượng này không có tác dụng gì cả (theo đúng ý của user luôn) :cry:

Các bạn hãy thử Code này và cho biết ý kiến nhé :

(defun c:m()
(setq ss (ssget))
(command "line" '(0 0 0) '(1 1 1) "")
(setq ss (ssadd (entlast) ss))

(command "move" ss "")
(while (< 0 (getvar "CMDACTIVE")) (command pause))

(setq dc (cdr(assoc 10 (entget (entlast)))))
(setq ss (ssdel (entlast) ss))
(entdel (entlast))
(setq kc (distance '(0 0 0) dc))
(setq ang (angle dc '(0 0 0) ))
(princ)
)
;
(defun c:um(/ ssg po lis)
(prompt "\n Chon doi tuong Move nham :")
(setq ssg (ssget) i 0 j 0)

(while (< i (sslength ss))
(setq lis (append lis (list (ssname ss i))))
(setq i (1+ i))
)

(while (< j (sslength ssg))
(if (/= (member (ssname ssg j) lis) nil) 
(progn
  (setq ss (ssdel (ssname ssg j) ss))
  (setq po (polar '(0 0 0) ang kc))
  (setq ssg (ssadd (ssname ssg j) ssg))
)
(princ "\n Doi tuong chon khong phai Move nham")
)
(setq j (1+ j))
)
(command "move" ssg "" '(0 0 0) po)
(princ)
)

Anh Tuệ ơi, em mới dùng qua thôi nhưng thấy lisp anh viết đã đúng hoàn toàn với ý của em, thật là tuyệt vời, chưa thấy có lỗi nào hoặc bất cập nào xảy đến cả. Vô cùng cảm ơn anh đã quan tâm viết lisp này giúp em :cry: :bigsmile: :bigsmile:


<<

Filename: 76416_m_um.lsp
Tác giả: nataca
Bài viết gốc: 76721
Tên lệnh: mm mn
Lisp đưa đối tượng về vị trí cũ sau khi move?
Ssg có chiêu này, bạn dùng thử xem có hợp ý không?

;;;--------------------------------------------------
(defun C:MM()
(command "move" (ssget) "" (setq p1 (getpoint))...
>>
Ssg có chiêu này, bạn dùng thử xem có hợp ý không?

;;;--------------------------------------------------
(defun C:MM()
(command "move" (ssget) "" (setq p1 (getpoint)) pause)
(setq p2 (getvar "lastpoint"))
(princ)
)
;;;--------------------------------------------------
(defun C:MN( )
(command "move" (ssget) "" p2 p1)
(princ)
)
;;;--------------------------------------------------

- Lệnh MM: hoạt động không khác gì lệnh move (M) của Acad

- Lệnh MN: chọn những chú nào bị nhầm, trả về nguyên quán! Lưu ý rằng, nó chỉ có tác dụng đúng với các đối tượng được move bởi MM, và phải thực hiện liền ngay sau đó. Để lâu ssg không dám chắc là nó có quay về chỗ cũ không, hay là lang thang đâu đó không biết!

- Nếu bạn thường xuyên bị... nhầm thì đổi luôn Move của Acad thành MM

Chiêu này của bác hơi bị lợi hại . Từ khoá của chiêu này là biến lastpoint :bigsmile:


<<

Filename: 76721_mm_mn.lsp
Tác giả: dangky2510
Bài viết gốc: 396998
Tên lệnh: gpmb
LISP GPMB

Bạn thử lại code này nhé:

(DEFUN C:gpmb(/ TH SS Index PtIns Ent PtM PtL PtR SSL SSR LenSSL LenSSR...
>>

Bạn thử lại code này nhé:

(DEFUN C:gpmb(/ TH SS Index PtIns Ent PtM PtL PtR SSL SSR LenSSL LenSSR LstPtXL LstPtXR
		  XL XR YL YR I PtDimLine) 
(ACET-ERROR-INIT (LIST (LIST "OSMODE" 0 "CLAYER" "DIM" "CMDECHO" 0) T))
(setq TH (getstring "\nChoòn trýõÌng hõòp: "))
(setq ss (ssget "X" '((0 . "INSERT") (2 . "Dau_co")))
	  Index 0)
  (while (setq Ent (ssname ss Index))
	(setq PtIns (cdr (assoc 10 (entget ent)))	
	  PtM (polar PtIns (/ pi 2) -10))
	(command "Zoom" "c" PtM 25)
	(setq PtL (polar PtM pi 20);Dieu chinh cho nay cho phu hop
	  PtR (polar PtM 0 20)
	  PtM (polar PtM (/ pi 2) 1)
	  SSL (ssget "c" PtM PtL '((0 . "LINE") (8 . "ENTTNTHIETKE")))
	  SSR (ssget "c" PtM PtR '((0 . "LINE") (8 . "ENTTNTHIETKE")))
	  Index (1+ Index))
	(setq LenSSL (sslength SSL)
	  I 0
	  LstPtXL Nil)
	(while (< I LenSSL)
	  (Setq LstPtXL (append LstPtXL (list(cadr (assoc 10 (entget (ssname SSL I)))))) I (1+ I))
	)
	(Setq XL (nth 0 (vl-sort LstPtXL '<)))
	(setq LenSSR (sslength SSR)
	  I 0
	  LstPtXR Nil)
	(while (< I LenSSR)
	  (Setq LstPtXR (append LstPtXR (list(cadr (assoc 10 (entget (ssname SSR I)))))) I (1+ I))
	)
	(Setq XR (nth 0 (vl-sort LstPtXR '>)))
	(setq I 0)
	(while (< I LenSSL)
	  (if (= (cadr (assoc 10 (entget (ssname SSL I)))) XL)
	(setq YL  (caddr (assoc 10 (entget (ssname SSL I)))))
	  )
	  (setq I (1+ I))
	)
	(setq I 0)
	(while (< I LenSSR)
	  (if (= (cadr (assoc 10 (entget (ssname SSR I)))) XR)
	(setq YR  (caddr (assoc 10 (entget (ssname SSR I)))))
	  )
	  (setq I (1+ I))
	)	
	(setq PtL (polar (list XL YL 0.0) pi 1.5))
	(if (= TH "1")
	  (setq PtR (polar (list XR YR 0.0) 0 1.5))
	  (setq PtR (list XR YR 0.0))
	)
	(command "Insert" "GPMB" PtL "" "" "" )
	(command "Insert" "GPMB" PtR "" "" "")
	(command "mirror" "l" "" PtR (polar PtR (/ pi 2) 5) "y")	
	(setq PtM (polar PtM (/ pi 2) 5)
	  PtL (list (car PtL) (cadr PtM) 0.0)
	  PtR (list (car PtR) (cadr PtM) 0.0) 
	  PtDimLine (polar PtM (/ Pi 2) 2))
	(command "_dimlinear" PtL PtM PtDimLine)
	(command "_dimlinear" PtM PtR PtDimLine)  
  )
  (command "zoom" "e")
  (acet-error-restore)
)
Có thay đổi: Bạn chỉ cần tạo một khối mốc lộ giới Trái với tên GPMB, tôi dx bổ sung chức năng Mirror để chuyển nó sang bên phải.

Lưu ý: - Điểm chèn (Insert Point) của Block đặt trong Block đừng để xa tít mù tắp như cái Block GPMB ban đầu cảu bạn. Vì rất khó xác định điểm chèn Block trên mặt đất tự nhiên nên tôi chỉ xác định được cao độ của chân đường đắp hoặc đỉnh đường đào thôi.

- Vùng chọn các đối tượng tôi tính từ tâm ra mỗi phía 20m nên nếu các trắc ngang có khoảng cách từ tim đến chân đường đắp hoặc đỉnh đường đào lớn hơn 20m thì sẽ ko xác định được, nếu có chỗ nào lớn hơn thì chuyển riêng trắc đó vào một file và chỉnh các dòng như chú thích trong code cho phù hợp, không chỉnh tổng thể vì sẽ dễ bị chọn nhầm sang các trắc khác.

 

Mình đang dùng lisp này của bạn, các trắc ngang khác không sao đến mấy trắc ngang mình up dưới đây lại lỗi. Bro nào tiện đường đi qua xem giúp mình với nhé

Thank!

Lisp: http://www.cadviet.com/upfiles/5/64560_gpmb.lsp

DWG: http://www.cadviet.com/upfiles/5/64560_test_1.dwg


<<

Filename: 396998_gpmb.lsp
Tác giả: proconeng86
Bài viết gốc: 321475
Tên lệnh: dmd
sửa lisp đổi màu đối tượng

 

- nhoc thì ko rành về dim, viết lsp đơn giản nhưng cũng hơi thủ công bạn xem thừ ^^

p/s: up hộ bạn ^^

>>

 

- nhoc thì ko rành về dim, viết lsp đơn giản nhưng cũng hơi thủ công bạn xem thừ ^^

p/s: up hộ bạn ^^

(defun c:dmd(/ mau kdim)
(vl-load-com)
(setvar 'cmdecho 0)
(setq mau (getint "\nNh\U+1EADp m\U+00E3 m\U+00E0u mu\U+1ED1n \U+0111\U+1ED5i:"))
(setq kdim (entget (car (nentsel "\nCh\U+1ECDn \U+0111\U+00FAng text dim:"))))
(entmod (subst (cons 62 mau) (assoc 62 kdim) kdim))
(vl-cmdf "regen")
(setvar 'cmdecho 1)
(princ)
)

 

 

Lisp của ban cũng rất hay nhưng sao mình có cảm giác nó làm máy mình giật giật nhỉ, máy mình yếu quá chăng.

Bạn có thể ghép vào lisp trên của mình được không vì cùng 1 lisp áp dụng cho nhiều đối tượng sẽ hay hơn, đỡ phải nhớ nhiểu, ngoài ra lisp trên của mình nó hiện lên được cái bảng màu sẽ trực quan chọn màu hơn

Mình cám ơn nhiều


<<

Filename: 321475_dmd.lsp
Tác giả: Tue_NV
Bài viết gốc: 193890
Tên lệnh: ha chon
Lisp lọc các số sau chữ L, rồi tính tổng.

Thử thêm cái này cho vui luôn:

(defun C:HA( / dk1 dk2 entlst kq str len)
(setq dk1 (strcat "D" (itoa (getint "\nNhap duong...
>>

Thử thêm cái này cho vui luôn:

(defun C:HA( / dk1 dk2 entlst kq str len)
(setq dk1 (strcat "D" (itoa (getint "\nNhap duong kinh muon thong ke: "))))
(setq entlst (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "TEXT") (1 . "D*#*,L#*")))))))
(setq kq 0)
(foreach ent entlst
 (setq str (cdr (assoc 1 (entget ent))))
 (setq dk2 (trai_str str ",") len (phai_str (phai_str str ",") "L"))
 (if (equal dk1 dk2)
  (setq kq (+ kq (atof len)))))
(princ (strcat "Tong chieu dai ung voi " dk1 " la: " (rtos kq 2 2)))
(princ))
;----- LÊy phÇn bªn Tr¸i str1 cña str (tr¶ vÒ chuçi bªn tr¸i hoÆc nil).
(defun TRAI_STR(str str1) (if (acet-str-find str1 str) (substr str 1 (- (acet-str-find str1 str) 1))))
;----- LÊy phÇn bªn Ph¶i str1 cña str (tr¶ vÒ chuçi bªn ph¶i hoÆc nil).
(defun PHAI_STR(str str1) (if (TRAI_STR str str1) (substr str (+ 1 (strlen str1) (strlen (TRAI_STR str str1))))))
(defun c:chon() (cadr (sssetfirst nil (ssget '((8 . "0"))))))

Dấu , là kí tự đặc biệt.

Trong trường hợp bạn viết (ssget '((0 . "TEXT") (1 . "D*#*,L#*"))) thì :

String : D400,L40 và string D400 cả string L40 đều được chọn

Nếu bạn viết như thế này (ssget '((0 . "TEXT") (1 . "D*#*',L#*"))) thì chỉ có string D400,L40 được chọn mà thôi.

Thêm kí tự ' trước kí tự ,

 

Nếu không khắc phục chổ này thì User chọn "lộn" thì code lisp lỗi ngay.


<<

Filename: 193890_ha_chon.lsp
Tác giả: 790312
Bài viết gốc: 400040
Tên lệnh: tt%C2%A0
Nhờ Chỉnh Lisp Cắt Thép Dầm Momen

Theo bài 1:

(defun c:tt  (/ modelSpace lay bv cd pt1 temp create-layer tiep_theo_qm kcach_dau Make-Line...
>>

Theo bài 1:

(defun c:tt  (/ modelSpace lay bv cd pt1 temp create-layer tiep_theo_qm kcach_dau Make-Line laythep)
 (defun kcach_dau  (mm-am len fac / del l-0)
  (if (eq mm-am t)
   (progn (setq l-0 (/ len 4)
                del (rem l-0 50))
          (if (> del 0)
           (setq l-0 (- l-0 del (/ -50 fac)))))
   (progn (setq l-0 (/ len 6)
                del (rem l-0 (/ 50 fac)))
          (if (> del 0)
           (setq l-0 (- l-0 del)))))
  l-0)
 (defun create-layer  (name color lineWeight)
  (entmakex (list '(0 . "LAYER")
                  (cons 100 "AcDbSymbolTableRecord")
                  (cons 100 "AcDbLayerTableRecord")
                  (cons 2 name)
                  (cons 70 0)
                  (cons 62 color)
                  (cons 6 "Continuous")
                  (cons 370 (fix (* 100 lineWeight))))))
 (defun Make-Line  (p1 p2 lay)
  (entmakex (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2) (cons 8 lay))))
 ;;-------------------
 (defun tiep_theo_qm  (/ cdim pt2 kc pd1 pd2 pd3 pa1 pa2 pa3 ptt)
  (setq cdim (* (getvar "DIMTXT") (getvar "DIMSCALE")))
  (setq pt2 (getpoint "\nNhap toa do diem cuoi duoi dam:" pt1))
  (setq kc (distance pt1 pt2))
  ;; Momen duong
  (setq pd1 (polar pt1 (* pi 0) (kcach_dau nil kc 1))
        pd2 (polar pt2 (* pi 1) (kcach_dau nil kc 1))
        pd3 (polar pt1 (* pi 1.5) (* cdim 4)))
  (setvar "CLAYER" "DIM")
  (mapcar (function (lambda (x y z) (vla-adddimaligned msp x y z)))
          (mapcar 'vlax-3d-point (list pt1 pd1 pd2))
          (mapcar 'vlax-3d-point (list pd1 pd2 pt2))
          (mapcar 'vlax-3d-point (list pd3 pd3 pd3)))
  (Make-Line (setq ptt (polar pd1 (* pi 0.5) bv)) (polar ptt (* pi 0.25) bv) laythep)
  (Make-Line (setq ptt (polar pd2 (* pi 0.5) bv)) (polar ptt (* pi 0.75) bv) laythep)
  ;; Momen am
  (setq pt1 (polar pt1 (* pi 0.5) cd)
        pt2 (polar pt2 (* pi 0.5) cd)
        pa1 (polar pt1 (* pi 0) (kcach_dau t kc 1))
        pa2 (polar pt2 (* pi 1) (kcach_dau t kc 1))
        pa3 (polar pt1 (* pi 0.5) (* cdim 4)))
  (mapcar (function (lambda (x y z) (vla-adddimaligned msp x y z)))
          (mapcar 'vlax-3d-point (list pt1 pa1 pa2))
          (mapcar 'vlax-3d-point (list pa1 pa2 pt2))
          (mapcar 'vlax-3d-point (list pa3 pa3 pa3)))
  (Make-Line (setq ptt (polar pa1 (* pi 1.5) bv)) (polar ptt (* pi 1.25) bv) laythep)
  (Make-Line (setq ptt (polar pa2 (* pi 1.5) bv)) (polar ptt (* pi 1.75) bv) laythep)
  (setvar "CLAYER" lay))
 ;; MAIN
 (vl-load-com)
 (setq msp     (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))
       lay     (getvar "clayer")
       laythep "THEPDOC")
 (create-layer laythep 1 0.4)
 (create-layer "DIM" 8 -3)
 (or (and cd (or (= (type cd) 'int) (= (type cd) 'real))) (setq cd 400))
 (or (and bv (or (= (type bv) 'int) (= (type bv) 'real))) (setq bv 20))
 (setq temp "T")
 (while (= temp "T")
  (initget 0 "Cao Bao")
  (setq pt1 (getpoint
             (strcat "\nCaodam <" (rtos cd 2 0) ">/Baove <" (rtos bv 2 0) ">. Nhap toa do diem dau duoi dam: ")))
  (cond ((= pt1 "Cao")
         (setq cd (cond ((getdist (strcat "\nChieu cao dam <" (rtos cd 2 0) ">:")))
                        (cd))))
        ((= pt1 "Bao")
         (setq bv (cond ((getdist (strcat "\nChieu day lop betong bao ve <" (rtos bv 2 0) ">:")))
                        (bv))))
        ((= pt1 nil) (setq temp nil))
        (t (tiep_theo_qm))))
 (princ))

Cái đó là có dim trước, rồi chia dim khác với topic này.

b2HgAau.png

Bác viết giùm mình cái code nó đơn giản hơn của thớt:

1. Đánh lệnh

2. Pick điểm 1, điểm 2, điểm 3, điểm 4.

3. Nhập chiều cao dầm

4. Nhập lớp bảo vệ

Sẽ được kết quả như trong hình. Chỗ khoanh mây là kích thước của điểm cần vẽ chứ không vẽ ra.

Chân thành cảm ơn.


<<

Filename: 400040_tt%C2%A0.lsp

Trang 302/330

302