Jump to content
InfoFile
Tác giả: taipham
Bài viết gốc: 386470
Tên lệnh: cco
Nhờ Viết Lisp Copy Cộng Dồn Khoảng Cách

 

Lâu lâu vận động trí óc để tránh Bệnh Alzheimer’s :D :

(defun c:cco (/ oldos css ss p0 p1 p2 a...
>>

 

Lâu lâu vận động trí óc để tránh Bệnh Alzheimer’s :D :

(defun c:cco (/ oldos css ss p0 p1 p2 a e d)
(defun css (ss p0 p1 a)
((lambda (i / e obj o1 i) (while (setq e (ssname ss (setq i (1+ i))))
(setq obj (vlax-ename->vla-object e)) (setq o1 (vla-copy obj)) 
(if p0 (vla-move o1 (vlax-3d-point p0) (vlax-3d-point p1)))
(vla-move o1 (vlax-3d-point p1) (vlax-3d-point (polar p1 a d))) )) -1) )
(princ "\n Chon doi tuong can copy") (setq ss (ssget) 
p0 (getpoint "\n Chon diem chuan")
p1 (getpoint p0 "\n Chon diem goc") 
p2 (getpoint p1 "\n Chon diem dinh huong copy") 
a (angle p1 p2) e (entlast))
(while (setq d (getdist "\n Nhap khoang cach can copy tiep theo: "))
(css ss p0 p1 a) (setq ss (ssadd))
(while (setq e (entnext e)) (setq ss (ssadd e ss))) 
(setq p0 nil e (entlast)) )
(princ))

Yeah, đúng ý rồi, cảm ơn anh,các anh và Cadviet


<<

Filename: 386470_cco.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 246943
Tên lệnh: vdc
(Yêu cầu) Viết lisp xuất cao độ từ block

Thây yêu cầu cũng đơn giản nên mình viết nhanh cho bạn.

Tên lệnh vdc nhé.

 

>>

Thây yêu cầu cũng đơn giản nên mình viết nhanh cho bạn.

Tên lệnh vdc nhé.

 

(defun dxf (code e) (cdr (assoc code (entget e))))

(defun MakeText (string point height)

(entmake (list (cons 0 "TEXT") (cons 1 string) (cons 10 point) (cons 40 height)))

)

(defun C:vdc(/ h ss i e pt pt_Insert cd_String)

(setvar "cmdecho" 0)

(if (not h0) (setq h0 2.0))

(setq h (getreal (strcat "\nNhap chieu cao <" (rtos h0 2 2) ">:")))

(if (not h) (setq h h0) (setq h0 h))

(princ "\nChon block can ghi cao do")

(setq ss (ssget (list (cons 0 "INSERT"))))

(repeat (setq i (sslength ss))

(setq

e (ssname ss (setq i (1- i)))

pt (dxf 10 e)

pt_Insert (list (car pt) (cadr pt))

cd_String (rtos (last pt))

)

(MakeText cd_String pt_Insert h)

)

(setvar "cmdecho" 1)

(princ "\nViet boi Hoc hoai van dot")

(princ)

)

 

Nếu muốn ghi bao nhiêu số lẻ thì dùng lệnh UNITS để chọn nhé

Hề hề hề,

Giá như bác cho thêm vào bộ lọc cái tên block thì sẽ đỡ bị xuất nhầm đối tượng hơn bác hè......


<<

Filename: 246943_vdc.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 312511
Tên lệnh: dd
Xin lisp tính độ dốc giữa 2 điểm nằm trên một đường polyline

 

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

 

(defun c:dd(/ t1 t2 pl dai)
  (setq t1 (car (entsel "\nChon text cao do 1:"))
t2...
>>

 

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

 

(defun c:dd(/ t1 t2 pl dai)
  (setq t1 (car (entsel "\nChon text cao do 1:"))
t2 (car (entsel "\nChon text cao do 2:"))
pl (car (entsel "\nChon polyline:"))
dai (vlax-curve-getDistAtParam pl (vlax-curve-getEndParam pl)))
  (princ (strcat "\nDo doc : " (rtos(/ (- (atof (cdr (assoc 1 (entget t1))))
                            (atof (cdr (assoc 1 (entget t2))))) dai))))
  (princ)
)

Hề hề hề,

Bác Tot77 có quan tâm tới việc vị trí của các text cao độ không tướng ứng với điểm đầu và điểm cuối của pline không ạ.???


<<

Filename: 312511_dd.lsp
Tác giả: gia_bach
Bài viết gốc: 423422
Tên lệnh: test
Hỏi về hàm vlax-curve-getPointAtDist
8 giờ trước, doductiep đã nói:

cảm ơn bác! Nhưng  đọc hết 2...

>>
8 giờ trước, doductiep đã nói:

cảm ơn bác! Nhưng  đọc hết 2 trang mà chả hiểu gì  ^_^ 

Túm lại là  em muốn chọn điểm (1 trong 2 đầu pline) để hàm Vlax-curve - getpointatDist bắt đầu tính khoảng cách từ nó mà mình không cần biết nó là đầu hay là cuối pline.

E đang có ý là sau khi pick chọn 1 trong 2 đầu của pline rồi kiểm tra điểm pick có phải là điểm đầu không, nếu đúng => dùng hàm. Nếu không thì xuất tọa độ pl đó rồi vẽ 1 pline mới với list tọa độ đảo ngược, sau đó dùng hàm xác định điểm cần tìm trên Pline mới vì khi đó 2 pline trùng nhau, chỉ ngược nhau điểm đầu và cuối.

Có cách nào nhanh hơn không ah?

 

 

 

Tham khảo:

(defun c:test (/ ent pickPt pt dist)
  (vl-load-com)
  (if (and (setq ent (entsel "\nSelect a curve ") )
	   (wcmatch (cdr (assoc 0 (entget (car ent))))"ARC,LINE,*POLYLINE,SPLINE" )   )
    (progn
      (setq pt (trans (cadr ent) 1 0)
            ent (car ent)  )
      (setq dist (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent)))
      (setq pickPt (vlax-curve-getClosestPointToProjection ent pt '(0. 0. 1.)))
      (if (< (vlax-curve-getDistAtPoint ent pickPt) (/ dist 2.) )
	(alert "Diem pick phia dau cua curve.")
	(alert "Diem pick phia cuoi cua curve.")  )    )  )  
  (princ))

 


<<

Filename: 423422_test.lsp
Tác giả: huunhantvxdts
Bài viết gốc: 426171
Tên lệnh: ve3dp
Xin lips nối các điểm point thành 3dpoly theo thứ tự

13 giờ trước, mavanbac đã nói:

Mình có tập hợp các điểm theo...

>>
13 giờ trước, mavanbac đã nói:

Mình có tập hợp các điểm theo tứ 1,2,3... tọa độ xyz Bạn nào giúp mình nối chúng lại thành 3d poly line 

PS(3105) (22).dwg

(defun C:ve3dp(/ ) 
(setq lsttext (acet-ss-to-list (ssget '((0 . "TEXT")))))
(setq lstpoint (mapcar '(lambda (e) (cons (cdr (assoc 10 (entget e))) (cdr (assoc 1 (entget e))))) lsttext))
(setq sxlistpoint (vl-sort lstpoint '(lambda (x y) ( < (atof (cdr x)) (atof (cdr y))))))
(setq lstpointve (mapcar '(lambda (e) (car e)) sxlistpoint))
(apply 'command 
    (append
       '(".3dpoly")
        lstpointve
       '("")
    )
))

Rãnh rỗi viết tí không biết đúng ý bạn chưa????


<<

Filename: 426171_ve3dp.lsp
Tác giả: Huynh Nghia
Bài viết gốc: 385630
Tên lệnh: q
Đổi Màu Text

 

Có lẻ theo cách củ chuối này trúng ý bạn hơn :D :

(defun c:q (/ ent obj tn) (vl-load-com)
(while...
>>

 

Có lẻ theo cách củ chuối này trúng ý bạn hơn :D :

(defun c:q (/ ent obj tn) (vl-load-com)
(while (setq ent (car (entsel "\nPick chon Text : ")))
(setq obj (vlax-ename->vla-object ent))
(if (wcmatch (cdr (assoc 0 (entget ent))) "DIMENSION")
(progn (vla-put-TextColor obj 3) (vl-cmdf ".ddedit" ent "") (vla-put-TextColor obj 2))
(progn (vla-put-Color obj 3) (vl-cmdf ".ddedit" ent "") (vla-put-Color obj 2)) )) 
(princ)) 

Thanks bạn pphung183! Trong trường hợp này thì cách củ chuối này hợp vối mình hơn. 


<<

Filename: 385630_q.lsp
Tác giả: cico501
Bài viết gốc: 154798
Tên lệnh: csv
Lisp chuyển cao độ đo đạc thực tế vào Cad

Hề hề hề,

Bạn xài thử cái của đi mót này xem nhé.


;Lisp by nPham. www.cadviet.com
(defun...
>>

Hề hề hề,

Bạn xài thử cái của đi mót này xem nhé.


;Lisp by nPham. www.cadviet.com
(defun csv->list (fn / str f lst)  
(defun Separate (str sym / lst pos  )
	(setq Lst (append))
	(while  (setq pos (vl-string-search sym str))
   		(setq Lst (append Lst (list (substr str 1 pos))))
			(setq str (substr str (+ pos 2)))
	  ) Lst)

(setq f (open fn "r"))
(setq lst (append))
(read-line f)
(while (setq str (read-line f)) (setq lst (append lst (list (Separate str ",")))))
(close f)
lst
)


(defun text->cad (pt1 cnt tlst / pt1 pt2)
	  ;10 60 20 20 40
   (setvar "CECOLOR" "BYLAYER") 
   (command ".text" "J" "MC" (list (+ (car pt1) 5)  (- (- (cadr pt1) (* 5 cnt)) 2.5)) "2" "0" (nth 0 tlst))
   (command ".text" "J" "ML" (list (+ (car pt1) 12)  (- (- (cadr pt1) (* 5 cnt)) 2.5)) "2" "0" (nth 1 tlst))
   (command ".text" "J" "MC" (list (+ (car pt1) 80) (- (- (cadr pt1) (* 5 cnt)) 2.5)) "2" "0" (nth 2 tlst))
	 (command ".text" "J" "MC" (list (+ (car pt1) 100) (- (- (cadr pt1) (* 5 cnt)) 2.5)) "2" "0" (nth 3 tlst))
	   (command ".text" "J" "MC" (list (+ (car pt1) 130) (- (- (cadr pt1) (* 5 cnt)) 2.5)) "2" "0" (nth 4 tlst))

   (setvar "CECOLOR" "8")
   (command ".line" (setq pt2 (list (car pt1) (- (nth 1 pt1) (* 5 (+ cnt 1))))) (polar pt2 0 150) "")

)

(defun c:csv (/ fn f lst wlst i x col pt tile) 

(setq  fn (getfiled "Select Data File" "" "csv" 0))
(if fn
(if (setq pt (getpoint "\nDiem chen <Cancel>:"))
(progn
(setq f (open fn "r"))
(setq tile (read-line f))
(close f)
(setq lst (vl-remove-if  '(lambda (x) (apply 'and (mapcar '(lambda (y) (= y "")) x)))(csv->list fn)))

(command ".text" "J" "MC" (list (+ (car pt) 75) (+ (cadr pt) 8)) "4" "0" tile)
(setvar "CECOLOR" "7")
(command ".line" pt (polar pt 0 150) "")
(setq row 0)
(mapcar '(lambda (x)	   	   
   	(setq row (+ row 1))
	  (text->cad pt (- row 1) x))
	lst
)
(setvar "cecolor" "7")
  (command "line" pt (polar pt (- (/ pi 2)) (* row 5)) "")  
  (command ".copy" (entlast) "" pt (polar pt 0 10))  
  (command ".copy" (entlast) "" pt (polar pt 0 60))  
(command ".copy" (entlast) "" pt (polar pt 0 20))
  (command ".copy" (entlast) "" pt (polar pt 0 20))  
  (command ".copy" (entlast) "" pt (polar pt 0 40))	

)))
 )

Hy vọng bạn hài lòng.

bạn có thể hướng dẫn mình kỹ một chút không? Ví dụ các tọa độ mình đã nhập hết vào excel rồi. Đã load lisp xong rồi. Bước tiếp theo là làm những j?

cảm ơn nhiều vì mình không biết nhiều về lisp!


<<

Filename: 154798_csv.lsp
Tác giả: Trang72
Bài viết gốc: 121646
Tên lệnh: input
Xuất dữ liệu cad sang EXCEL lần lượt

Chào cả nhà !

Thấy mấy bác cũng có hứng thú với đề tài này nên mình " chế " lại 1 chút cho vui. Chủ yếu là để tham khảo học hỏi lẫn nhau.

Code dưới đây...

>>
Chào cả nhà !

Thấy mấy bác cũng có hứng thú với đề tài này nên mình " chế " lại 1 chút cho vui. Chủ yếu là để tham khảo học hỏi lẫn nhau.

Code dưới đây thực hiện công việc ghi dwx liệu nhập ra file, nhưng trước khi ra file nó được ghi vào list_box để quan sát trước.

Ưu điểm:

- Số TT twj gia tăng

- nhập liệu bằng TAB-ENter, sau khi enter con trỏ quay về code, thuận tiện cho người nhập, đồng thời reset các ô nhập liệu (trừ stt)

- Nút getdistance (theo ý tưỏng của bác gì đó)

- Quan sát được toàn bộ du liêu trươc khi ghi

Tồn tại: (cần bổ sung)

- Kiểm tra tính hợp lệ dwx liệu, loại bỏ dữ liệu rỗng

- Nút thêm, xoá, swả dw liệu trên list_box

- Cần phải hỏi lại trước khi đóng mà không ghi

 

Mấy bác có hứng thú thì phát triển tiếp nhé . Để chơi thôi chứ không biết có cần để làm gì không nwã. Hehe

 

minh hoạ:

input.png

 

Code:

;;; www.cadviet.com
(defun DCLmaker ( / f fn )
(setq fn (strcat (vl-filename-mktemp) ".dcl"))
(setq f (open fn "w"))
(write-line (strcat
"input:dialog {
label=\"Write to file\";
: boxed_row {
label=\"Row data\";
: column {: text {label=\"Number\";} : edit_box {key=\"number\";edit_width=5;}}
: column {: text {label=\"Code\";} : edit_box {key=\"code\";edit_width=8;}}
: column {: text {label=\"Distance\";} : edit_box {key=\"distance\";edit_width=8;}}
: column {: text {label=\"Notes\";} : edit_box {key=\"note\";edit_width=20;}}
: column {spacer; : button {key=\"add\";label=\"Add\";edit_width=20;}}
}
: list_box {
key=\"data\";
label=\"Data\";
}
: row { 
: button {
	label=\"Distance\";
	fixed_width=true;	
	key=\"zoom\";
		}
	: button {
	label=\"Close without write\";
	fixed_width=true;
	is_cancel=true;
	key=\"cancel\";	
	alignment=right;
		}	
: button {
	label=\"Close and write\";
	fixed_width=true;		
	key=\"accept\";
	is_default=true;
	alignment=right;
		}
		}
}"
) f)
(close f)
fn
)
;---------------------------------------------------------------------------
;---------------------------------------------------------------------------
(defun add&view (key ss /)
 (start_list key)
 (foreach x ss (add_list x))
 (end_list)
)
;---------------------------------------------------------------------------
(defun savevars ( / vars)
(setq vars (strcat
(setq number (get_tile "number")) ",			"
(get_tile "code") ",			"
(rtos (distof (get_tile "distance")) 2 2) ",			"
(get_tile "note")))

(set_tile "code" "") 
(set_tile "distance" "")
(set_tile "note" "")
vars
)
;---------------------------------------------------------------------------
(defun c:input (/ fn f number sta id data dis)


(setq id (load_dialog (dclmaker)))

(setq sta 2)	
(while (> sta 1)	
(new_dialog "input" id)
	(if dis (set_tile "distance" (rtos dis 2 2)))
  (add&view "data" data)

(mode_tile "number" 2)
(action_tile "add" "(PROGN
			  (setq data (append data (list (savevars))))
			  (add&view \"data\" data)
			(set_tile \"number\" (itoa (1+ (atoi number))))
			(mode_tile \"code\" 2)
			  )")
(action_tile "zoom" "(done_dialog 2)")  
(setq sta (start_dialog))

	(cond
  ((= sta 2) (setq dis (getdist "\nNhap khoang cach:")))
  ((= sta 1) (progn			
		 (if (setq fn (getfiled "Select a File" "" "cvs" 1))
			 (progn
		 (setq f (open fn "w"))
		   (foreach x data (write-line x f))
			 (close f)
		 ))))
  )




 )
(done_dialog)
(unload_dialog id)

 )

Code của bác rất hay nhưng dữ liệu 4 cột chỉ vào trong 1 cel.Nếu tách dữ liệu sang mỗi 1 dữ liệu sang 1 cel thì quả là hay.


<<

Filename: 121646_input.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 121490
Tên lệnh: cvs
Xuất dữ liệu cad sang EXCEL lần lượt
Chào các bác.

Tiếp sức cùng bác Bình, "mình làm thử cái này hơi thừa vì chưa chắc có ai cần dùng ?"

Đề bài vẫn là của bạn...

>>
Chào các bác.

Tiếp sức cùng bác Bình, "mình làm thử cái này hơi thừa vì chưa chắc có ai cần dùng ?"

Đề bài vẫn là của bạn Trang72 và ý tuởng từ LISP của bác Bình, đáp án thì có khác chút đỉnh với nguyên bản ..

 

Sử dụng file "NHAPLIEU.dcl" của bác Bình.

Môt số cải tiến :

- gán giá trị mặc định cho hộp thoại

- STT tự động tăng lên 1 sau mỗi lần nhấn OK

- chức năng của button ZOOM đuợc đổi thành GET_Distance (đo khoảng cách 2 điểm trên CAD)

(defun c:cvs (/ dcflag dcl_id f filename kc ma note retlist stt)
 (defun saveVars ();save data
   (setq STT (get_tile "ebox1")
  Ma  (get_tile "ebox2")
  KC  (get_tile "ebox3")
  note (get_tile "ebox4")   )  )

 (setq dcl_id (load_dialog "NHAPLIEU.dcl"))
 (setq filename (getfiled "Select a File" "" "csv" 1))
 (setq f (open filename "a"))

 ;init data
 (setq STT  1
Ma   "CadViet"
KC   1000
note "AutoLisp")

 (while (/= dcflag 0)    
   (if	(not (new_dialog "NHAPLIEU" dcl_id))
     (exit)    )

   ;set data
   (set_tile "ebox1" (itoa stt))
   (set_tile "ebox2" Ma)    
   (set_tile "ebox3" (rtos kc))
   (set_tile "ebox4" note)

   (action_tile "accept" "(saveVars)(done_dialog 1)")
   (action_tile "zoom" "(done_dialog 2)")

   (setq dcFlag (start_dialog))
   (cond

     ((= dcflag 1);add data to file
      (setq retlist (strcat stt "\t" ma "\t" kc "\t" note "\t"))
      (princ "\n")
      (princ retlist)
      (write-line retlist f)
      (setq stt (1+ (atoi stt)))
      (setq kc (atof kc)) )

     ((= dcflag 2);Get distance
      (if (setq tmp (getdist "\nPick 2 diem de do khoang cach :")) ))
     );cond
   )
 (princ "\n \n ...EXAMPLE Cancelled. \n ")  
 (close f)
 (unload_dialog dcl_id)
 (princ))

Chào bác Giabach,

Sau khi test cái lisp của bác, mình thấy có vài ý như sau:

1/- Có nhẽ do mình xài Cad2004 nên nó không hiểu cái lisp của bác và cứ báo là ; error: syntax error

Sau khi đọc lại cái lisp thì mình thấy cái hàm (cond ....................) của bác có nhẽ là viết theo đời mới nên mình bổ sung thêm như sau thì lisp chạy ngon lành:

(cond

( (= dcflag 1);add data to file

(progn

(setq retlist (strcat stt "\t" ma "\t" kc "\t" note "\t"))

(princ "\n")

(princ retlist)

(write-line retlist f)

(setq stt (1+ (atoi stt)))

(setq kc (atof kc))

)

)

 

( (= dcflag 2);Get distance

(setq tmp (getdist "\nPick 2 diem de do khoang cach :"))

)

);cond

 

2/- Việc bác cho các giá trị mặc định sẽ thuận tiện cho người dùng không phải nhập lại các giá trị nếu các giá trị này ở record sau giống như record trưởc. Tuy nhiên cũng có bất lợi là dễ làm cho người sử dụng nhầm lẫn khi có những giá trị cần bỏ qua. Lúc này người sử dụng sẽ phải xóa cái giá trị đó đi trong hộp thoại.

3/- Việc bác sử dụng hàm getdist trong trường hợp này là khá hay thay vì các thao tác phải zoom pan màn hình khác.

4/- Việc bác sử dụng tham số a cho hàm open cũng là một ý rất hay.

 

Chúc bác khỏe và vui.


<<

Filename: 121490_cvs.lsp
Tác giả: Tue_NV
Bài viết gốc: 144569
Tên lệnh: eo1
Lisp xóa text nằm ngoài khoảng giá trị !

Hề hề hề,

Đây là lisp thứ 2 để bạn ấy tha hồ mà chọn hỉ?????


(defun c:eo1 (/ a b num sst...
>>

Hề hề hề,

Đây là lisp thứ 2 để bạn ấy tha hồ mà chọn hỉ?????


(defun c:eo1 (/ a b num sst ssl txt )
(vl-load-com)
(setq a (getreal "\n Nh\U+1EADp gi\U+00E1 tr\U+1ECB nh\U+1ECF nh\U+1EA5t a = :")
         b (getreal "\n Nh\U+1EADp gi\U+00E1 tr\U+1ECB l\U+1EDBn nh\U+1EA5t b = (b>a): ")
         sst (ssget (list (cons 0 "*TEXT")))
         ssl (acet-ss-to-list sst)
)
(foreach x ssl
            (setq txt (cdr (assoc 1 (entget x)))
                     num (atof txt)
            )
            (if(or (< num a) (> num B))
                (command "erase" x "")
            )
)
)

 

Mong bác Ketxu chớ giận vì cái éo này do cái eo của bác đẻ ra ấy mà......

Cai éo của bác Bình nên thay dòng này mới kĩ được :lol:

Dòng này :

(if (or (< num a) (> num B ))

(command "erase" x "")

)

-> Nên sửa thành :

(if (and (distof txt) (or (< num a) (> num B )))

(command "erase" x "")

)


<<

Filename: 144569_eo1.lsp
Tác giả: hanam1210
Bài viết gốc: 172040
Tên lệnh: tbkd
lisp vẽ đường bóng ( đường thể hiện dốc trên mặt bằng )

Mình đưa ra 1 ví dụ để bạn thấy việc viết lisp không đơn giản, và nếu người yêu cầu không biết mình cần gì, sẽ không bao giờ có...

>>

Mình đưa ra 1 ví dụ để bạn thấy việc viết lisp không đơn giản, và nếu người yêu cầu không biết mình cần gì, sẽ không bao giờ có đáp án, hoặc chí ít cũng không được như ý

(defun c:tbkd(/ eLine curve1 curve2 i j len1 len2 tmp)
(vl-load-com)
(or #dist (setq #dist 10)) ; 10 = Khoang cach mac dinh
(setq #dist (cond ((getdist (strcat "\nKhoang cach bat dau <" (vl-princ-to-string #dist) " > :")))(#dist)))
(or #inc (setq #inc 1.2)) ;
(setq #inc (cond ((getdist (strcat "\nGia so <" (vl-princ-to-string #inc) " > :")))(#inc)))
(defun eLine (p1 p2  / p2 col)(entmake  (list (cons 0 "LINE")(cons 10 p1)  (cons 11 p2)(cons 62 8)  (cons 8 "0"))))
;;Doan duoi nay khong can de y
(If
(and
(setq curve1  (car(entsel "\nPath curve 1 :")))
(setq curve2  (car(entsel "\nPath curve 2 :")))
(wcmatch (cdadr (entget curve1)) "*LINE,ARC")
(wcmatch (cdadr (entget curve2)) "*LINE,ARC")
(eLine (vlax-curve-getStartPoint curve1) (vlax-curve-getStartPoint curve2))
(setq tmp 0 i 0 len1 (vlax-curve-getDistAtParam curve1 (vlax-curve-getEndParam curve1)) len2 (vlax-curve-getDistAtParam curve2 (vlax-curve-getEndParam curve2)))
)
(while (<= (setq tmp (+ (* #dist (expt #inc (setq i (1+ i))))tmp)) len1)
 (eLine (vlax-curve-getPointAtDist curve1 tmp) (vlax-curve-getPointAtDist curve2 tmp))
)
)
)

Vâng, cảm ơn bác KETXU. Lisp có chạy nhưng có vấn đề thế này, chắc do bác KETXU chưa đọc kỹ yêu cầu của em. Đó là khi chạy lisp cho phép ta pick điểm M và N bởi vì từ M đến N. Khoảng cách ban đầu là khoảng cách tại điểm M, Sở dĩ phải sinh ra điểm M và N đó bởi vì từ M đến N sẽ xảy ra 2 trường hợp, trường hợp 1 là đường bóng mau dần với gia số <1, trường hợp 2 là đường bóng thưa dần với gia số >1. Hiện tại lisp tự động vẽ ra các đường bóng. Chưa đáp ứng được là đường bóng chạy từ M đến N mau hay thưa đi. và cái điểm M và N đó dùng để giới hạn khoảng kẻ đường bóng, vì các đường nét trên bình đồ thường là 1 đường liền, nếu ta không giới hạn như vậy thì lại phải trim các đường biên. Và 1 vấn đề nữa là lisp tự động chạy chứ ko cho phép chọn đường A trong yêu cầu, vì có nhiều khi ta muốn kẻ đường bóng theo một phương ta chọn trước chứ ko phải là nhất nhất lúc nào cũng theo một phương có sẵn. Tóm lại, lisp cần phải chỉnh sửa vấn đề sau:

1. Cho phép pick điểm Start (M), và end (N) để giới hạn phạm vi kể đường bóng và biết được từ M>N đường bóng sẽ mau hay thưa đi

2.Bổ sung chọn đường A ( Trong yêu cầu), đường bóng sẽ song song với đường A có sẵn, Đường A là Line, Pline

Hiện tại khi lisp chạy với 2 đường biên không song song nhau thì các đường bóng không song song với nhau mà lại cắt nhau. như thế là sai

Mong bác KETXU hoàn thiện giúp em với ạ !


<<

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

 

Nể Bác  gia_bach viết code rất già dặn :) , chắc Bác là người chính chắn ko thix quậy phá như Nhoc

 

Nhoc...

>>

 

Nể Bác  gia_bach viết code rất già dặn :) , chắc Bác là người chính chắn ko thix quậy phá như Nhoc

 

Nhoc thêm thắt theo yêu cầu của pawuta chỉ chừa lại phần "Khoai" cho Bác gia_bach. Pawuta ơiii ! Bạn mới làm wen Lisp mà yêu cầu "Khoai" thế :wub: : tự động thay đổi giá trị theo khi thay đổi các giá trị các block att :wub: .

(defun c:ThKl (/ ft doc) (vl-load-com)
(setq ft (vla-get-activeTextStyle (vla-get-activedocument (vlax-get-acad-object))))
(vla-setfont ft "VNI-Helve" :vlax-False :vlax-False 0 32)
(princ "\nChon Block can tong hop :")
(if (ssget (list (cons 0 "INSERT") (cons 66 1)))
(tkatt (vla-get-ActiveSelectionSet (setq doc (vla-get-ActiveDocument (vlax-get-Acad-Object))))
(vla-get-modelspace doc) "DK" "TCD" "TKL" )
(princ "\nKhong chon duoc Block thuoc tinh."))
(princ))
(defun tkatt (ssets msp idTag val1tag val2tag / asoc h i id lst pt row tblobj val1 val2 width)
;  By : Gia_Bach, www.CadViet.com 2015 ;;
(vlax-for obj ssets
(setq id nil val1 nil val2 nil)
(foreach att (vlax-invoke obj 'GetAttributes)
(cond
( (= (vla-get-TagString att) idTag)
(setq id (vla-get-TextString att)) )
( (= (vla-get-TagString att) val1Tag)
(setq val1 (vla-get-TextString att)) )
( (= (vla-get-TagString att) val2Tag)
(setq val2 (vla-get-TextString att))	)))
(if (and id (distof id 2) val1 val2 (setq val1 (distof val1 2)) (setq val2 (distof val2 2)))
(if (setq asoc (assoc id lst))
(setq lst (subst (cons id (list (+ val1 (car (cdr asoc))) (+ val2 (cadr (cdr asoc))))) asoc lst))
(setq lst (append lst (list (cons id (list val1 val2)))) )) ))
(cond
( (not lst )
(princ "\nKhong tim duoc so lieu.") )
( (> (atof (substr (getvar "ACADVER") 1 4)) 16.0)
(if (setq pt (getpoint "\nDiem dat Bang tong hop:"))
(progn
(setq h 2.5 width (* 20 h)
TblObj (vla-addtable msp (vlax-3d-point pt) (+ (length lst) 2) 4 (* 2 h) width))
(vla-put-regeneratetablesuppressed TblObj :vlax-true)
(vla-put-vertcellmargin TblObj (* 0.75 h))
(mapcar '(lambda (x) (vla-setTextStyle TblObj x (getvar 'textstyle))) 
(list acTitleRow acHeaderRow acDataRow) )
(mapcar '(lambda (x) (vla-setTextHeight TblObj x h)) (list acDataRow) )
(mapcar '(lambda (x) (vla-setTextHeight TblObj x 3.5))
(list acTitleRow acHeaderRow) )
(mapcar '(lambda (x) (vla-setAlignment TblObj x 8))
(list acTitleRow acHeaderRow acDataRow))
(vl-catch-all-error-p (vl-catch-all-apply (function (lambda () (vla-MergeCells TblObj 0 0 0 3)) )))
(vla-setText TblObj 0 0 "TOÅNG HÔÏP KHOÁI LÖÔÏNG")
(vla-setText TblObj 1 0 "STT")
(vla-setText TblObj 1 1 "ÑÖÔØNG KÍNH")
(vla-setText TblObj 1 2 "TOÅNG CHIEÀU DAØI")
(vla-setText TblObj 1 3 "TOÅNG KHOÁI LÖÔÏNG")
(setq row 2 i 1)
(foreach pt (vl-sort lst '(lambda (x y) (< (car x) (car y))))
(vla-setText TblObj row 0 (itoa i))
(vla-setText TblObj row 1 (car pt))
(vla-setText TblObj row 2 (rtos (car (cdr pt)) 2 2))
(vla-setText TblObj row 3 (rtos (cadr (cdr pt)) 2 2))
(setq row (1+ row) i (1+ i))	)
(vla-put-regeneratetablesuppressed TblObj :vlax-false)
(vlax-release-object TblObj)	)))
(t (foreach it (vl-sort lst '(lambda (x y) (< (car x) (car y))))
(princ (strcat "\n"(car it) " : " (rtos (car (cdr it)) 2 2) " : " (rtos (cadr (cdr it)) 2 2))))  ))
)

Hề hề hề, Bác Hề hề hề rất nhiệt tình nhưng Lisp Bác chưa mang tính tổng quát như Bác gia_bach (Nhoc nhận xét sai thì bỏ wa nhe :P )

Nhoc thấy Lee có một số hàm lấy BlockAtt nè Bác Hề hề hề :P

http://www.lee-mac.com/attributefunctions.html

 

Nhóc ơi bị lỗi rồi, nhóc xem lại với nha

136880_capture.jpg


<<

Filename: 345520_thkl.lsp
Tác giả: nguyen tuan hung
Bài viết gốc: 170592
Tên lệnh: nb
convert anonymous block to normal block

Vấn đề của bạn có thể xử lý bằng lisp này cũng được :

>>

Vấn đề của bạn có thể xử lý bằng lisp này cũng được :

http://www.cadviet.c...31

Nó sẽ copy block Anon bạn chọn thành 1 block mới, rồi bạn chèn vào đúng điểm chèn cũ của block đó ( trong ví dụ cảu bạn thì toàn '( 0 0 0).

Từ lisp này cũng có thể biến hóa thành lisp convert block anon -> block thường :

;| Change Anonymous Block to normal with new Name
@ Ketxu 27 - 9 - 2011
|;
(defun c:nb( / blkObj blkName blkNew_Name fn pt)
(vl-load-com)
(defun ST:SS->List-Vla (ss / n e l)
 (setq n (sslength ss))
 (while (setq e (ssname ss (setq n (1- n))))
(setq l (cons (vlax-ename->vla-object e) l))
 )
)

(defun change_block(old new)
(foreach blkObj (setq ss (ST:SS->List-Vla (ssget "X" (list (cons 0 "INSERT")(cons 2 old)))))
(vla-put-name blkObj new);;change the name
(vla-update blkObj)
)
)
(grtext -1 "Free Lisp From Cadviet @Ketxu")
(setvar "cmdecho" 0)
(setq
blkObj (vlax-ename->vla-object (car(entsel "\nBlock Source :")))
blkName (vlax-get-property blkObj
   (if (vlax-property-available-p blkObj 'EffectiveName) 'EffectiveName 'Name)
 )  
blkNew_Name (getstring "\n New Name :")
 fn (strcat (getenv "TEMP") "\\" blkNew_Name ".dwg")
)
(command ".-wblock" fn "_Y" blkName "")  
(command "._insert" (strcat blkNew_Name "=" fn) nil )
(if (wcmatch "`*" (substr blkName 1 1))(setq blkName (strcat "`*" (substr blkName 2))))
(change_block blkName blkNew_Name)
(vl-file-delete  fn)
)

Lisp này chạy tốt anh à.

Anh Két có thể sửa 1 chút là khi sử dụng lệnh nb -> chọn 1 đối tượng(block không tên)->đặt tên là "1"(khi kết thúc tất cả các block không tên mà hình dạng giống như block mình vừa chọn ban đầu đều có tên là "1".

Vi dụ có 5 block giống nhau khi thao tác 1 lần xong thì 5 block đều có tên giống nhau.

Em hưng


<<

Filename: 170592_nb.lsp
Tác giả: namtay
Bài viết gốc: 223614
Tên lệnh: unanonall unanon
convert anonymous block to normal block

hôm nay gặp một bài toán khó, là hiệu chỉnh một block anonymous. Ví dụ trong file này:

hôm nay gặp một bài toán khó, là hiệu chỉnh một block anonymous. Ví dụ trong file này: http://www.cadviet.c.../new_block3.zip

 

AutoCAD không cho chỉnh sửa block anonymous (là block có tên đầu bằng *, vd *U123).

May thay, tìm kiếm được lisp đổi block anonymous sang block bình thường tại trang http://www.draftsperson.net

;=============================================== ;    UnAnon.Lsp                           		Jul 05, 1998 ;====================================== (princ "\nCopyright © 1998, Fabricated Designs, Inc.") (princ "\nLoading UnAnon v1.0 ") (setq uan_ nil lsp_file "UnAnon") ;================== For Automated Calling From Another Program ========= (defun uan_auto (ar1) (UnAnon ar1)) ;================== Macros ============================================= (defun PDot ()(princ ".")) (PDot);++++++++++++ Set Modes & Error ++++++++++++++++++++++++++++++++++ (defun uan_smd ()  (SetUndo)  (setq olderr *error*   	*error* (lambda (e)         		(and (/= e "quit / exit abort")                      (princ (strcat "\nError: *** " e " *** ")))         		(command "_.UNDO" "_END" "_.U")         		(uan_rmd))        uan_var '(   ("CMDECHO"   . 0) ("MENUECHO" . 0) ("MENUCTL"   . 0) ("MACROTRACE" . 0)   ("OSMODE"    . 0) ("SORTENTS" . 119)("MODEMACRO" . ".")   ("BLIPMODE"  . 0) ("EXPERT"   . 0) ("SNAPMODE"  . 1) ("PLINEWID"   . 0.0)   ("ORTHOMODE" . 1) ("GRIDMODE" . 0) ("ELEVATION" . 0) ("THICKNESS"  . 0)   ("FILEDIA"   . 0) ("FILLMODE" . 0) ("SPLFRAME"  . 0) ("UNITMODE"   . 0)   ("TEXTEVAL"  . 0) ("ATTDIA"   . 0) ("AFLAGS"    . 0) ("ATTREQ" 	. 1)   ("ATTMODE"   . 1) ("UCSICON"  . 1) ("HIGHLIGHT" . 1) ("REGENMODE"  . 1)   ("COORDS"    . 2) ("DRAGMODE" . 2) ("DIMZIN"    . 1) ("PDMODE" 	. 0)   ("CECOLOR"   . "BYLAYER") ("CELTYPE" . "BYLAYER")))  (foreach v uan_var   	(setq m_v (cons (getvar (car v)) m_v)     		m_n (cons (car v) m_n))   	(setvar (car v) (cdr v)))  (princ (strcat (getvar "PLATFORM") " Release " (substr (ver) 18 2)    " -  Convert To Anonymous Blocks ....\n"))  (princ)) (PDot);++++++++++++ Return Modes & Error +++++++++++++++++++++++++++++++ (defun uan_rmd ()   (setq *error* olderr)   (mapcar 'setvar m_n m_v)   (command "_.UNDO" "_END")   (prin1)) (PDot);++++++++++++ Set And Start An Undo Group ++++++++++++++++++++++++ (defun SetUndo ()  (and (zerop (getvar "UNDOCTL"))   	(command "_.UNDO" "_ALL"))  (and (= (logand (getvar "UNDOCTL") 2) 2)   	(command "_.UNDO" "_CONTROL" "_ALL"))  (and (= (logand (getvar "UNDOCTL") 8) 8)   	(command "_.UNDO" "_END"))  (command "_.UNDO" "_GROUP")) (PDot);++++++++++++ Get Entity Name ++++++++++++++++++++++++++++++++++++ (defun GetOne (/ st os)  (setq os (getvar "SNAPMODE") s nil)  (setvar "SNAPMODE" 0)  (while (not st) 		(setq st (ssget)))  (while (> (sslength st) 1) 		(setq st nil) 		(princ "\nOnly 1 At A Time Please\n") 		(while (not st)                (setq st (ssget))))  (setvar "SNAPMODE" os)  (setq s (ssname st 0))) (PDot);++++++++++++ Convert An Anonymous Block To Named Block ++++++++++ (defun UnAnon (b / tdef en ed bc bn bd in)          ;Supply ename   (setq bn "TEMP1" bc 1)   (while (tblsearch "BLOCK" bn)          (setq bc (1+ bc) bn (strcat "TEMP" (itoa bc))))   (and (= (type B ) 'ENAME)        (setq bd (entget B )              in (cdr (assoc 2 bd))))   (if (or (not bd)   		(not in)   		(/= "INSERT" (cdr (assoc 0 bd)))   		(/= "*U" (substr in 1 2))   		(= (logand (cdr (assoc 70 (tblsearch "BLOCK" in)))  4)  4)   		(= (logand (cdr (assoc 70 (tblsearch "BLOCK" in))) 16) 16)   		(= (logand (cdr (assoc 70 (tblsearch "BLOCK" in))) 32) 32))        (progn          (princ "*** Not An Anonomymous Block *** ")          (setq bn nil bc nil bd nil in nil b nil)          (exit)))   (setq tdef (tblsearch "BLOCK" in)   		en (cdr (assoc -2 tdef))   		ed (entget en))   (entmake (list (cons 0 "BLOCK")                  (cons 2 bn)                  (cons 70 0)                  (cons 10 (cdr (assoc 10 tdef)))))   (entmake ed)   (while (setq en (entnext en))          (setq ed (entget en))          (entmake ed))   (entmake (list (cons 0 "ENDBLK")))   (setq bd (subst (cons 2 bn) (assoc 2 bd) bd))   (entmod bd)   (entupd B )   (princ (strcat "\n" bn))) (PDot);************ Main Program *************************************** (defun uan_ (/ m_v m_n olderr uan_var s)   (uan_smd)   (GetOne)   (UnAnon s)   (uan_rmd)) (defun c:UnAnonall (/ ss i)  (setq ss (ssget "X" (list (cons 0 "INSERT")(cons 67 (if (= (getvar "TILEMODE") 1) 0 1)))))  (and ss    (setq i (sslength ss))    (while (not (minusp (setq i (1- i))))   		(setq en (ssname ss i))   		(if (= "*U" (substr (cdr (assoc 2 (entget en))) 1 2))       		(UnAnon en))))  (prin1)) (PDot);************ Load Program *************************************** (defun C:UnAnon () (uan_)) (if uan_ (princ "\nUnAnon Loaded\n")) (prin1) ;================== End Program ======================================== 

dùng lệnh UnAnon hoặc UnAnonAll để biến một hoặc tất cả các block anonymous.

 

Và sau đó dùng lệnh bedit hoặc refedit để hiệu chỉnh nó.

anh Hoanh pha giup em block nay voi.thank.

em phá theo cách của anh nó toàn bị vỡ ko sử dụng được http://www.cadviet.com/upfiles/3/116056_4den_trinh_l.dwg


<<

Filename: 223614_unanonall_unanon.lsp
Tác giả: hoanghung.k2012
Bài viết gốc: 220455
Tên lệnh: xuat
Xin được giúp đỡ về cách tao point và xuất tọa độ cho cao

Cái này trên diễn đàn đã có... Mình copy và paste cho Bạn nè! Dùng thử có đunhs ý không nhen???

(defun...
>>

Cái này trên diễn đàn đã có... Mình copy và paste cho Bạn nè! Dùng thử có đunhs ý không nhen???

(defun c:xuat()
(setq ss (ssget '((0 . "TEXT")))
fn (getfiled "Ten file: " "" "txt" 1)
f (open fn "w")
lst (ss2ent ss)
)
(foreach e lst
(setq tt (entget e)
p (cdr (assoc 10 tt))
x (rtos (car p))
y (rtos (cadr p))
nd (cdr (assoc 1 tt))
)
(write-line (strcat y "\t" x "\t" nd ) f)
)
(close f)
(princ)
)
(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)
)

 

Rất cảm ơn bạn !

Đây là cái Lisp may mình cần, Mình đã search tìm mà không thấy. một lần nữa xin cảm ơn sự giúp đỡ của bạn.


<<

Filename: 220455_xuat.lsp
Tác giả: Bee
Bài viết gốc: 419322
Tên lệnh: minj
Lisp Tự Mirror, Sau Đó Join Các Đường Đã Mirror

Bác ơi.

Lisp này, chẳng hạn mình muốn chạy lệnh qua 1 đường tự chọn(điểm đầu, điểm cuối) chứ không mặc định qua...

>>

Bác ơi.

Lisp này, chẳng hạn mình muốn chạy lệnh qua 1 đường tự chọn(điểm đầu, điểm cuối) chứ không mặc định qua trục,thì làm sao bác.

Em thêm cái đoạn đánh dấu đỏ, mà nó chỉ mirror 1 đường, không join, rồi dừng lại.

 

(defun c:minj (/ ss n ss1)

(setq ss (ssget))

(setq n 0)

(setq ss1 (ssadd))

(setq stap (getpoint "\nStart point of Mirror line (line may intersect every polyline only once!): "))

(setq endp (getpoint stap "\nEnd point of Mirror line: "))

(repeat (sslength ss)

(setq ss1 (ssadd (ssname ss n) ss1))

(command "mirror" ss1 "" "stap" "endp" "N" "")

(setq ss1 (ssadd (entlast) ss1))

(command ".PEDIT" "m" ss1 "" "j" "0.025" "" )

(setq ss1 (ssadd))

(setq n (1+ n))

)

(princ)

)

 

Bác xem giúp em với.

Thanks :blush:

Stap và endp là biến nên để trong câu lệnh ko có dấu ngoặc kép.

thay dòng này vào là ok: (command "mirror" ss1 "" "_none" stap "_none" endp "N" "")

^_^


<<

Filename: 419322_minj.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 138384
Tên lệnh: bd
Nhờ sửa LISP ghi độ dốc đường thẳng

Đây là Lisp của anh Sơn em sửa lại (setq chuoi (100/strcat (rtos i 2 tphan)"%")):...

>>

Đây là Lisp của anh Sơn em sửa lại (setq chuoi (100/strcat (rtos i 2 tphan)"%")):

(defun c:TLT ()
  (setq os (getvar "osmode"))
   (setq p (getpoint "\nChon diem dau: " ))
   (setq p1 (getpoint "\nChon diem cuoi: " p))
   (cond ((null tphan) (setq tphan 2)))
   (setq dau1 (car p))
   (setq cuoi1 (cadr p))
   (setq dau2 (car p1))
   (setq cuoi2 (cadr p1))
   (setq lx (abs (- dau1 dau2)))
   (setq ly (abs (- cuoi1 cuoi2)))
   (setq i (/ lx ly))
  (setq caochu (getreal "\nnhap cao chu: "))
  (setvar "osmode" 0)
   (command "layer" "S" "0" "")
   (setq pt1 (polar p (angle p p1) (/ (distance p p1) 2)))
          (setq dau1 (+ 5 (car pt1)))
          (setq cuoi1 (cadr pt1))
          (setq goc (/ (* (angle p p1) 180) pi))
  (setq pt2 (polar pt1 (+ (angle p p1) (/ pi 2)) caochu))
          (setq chuoi (100/strcat  (rtos i 2 tphan)"%"))
          (command "text" "J" "M" pt2 caochu goc chuoi )
(setvar "osmode" os)         
)

 

Còn đây là file lisp gốc của anh ấy:

(defun c:TLT ()
  (setq os (getvar "osmode"))
   (setq p (getpoint "\nChon diem dau: " ))
   (setq p1 (getpoint "\nChon diem cuoi: " p))
   (cond ((null tphan) (setq tphan 2)))
   (setq dau1 (car p))
   (setq cuoi1 (cadr p))
   (setq dau2 (car p1))
   (setq cuoi2 (cadr p1))
   (setq lx (abs (- dau1 dau2)))
   (setq ly (abs (- cuoi1 cuoi2)))
   (setq i (/ lx ly))
  (setq caochu (getreal "\nnhap cao chu: "))
  (setvar "osmode" 0)
   (command "layer" "S" "0" "")
   (setq pt1 (polar p (angle p p1) (/ (distance p p1) 2)))
          (setq dau1 (+ 5 (car pt1)))
          (setq cuoi1 (cadr pt1))
          (setq goc (/ (* (angle p p1) 180) pi))
  (setq pt2 (polar pt1 (+ (angle p p1) (/ pi 2)) caochu))
          (setq chuoi "1/"(strcat  (rtos i 2 tphan)))
          (command "text" "J" "M" pt2 caochu goc chuoi )
(setvar "osmode" os)         
)

Anh sửa giúp em và chèn giúp em đoạn Code để sau khi thực hiện lệnh nó tự động bật Osnaps trở lại

Đây là đoạn Code bật Osnap:

 

(defun c:bd ()
 (setvar "osmode" 2743)

 (princ)
 )

Cả 2 lisp trên đều sai cú pháp, có thể sửa lại như sau:

1. Sửa dòng (setq chuoi...

thành (setq chuoi (strcat (rtos (* i 100) 2 2) "%" ))

2. Chế độ osnap của 2 file đã đặt đúng (tức là sau khi thực hiện lệnh xong nó trả về giá trị cũ)


<<

Filename: 138384_bd.lsp
Tác giả: dkkx3a
Bài viết gốc: 109368
Tên lệnh: dtt
nhờ viết lisp biến dim thành text
Bạn thử cái này xem :

(defun c:dtt(/ ss sst)
(if (setq ss (ssget '((0 . "DIMENSION"))) i -1)
 (Repeat (sslength ss)
 (if (vl-cmdf "explode" ss)
   (Repeat (sslength (setq sst...
>>
Bạn thử cái này xem :

(defun c:dtt(/ ss sst)
(if (setq ss (ssget '((0 . "DIMENSION"))) i -1)
 (Repeat (sslength ss)
 (if (vl-cmdf "explode" ss)
   (Repeat (sslength (setq sst (ssget "P" (list(cons 0 "~*TEXT")))))
	   (vl-cmdf "erase" (ssname sst (setq i (1+ i))) "")
   )
 )
(setq i -1)
 )
)
)

 

Có cần thiết phải cần đến LSP không anh TUE_NV, bởi vì không phải lúc nào cũng có LSP bên cạnh, cái này dùng lệnh cad cũng nhanh chứ không quá phức tạp mà, theo ngu ý của em thì với những vấn đề cad giải quyết nhanh được thì mình sài lệnh CAD, nếu ko lâu ngày đâm ở máy ta thì vẽ ào ào, nhảy sang máy khác lại ì à ì ạch anh ạ....

@PS: mong một ngày đc gặp anh TuE_NV tại ĐN...


<<

Filename: 109368_dtt.lsp
Tác giả: bach1212
Bài viết gốc: 196222
Tên lệnh: ch
Chỉnh sửa nhanh Scale Hatch, đổi nhanh nhiều góc cho hàng loạt hatch

Chỉnh scale hay chỉnh góc bạn :) ?

 

P/s :

(defun c:ch(/ a c)
(vl-load-com)
(if (and
 (ssget (list (cons 0 "HATCH")))
...
>>

Chỉnh scale hay chỉnh góc bạn :) ?

 

P/s :

(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)))
 (if (wcmatch (vla-get-ObjectName object) "AcDbHatch")
  (or
(vla-put-PatternAngle object (+ (vla-get-PatternAngle object) a))
(vla-put-PatternScale object c)
  )
 )
)
)
)

Hí hí, chuẩn chuẩn quá............. :P Cả scale và góc cộng trừ thêm đều oki.


<<

Filename: 196222_ch.lsp
Tác giả: hatieu
Bài viết gốc: 21760
Tên lệnh: shh
lisp vẽ và hatch theo yêu cầu
Tên lệnh là SHH (Scale hatch):

(setq lsthatch '(("ANSI37" . 0.929259338) ("AR-SAND" . 18.3594989) ("ANSI33" . 1.3465935)))

(defun c:shh ()
 (defun sh (ent)
   (setq...
>>
Tên lệnh là SHH (Scale hatch):

(setq lsthatch '(("ANSI37" . 0.929259338) ("AR-SAND" . 18.3594989) ("ANSI33" . 1.3465935)))

(defun c:shh ()
 (defun sh (ent)
   (setq tt	(entget ent)
  hname	(cdr (assoc 2 tt))
   )
   (if	(setq g (assoc hname lsthatch))
     (progn
(command ".area" "o" ent)
(setq dt  (getvar "area")
      msc (cdr g)
      nsc (/ (sqrt dt) msc)	      
)
(command ".hatchedit" ent "p" "" nsc "")
     )
   )
 )
 (setq ss (ssget '((0 . "HATCH"))))
 (sudung sh ss)
 (princ)
)

(defun sudung (ham ss / sodt index entdt soapp)
 (setq	sodt  (cond
	(ss (sslength ss))
	(t 0)
      )
soapp 0
index 0
 )
 (repeat sodt
   (setq entdt	(ssname ss index)
  index	(1+ index)
   )
   (if	(ham entdt)
     (setq soapp (1+ soapp))
   )
 )
 soapp
)

EM CẢM ƠN BÁC HOÀNH NHÉ!! NHƯNG SAO EM DÙNG CÓ THẤY ĐƯỢC NHƯ Ý EM ĐÂU. HÌNH NHƯ BÁC VẪN CHƯA HIỂU Ý EM, HAY LÀ EM KHÔNG HIỂU ĐOẠN LISP NÀY CỦA BÁC.

Ý CỦA EM LÀ LẬP MỘT LISP MÀ KHI TA VẼ HÌNH CHỮ NHẬT THÌ LẬP TỨC NÓ ĐƯỢC HATCH THEO YÊU CẦU (HATCH "BRASS" VÀ TỶ LỆ GIỮA HATCH VÀ MIỀN DIỆN TÍCH ĐƯỢC HATCH NHƯ TRONG FILE MẪU), TƯƠNG TỰ NHƯ HÌNH TRÒN, ELIP, HAY HÌNH BẤT KỲ. MONG ANH GIÚP.


<<

Filename: 21760_shh.lsp

Trang 266/330

266