Đến nội dung


Hình ảnh
- - - - -

[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


  • Please log in to reply
32 replies to this topic

#1 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 992 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 13 August 2011 - 08:47 AM

Để 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.c...hung_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.
  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#2 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5678 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 13 August 2011 - 08:57 AM

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

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#3 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 992 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 13 August 2011 - 10:10 AM

Đầ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.c...ng_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
  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#4 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5678 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 13 August 2011 - 10:21 AM

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 .... ??
  • 0

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#5 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 992 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 13 August 2011 - 10:29 AM

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, :)
  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#6 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5678 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 13 August 2011 - 01:45 PM

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

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#7 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 992 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 13 August 2011 - 02:36 PM

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
  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#8 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5678 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 13 August 2011 - 02:39 PM

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

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#9 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 992 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 13 August 2011 - 02:49 PM

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
  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#10 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5678 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 13 August 2011 - 05:58 PM

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))))

  • 0

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#11 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

  • Moderator
  • PipPipPipPipPipPipPip
  • 6007 Bài viết
Điểm đánh giá: 3113 (tuyệt vời)

Đã gửi 13 August 2011 - 07:18 PM

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....

Bài viết đã được chỉnh sửa nội dung bởi phamthanhbinh: 15 August 2011 - 02:37 AM
Bổ sung lisp etrim. Sửa lỗi lisp

  • 2
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#12 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5678 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 13 August 2011 - 09:17 PM

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)
)

  • 1

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#13 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5678 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 14 August 2011 - 12:20 AM

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
)
)

  • 2

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#14 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 992 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 14 August 2011 - 08:42 AM

@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.
  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#15 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 992 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 14 August 2011 - 11:44 AM

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")
  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#16 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5678 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 14 August 2011 - 12:47 PM

Đú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
  • 0

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#17 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 992 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 14 August 2011 - 03:19 PM

Đú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 .
  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#18 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5678 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 14 August 2011 - 05:29 PM

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
  • 0

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#19 TRUNGNGAMY

TRUNGNGAMY

    biết lệnh block

  • Members
  • PipPipPipPipPipPip
  • 401 Bài viết
Điểm đánh giá: 91 (tàm tạm)

Đã gửi 14 August 2011 - 06:26 PM

@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 đồ.
  • 0

#20 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 992 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 14 August 2011 - 07:13 PM

@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 :)
  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn