[Yêu cầu] Nhờ các bác viết lisp vẽ mắt lưới khung và ghi tọa độ khung HCN nghiêng

Tháng 8 13, 2011

Để phục vụ cho việc biên tập bình đồ và in ấn bản vẽ em thường phải làm một số thao tác thủ công để hoàn thành công việc đó.

Vì kiến thức em còn nông cạn và cũng ít thời gian tập trung ngồi nghiên cứu nên hôm nay em mạo muội xin nhờ các bác giúp đỡ dùm em cái Lisp thực hiện việc tạo mắt lưới khung bình đồ. Cả buổi sáng hì hục vẽ để up lên nhờ các bác viết dùm em. Công việc cũng thiết thực cho ngành trắc địa góp phần nâng cao năng suất lao động và giảm chi phí in ấn nên em rất mong các bác giúp đỡ.

Tất cả các thông số chi tiết về kích thước em đã ghi lên bản vẽ để các bác xem. Nếu thành công được công việc này em sẽ hiến tặng các bác ngành trắc địa với việc in ấn nhanh bình đồ với các khung nghiêng ngang dọc. Cuộc sống là cần chia sẻ, em rất mong các bác quan tâm và giúp đỡ. Em cũng muốn cống hiến nhiều hơn trong diễn đàn Cadviet. Em xin chân thành cảm ơn các bác nhiều.

http://www.cadviet.com/upfiles/3/khung_ban_do.dwg

P/S: Vì em đang có việc bận nên có thể không trả lời ngay một số thắc mắc của các bác nhưng em sẽ cố gắng ngày nào cũng theo dõi vài lần để mong chờ tin các bác.

Tháng 8 13, 2011

Đầu tiên là thiếu điểm cơ sở để tạo grid đã :)

Tháng 8 13, 2011

Đầu tiên là thiếu điểm cơ sở để tạo grid đã :)

Không thiếu đâu Ketxu :rolleyes: , khi kích chọn hình chữ nhật thì sẽ tìm được toạ độ chẵn X và Y (tọa độ này chia hết cho 100 nhân với tỷ lệ mà mình nhập vào). Để minh họa điều này mình sẽ đưa 1 bản vẽ với các tỷ lệ khác nhau cho Ketxu xem.

http://www.cadviet.com/upfiles/3/khung_ban_do_2.dwg

Với ví dụ minh họa thì đều do phần mềm chạy ra, mình toàn làm thủ công với công việc nhặt đó.

Cảm ơn Ketxu đã quan tâm

Tháng 8 13, 2011

Câu này "Dùng phần mềm tạo mắt lưới và ghi tọa độ khung chẵn" là cái gì làm hả bác ? Lisp làm hay cái phần mềm riêng

Với ví dụ minh họa thì đều do phần mềm chạy ra

Nếu là lisp chạy ra thì nó thể hiện bằng cách nào ? Point ? Hay Line vuông góc ? Hay .... ??

Tháng 8 13, 2011

Câu này "Dùng phần mềm tạo mắt lưới và ghi tọa độ khung chẵn" là cái gì làm hả bác ? Lisp làm hay cái phần mềm riêng

Nếu là lisp chạy ra thì nó thể hiện bằng cách nào ? Point ? Hay Line vuông góc ? Hay .... ??

Đây là một e-SUPPORT của EGS phục vụ cho ngành trắc địa (EARTH SCIENCES & SURVEYING), nó rất chuối vì nó được bảo mật và đóng gói, chạy vừa trên Lisp kết hợp VBA. Đại loại là 1 phần mềm tích hợp vào Cad để thực hiện các công việc trắc địa.

Anh muốn có 1 lisp mà nó chạy ra giống như kết quả cuối cùng của việc làm thủ công đó.

Việc anh dùng phần mềm e-SUPPORT để chạy ra tọa độ gắn với khung để minh họa rằng ko cần điểm cơ sở tạo Grid và nó phụ thuộc vào tỷ lệ mình nhập vào.

Hii. Cái thằng e-SUPPORT này anh toàn phải đưa đồng hồ máy tính 2006 thôi mới chạy được. Crack thì chỉ có hacker. Hiii. Cảm ơn Ketxu, :)

Tháng 8 13, 2011

Bác có thể ngó qua thằng này và sửa sang nó (nếu ngại code) :

My link

Tháng 8 13, 2011

Bác có thể ngó qua thằng này và sửa sang nó (nếu ngại code) :

My link

Ketxu chưa xem file đi kèm theo của anh à.

Link Ketxu gửi là tạo mắt lưới dạng điểm mà nó là hình chữ nhật chưa bị xoay.

Các thao tác mà anh muốn Lisp nó làm là:

1. Chọn đối tượng rectang

2. Nhập tỷ lệ bản đồ (Không phải tỷ lệ bản vẽ, dựa vào tỷ lệ mà nó xác định được bước nhảy của mắt lưới dấu thập và kích thước của mắt lưới, text ghi tọa độ của khung)

Qua 2 bước này thì lisp sẽ thực hiện xác định các tọa độ chẵn X và chẵn Y (Như đã nói trước, tọa độ này chia hết cho 100*tỷ lệ nhập vào). Lisp tự động vẽ các dấu thập ở bên trong Rectang với khoảng cách là 100 * tỷ lệ nhập. Tại các khung của bản đồ (Rectang) thì có các râu (line) được vẽ vào trong. Râu dọc thì viết text dọc nằm ngoài khung, râu ngang thì viết text ngang nằm ngoài khung như hình vẽ đã gửi lần trước.

Theo như tham khảo ý kiến bác PhamThanhBình thì bác cũng đưa ra cách giải quyết nhưng anh bận nên chưa thực hiện được.

Cách làm của bác ấy là:

1. Sau khi kích chọn Rectang thì xác định được điểm cơ sở Xmin và Y min, Xmax Ymax (Ghi ghú: Điểm cơ sở ở đây được định nghĩa là điểm có tọa độ chia hết cho 100*tỷ lệ nhập vào).

2. Từ điểm cơ sở đó mình vẽ Xline theo chiều X và Xline theo chiều Y.

3. Xác định giao điểm XLine với khung Rectang (khung bản đồ)

4. Xline theo chiều X thì tại giao điểm đó vẽ 1 line với giao điểm là điểm chính giữa theo chiều X (ngang), tương tự với Xline theo chiều dọc.

5. Extrim để tạo ra các râu quay vào trong với đường bao kín là khung bản đồ.

Như vậy là giải quyết được các râu quay vào trong với kích thước đã ghi trong minh họa.

Còn các text thì muốn nó nằm ngoài khung và không trùng đè lên nhau thì chưa tính.

Tất cả các vấn đề gần như anh ghi vào trong ví dụ minh họa trong file đi kèm rồi.

Ketxu có lòng thì giúp anh với nhé.

Cảm ơn ketxu

Tháng 8 13, 2011

Em lọ mọ tìm link, còn anh thậm chí còn chưa down về dùng thử !

Tháng 8 13, 2011

Em lọ mọ tìm link, còn anh thậm chí còn chưa down về dùng thử !

Down về dùng rồi mà, có 2 cái lisp vẽ thì nó vẫn vậy. Em xem lại dùm anh chút.Hic

Tháng 8 13, 2011

Em down về thì nó lại dùng được :huh:

Nhìn cái lisp không muốn chỉnh luôn :)

;; gridR draws a draws an OS survey grid to the
;; extents of a rectangle. Hallen11, April 2011.
(defun c:gridR ()
(setvar "CMDECHO" 0)
(command "-osnap" "off")
(setq VP1 nil
  interval 0
  scale 0
)
  (while (not (and (= (cdr(assoc 70 VP1)) 1 ) (= (cdr(assoc 0 VP1)) "LWPOLYLINE" )) ) 
	(setq VP1 (entget(car (entsel "\nSelect Rectangle: "))))
  )
  (while (not (or (= interval 10) (= interval 50) (= interval 100)))
	(setq interval (getint "\nEnter Interval: [10/50/100] ")) 
  )
  (while (not (or (= scale 50) (= scale 100) (= scale 200) (= scale 500) (= scale 1000) (= scale 1250)))
	(setq scale (getint "\nEnter Scale: [50/100/200/500/1000/1250] ")) 
  )
(setq txtH (* 0.002 scale))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun xRound (x)
(setq A (atoi(substr
			(rtos x 2 4) 
			(- (vl-string-search "." (rtos x 2 4)) 2)
		  2))
  x1 	(substr 
			(rtos x 2 4) 1
			(- (vl-string-search "." (rtos x 2 4)) 3)
		)
  x2	(cond 
			((= interval 10)
				(cond 
					((< A 5)(setq x2 "00"))
					((and (>= A 5) (< A 15))(setq x2 "10"))
					((and (>= A 15) (< A 25))(setq x2 "20"))
					((and (>= A 25) (< A 35))(setq x2 "30"))
					((and (>= A 35) (< A 45))(setq x2 "40"))
					((and (>= A 45) (< A 55))(setq x2 "50"))
					((and (>= A 55) (< A 65))(setq x2 "60"))
					((and (>= A 65) (< A 75))(setq x2 "70"))
					((and (>= A 75) (< A 85))(setq x2 "80"))
					((and (>= A 85) (< A 95))(setq x2 "90"))
					((>= A 95)(setq x2 "100"))					
				))
			((= interval 50)
				(cond
					((< A 25)(setq x2 "00"))
					((and (>= A 25) (< A 75))(setq x2 "50"))
					((>= A 75)(setq x2 "100"))
				))
			((= interval 100)
				(cond
					((< A 50)(setq x2 "00"))
					((>= A 50)(setq x2 "100"))
				))
		)
)

(if (= x2 "100")
(setq x1 (itoa (+ (atoi x1) 1))
	  x2 "00")
)

(setq G1x (strcat x1 x2))	

(while (<= (atoi G1x) x)
(cond 
	( (= interval 10) (setq G1x (itoa (+ (atoi G1x) 10))) )
	( (= interval 50) (setq G1x (itoa (+ (atoi G1x) 50))) )
	( (= interval 100) (setq G1x (itoa (+ (atoi G1x) 100))) )
)
)
)

(defun FindN (A B)
(rtos (+
		(*
			(/
				(-(cadr B)(cadr A))
				(-(car B)(car A))
			)
		(- (atoi Ex) (car A)))
	(cadr A))
2 4)
)

(defun FindN2 (A B)
(rtos (- (cadr A)
			 (*
				(/
					(-(cadr A)(cadr B))
					(-(car B)(car A))
				)
			 (- (atoi Ex)(car A)))
	   )
2 4)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Get Rec Points ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(setq RC ())
(foreach n VP1
	(cond
		((= (car n) 10) (setq RC (cons (cdr n) RC)) )
	)	  
)
(setq RCx (list (car (nth 0 RC))(car (nth 1 RC))(car (nth 2 RC))(car (nth 3 RC))) )
(cond
	( (and (<= (nth 0 RCx)(nth 1 RCx)) (<= (nth 0 RCx)(nth 2 RCx))(<= (nth 0 RCx)(nth 3 RCx)))
	(setq pt1 (nth 0 RC)) )
	( (and (<= (nth 1 RCx)(nth 0 RCx)) (<= (nth 1 RCx)(nth 2 RCx))(<= (nth 1 RCx)(nth 3 RCx)))
	(setq pt1 (nth 1 RC)) )
	( (and (<= (nth 2 RCx)(nth 1 RCx)) (<= (nth 2 RCx)(nth 0 RCx))(<= (nth 2 RCx)(nth 3 RCx)))
	(setq pt1 (nth 2 RC)) )
	( (and (<= (nth 3 RCx)(nth 1 RCx)) (<= (nth 3 RCx)(nth 2 RCx))(<= (nth 3 RCx)(nth 0 RCx)))
	(setq pt1 (nth 3 RC)) )		
)

(foreach n RC
	(cond
		((and (= (car n) (car pt1))(> (cadr n) (cadr pt1)))
		(setq pt1 n))
	)
)
(setq RC2 ())
(foreach n RC
	(cond
		((not(= n pt1))(setq RC2(cons n RC2)) )
	)
)

(cond
	( (and (> (cadr(nth 0 RC2))(cadr(nth 1 RC2))) (> (cadr(nth 0 RC2))(cadr(nth 2 RC2))) )
	(setq pt2 (nth 0 RC2)) )
	( (and (> (cadr(nth 1 RC2))(cadr(nth 0 RC2))) (> (cadr(nth 1 RC2))(cadr(nth 2 RC2))) )
	(setq pt2 (nth 1 RC2)) )
	( (and (> (cadr(nth 2 RC2))(cadr(nth 1 RC2))) (> (cadr(nth 2 RC2))(cadr(nth 0 RC2))) )
	(setq pt2 (nth 2 RC2)) )
)
(setq RC3 ())
(foreach n RC2
	(cond
		((not(= n pt2))(setq RC3(cons n RC3)) )
	)
)
(if
(> (caar RC3)(caar(cdr RC3)))
	(setq pt3 (car RC3)
		  pt4 (nth 1 RC3))
	(setq pt3 (nth 1 RC3)
		  pt4 (car RC3))
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Eastings and Grid Ticks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(command "-LAYER" "M" "Survey Grid" "C" "5" "" "")
(command "-STYLE" "Survey Grid" "txt" "0.0" "1.0" "20" "N" "N" "N")
(setq Ex (xRound (car pt1)))
(while (< (atof Ex) (car pt2))
(setq 
	Ey (FindN pt1 pt2)
	Ey2 (if (> (atoi Ex) (car pt4))
			(FindN pt4 pt3)
			(FindN2 pt1 pt4)
		)
	StPt (strcat Ex "," Ey) Stpt_1 (list (atof Ex)(atof Ey))
	EndPt (strcat Ex "," Ey2) EndPt_1 (list (atof Ex)(atof Ey2))
)
( ST:Entmake-Line Stpt_1 (list (atof Ex)(- (atof Ey) (* scale 0.01))) "Survey Grid" 1)
;(command "LINE" StPt (strcat Ex "," (rtos (-(atof Ey) (* scale 0.01)) 2 4)) "")

(setq gline (entget (ssname (ssget "L") 0))
	txt1 (strcat (rtos (+ (* 0.0001 scale) (cadr (assoc 10 gline))) 2 4) "," (rtos (caddr (assoc 10 gline)) 2 4))
	txt2 (strcat (rtos (+ (* 0.0001 scale) (cadr (assoc 11 gline))) 2 4) "," (rtos (caddr (assoc 11 gline)) 2 4))
	txt (strcat (rtos (cadr(assoc 10 gline)) 2 4) "E")
)

(command "-mtext" txt1 "S" "Survey Grid" "H" txtH "R" txt2 "J" "BL" txt2 txt "")
(ST:Entmake-Line (list (atof Ex)(+(atof Ey2) (* scale 0.01)))EndPt_1 "Survey Grid" 1)
;(command "LINE" (strcat Ex "," (rtos (+(atof Ey2) (* scale 0.01)) 2 4)) EndPt "")

(setq gline (entget (ssname (ssget "L") 0))
	txt1 (strcat (rtos (+ (* 0.0001 scale) (cadr (assoc 10 gline))) 2 4) "," (rtos (caddr (assoc 10 gline)) 2 4))
	txt2 (strcat (rtos (+ (* 0.0001 scale) (cadr (assoc 11 gline))) 2 4) "," (rtos (caddr (assoc 11 gline)) 2 4))
	txt (strcat (rtos (cadr(assoc 10 gline)) 2 4) "E")
)

(command "-mtext" txt1 "S" "Survey Grid" "H" txtH "R" txt2 "J" "BR" txt2 txt "")


(setq GTy (atoi (xRound (atof Ey2)) ))
	(while (< GTy (atof Ey))
		(setq 
				a (* scale 0.005)
				Lx1 (list (- (atof Ex) a) GTy)
				Lx2 (list (+ (atof Ex) a) GTy)
				Ly1 (list (atof Ex) (- GTy a))
				Ly2 (list (atof Ex) (+ GTy a))
		)
		( ST:Entmake-Line Lx1 Lx2 "Survey Grid" 1)
		( ST:Entmake-Line Ly1 Ly2 "Survey Grid" 1)

		(setq GTy (+ GTy interval))
	)
(setq Ex (rtos (+ (atof Ex) interval) 2 4))
)


(if (not (= (cadr pt1) (cadr pt2)))
(progn
(setq Ex (xRound (car pt2)))
	(while (< (atof Ex) (car pt3))
		(setq 
			Ey (FindN2 pt2 pt3)
			Ey2 (if (> (atoi Ex) (car pt4))
					(FindN pt4 pt3)
					(FindN2 pt1 pt4)
				)
			StPt (strcat Ex "," Ey) Stpt_1 (list (atof Ex)(atof Ey))
			EndPt (strcat Ex "," Ey2) EndPt_1 (list (atof Ex)(atof Ey2))
		)

		( ST:Entmake-Line Stpt_1 (list (atof Ex)(- (atof Ey) (* scale 0.01))) "Survey Grid" 1)
		;(command "LINE" StPt (strcat Ex "," (rtos (-(atof Ey) (* scale 0.01)) 2 4)) "")

		(setq gline (entget (ssname (ssget "L") 0))
			txt1 (strcat (rtos (+ (* 0.0001 scale) (cadr (assoc 10 gline))) 2 4) "," (rtos (caddr (assoc 10 gline)) 2 4))
			txt2 (strcat (rtos (+ (* 0.0001 scale) (cadr (assoc 11 gline))) 2 4) "," (rtos (caddr (assoc 11 gline)) 2 4))
			txt (strcat (rtos (cadr(assoc 10 gline)) 2 4) "E")
		)

		(command "-mtext" txt1 "S" "Survey Grid" "H" txtH "R" txt2 "J" "BL" txt2 txt "")
		(ST:Entmake-Line (list (atof Ex)(+(atof Ey2) (* scale 0.01)))EndPt_1 "Survey Grid" 1)
		;(command "LINE" (strcat Ex "," (rtos (+(atof Ey2) (* scale 0.01)) 2 4)) EndPt "")

		(setq gline (entget (ssname (ssget "L") 0))
			txt1 (strcat (rtos (+ (* 0.0001 scale) (cadr (assoc 10 gline))) 2 4) "," (rtos (caddr (assoc 10 gline)) 2 4))
			txt2 (strcat (rtos (+ (* 0.0001 scale) (cadr (assoc 11 gline))) 2 4) "," (rtos (caddr (assoc 11 gline)) 2 4))
			txt (strcat (rtos (cadr(assoc 10 gline)) 2 4) "E")
		)

		(command "-mtext" txt1 "S" "Survey Grid" "H" txtH "R" txt2 "J" "BR" txt2 txt "")


		(setq GTy (atoi (xRound (atof Ey2)) ))
			(while (< GTy (atof Ey))
				(setq 
						a (* scale 0.005)
						Lx1 (list (- (atof Ex) a) GTy)
						Lx2 (list (+ (atof Ex) a) GTy)
						Ly1 (list (atof Ex) (- GTy a))
						Ly2 (list (atof Ex) (+ GTy a))
				)
				( ST:Entmake-Line Lx1 Lx2 "Survey Grid" 1)
				( ST:Entmake-Line Ly1 Ly2 "Survey Grid" 1)
				(setq GTy (+ GTy interval))
			)
		(setq Ex (rtos (+ (atof Ex) interval) 2 4))
	)
)	
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Northings ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun FindE (A B)
(rtos (+
		(*
			(/
				(-(car B)(car A))
				(-(cadr B)(cadr A))
			)
		(- (atoi Ex) (cadr A)))
	(car A))
2 4)
)

(defun FindE2 (A B)
(rtos (- (car A)
			 (*
				(/
					(-(car A)(car B))
					(-(cadr B)(cadr A))
				)
			 (- (atoi Ex)(car A)))
	   )
2 4)
)


(setq Ex (xRound (cadr pt2)))
(while (> (atof Ex) (cadr pt2))
(setq Ex (rtos (- (atof Ex) interval) 2 4))
)
(while (> (atof Ex) (cadr pt3))
(setq 
	Ey (FindE pt2 pt3)
	Ey2 (if (> (atoi Ex) (cadr pt1))
			(FindE pt2 pt1)
			(FindE2 pt1 pt4)
		)
	StPt (strcat Ey "," Ex)  Stpt_1 (list (atof Ey)(atof Ex))
	EndPt (strcat Ey2 "," Ex)	EndPt_1 (list (atof Ey2)(atof Ex))
)
( ST:Entmake-Line Stpt_1 (list (- (atof Ey) (* scale 0.01)) (atof Ex)) "Survey Grid" 1)
;(command "LINE" StPt (strcat (rtos (-(atof Ey) (* scale 0.01)) 2 4) "," Ex) "")

(setq gline (entget (ssname (ssget "L") 0))
			txt1 (strcat (rtos (cadr (assoc 10 gline)) 2 4) "," (rtos (+ (* 0.0001 scale) (caddr (assoc 10 gline))) 2 4))
			txt2 (strcat (rtos (cadr (assoc 11 gline)) 2 4) "," (rtos (+ (* 0.0001 scale) (caddr (assoc 11 gline))) 2 4))
			txt (strcat (rtos (caddr(assoc 10 gline)) 2 4) "N")
		)

		(command "-mtext" txt2 "S" "Survey Grid" "H" txtH "R" txt1 "J" "BR" txt1 txt "")
(ST:Entmake-Line EndPt_1 (list (+(atof Ey2) (* scale 0.01)) (atof Ex)) "Survey Grid" 1)		
;(command "LINE" EndPt (strcat (rtos (+(atof Ey2) (* scale 0.01)) 2 4) "," Ex) "")

(setq gline (entget (ssname (ssget "L") 0))
			txt1 (strcat (rtos (cadr (assoc 10 gline)) 2 4) "," (rtos (+ (* 0.0001 scale) (caddr (assoc 10 gline))) 2 4))
			txt2 (strcat (rtos (cadr (assoc 11 gline)) 2 4) "," (rtos (+ (* 0.0001 scale) (caddr (assoc 11 gline))) 2 4))
			txt (strcat (rtos (caddr(assoc 10 gline)) 2 4) "N")
		)

		(command "-mtext" txt1 "S" "Survey Grid" "H" txtH "R" txt2 "J" "BL" txt2 txt "")


(setq Ex (rtos (- (atof Ex) interval) 2 4))
)

(if (not (= (cadr pt1) (cadr pt2)))
(progn
(setq Ex (xRound (cadr pt3)))
(while (> (atof Ex) (cadr pt3))
	(setq Ex (rtos (- (atof Ex) interval) 2 4))
)
(while (> (atof Ex) (cadr pt4))
	(setq 
		Ey (FindE pt3 pt4)
		Ey2 (if (> (atoi Ex) (cadr pt1))
				(FindE2 pt2 pt1)
				(FindE pt1 pt4)
			)
		StPt (strcat Ey "," Ex)
		EndPt (strcat Ey2 "," Ex)
	)

	(command "LINE" StPt (strcat (rtos (-(atof Ey) (* scale 0.01)) 2 4) "," Ex) "")

	(setq gline (entget (ssname (ssget "L") 0))
				txt1 (strcat (rtos (cadr (assoc 10 gline)) 2 4) "," (rtos (+ (* 0.0001 scale) (caddr (assoc 10 gline))) 2 4))
				txt2 (strcat (rtos (cadr (assoc 11 gline)) 2 4) "," (rtos (+ (* 0.0001 scale) (caddr (assoc 11 gline))) 2 4))
				txt (strcat (rtos (caddr(assoc 10 gline)) 2 4) "N")
			)

			(command "-mtext" txt2 "S" "Survey Grid" "H" txtH "R" txt1 "J" "BR" txt1 txt "")

	(command "LINE" EndPt (strcat (rtos (+(atof Ey2) (* scale 0.01)) 2 4) "," Ex) "")

	(setq gline (entget (ssname (ssget "L") 0))
				txt1 (strcat (rtos (cadr (assoc 10 gline)) 2 4) "," (rtos (+ (* 0.0001 scale) (caddr (assoc 10 gline))) 2 4))
				txt2 (strcat (rtos (cadr (assoc 11 gline)) 2 4) "," (rtos (+ (* 0.0001 scale) (caddr (assoc 11 gline))) 2 4))
				txt (strcat (rtos (caddr(assoc 10 gline)) 2 4) "N")
			)

			(command "-mtext" txt1 "S" "Survey Grid" "H" txtH "R" txt2 "J" "BL" txt2 txt "")


	(setq Ex (rtos (- (atof Ex) interval) 2 4))
)
)
)
(command "-osnap" "End,Mid,Cen,Int,Perp,Near")		
(setvar "CMDECHO" 1)


(princ)
)
(defun ST:Entmake-Line (pt1 pt2 lay color)(entmakex (list (cons 0 "Line")(cons 10 pt1)(cons 11 pt2)(cons 8 lay)(cons 62 color))))

Tháng 8 13, 2011

Down về dùng rồi mà, có 2 cái lisp vẽ thì nó vẫn vậy. Em xem lại dùm anh chút.Hic

Hề hề hề,

Mình thì lại lọ mọ viết. Ra được cái này có vẻ đúng với ý của bác. Tuy nhiên cũng còn tí khó chịu, ấy là tùy theo các góc nghiêng của khung chữ nhật và tỷ lệ bản vẽ nhập vố mà có thể các text số vẫn còn cưỡi lên nhau tí ti. Bác cứ dùng thử và cho ý kiến để mình lọ mọ thêm tí nữa vậy...


(defun c:khbd (/ p1 d r g k p2 p3 p4 kg pls1 pls2 xmin ymin xmax ymax pmin pmax 
                   l1 l2 sh sc ss ss1 ss2 i pls3 lx ly)
(vl-load-com)
(Command "undo" "be")
(command "ucs" "w")
(alert "\n Ve khung trong cua vung ban do")
(setq p1  (getpoint "\n Nhap diem goc ban do"))
(setq d (getreal "\n Nhap chieu dai vung ban do: ")
       r (getreal "\n Nhap chieu rong vung ban do: ")
       g (getangle  p1 "\n Nhap goc quay ban do: ")
       k (getreal "\n Nhap ty le ban do: ")
)
(command "pline" p1 (setq p2 (polar p1 g d))
                              (setq p3 (polar p2 (+ g (/ pi 2)) r))
                              (setq p4 (polar p3 (+ g pi) d))
                              "c"
)
(setq kg (entlast))
(setq pls1 (acet-ent-geomextents kg))
(setq pls2 (acet-geom-vertex-list kg))
(command "zoom" "W" (car pls1) (cadr pls1))
(setq xmin (* (fix (/ (car (vl-sort (mapcar '(lambda (x) (car x)) pls2) '(lambda (a b ) (< a b )))) 100)) 100))
(setq ymin (* (fix (/ (car (vl-sort (mapcar '(lambda (y) (cadr y)) pls2) '(lambda (a b ) (< a b )))) 100)) 100))
(setq xmax (* (fix (/ (car (vl-sort (mapcar '(lambda (x) (car x)) pls2) '(lambda (a b ) (> a b )))) 100)) 100))
(setq ymax (* (fix (/ (car (vl-sort (mapcar '(lambda (y) (cadr y)) pls2) '(lambda (a b ) (> a b )))) 100)) 100))
(setq pmin (list xmin ymin))
(setq pmax (list xmax ymax))
(setq sh (+ 2 (fix (/ (- ymax ymin) (/ k 10)))))
(setq sc (+ 2 (fix (/ (- xmax xmin) (/ k 10)))))
;;;;; Tao luoi diem
(linepx (list (- xmin (/ k 200)) ymin) (/ k 100))
(setq l1 (entlast))
(linepy (list xmin (- ymin (/ k 200))) (/ k 100)) 
(setq l2 (entlast))
(command "array" l1 l2 "" "r" sh sc (/ k 10) (/ k 10))
(setq ss1 (ssget "cp" pls2))
(setq ss (ssget ))
(setq ss2 (subss ss ss1))
(command "erase" ss2 "")
;;;;;;;;Ket thuc tao luoi diem

;;;;;; Ve rau danh so toa do
(setq i 0)
(repeat sh
      (linepx (list (- xmin k) (+ ymin (* i (/ k 10)))) (+ (- xmax xmin) (* 2 k)))
      (setq lx (entlast))
      (setq pls3 (vl-sort (acet-geom-intersectwith lx kg 0) '(lambda (a b ) (< (car a) (car b )))))
      (if pls3
            (progn
                  (linepx (car pls3) (/ k 200))
                  ;;;;;(entmake (list (cons 0 "text") (cons 40 (/ k 200)) (cons 50 0.0)
                                     ;;;;; (cons 8 "GRD_UTMGRID") (cons 1 (rtos (cadar pls3) 2 0))
                                     ;;;;; (cons 72 2) (cons 11 (car pls3)) (cons 73 2))
                  ;;;;;)
                  (command "text" "j" "mr" (list (- (caar pls3) (/ k 200)) (cadar pls3)) (/ k 200) 0 (rtos (cadar pls3) 2 0))
                  (if (cadr pls3)
                      (progn
                                (linepx (cadr pls3) (- (/ k 200)))
                                (command "text" "j" "ml" (list (+ (caadr pls3) (/ k 200)) (cadadr pls3)) (/ k 200) 0 (rtos (cadadr pls3) 2 0))
                      )

                  )
            )
      )
      (command "erase" lx "")
      (setq i (1+ i))
)
(setq i 0)
(repeat sc
      (linepy (list (+ xmin (* i (/ k 10))) (- ymin k )) (+  (- ymax ymin) (* 2 k)))
      (setq ly (entlast))
      (setq pls3 (vl-sort (acet-geom-intersectwith ly kg 0) '(lambda (a b ) (< (cadr a) (cadr b )))))
      (if pls3
            (progn
                  (linepy (car pls3) (/ k 200))
                  (command "text" "j" "mr" (list (caar pls3) (- (cadar pls3) (/ k 200))) (/ k 200) 90 (rtos (caar pls3) 2 0))
                  (if (cadr pls3)
                      (progn
                      (linepy (cadr pls3) (- (/ k 200)))
                      (command "text" "j" "ml" (list (caadr pls3) (+ (cadadr pls3) (/ k 200))) (/ k 200) 90 (rtos (caadr pls3) 2 0))
                      )
                  )
            )
      )
      (command "erase" ly "")
      (setq i (1+ i))
)
(etrim kg (list (+ xmax k) (+ ymax k)))
;;;;;; Ket thuc ve rau danh so toa do



(command "undo" "e")
(princ)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;-------------------------------------------------------------------------------
(Defun DTR(x) (/ (* x pi) 180) ) ;;;change degree to radian, return REAL
;;;-------------------------------------------------------------------------------
(defun lineP (p0 a r / p1) ;;;Line polar: point, degree angle, radius
   (setq p1 (polar p0 (dtr a) r))
   (command "line" p0 p1 "")
)
;;;-------------------------------------------------------------------------------
(defun linePX (p0 x) (lineP p0 0 x)) ;;;Horizontal line: length x, from p0
;;;-------------------------------------------------------------------------------
(defun linePY (p0 y) (lineP p0 90 y)) ;;;Vertical line: length y, from p0
;;;-------------------------------------------------------------------------------

(defun subss ( ss1 ss2 / lst1 lst2)
(setq lst1 (acet-ss-to-list ss1))

(setq lst2 (acet-ss-to-list ss2))

(foreach x lst2
      (if (member x lst1)
          (setq lst1 (vl-remove x lst1))
      )
)
(setq ss3 (acet-list-to-ss lst1))
ss3
)
(defun etrim ( na a / la b d e1 lst lst2 n j k m ss na2 na3 na4
                     x y z flag flag2 flag3 zlst vpna vplocked
            )


(setq e1 (entget na));setq
(if (or (setq flag (equal (acet-dxf 0 e1) "POLYLINE"))
       (setq flag (equal (acet-dxf 0 e1) "LWPOLYLINE"))
       (equal (acet-dxf 0 e1) "LINE")
       (equal (acet-dxf 0 e1) "CIRCLE")
       (equal (acet-dxf 0 e1) "ARC")
       (equal (acet-dxf 0 e1) "ELLIPSE")
       (equal (acet-dxf 0 e1) "TEXT")
       (equal (acet-dxf 0 e1) "ATTDEF")
       (equal (acet-dxf 0 e1) "MTEXT")
       (equal (acet-dxf 0 e1) "SPLINE")
   );or
   (progn
    (if (and flag
             (equal 8 (logand 8 (acet-dxf 70 e1)))
        );and
        (setq flag nil)
    );if
    (setq     a (trans a 1 0)
           vpna (acet-currentviewport-ename)
    );setq
    (acet-ucs-cmd (list "_View"))

    (setq   lst (acet-geom-object-point-list na nil)  ;;;find extents of selected cutting edge object
            lst (acet-geom-list-extents lst)
              x (- (car (cadr lst)) (car (car lst)))
              y (- (cadr (cadr lst)) (cadr (car lst)))
              x (* 0.075 x)
              y (* 0.075 y)
              z (list x y)
              x (list (+ (car (cadr lst)) (car z))
                      (+ (cadr (cadr lst)) (cadr z))
                );list
              y (list (- (car (car lst)) (car z))
                      (- (cadr (car lst)) (cadr z))
                );list
           zlst (zoom_2_object (list x y))
    );setq
    (if vpna
        (setq vplocked (acet-viewport-lock-set vpna nil)) ;unlock cur viewport if needed.
    );if
    (command "_.zoom" "_w" (car zlst) (cadr zlst))

    (entupd na)                  ;;;update the ent. so it's curves display smoothly

    (setq lst (acet-geom-object-point-list na
                      (/ (acet-geom-pixel-unit) 2.0)
              )
    );setq
    (if (or (not flag)
            (not (acet-geom-self-intersect lst nil))
        );or
        (progn             ;then the object is valid and not a self intersecting polyline.
         (if (and flag
                  (equal (car lst) (last lst) 0.0001)
             );and
             (setq flag3 T);then the polyline could potentialy need a second offset
         );if
         (if (setq la (acet-layer-locked (getvar "clayer")))
             (command "_.layer" "_unl" (getvar "clayer") "")
         );if

         (command "_.pline")
         (setq b nil)
         (setq n 0);setq
         (repeat (length lst)
          (setq d (nth n lst))
          (if (not (equal d b 0.0001))
             (progn
              (command d)
              (setq lst2 (append lst2 (list d)));setq
              (setq b d);setq
             );progn
          );if
          (setq n (+ n 1))
         );repeat
         (command "")
         (setq  na2 (entlast)
                 ss (ssadd)
                 ss (ssadd na2 ss)
                lst nil
         );setq
         (acet-ss-visible ss 1)
         (setq lst2 (get_fence_points na2 a lst2 flag3 flag));setq

         (if la
             (command "_.layer" "_lock" (getvar "clayer") "")
         );if
         (acet-ucs-cmd (list "_p"))
         ;Move the ents to force a display update of the ents to avoid viewres problems.
         (setvar "highlight" 0)
         (if (setq ss (ssget "_f" (last lst2)))
             (command "_.move" ss "" "0,0,0" "0,0,0")
         );if
         (if flag
             (progn
              (if (setq la (acet-layer-locked (acet-dxf 8 e1)))
                  (command "_.layer" "_unl" (acet-dxf 8 e1) "")
              );if
              (acet-ucs-set-z (acet-dxf 210 e1))
              (command "_.copy" na "" "0,0,0" "0,0,0")
              ;(entdel na)
              (acet-ss-visible (ssadd na (ssadd)) 1);make it invisible for a while.
                                                   ;rk 12:01 PM 3/10/98
              (setq na3 na
                     na (entlast)
              );setq
              (command "_.pedit" na "_w" "0.0" "_x")
              (acet-ucs-cmd (list "_p"))
              (if la (command "_.layer" "_lock" (acet-dxf 8 e1) ""));if
             );progn
         );if
         (command "_.trim" na "")
         (setq m (- (length lst2) 1));setq
         (setq k 0)
         (repeat (length lst2)
          (setq lst (nth k lst2))
          (setq a (trans (car lst) 0 1))
          (setq n 1)
          (repeat (- (length lst) 1) ;repeat each fence list
           (setq b (trans (nth n lst) 0 1))
           (if (equal a b 0.0001)
               (setq flag2 T)
               (setq flag2 nil)
           );if
           (setq na4 nil);setq
           (setq j 0);setq
           (while (not flag2)       ;repeat each segment of the fence until no new ents are created.
            (setq na4 (entlast));setq
            (command "_F" a b "")
            (if (and (equal na4 (entlast))
                     (or (not (equal k m))
                         (> j 0)
                     );or
                );and
                (setq flag2 T)
            );if
            (setq j (+ j 1));setq
           );while
           (setq a B);setq
           (setq n (+ n 1));setq
          );repeat

          (setq k (+ k 1))
         );repeat
         (command "")

         (if flag
             (progn
              (if (setq la (acet-layer-locked (acet-dxf 8 e1)))
                  (command "_.layer" "_unl" (acet-dxf 8 e1) "")
              );if
              (entdel na) ;get rid of the copy

              ;(entdel na3);bring back the original
              (acet-ss-visible (ssadd na3 (ssadd)) 0) ;bring back the original
                                                     ;rk 12:01 PM 3/10/98
              (if la (command "_.layer" "_lock" (acet-dxf 8 e1) ""));if
             );progn
         );if
        );progn
        (progn
         (acet-ucs-cmd (list "_p"))
         (princ "\nSelf intersecting edges are not acceptable.")
        );progn else invalid self intersecting polyline
    );if
    (command "_.zoom" "_p")
    (if vplocked
        (acet-viewport-lock-set vpna T) ;then re-lock the viewport
    );if
   );progn then it's a most likely a valid entity.
);if
);defun etrim
(defun zoom_2_object ( lst / p1 p2 p3 p4 p5 p6 mp dx dy dx2 dy2
                            r1 r2 na e1 x w h dv1 dv2 x
                    )

(setq  lst (acet-geom-m-trans lst 1 2)
        p1 (acet-geom-m-trans (acet-geom-view-points) 1 2)    ;p1 and p2 are the viewpnts
        p2 (cadr p1)
        p1 (car p1)
        p1 (list (car p1) (cadr p1))
        p2 (list (car p2) (cadr p2))
);setq
(if lst
    (progn
     (setq   p5 (acet-geom-list-extents lst)              ;p5 and p6 are the geometry points
             p6 (cadr p5)
             p5 (car p5)
             p5 (list (car p5) (cadr p5))
             p6 (list (car p6) (cadr p6))
             mp (acet-geom-midpoint p5 p6)           ;prepare to resize the geometry rectang to
             dx (- (car p2) (car p1))    ;have the same dy/dx ratio as p1 p2.
             dy (- (cadr p2) (cadr p1))
            dx2 (- (car p6) (car p5))
            dy2 (- (cadr p6) (cadr p5))
     );setq
     (if (equal dx 0.0)  (setq dx 0.000001))  ;just in case div by zero
     (if (equal dx2 0.0) (setq dx2 0.000001))
     (setq   r1 (/ dy dx)
             r2 (/ dy2 dx2)
     );setq
     (if (< r2 r1)
         (setq dy2 (* r1 dx2));then scale dy2 up
         (progn
          (if (equal r1 0.0)  (setq r1 0.000001))  ;just in case div by zero
          (setq dx2 (* dy2 (/ 1.0 r1)));else scale dx2 up
         );progn
     );if
     (setq p5 (list (- (car mp) (/ dx2 1.98))   ;1.98 is used instead of 2.0 to expand
                    (- (cadr mp) (/ dy2 1.98))  ;the rectangle slightly
              );list
           p6 (list (+ (car mp) (/ dx2 1.98))
                    (+ (cadr mp) (/ dy2 1.98))
              );list
     );setq
    );progn then lst
);if
(if (and lst
         (equal 0 (getvar "tilemode"))
         (not (equal 1 (getvar "cvport")))
         (setq na (acet-currentviewport-ename))
    );and
    (progn
     (setq  e1 (entget na)
             x (cdr (assoc 10 e1))
             w (cdr (assoc 40 e1))
             h (cdr (assoc 41 e1))
            p3 (list (- (car x) (/ w 2.0))
                     (- (cadr x) (/ h 2.0))
               );list
            p4 (list (+ (car x) (/ w 2.0))
                     (+ (cadr x) (/ h 2.0))
               );list
            p3 (trans p3 3 2)      ;p3 and p4 are the viewport points
            p4 (trans p4 3 2)
           dv1 (acet-geom-delta-vector p1 p3)
           dv2 (acet-geom-delta-vector p2 p4)
             x (distance p1 p2)
     );setq
     (if (equal 0 x) (setq x 0.000001));just in case
     (setq   x (/ (distance p5 p6)
                  x
               )
           dv1 (acet-geom-vector-scale dv1 x)
           dv2 (acet-geom-vector-scale dv2 x)
            p5 (acet-geom-vector-add p5 dv1)
            p6 (acet-geom-vector-add p6 dv2)
      );setq
    );progn then
);if
(setq p1 (list (car p1) (cadr p1) 0.0)
      p2 (list (car p2) (cadr p2) 0.0)
      p5 (list (car p5) (cadr p5) 0.0)
      p6 (list (car p6) (cadr p6) 0.0)
);setq
(if lst
    (setq lst (list (trans p5 2 1)
                    (trans p6 2 1)
              );list
    );setq
    (setq lst nil)
);if

lst
);defun zoom_2_object

(defun get_fence_points ( na2 a lst2 flag plflag / a1 a2 pl1 pl2 b c d n
                                                  lst lst2 lst3 lst4 na
                       )

(if flag
   (progn
    (setq lst2 (cdr lst2));setq
    (repeat (fix (/ (length lst2) 2))
     (setq lst2 (append (cdr lst2) (list (car lst2)));append
     );setq
    );repeat
    (setq lst2 (append lst2 (list (car lst2))));setq
    (command "_.area" "_ob" na2)
    (setq pl1 (getvar "perimeter")
           a1 (getvar "area")
    );setq
   );progn
);if

(setq    a (trans a 0 1)
        b (* (getvar "viewsize") 0.05);initial offset distance
        n 3.0                         ;number of offsets
        d (/ b (- n 1))               ;delta offset
        c (acet-geom-pixel-unit)
     lst4 (acet-geom-view-points)
);setq

(while (> b c)
(setq na (entlast))
(command "_.offset" b na2 a "")
(if (and (not (equal na (entlast)))
        (setq lst3 (acet-geom-vertex-list (entlast)))
        (or (not plflag)
            (setq lst3 (intersect_check lst2 lst3 lst4))
        );or
   );and
   (progn
    (setq lst3 (acet-geom-m-trans lst3 1 0))
    (acet-ss-visible (ssadd (entlast) (ssadd)) 1)
    (if flag
        (progn
         (command "_.area" "_ob" (entlast))
         (setq pl2 (getvar "perimeter")
                a2 (getvar "area")
         );setq
        );progn
    );if
    (setq lst (append lst (list lst3)));setq
    (entdel (entlast))  ;delete the ent after getting it's vertex info
    (if flag
        (setq lst (append lst
                          (another_offset pl1 pl2 a1 a2 b na2 lst2 a lst3 lst4)
                  );append
        );setq
    );if
   );progn then offset was a success
   (if (not (equal na (entlast))) (entdel (entlast)));if else
);if
(setq b (- b d));setq
);while
(setq na (entlast))
(command "_.offset" c na2 a "")
(if (and (not (equal na (entlast)))
        (setq lst3 (acet-geom-vertex-list (entlast)))
        (or (not plflag)
            (setq lst3 (intersect_check lst2 lst3 lst4))
        );or
   );and
   (progn
    (setq lst3 (acet-geom-m-trans lst3 1 0))
    (acet-ss-visible (ssadd (entlast) (ssadd)) 1)
    (if flag
        (progn
         (command "_.area" "_ob" (entlast))
         (setq pl2 (getvar "perimeter")
                a2 (getvar "area")
         );setq
        );progn
    );if
    (setq lst (append lst (list lst3)));setq
    (entdel (entlast));then offset was a success so delete the ent after getting it's info
    (if flag
        (setq lst (append lst
                          (another_offset pl1 pl2 a1 a2 c na2 lst2 a lst3 lst4)
                  );append
        );setq
    );if
   );progn then
   (if (not (equal na (entlast))) (entdel (entlast)));if else
);if
(entdel na2)

lst
);defun get_fence_points
(defun intersect_check ( lst lst2 lst3 / x x2 y y2 lst4 flag len len2
                                        a aa b bb c d n j)

(setq  len (length lst)
     len2 (length lst2)
        x (car (car lst3))
       x2 (car (cadr lst3))
        y (cadr (car lst3))
       y2 (cadr (cadr lst3))
);setq

(setq n 0);setq
(while (and (not flag)
           (< (+ n 1) len2)
      );and
(setq   aa (nth n lst2)
       bb (nth (+ n 1) lst2)
        a (bns_truncate_2_view aa bb x y x2 y2)
        b (bns_truncate_2_view bb aa x y x2 y2)
     lst4 (append lst4 (list a))
);setq
(if (or (not (equal a aa))
       (not (equal b bb))
   );or
   (setq lst4 (append lst4 (list B)))
);if
(setq j 0);setq
(while (and (not flag)
            (< (+ j 1) len)
       );and
(setq    c (nth j lst)
         d (nth (+ j 1) lst)
      flag (inters a b c d)
);setq

(setq j (+ j 1));setq
);while

(setq n (+ n 1));setq
);while
(if (not (equal b (last lst4)))
   (setq lst4 (append lst4 (list B)));setq
);if
(if (not flag)
   (setq flag lst4)
   (setq flag nil)
);if
flag
);defun intersect_check
(defun another_offset ( pl1 pl2 a1 a2 b na2 lst2 a lst3 lst4 / na ss lst da1 da2)

(setq da1 (abs (- a2 a1)));setq
(setq da2 (- (* b (max pl2 pl1))
            (/ (* b (abs (- pl2 pl1)))
                2.0
            )
         )
);setq
(if (> (abs (- da2 da1))
      (* 0.01 (max a1 a2))
   )
   (progn

    (acet-pline-make (list lst2))
    (setq  na (entlast)
          na2 (entlast)
           ss (ssadd)
           ss (ssadd na ss)
    );setq
    (acet-ss-visible ss 1)
    (command "_.offset" b na2 a "")
    (if (and (not (equal na (entlast)))
             (setq lst3 (acet-geom-vertex-list (entlast)))
             (setq lst3 (intersect_check lst2 lst3 lst4))
        );and
        (progn
         (acet-ss-visible (ssadd (entlast) (ssadd)) 1)
         (command "_.area" "_ob" (entlast))
         (setq pl2 (getvar "perimeter")
                a2 (getvar "area")
         );setq
         (setq lst (list (acet-geom-vertex-list (list (entlast) 0))));setq
         (entdel (entlast));then offset was a success so delete the ent after getting it's info
        );progn then
        (if (not (equal na (entlast))) (entdel (entlast)));if else
    );if
    (entdel na2)
   );progn then let's do that second offset
);if

lst
);defun another_offset

Trong lisp này có xài mấy thứ mót được của bác SSG , Ketxu và các bác khác nữa, mong các bác không giận khi mình xài chùa....

Chỉnh sửa Tháng 8 14, 2011 theo phamthanhbinh
Bổ sung lisp etrim. Sửa lỗi lisp

Tháng 8 13, 2011

Theo em thì ý bác Duân nó na ná thế này. Các phần text sau e chưa viết, dùng array có vẻ nhanh, tuy nhiên theo e cách này có vẻ rối^^

P/S : dạo này e hạn chế ACET nên code dài lắm ^^

(defun c:test (/ lstIn lstAll)
(defun round+ (num prec) ;num : real
 (if (< 0 prec)
   (* prec
      (if (minusp (setq num (/ num prec)))
    (fix num)
    (if (= num (fix num))
      num
      (fix (1+ num))
    )
      )
   )
   num
 )
)
(defun dxf (code ent)(cdr (assoc code (entget ent))))
(defun ST:List-Filter (lst vl)(mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) vl)) lst)))
(defun ST:Entmake-Line (p1 p2 col)(entmakex (list (cons 0 "LINE")(cons 10 p1)(cons 11 p2)(cons 62 col))))
(defun ST:Entmake-Point (pt Len / lstEn)
(append (list (ST:Entmake-Line (mapcar '- pt (list (/ len 2) 0 0))(mapcar '+ pt (list (/ len 2) 0 0)) 1)) 
(list (ST:Entmake-Line (mapcar '- pt (list 0 (/ len 2)  0))(mapcar '+ pt  (list 0 (/ len 2)  0)) 1)))
)
(defun ST:Ss->ListEnt (ss / n e l)
 (setq n (sslength ss))
 (while (setq e (ssname ss (setq n (1- n))))
   (setq l (cons e l))
 )  
)

;====================================== 
;========= Start Rountine Here ========
;======================================

(setq e (car(entsel)))
(vla-getboundingbox (vlax-ename->vla-object e) 'p1 'p2)
(mapcar  '(lambda (a B) (* 0.5 (+ a B)))
(setq p1 (vlax-safearray->list p1)) (setq p2(vlax-safearray->list p2)))
(setq oldOs (getvar "osmode")		
	dump (setvar "osmode" 0)
	rnd 300 
	lengthx (abs (- (car p2) (car p1)))
	lengthy (abs (- (cadr p2) (cadr p1)))
	xStart (round+ (float (car p1)) rnd)	
	numx (fix (/ lengthx rnd))
	yStart (round+ (float (cadr p1)) rnd) 
	numy (fix (/ lengthy rnd))
	pntStart (list Xstart Ystart)
	i 1
	lstss (ssadd)
	elast (entlast)
	lstRec (ST:List-Filter (entget e) 10)
	Point (ST:Entmake-Point (list xStart ysTart) 40)
)
(command ".-array" (car Point ) (cadr Point) "" "r" numy numx	rnd rnd)

(while (setq elast (entnext elast))(setq lstAll (cons elast lstAll)))
(setq lstIn (ST:Ss->ListEnt (ssget "wp" lstRec)))
;Xoa ngoai :
(foreach ename lstAll (if (not (vl-position ename lstIn))(entdel ename)))
(setq lstIn (vl-sort lstIn '(lambda (x y)(< (cadr (dxf 10 x))(cadr (dxf 10 y))))))
(command "zoom" "o" (car lstIn) "") ; Lay diem duoi cung
(setvar "osmode" oldOs)	
)

Tháng 8 13, 2011

Theo như tham khảo ý kiến bác PhamThanhBình thì bác cũng đưa ra cách giải quyết nhưng anh bận nên chưa thực hiện được.

5. Extrim để tạo ra các râu quay vào trong với đường bao kín là khung bản đồ.

Như vậy là giải quyết được các râu quay vào trong với kích thước đã ghi trong minh họa.

Còn các text thì muốn nó nằm ngoài khung và không trùng đè lên nhau thì chưa tính.

@ bác D :

Xanh : :blush: Đến bao giờ đây ạ ???? E vẫn nhớ e nhờ bác cái lisp modify dim từ rất lâu rồi....Làm cái j cũng vậy thôi, quan trọng nhất vẫn là quyết làm

Tím : không nên lạm dụng Express quá ^^

Đỏ : Làm được nhưng làm quá trình trở nên rườm rà bác ạ, và với cách đặt TextBase, thi thoảng mới xảy ra hiện tượng trùng chữ

E tặng bác, hy vọng bác hài lòng, tốc độ có nhanh hơn cái lisp e gửi bài đầu

(defun c:gridS (/ round+ ST:Entmake-Point  ST:Entmake-Line wtxt ST:GGBP ST:Ent-IntersObj
			e tile_tmp  dis rau tHeight len_per p1 p2 x1 x2 x1_tmp y1_tmp lstInter
			1st 2nd objLine
			)


;===================================
;======== Local Functions Area =====
;===================================


(defun round+ (num prec)
 (if (< 0 prec)
   (* prec
      (if (minusp (setq num (/ num prec)))
    (fix num)
    (if (= num (fix num))
      num
      (fix (1+ num))
    )
      )
   )
   num
 )
)
(defun ST:Entmake-Point (pt Len / lstEn)
(append (list (ST:Entmake-Line (mapcar '- pt (list (/ len 2) 0 0))(mapcar '+ pt (list (/ len 2) 0 0)) 1)) 
(list (ST:Entmake-Line (mapcar '- pt (list 0 (/ len 2)  0))(mapcar '+ pt  (list 0 (/ len 2)  0)) 1)))
)
(defun ST:Entmake-Line (p1 p2 col)(entmakex (list (cons 0 "LINE")(cons 10 p1)(cons 11 p2)(cons 62 col))))
(defun ST:Ent-IntersObj (e1 e2  / ob1 ob2 g L i kq)
(setq
   ob1 (vlax-ename->vla-object e1)
   ob2 (vlax-ename->vla-object e2))	
(setq g (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendNone)))
(if (/= (vlax-safearray-get-u-bound g 1) -1) (setq L (vlax-safearray->list g)))
(setq i 0)
(repeat (/ (length L) 3)
   (setq kq (append (list (list (nth i L) (nth (+ i 1) L) (nth (+ i 2) L))) kq))
   (setq i (+ i 3))
)
kq
)
(defun wtxt(txt p h tAng jt / sty d h1 h2 wf h) ;;;Write txt on graphic screen at p
(setq    sty   (getvar "textstyle") ) 
(entmakex (list (cons 0 "TEXT") (cons 7 sty) (cons 40 h)(cons 1 txt) (cons 10 p)(cons 62 4)(cons 73 2)(cons 11 p)(cons 50  tAng)
(cons 72 (cond ((= jt "R")2) (T 0)))))
)
(defun ST:GGBP (p1 p2 dis len_perLine / x1) ;trai -> phai
	(setq x1 (round+ (car p1) dis))
	(repeat (fix (/ (distance p1 p2) dis))
		(ST:Entmake-Point  (list  x1 (cadr p1))	len_perLine)
		(setq x1 (+ x1 dis))))


;==============================			
;         Start here		
;==============================
(grtext -1 "Free lisp from CADVIET @Ketxu")
(setq e (car(entsel "\nCh\U+1ECDn HCN :")))
(or #tile (setq #tile 500))
(setq tile_tmp (getint (strcat "\nT\U+1EC9 l\U+1EC7 b\U+1EA3n \U+0111\U+1ED3 < " (rtos #tile 2 0) " > : ")))
(if tile_tmp (setq #tile tile_tmp))

(setq dis (/ #tile 10.0)
	rau (/ #tile 200.0)
	tHeight rau
	len_per (/ #tile 100.0)
)
(vla-getboundingbox (vlax-ename->vla-object e) 'p1 'p2)
(mapcar  '(lambda (a B) (* 0.5 (+ a B)))
(setq p1 (vlax-safearray->list p1)) (setq p2(vlax-safearray->list p2)))
(setq x1 (car p1) x2 (car p2) y1 (cadr p1) y2 (cadr p2) y1_tmp (round+ y1 dis) x1_tmp (round+ x1 dis))
;;; DoX 
(repeat (fix (/ (abs (- y1 y2)) dis))
	(setq objLine (ST:Entmake-Line (list x1 y1_tmp)(list x2 y1_tmp) 1))
	(setq y1_tmp (+ y1_tmp dis) 
			lstInter (ST:Ent-IntersObj (entlast) e)
			lstInter (vl-sort lstInter '(lambda (x y) (< (car x)(car y))))
			1st (car lstInter) 2nd (cadr lstInter)
	)
	;Trai
	(ST:Entmake-Line 1st (mapcar '+ 1st (list rau 0 0)) 3)
	(wtxt (rtos (cadr 1st) 2 0) (mapcar '- 1st (list rau 0 0)) tHeight 0 "R")
	;Phai
	(ST:Entmake-Line 2nd (mapcar '- 2nd (list rau 0 0)) 3)
	(wtxt (rtos (cadr 2nd) 2 0) (mapcar '+ 2nd (list rau 0 0)) tHeight 0 "L")
	(ST:GGBP (car lstInter) (cadr lstInter) dis len_per)				
	(entdel objLine)
;;Do sth else		

)
;;DoY
(repeat (fix (/ (abs (- x1 x2)) dis))
	(setq objLine (ST:Entmake-Line (list x1_tmp y1)(list x1_tmp y2) 1))
	(setq x1_tmp (+ x1_tmp dis) 
			lstInter (ST:Ent-IntersObj (entlast) e)
			lstInter (vl-sort lstInter '(lambda (x y) (< (cadr x)(cadr y))))
			1st (car lstInter) 2nd (cadr lstInter)
	)
	;Duoi
	(ST:Entmake-Line 1st (mapcar '+ 1st (list 0 rau 0)) 3)
	(wtxt (rtos (car 1st) 2 0) (mapcar '- 1st (list 0 rau 0)) tHeight (/ pi 2) "R")
	;Tren
	(ST:Entmake-Line 2nd (mapcar '- 2nd (list 0 rau 0 )) 3)
	(wtxt (rtos (cadr 2nd) 2 0) (mapcar '+ 2nd (list 0 rau 0 )) tHeight (/ pi 2) "L")		

	(entdel objLine)
;;Do sth else		
) 
)

Tháng 8 14, 2011

@Ketxu, @Phamthanhbinh: Không biết phải nói thế nào đây, mình cảm động quá. Bài toán rất phức tạp, code lại dài mà các bác ấy lại nhiệt tình đến như vậy.

@Ketxu: Công nhận là anh lười, không tập trung giải quyết triệt để để làm cái dim đó, nhưng vì tính chất công việc của anh nó đòi hỏi không chỉ biết về Cad mà còn nhiều lĩnh vực khác mà chỉ có anh em Trắc Địa mới hiểu nên anh phải tranh thủ thời gian rảnh mà phân phối thời gian tập trung nghiên cứu từng vấn đề. Nếu chỉ có mỗi Cad thôi thì niềm đam mê đó ko chỉ dừng lại ở đó. Lisp em gửi chạy rất mượt, tốc độ khủng khiếp và đúng là đã đạt yêu cầu bài toán (Tuy nhiên một số text nó vẫn đè lên nhau khi text ngang và dọc nó gần nhau, cái này ko tính). Đúng là không nên lợi dụng Express nhiều, lỗi thì chả biết đâu mà tìm. Cảm ơn Ketxu nhiều.

@Phamthanhbinh: Cảm ơn bác Bình, bác rất nhiệt tình và luôn hết lòng vì anh em mà ngày đêm lọ mọ viết code và thuật toán. Hic, em mà loay hoay viết Code thì không biết đến bao giờ vì trình độ còn hạn hẹp. Em cũng muốn mót được như bác. Cảm ơn bác nhiều.

Tháng 8 14, 2011

P/s: Ketxu xem lại dùm anh cái ghi text nhé. Các Text ghi tọa độ chẵn chia hết cho 100*tỷ lệ nhập vào, tức là tại các râu thì các Text ghi tọa độ chẵn chứ ko phải tọa độ cái đỉnh râu đó. Như vậy là sẽ có 2 cặp text ghi tọa độ X và Y giống nhau. Ketxu xem lại và chỉnh sửa lại cho anh nhé. Cảm ơn Ketxu

P/s: Text ghi ngang thì được rồi nhưng text ghi dọc thì nó lại là tọa độ của đỉnh râu. Thôi để anh tự sửa cũng được. Nhầm nhọt tọa độ ấy mà. Hiii

P/s: Sai ở chỗ

;Tren

(ST:Entmake-Line 2nd (mapcar '- 2nd (list 0 rau 0 )) 3)

(wtxt (rtos (cadr 2nd) 2 0) (mapcar '+ 2nd (list 0 rau 0 )) tHeight (/ pi 2) "L")

Tháng 8 14, 2011

Đúng rồi ạ, mis chỗ đó thôi, text đứng lấy car nhưng e copy xuống mà chưa sửa hết. Text trùng có thể bác thử tự xử lý xem sao. Với mỗi lần tạo text xong thì lấy ssget "c" xung quanh text box của text đó, nếu gặp phải text khác thì move text này đi 1 đoạn tùy theo ý bác

Tháng 8 14, 2011

Đúng rồi ạ, mis chỗ đó thôi, text đứng lấy car nhưng e copy xuống mà chưa sửa hết. Text trùng có thể bác thử tự xử lý xem sao. Với mỗi lần tạo text xong thì lấy ssget "c" xung quanh text box của text đó, nếu gặp phải text khác thì move text này đi 1 đoạn tùy theo ý bác

Giúp anh thì giúp cho chót với ketxu. Lại mày mò lisp của người khác thì đó là 1 cực hình đối với anh. Cái miss lúc nãy thì dễ phát hiện chứ cái này anh chả biết. Nhón tay giúp anh tí nha. Hii. :D .

Tháng 8 14, 2011

Rất tiếc là cái phần này không liên quan gì đến các phần khác, nên không phải mày mò bác ạ :blush: Dòng nào tạo chữ nó có cái chữ Wtxt rất là to rồi

Tháng 8 14, 2011

@ketxu : Mình thấy lisp rất hay nhưng khi thử trên HCN thẳng đứng thì nó hay bị thiếu một hàng dọc bên phải và một hàng ngang trên cùng. Trong HCN nghiêng cũng bỏ sót một số vị trí kg có lưới chữ thập

@thanhduan2407 : Mình nghĩ lưới chữ thập kg nên dùng 2 đt cắt nhau mà nên sd block có tên là "luoi" chẳng hạn để phân biệt với nội dung (các đường line) trong bản đồ.

Tháng 8 14, 2011

@ketxu : Mình thấy lisp rất hay nhưng khi thử trên HCN thẳng đứng thì nó hay bị thiếu một hàng dọc bên phải và một hàng ngang trên cùng. Trong HCN nghiêng cũng bỏ sót một số vị trí kg có lưới chữ thập

@thanhduan2407 : Mình nghĩ lưới chữ thập kg nên dùng 2 đt cắt nhau mà nên sd block có tên là "luoi" chẳng hạn để phân biệt với nội dung (các đường line) trong bản đồ.

Đồng ý với ý kiến của bác TRUNGNGAMY, chắc bác chạy nhiều lần và soi rất kỹ nên phát hiện ra điều đó. Còn với việc phân việc phân biệt với các đối tượng của bản đồ thì em có ý tưởng khác. Em chỉ làm mắt lưới cho việc in bình đồ thôi. Khi nào hoàn thành xong cái này thì em sẽ cho ra sản phẩm mới kết hợp giữa các Lisp. Em tạo mắt lưới và ghi tọa độ khung chỉ là tạo ra một Wblock để insert vào layout khi in ấn chứ ko để trong model thì nó sẽ đè lên các đối tượng của bản đồ. Do vậy mà em cố ý đưa text ra ngoài khung để ko bị trùng đè với các đối tượng khác trong bản đồ. Cảm ơn bác đã đóng góp ý kiến :)

P/s: Ketxu: Uhm, anh thử tìm tòi xem, không biết cái khung ngoài text nó như thế nào nhỉ? Để anh xem lại cái lisp của bác Gia_Bach về xóa text đè nhau xem sao. Hiii. Anh lười mà, hee :)

Tháng 8 14, 2011

@bác Trung,a Duan : cái dấu thập tạo bằng hàm entmake-Point, có thể thay bằng bất cứ gì cũng được ạ, k khó khăn gì. Còn vấn đề bỏ sót là do vấn đề số vòng lặp e dùng hàm fix, có thể không được như ý, nếu cần a Duan có thể thay bằng while

@a Duan : bác chú ý hàm textbox là được, và chỉ cần xử lý với text ở bước chèn DoY.

Tháng 8 14, 2011

Đồng ý với ý kiến của bác TRUNGNGAMY, chắc bác chạy nhiều lần và soi rất kỹ nên phát hiện ra điều đó. Còn với việc phân việc phân biệt với các đối tượng của bản đồ thì em có ý tưởng khác. Em chỉ làm mắt lưới cho việc in bình đồ thôi. Khi nào hoàn thành xong cái này thì em sẽ cho ra sản phẩm mới kết hợp giữa các Lisp. Em tạo mắt lưới và ghi tọa độ khung chỉ là tạo ra một Wblock để insert vào layout khi in ấn chứ ko để trong model thì nó sẽ đè lên các đối tượng của bản đồ. Do vậy mà em cố ý đưa text ra ngoài khung để ko bị trùng đè với các đối tượng khác trong bản đồ. Cảm ơn bác đã đóng góp ý kiến :)

P/s: Ketxu: Uhm, anh thử tìm tòi xem, không biết cái khung ngoài text nó như thế nào nhỉ? Để anh xem lại cái lisp của bác Gia_Bach về xóa text đè nhau xem sao. Hiii. Anh lười mà, hee :)

Hề hề hề,

Cái khung bao text nó ở đây nè:

textbox Function

Measures a specified text object, and returns the diagonal coordinates of a box that encloses the text

(textbox elist)

Arguments

elist

An entity definition list defining a text object, in the format returned by entget.

If fields that define text parameters other than the text itself are omitted from elist, the current (or default) settings are used.

The minimum list accepted by textbox is that of the text itself.

Return Values

A list of two points, if successful; otherwise nil.

The points returned by textbox describe the bounding box of the text object as if its insertion point is located at (0,0,0) and its rotation angle is 0. The first list returned is generally the point (0.0 0.0 0.0) unless the text object is oblique or vertical, or it contains letters with descenders (such as g and p). The value of the first point list specifies the offset from the text insertion point to the lower-left corner of the smallest rectangle enclosing the text. The second point list specifies the upper-right corner of that box. Regardless of the orientation of the text being measured, the point list returned always describes the lower-left and upper-right corners of this bounding box

Còn nếu chịu dùng acet thì: (acet-ent-geomextents ename)

@ Bác ketxu: Hề hề hề, đúng là dùng express tools thì nó ngắn hơn nhưng mà phải ngẫm nhiều hơn và người đi mót sẽ khó mót hơn. Tuy nhiên khi đã có mà không dùng thì nó cũng ..... ngơ ngơ thế nào ấy bác ạ. Vậy nên mình cũng chỉ dám dùng những thứ mà ít nhiều cũng đã được mọi người xài trên diễn đàn rồi thôi. (vì là mình mót được mà). Còn nhiều cái khác đọc chửa ngấm nên vẫn chả dám xài đành để làm vốn ngâm từ từ bác ạ.

Cái express tools này cũng lạ, có cái nó cho dùng với hàm command, còn có cái lại chỉ được dùng như hàm của lisp. Thật tức như bò đá. Bác có biết lý do thì giải thích giùm mình một chút. Tỷ như cái extrim chẳng hạn. Có lúc dùng (etrim .... ) thì Ok nhưng có lúc lại báo lỗi unknown command.

Như cái lisp mình viết gửi bác thanhduan2407, ở máy mình thì không sao nhưng sang máy của bác ấy thì cứ unknown hoài. Vậy nên mình mới điên tiết, copy luôn cả cái etrim vào cuối cho bác ấy mà chả biết có dùng được không nữa.

Hề hề hề, Như vậy đâm ra ngắn quá hóa dài bác ạ......

@ Bác Thanhduan2407: Mình đã sửa lại lisp để tránh hiện tượng bỏ sót râu mà bạn đã gặp, đồng thời bổ sung luôn cục lisp Etrim vào cuối lisp để bác dùng khỏi bị lỗi. Tuy nhiên có một cách là bác add luôn cai thằng lisp Extrim vào startup Suit của CAD để khỏi cần đoạn lisp Etrim bổ sung đó. Hoặc trước khi chạy lisp này bác thực hiện chơi một lệnh Extrim trong CAD là nó hết báo lỗi của hàm (etrim ..... ) bác ạ.

Tháng 8 14, 2011

@ Bác ketxu: Hề hề hề, đúng là dùng express tools thì nó ngắn hơn nhưng mà phải ngẫm nhiều hơn và người đi mót sẽ khó mót hơn. Tuy nhiên khi đã có mà không dùng thì nó cũng ..... ngơ ngơ thế nào ấy bác ạ. Vậy nên mình cũng chỉ dám dùng những thứ mà ít nhiều cũng đã được mọi người xài trên diễn đàn rồi thôi. (vì là mình mót được mà). Còn nhiều cái khác đọc chửa ngấm nên vẫn chả dám xài đành để làm vốn ngâm từ từ bác ạ.

Cái express tools này cũng lạ, có cái nó cho dùng với hàm command, còn có cái lại chỉ được dùng như hàm của lisp. Thật tức như bò đá. Bác có biết lý do thì giải thích giùm mình một chút. Tỷ như cái extrim chẳng hạn. Có lúc dùng (etrim .... ) thì Ok nhưng có lúc lại báo lỗi unknown command.

Như cái lisp mình viết gửi bác thanhduan2407, ở máy mình thì không sao nhưng sang máy của bác ấy thì cứ unknown hoài. Vậy nên mình mới điên tiết, copy luôn cả cái etrim vào cuối cho bác ấy mà chả biết có dùng được không nữa.

Hề hề hề, Như vậy đâm ra ngắn quá hóa dài bác ạ......

- Em phát hiện ra là khá nhiều hàm ACET thực hiện trên cơ chế của (command...) , thành ra cũng hết mê tín nó ^^

=> Chịu khó dần dần viết lại được cái j ngắn ngắn thì viết ^^

Giả như cái thằng acet-ent-geomextents cũng có thể tạm hài lòng với :

(defun myself-ent-geomextents (ename / p1 p2)
(vla-getboundingbox (vlax-ename->vla-object ename) 'p1 'p2)

(mapcar '(lambda (a x) (* 0.5 (+ a x)))

(setq p1 (vlax-safearray->list p1)) (setq p2(vlax-safearray->list p2)))

(list p1 p2))

, mặc dù so về tốc độ thì không bằng ^^. Cứ dần dà như thế, ta sẽ bỏ được câu "Bạn nhớ là máy phải có Express rồi nhé ^^, nhất là viết chương trình mình dùng.

- Vụ Unknown thì e cũng không rõ ^^ Nếu dùng (etrim..) thì chỉ có thể báo chưa định nghĩa hàm thôi ạ.

Thường thì các lệnh ACET thực hiện rất quy củ theo bố cục :

(defun C:Lệnh (/ ...) ; Thủ tục
(defun Hàm (Đối số) ...)

(setq Đối số .......)

(Hàm Đối số) ;Hàm

)

Giả dụ như cái bạn Extrim, ta muốn gọi nó như 1 thủ tục thì gọi (c:Lệnh) ( ở đây là (c:extrim))

Muốn gọi nó như 1 hàm thì phải tìm code của nó để lôi ra cái tên Hàm + các đối số (ở đây là Etrim)

Vấn đề là tìm được code của nó. 1 số thứ trong file lisp thì ta có thể dùng chương trình tìm theo nội dung để lôi nó ra :)

- Ví dụ ở đây ta tìm được hàm etrim trong file Extrim.lsp, thư mục Expres với giải thích rõ ràng :

;Entity-TRIM function
;takes: na - entity name

; a - a point, the side to trim on

;NOTE: This function does not allow for the possible miss of

; non-continuous linetypes.

(defun etrim ( na a / ....)

;

^^

Tháng 8 14, 2011

@bác Trung,a Duan : cái dấu thập tạo bằng hàm entmake-Point, có thể thay bằng bất cứ gì cũng được ạ, k khó khăn gì. Còn vấn đề bỏ sót là do vấn đề số vòng lặp e dùng hàm fix, có thể không được như ý, nếu cần a Duan có thể thay bằng while

@a Duan : bác chú ý hàm textbox là được, và chỉ cần xử lý với text ở bước chèn DoY.

Hề hề hề,

Không phải dùng while dâu bác Ketxu ơi, bác cứ nhớ bài toán trồng cây hồi lớp 4 là giải được cái vụ thiếu grid ấy mà. Số line phải là số khoảng cách cộng 1 bác ạ.

Việc các text cưỡi lên nhau thì move cũng được nhưng như vậy thì các text sẽ cách khung không đều nhau -> hơi xấu trai bác ạ. Giá có cách nào để cho các text này cứ đều tăm tắp thì hay quá. Chiều dài text lại không hẳn là cố định nên hơi khó xác định cái khoảng cách này. Vả lại còn cái góc xoay của khung nữa. Hề hề hề, khó quá.....

Tháng 8 15, 2011

Giúp anh thì giúp cho chót với ketxu. Lại mày mò lisp của người khác thì đó là 1 cực hình đối với anh. Cái miss lúc nãy thì dễ phát hiện chứ cái này anh chả biết. Nhón tay giúp anh tí nha. Hii. :D .

Hề hề hế,

Nhón thế này có được không hè???


(defun c:khbd (/ k kg pls1 pls2 xmin ymin xmax ymax pmin pmax 
                   l1 l2 sh sc ss ss1 ss2 i pls3 lx ly pc stxt1 stxt2 ltxt ltx stx)
(vl-load-com)
(Command "undo" "be")
(command "ucs" "w")
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
;;;;;;(alert "\n Chon khung trong cua vung ban do")
;;;;;;(setq p1  (getpoint "\n Nhap diem goc ban do"))
(setq kg (car (entsel "\n Chon khung trong cua vung ban do")))

;;;;;;(command "pline" p1 (setq p2 (polar p1 g d))
;;;;;;                               (setq p3 (polar p2 (+ g (/ pi 2)) r))
;;;;;;                               (setq p4 (polar p3 (+ g pi) d))
;;;;;;                               "c"
;;;;;;)
;;;;(setq kg (entlast))
(setq pls1 (acet-ent-geomextents kg))
(setq pls2 (acet-geom-vertex-list kg))
(command "zoom" "W" (car pls1) (cadr pls1))
(setq xmin (* (fix (/ (car (vl-sort (mapcar '(lambda (x) (car x)) pls2) '(lambda (a B) (< a B)))) 100)) 100))
(setq ymin (* (fix (/ (car (vl-sort (mapcar '(lambda (y) (cadr y)) pls2) '(lambda (a B) (< a B)))) 100)) 100))
(setq xmax (* (fix (/ (car (vl-sort (mapcar '(lambda (x) (car x)) pls2) '(lambda (a B) (> a B)))) 100)) 100))
(setq ymax (* (fix (/ (car (vl-sort (mapcar '(lambda (y) (cadr y)) pls2) '(lambda (a B) (> a B)))) 100)) 100))
(setq pmin (list xmin ymin))
(setq pmax (list xmax ymax))
(setq ;;;;;d (getreal "\n Nhap chieu dai vung ban do: ")
       ;;;;;r (getreal "\n Nhap chieu rong vung ban do: ")
       ;;;;;g (getangle  p1 "\n Nhap goc quay ban do: ")
       k (getreal "\n Nhap ty le ban do: ")
)
(setq sh (+ 2 (fix (/ (- ymax ymin) (/ k 10)))))
(setq sc (+ 2 (fix (/ (- xmax xmin) (/ k 10)))))
;;;;; Tao luoi diem
(linepx (list (- xmin (/ k 200)) ymin) (/ k 100))
(setq l1 (entlast))
(linepy (list xmin (- ymin (/ k 200))) (/ k 100)) 
(setq l2 (entlast))
(command "array" l1 l2 "" "r" sh sc (/ k 10) (/ k 10))
(setq ss1 (ssget "cp" pls2))
(command "zoom" "e")
(setq ss (ssget "c" pmin (list (+ xmax k) (+ ymax k)) (list (cons 0 "line"))))
(setq ss2 (subss ss ss1))
(command "erase" ss2 "")
(command "zoom" "p")
;;;;;;;;Ket thuc tao luoi diem
(setq ss2 (acet-ss-to-list (ssget "f" pls2 (list (cons 0 "line")))))
(foreach e ss2
      (setq pc (car (acet-geom-intersectwith e kg 0)))
      (if (= (cadr (assoc 10 (entget e))) (cadr (assoc 11 (entget e))))
          (if (setq sp (ssget "c" (list (- (cadr (assoc 10 (entget e))) (/ k 200)) (+ (caddr (assoc 10 (entget e))) (/ k 10)))
                                        (list (+ (cadr (assoc 10 (entget e))) (/ k 200)) (+ (caddr (assoc 11 (entget e))) (/ k 10)))
                                        (list (cons 0 "line")) ))
              (command "break" e pc (cdr (assoc 10 (entget e))))
              (command "break" e pc (cdr (assoc 11 (entget e))))
          )
       )
       (if (= (caddr (assoc 10 (entget e))) (caddr (assoc 11 (entget e))))
          (if (setq sp (ssget "c" (list (+ (cadr (assoc 10 (entget e))) (/ k 10)) (- (caddr (assoc 10 (entget e))) (/ k 200)))
                                        (list (+ (cadr (assoc 11 (entget e))) (/ k 10)) (+ (caddr (assoc 11 (entget e))) (/ k 200)))
                                        (list (cons 0 "line")) ))
              (command "break" e pc (cdr (assoc 10 (entget e))))
              (command "break" e pc (cdr (assoc 11 (entget e))))
           )
        )
)

;;;;;; Ve rau danh so toa do
(setq i 0)
(repeat sh
      (linepx (list (- xmin k) (+ ymin (* i (/ k 10)))) (+ (- xmax xmin) (* 2 k)))
      (setq lx (entlast))
      (setq pls3 (vl-sort (acet-geom-intersectwith lx kg 0) '(lambda (a B) (< (car a) (car B)))))
      (if pls3
            (progn
                  (linepx (car pls3) (/ k 200))
                  ;;;;;(entmake (list (cons 0 "text") (cons 40 (/ k 200)) (cons 50 0.0)
                                     ;;;;; (cons 8 "GRD_UTMGRID") (cons 1 (rtos (cadar pls3) 2 0))
                                     ;;;;; (cons 72 2) (cons 11 (car pls3)) (cons 73 2))
                  ;;;;;)
                  (command "text" "j" "mr" (list (- (caar pls3) (/ k 200)) (cadar pls3)) (/ k 200) 0 (rtos (cadar pls3) 2 0))
                  (if (cadr pls3)
                      (progn
                                (linepx (cadr pls3) (- (/ k 200)))
                                (command "text" "j" "ml" (list (+ (caadr pls3) (/ k 200)) (cadadr pls3)) (/ k 200) 0 (rtos (cadadr pls3) 2 0))
                      )

                  )
            )
      )
      (command "erase" lx "")
      (setq i (1+ i))
)
(setq i 0)
(repeat sc
      (linepy (list (+ xmin (* i (/ k 10))) (- ymin k )) (+ (- ymax ymin) (* 2 k)))
      (setq ly (entlast))
      (setq pls3 (vl-sort (acet-geom-intersectwith ly kg 0) '(lambda (a B) (< (cadr a) (cadr B)))))
      (if pls3
            (progn
                  (linepy (car pls3) (/ k 200))
                  (command "text" "j" "mr" (list (caar pls3) (- (cadar pls3) (/ k 200))) (/ k 200) 90 (rtos (caar pls3) 2 0))
                  (if (cadr pls3)
                      (progn
                      (linepy (cadr pls3) (- (/ k 200)))
                      (command "text" "j" "ml" (list (caadr pls3) (+ (cadadr pls3) (/ k 200))) (/ k 200) 90 (rtos (caadr pls3) 2 0))
                      )
                  )
            )
      )
      (command "erase" ly "")
      (setq i (1+ i))
)

;;;;(etrim kg (list (+ xmax k) (+ ymax k)))
;;;;;; Ket thuc ve rau danh so toa do

(setq stxt1 (acet-ss-to-list (ssget "x" (list (cons 0 "text") (cons 50 (/ pi 2)) (cons 72 2)))))
(foreach txt stxt1
       (setq ltxt (acet-ent-geomextents txt))
       (setq stx (acet-ss-to-list (ssget "c" (car ltxt) (cadr ltxt) (list (cons 0 "text")))))
       (if (> (length stx) 1)
           (progn
                    (foreach tx stx
                           (if (not (eq tx txt))
                               (progn
                                      (setq ltx (acet-ent-geomextents tx))
                                      (command "move" txt "" (cadr ltxt) (list (caadr ltxt) (- (cadar ltx) (/ k 100))))
                               )
                            )
                    )
           )
       )
)
(setq stxt2 (acet-ss-to-list (ssget "x" (list (cons 0 "text") (cons 50 (/ pi 2)) (cons 72 0)))))
(foreach txt stxt2
       (setq ltxt (acet-ent-geomextents txt))
       (setq stx (acet-ss-to-list (ssget "c" (car ltxt) (cadr ltxt) (list (cons 0 "text")))))
       (if (> (length stx) 1)
           (foreach tx stx
                     (if (not (eq tx txt))
                         (progn
                                 (setq ltx (acet-ent-geomextents tx))
                                 (command "move" txt "" (car ltxt) (list (caar ltxt) (+ (cadadr ltx) (/ k 100))))
                         )
                      )
             )
          ;;;;;;;;;; (command "move" txt "" (car ltxt) (list (caar ltxt) (cadadr ltxt)))
       )
)


(setvar "osmode" oldos)
(command "undo" "e")
(princ)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;-------------------------------------------------------------------------------
(Defun DTR(x) (/ (* x pi) 180) ) ;;;change degree to radian, return REAL
;;;-------------------------------------------------------------------------------
(defun lineP (p0 a r / p1) ;;;Line polar: point, degree angle, radius
   (setq p1 (polar p0 (dtr a) r))
   (command "line" p0 p1 "")
)
;;;-------------------------------------------------------------------------------
(defun linePX (p0 x) (lineP p0 0 x)) ;;;Horizontal line: length x, from p0
;;;-------------------------------------------------------------------------------
(defun linePY (p0 y) (lineP p0 90 y)) ;;;Vertical line: length y, from p0
;;;-------------------------------------------------------------------------------

(defun subss ( ss1 ss2 / lst1 lst2)
(setq lst1 (acet-ss-to-list ss1))

(setq lst2 (acet-ss-to-list ss2))

(foreach x lst2
      (if (member x lst1)
          (setq lst1 (vl-remove x lst1))
      )
)
(setq ss3 (acet-list-to-ss lst1))
ss3
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

Hề hề hề, nếu vẫn chưa ưng thì bác nhón tay post lên để mình sửa lại nhé.......

Đăng nhập

[Yêu cầu] Nhờ các bác viết lisp vẽ mắt lưới khung và ghi tọa độ khung HCN nghiêng

Các bài được khuyến nghị

thanhduan2407 272

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

ketxu 2.984

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

thanhduan2407 272

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

ketxu 2.984

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

thanhduan2407 272

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

ketxu 2.984

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

thanhduan2407 272

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

ketxu 2.984

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

thanhduan2407 272

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

ketxu 2.984

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

phamthanhbinh 3.146

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

ketxu 2.984

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

ketxu 2.984

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

thanhduan2407 272

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

thanhduan2407 272

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

ketxu 2.984

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

thanhduan2407 272

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

ketxu 2.984

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

TRUNGNGAMY 91

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

thanhduan2407 272