Chuyển đến nội dung
Diễn đàn CADViet
  • Thông báo

    • Nguyen Hoanh

      CADViet đã hoàn tất nâng cấp   14/09/2017

      Chào các bạn, CADViet đã hoàn tất việc nâng cấp lên phiên bản mới. Tất cả các chức năng đã hoạt động theo kỳ vọng của ban quản trị. Nếu có vấn đề gì cần phản hồi, các bản post ở đây nhé: Trân trọng, Nguyễn Hoành.
thanhduan2407

[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    226

@Phamthanhbinh: Hic hic, em cảm ơn bác nhiều. Rất vừa với ý của em.

@Ketxu: Cảm ơn Ketxu nhé

Cả hai đều rất nhiệt tình, em sẽ cố gắng nghiên cứu. Cảm ơn các bác

Mạo muội Bác Bình và Ketxu, em tự sửa cho tốc độ nó nhanh hơn một chút cho cái viết text nó nhanh. Hề hề hề.

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=52041&st=20

(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)
(setq kg (car (entsel "\n Chon khung trong cua vung ban do")))
(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 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")))))
(setq s1 ((lambda (sec) (+ (* 86400 (- sec (fix sec))) 60)) (getvar "DATE")))
(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))
;;;                   (command "text" "j" "mr" (list (- (caar pls3) (/ k 200)) (cadar pls3)) (/ k 200) 0 (rtos (cadar pls3) 2 0))
       	   (wtxt "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))
		            (wtxt "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))
              (wtxt "MR" (list (caar pls3) (- (cadar pls3) (/ k 200))) (/ k 200) (/ pi 2) (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))
	          (wtxt "ML" (list (caadr pls3) (+ (cadadr pls3) (/ k 200))) (/ k 200) (/ pi 2) (rtos (caar pls3) 2 0))
                      )
                  )
            )
      )
      (command "erase" ly "")
      (setq i (1+ i))
)

;;;;;; 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))))
                         )
                      )
             )
       )
)
(setvar "osmode" oldos)
(command "undo" "e")
(setq s2 ((lambda (sec) (+ (* 86400 (- sec (fix sec))) 60)) (getvar "DATE")))
(prompt (strcat   "Thoi gian thuc hien chuong trinh la: " (rtos (- s2 s1) 2 3) " giay"))
(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 wtxt(jt p h tAng txt  / 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 73 2)(cons 11 p)(cons 50  tAng)
(cons 72 (cond ((= jt "R") 2) (T 0)))))
)

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

^^ @ a Duân : Hàm viết text chỉ cond "R" và T, mà bác chơi cả "MR" với "ML" mần chi để nó chui vào trong HCN thế ạ ^^ Và nếu tiện entmake thì cố entmake hết tất tần tật luôn đi ạ. Hề hề.

  • Vote tăng 1

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    226

^^ @ a Duân : Hàm viết text chỉ cond "R" và T, mà bác chơi cả "MR" với "ML" mần chi để nó chui vào trong HCN thế ạ ^^ Và nếu tiện entmake thì cố entmake hết tất tần tật luôn đi ạ. Hề hề.

Hê hê hê, biết là sai rồi nhưng cứ cho vào đấy, có thấy sai đâu. Hê hê, Ketxu chỉnh lại cái hàm tạo text ấy đi, cái thuộc tính "ML, MC, MB, MR ... " anh chả tìm thấy chỗ phân biệt để chui vào đó nhặt. Hic

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

Cái "R" của e thực chất là Midle Right, còn T là midle Left, vì vậy mới có mã 72, 73. A dùng mà k thấy là nó đã ở chế độ midle rồi sao :o.Trong trường hợp e giải quyết bài toán chỉ dùng 2 chế độ đó, viết hết ra mần chi cho hàm nó dài ạ. A muốn có thêm các cái khác thì phải đổi rồi xem entget của nó thôi, hoặc là tìm hàm Make_text bác Thái Bụi viết trên 4r rồi.

  • Vote tăng 1

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

cái này đúng thật sự dúp ích rât nhiều cho n ace trắc địa, cảm ơn cute, nhưng cho mình xin góp thêm chút ý kến. nếu có chuyển khung in và xoay ngang vào Layout thì thật ko còn gi tuyệt vời hơn. tks mọi người

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

Các bác có thể viết lại lips này giúp em theo biên chế bản vẽ như sau được không ạ

Với tỉ lệ 1:1000  thì khung theo trục Y có chiều rộng là 25, theo trục X có chiều rộng là 5

Với tỉ lệ 1:2000  thì khung theo trục Y có chiều rộng là 50, theo trục X có chiều rộng là 10

Em chân thành cảm ơn ạ. 

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

bac phamthanhbinh cho em hỏi chút ạ

Khi em sd lips của bác em chọn khung trong xong thì command hiện Command: ; error: too many arguments

Bác cho em hỏi cách khắc phục ạ

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

bac phamthanhbinh cho em hỏi chút ạ

Khi em sd lips của bác em chọn khung trong xong thì command hiện Command: ; error: too many arguments

Bác cho em hỏi cách khắc phục ạ

Hề hề hề,

 Ây da, cái ni ngộ việt lâu lâu rồi há, chả piết nị dùng lisp nào nữa vì nó đã được chỉnh sửa nhiều nhiều rồi á. vậy nên nị thử post cái lisp mà nị dùng lên coi sao nhé. Lâu nay ngộ cũng không chuyên tâm lắm với nó nên chắc cũng phải mất nhiều nhiều thời gian mới tìm ra cái lỗi à. Nị cứ post cái lisp của nị dùng lên có khi các bác khác sẽ giúp nị nhanh hơn là ngộ đó.

Hề hề hề , thông cảm cho ngộ nhen.

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

Tạo một tài khoản hoặc đăng nhập để nhận xét

Bạn cần phải là một thành viên để lại một bình luận

Tạo tài khoản

Đăng ký một tài khoản mới trong cộng đồng của chúng tôi. Điều đó dễ mà.

Đăng ký tài khoản mới

Đăng nhập

Bạn có sẵn sàng để tạo một tài khoản ? Đăng nhập tại đây.

Đăng nhập ngay


×