Đến nội dung


Hình ảnh
- - - - -

Lisp chương trình tự động vẽ khung bản đồ


  • Please log in to reply
6 replies to this topic

#1 quanghuy181

quanghuy181

    biết vẽ arc

  • Members
  • PipPip
  • 41 Bài viết
Điểm đánh giá: 1 (bình thường)

Đã gửi 05 January 2009 - 09:50 PM

Mình có đoạn code sau nhưng mà không biết là làm sao khi chạy chương trình thì nó lại không vẽ toàn bộ khung mà thỉnh thoảng lại lỗi ở góc khung và có khi lại chỉ vẽ khung ngoài và vài dòng chữ thập. Các bạn xem rồi chỉnh lại giúp mình nhé

;;; Tu dong ve khung ban do .

(defun c:kh ()
;;; (princ "\n CHUONG TRINH VE KHUNG BAN DO .")
(setvar "blipmode" 1)
(setq sp (getpoint "\n Chon goc khung thu 1 (Goc trai ben tren): "))
(setq ep (getpoint sp "\n Chon goc khung thu 2 (Goc phai ben duoi): "))

; (princ "\n Chon goc khung thu 1 (Goc trai ben tren): ")
; (setq sp (getpoint))

; (prompt "\n Chon goc khung thu 2 (Goc phai ben duoi): ")
; (setq ep (getcorner (getpoint)) )

(setq tyle (getint "\n Hay cho ty le ban do <500>: "))
(if (= tyle nil) (setq tyle 500.0))
(setvar "blipmode" 0)
;;--- Dat bien chung cho chuong trinh -----
(setq x1 (nth 0 sp)) (setq y1 (nth 1 sp))
(setq x2 (nth 0 ep)) (setq y2 (nth 1 ep))
(setq dayn (/ (* tyle 0.05) 500.0))
(setq kctn (/ tyle 100.0))
(setq ktmk (/ (* tyle 1.75) 500.0))
(setq caoc (/ (* tyle 1.20) 500.0))
(setq dich (/ (* tyle 0.33) 500.0))
;;;---- ve khung trong ------
(command "LAYER" "M" "KHUNG" "")
(Command "PLINE"
(list x1 y1)
(list x2 y1)
(list x2 y2)
(list x1 y2)
"C"
)
;;;;-------Ve khung ngoai ----------
(command "LAYER" "M" "KHUNG" "")
(Command "PLINE"
(list (- x1 kctn) (+ y1 kctn)) "w" dayn dayn
(list (+ x2 kctn) (+ y1 kctn))
(list (+ x2 kctn) (- y2 kctn))
(list (- x1 kctn) (- y2 kctn))
"C"
)
;;;------- Ve net ngang va doc -------
(setq nhay (/ tyle 10.0))
(setq tmpX1 (/ x1 nhay)) (setq tmpX2 (fix tmpX1)) (setq x (* tmpX2 nhay))
(setq tmpY1 (/ y2 nhay)) (setq tmpY2 (fix tmpY1)) (setq y (* tmpY2 nhay))
;-------------------------------------
(command "style" "STANDARD" "" caoc "" "" "" "" "" "")
(while (<= x x2)
(if (>= x x1)
(command "LINE" (list x y1) (list x (+ y1 kctn)) ""
"LINE" (list x y2) (list x (- y2 kctn)) ""
"TEXT" "C" (list x (+ y1 (/ kctn 2))) 0. (rtos x 2 0)
"TEXT" "TC" (list x (- y2 (/ kctn 2))) 0. (rtos x 2 0)
)
) ;endif
(setq x (+ x nhay))
)
(while (<= y y1)
(setq tmp1 (rtos y 2 0))
(setq len1 (strlen tmp1))
(if ( <= len1 3)
(progn (setq bef "000") (setq aff tmp1))
(progn (setq bef (substr tmp1 1 (- len1 3)))
(setq aff (substr tmp1 (- len1 2) 3))
)
) ;;if
(if (>= y y2)
(command "LINE" (list x1 y) (list (- x1 kctn) y) ""
"LINE" (list x2 y) (list (+ x2 kctn) y) ""
"TEXT" "BC" (list (- x1 (/ kctn 2)) y) 0. bef
"TEXT" "TC" (list (- x1 (/ kctn 2)) (- y dich)) 0. aff

"TEXT" "BC" (list (+ x2 (/ kctn 2)) y) 0. bef
"TEXT" "TC" (list (+ x2 (/ kctn 2)) (- y dich)) 0. aff
)
); endif
(setq y (+ y nhay))
)
;--------- Ve chu thap --------------
(setq nhay (/ tyle 10.0)) (setq tmpX1 (/ x1 nhay)) (setq tmpX2 (fix tmpX1))
(setq x (* tmpX2 nhay))
(setq tmpY1 (/ y2 nhay)) (setq tmpY2 (fix tmpY1))
(while (< x x2)
(setq y (* tmpY2 nhay))
(while (< y y1)
(if (and (>= x x1) (>= y y2))
(command "LINE" (list (- x ktmk) y) (list (+ x ktmk) y) "")
)
(if (and (>= y y2) (>= x x1))
(command "LINE" (list x (- y ktmk)) (list x (+ y ktmk)) "")
)
(setq y (+ y nhay))
)
(setq x (+ x nhay))
)
(command "REDRAW")
); End of program


  • 0

#2 quanghuy181

quanghuy181

    biết vẽ arc

  • Members
  • PipPip
  • 41 Bài viết
Điểm đánh giá: 1 (bình thường)

Đã gửi 06 January 2009 - 09:44 PM

Nhanh Bác nào giúp em cái. Bình thường vẫn sử dụng ngon lành vậy mà lúc đang cần gấp thì nó lại dở chứng....
  • 0

#3 elleHCSC

elleHCSC

    biết lệnh copy

  • Members
  • PipPipPip
  • 119 Bài viết
Điểm đánh giá: 98 (tàm tạm)

Đã gửi 07 January 2009 - 09:05 AM

Mình có đoạn code sau nhưng mà không biết là làm sao khi chạy chương trình thì nó lại không vẽ toàn bộ khung mà thỉnh thoảng lại lỗi ở góc khung và có khi lại chỉ vẽ khung ngoài và vài dòng chữ thập. Các bạn xem rồi chỉnh lại giúp mình nhé


Đồng chí này ở đâu ra mà lôi được cái code elle viết từ hồi 1998 cũ rích rồi post lung tung lên trên này thế không biết. ^_^
Config osnap bằng nil hết đi thì là đươc. Code đời đầu khi mới mày mò lisp mà
Mã nó rành rành ra thế, có 1 đoạn ngắn thì tìm xem nó bị sao mà ko chạy được chứ...hic
  • 0
Share for all, all will share !

--------------------
HTTP://WWW.HCSC.VN
HTTP://WWW.HCSC.COM.VN

#4 quanghuy181

quanghuy181

    biết vẽ arc

  • Members
  • PipPip
  • 41 Bài viết
Điểm đánh giá: 1 (bình thường)

Đã gửi 07 January 2009 - 12:07 PM

bạn nói Config OSnap bằng nil hết đi là được nghĩa là sao cơ?? Nhờ bạn chỉ dùm cho mình cái...
  • 0

#5 elleHCSC

elleHCSC

    biết lệnh copy

  • Members
  • PipPipPip
  • 119 Bài viết
Điểm đánh giá: 98 (tàm tạm)

Đã gửi 07 January 2009 - 03:04 PM

bạn nói Config OSnap bằng nil hết đi là được nghĩa là sao cơ?? Nhờ bạn chỉ dùm cho mình cái...


http://www.cadviet.c...files/Osnap.bmp

Làm sao để nó được như thế này là Ok...
Bác này chắc mới dùng cad... ^_^ nên chưa rành lắm cái Osnap...hic...giống mình hồi xửa thế...khác elleHCSC là post lisp loạn cả lên...hồi đó internet đâu có dể như bây giờ...hic

elleHCSC sửa lại chút cho ban nè
http://www.cadviet.com/upfiles/k.lsp

Mà sao bác này cứ post lisp lung tung hết cả lên thế ko biết, đúng là tam sao thất bản...diễn đàn nào cũng post...
  • 0
Share for all, all will share !

--------------------
HTTP://WWW.HCSC.VN
HTTP://WWW.HCSC.COM.VN

#6 quanghuy181

quanghuy181

    biết vẽ arc

  • Members
  • PipPip
  • 41 Bài viết
Điểm đánh giá: 1 (bình thường)

Đã gửi 07 January 2009 - 08:39 PM

Cám ơn elle nhé mình sẽ thử xong có gì mình Reply lại nhé!
  • 0

#7 cunipro

cunipro

    biết zoom

  • Members
  • Pip
  • 12 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 02 October 2014 - 01:02 PM

sao khong dow ve duoc vay bac


  • 0