Đến nội dung


Hình ảnh
- - - - -

Giúp xóa chế độ truy bắt điểm trong Lisp


  • Please log in to reply
4 replies to this topic

#1 qh2qa06

qh2qa06

    biết vẽ pline

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

Đã gửi 13 August 2014 - 11:13 AM

Mình có Lisp tính diện tích nhưng mỗi khi dùng Lisp này nó sẽ tắt hết chế độ truy bắt điểm của mình. Nhờ mọi người giúp sửa Lisp này sao cho sau khi dùng lệnh (TDT) thì chế độ truy bắt điểm vẫn còn nguyên.

Cảm ơn mọi người!http://www.cadviet.c...3/64018_tdt.lsp

 

Nhân tiện ai có Lisp FLAT chuyển tất cả đối tượng trong bản vẽ về cùng cao độ thì cho mình xin luôn. Hôm trước mình có xem topic nhưng không dùng được file của gia_bach up lên vì nó không phải file lisp thì phải.

Topic về Lisp FLAT ở đây:

http://www.cadviet.c...o-em-xin-voi-a/


  • 0

#2 thanhduan2407

thanhduan2407

    biết lệnh adcenter

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

Đã gửi 13 August 2014 - 11:21 AM

Lỗi download của diễn đàn, ko lấy về dc.

Bạn đừng up mà hãy post lên mình sửa cho.


  • 1



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







#3 qh2qa06

qh2qa06

    biết vẽ pline

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

Đã gửi 13 August 2014 - 01:20 PM

Lỗi download của diễn đàn, ko lấy về dc.

Bạn đừng up mà hãy post lên mình sửa cho.

;***************** Tinh dien tich va gan vao text ***********

(defun c:TDT()

  (if (= Ty_le nil) (progn

    (setq Ty_le (getreal "\nDrawing scale : "))

    (setq He_so (/ 1 Ty_le))

    (setq He_so2 (* He_so He_so))

    )

  )

  (setq dtl 0)

  (setq ss (ssadd))

  (setq oslast (getvar "OSMODE"))

  (command "osnap" "")

  (print)

  (print)

  (setq pt1 (getpoint "\nPick internal point : "))

  (while (/= pt1 nil)

    (command "-boundary" pt1 "")

    (setq et (entlast))

    (ssadd et ss)

    (command "area" "e" "last")

    (setq vsize ( /(getvar "VIEWSIZE") 300 ))

    (command "hatch" "ANSI31" vsize "0" "last" "")

    (setq et (entlast))

    (ssadd et ss)

    (setq dtcon (getvar "AREA"))

    (setq dtl (+ dtcon dtl))

    (print)

    (print)

    (setq pt1 (getpoint "\nPick internal point : "))

  )

  (setvar "OSMODE" oslast)

  (command "erase" ss "")

  (setq ss nil)

  (command "redraw")

  (setq dtl (/ dtl He_so2) )

  (setq en (car (entsel "Thay cho so : ")))

  (setq elst (entget en))

  (setq elst (subst (cons 1 (strcat  ( rtos dtl  2 2))) (assoc 1 elst) elst))

  (entmod elst)

;  (print)

;  (prompt (strcat "\nTotal area : " (rtos dTy_le 2 2)))

;  (print)

;  (setq pt2 (getpoint "\nPoint to write: "))

;  (command "text" pt2 (/ vsize 6) "0" (rtos dtl 2 2))

);defun


  • 0

#4 thanhduan2407

thanhduan2407

    biết lệnh adcenter

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

Đã gửi 13 August 2014 - 02:24 PM

LISP của bạn còn nhiều hạn chế quá. Bạn dùng LISP này xem, do bác TUE_NV viết:

 

(defun c:TDTNV( / ss lst fid lstEn h) ;;;;TINH DIEN TICH NHIEU VUNG
(vl-load-com)
;;;KHONG CHO HIEN THI CAC THONG TIN LEN MAN HINH TEXT SCREEN
(setvar "CMDECHO" 0)
;;;;;;;;NHAP KHOANG CHO PHEP POLYLINE BI HO 
(setvar "hpgaptol" 0.5)
(defun *error* ( msg )
	(if Olmode (setvar 'osmode Olmode))
  	(if Clor (setvar "CECOLOR" Clor))
	(if (not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
	    (princ (strcat "\nError: " msg))
	)
	(princ)
)
(setq Olmode (getvar 'osmode))
(setq Clor (getvar "CECOLOR"))
(setvar 'osmode 0)
(setvar "CECOLOR" "1")
;;;;TAO LAYER TEXT_AREA VOI COLOR LA 3
(MLA "TEXT_AREA" 3)
;;;;;;;;;;;;NHAP VA LUU CHIEU CAO TEXT;;;;;;;
(or *h* (setq *h* 1))
(setq h (getdist (strcat "\n Nhap chieu cao Text <"
		  (rtos *h* 2 2)
		 ">: "
	  )
 )
)
(if (not h) (setq h *h*) (setq *h* h))

;;;;;;CHUONG TRINH TINH LIEN TUC
(while
	(setq pnt (getpoint "\n Pick diem trong cac vung kin :"))
	(setq DT1 (TDTL pnt))
  	(wtxt (rtos DT1 2 3) Pnt h 0 "C" "TEXT_AREA")
)
(setvar 'osmode Olmode)
(setvar "CECOLOR" Clor)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun TDTL (Pnt / frome toe cur ssSmal H1 );;;tinh dien tich le
(vl-load-com)
(setvar 'osmode 0)
(setq frome (entlast));; chon doi tuong cuoi cung truoc khi boundary
;;;(setq pnt (getpoint "\n Pick diem trong cac vung kin :"))

(command "-boundary" Pnt "");; boundary
(setq toe (entlast));; chon doi tuong cuoi cung sau khi boundary
(setq cur frome; khoi tao
      ssSmal (ssadd)
       DTichLe 0
)
;;;;;KHI TAO BOUNDARY THI NO SE TAO RA MOT SO DOI TUONG (NEU TRONG VUNG KIN DO CO DOI TUONG CHIEM DIEN TICH)
(while (not (eq cur toe));; chon cac doi tuong tu frome den toe
  (progn
	(setq cur (entnext cur)
	       ssSmal (ssadd cur ssSmal)
	)
    	;;;TINH DIEN TICH CUA CAC DOI TUONG SINH RA
    	;;;;DTICH BAN DAU GAN = 0, TRU DI CAC DOI TUONG VUA SINH RA
	(command "area" "S" "O" ssSmal "" "")
    	;;;;;;;GOI DIEN TICH VUA 
	(setq H1 (getvar "area"))
    	;;;TINH DIEN TICH TUNG DOI TUONG SINH RA
	(setq DTichLe (+ DTichLe H1))
  )
)
;;;TINH DIEN TICH TONG TAT CA CAC DOI TUONG 
(command "area" "A" "O" "L" "" "")
;;;;;;;GOI DIEN TICH VUA TINH
(setq H1 (getvar "area"))
(setq DTichLe (+ DTichLe (* H1 2)))
;;;;;;XOA CAC POLYLINE SINH RA SAU LENH BOUNDARY
(command "erase" ssSmal "")
;;;(entmake (list (cons 0 "TEXT") (cons 10 Pnt) (cons 40  5) (cons 1  (rtos DTichLe 2 3))))
DTichLe
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;TAO TEXT ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun wtxt (string Point Height Ang justify Layer / Lst)
 (setq Lst (list '(0 . "TEXT")
   (cons 8 (if Layer Layer (getvar "Clayer")))
   (cons 62 (if Color Color 256))
   (cons 10 point)
   (cons 40 Height)
   (cons 1 string)
   (if Ang (cons 50 Ang))
   (cons 7 (if Style Style (getvar "Textstyle"))))
  justify (strcase justify))
 (cond ((= justify "C") (setq Lst (append Lst (list (cons 72 1) (cons 11 point)))))
       		((= justify "L") (setq Lst (append Lst (list (cons 72 0)(cons 73 0) (cons 10 point)))))
        	((= justify "R") (setq Lst (append Lst (list (cons 72 2) (cons 11 point)))))
        	((= justify "M") (setq Lst (append Lst (list (cons 72 4) (cons 11 point)))))
        	((= justify "TL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 3)))))
        	((= justify "TC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 3)))))
        	((= justify "TR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 3)))))   
        	((= justify "ML") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 2)))))
        	((= justify "MC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 2)))))
        	((= justify "MR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 2)))))
        	((= justify "BL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 1)))))
        	((= justify "BC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 1)))))
        	((= justify "BR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 1))))))
 (entmake Lst)
)
;;;;;;;;;;;;;;;;;;;TAO LAYER MOI ;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun MLA ( name colour );;;;MAKE LAYER
    (if (null (tblsearch "LAYER" name))
        (entmake
            (list
               '(0 . "LAYER")
               '(100 . "AcDbSymbolTableRecord")
               '(100 . "AcDbLayerTableRecord")
               '(70 . 0)
                (cons 2 name)
                (cons 62 colour)
            )
        )
    )
)

  • 1



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







#5 qh2qa06

qh2qa06

    biết vẽ pline

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

Đã gửi 15 August 2014 - 09:09 AM

LISP của bạn còn nhiều hạn chế quá. Bạn dùng LISP này xem, do bác TUE_NV viết:

 

(defun c:TDTNV( / ss lst fid lstEn h) ;;;;TINH DIEN TICH NHIEU VUNG
(vl-load-com)
;;;KHONG CHO HIEN THI CAC THONG TIN LEN MAN HINH TEXT SCREEN
(setvar "CMDECHO" 0)
;;;;;;;;NHAP KHOANG CHO PHEP POLYLINE BI HO 
(setvar "hpgaptol" 0.5)
(defun *error* ( msg )
	(if Olmode (setvar 'osmode Olmode))
  	(if Clor (setvar "CECOLOR" Clor))
	(if (not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
	    (princ (strcat "\nError: " msg))
	)
	(princ)
)
(setq Olmode (getvar 'osmode))
(setq Clor (getvar "CECOLOR"))
(setvar 'osmode 0)
(setvar "CECOLOR" "1")
;;;;TAO LAYER TEXT_AREA VOI COLOR LA 3
(MLA "TEXT_AREA" 3)
;;;;;;;;;;;;NHAP VA LUU CHIEU CAO TEXT;;;;;;;
(or *h* (setq *h* 1))
(setq h (getdist (strcat "\n Nhap chieu cao Text <"
		  (rtos *h* 2 2)
		 ">: "
	  )
 )
)
(if (not h) (setq h *h*) (setq *h* h))

;;;;;;CHUONG TRINH TINH LIEN TUC
(while
	(setq pnt (getpoint "\n Pick diem trong cac vung kin :"))
	(setq DT1 (TDTL pnt))
  	(wtxt (rtos DT1 2 3) Pnt h 0 "C" "TEXT_AREA")
)
(setvar 'osmode Olmode)
(setvar "CECOLOR" Clor)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun TDTL (Pnt / frome toe cur ssSmal H1 );;;tinh dien tich le
(vl-load-com)
(setvar 'osmode 0)
(setq frome (entlast));; chon doi tuong cuoi cung truoc khi boundary
;;;(setq pnt (getpoint "\n Pick diem trong cac vung kin :"))

(command "-boundary" Pnt "");; boundary
(setq toe (entlast));; chon doi tuong cuoi cung sau khi boundary
(setq cur frome; khoi tao
      ssSmal (ssadd)
       DTichLe 0
)
;;;;;KHI TAO BOUNDARY THI NO SE TAO RA MOT SO DOI TUONG (NEU TRONG VUNG KIN DO CO DOI TUONG CHIEM DIEN TICH)
(while (not (eq cur toe));; chon cac doi tuong tu frome den toe
  (progn
	(setq cur (entnext cur)
	       ssSmal (ssadd cur ssSmal)
	)
    	;;;TINH DIEN TICH CUA CAC DOI TUONG SINH RA
    	;;;;DTICH BAN DAU GAN = 0, TRU DI CAC DOI TUONG VUA SINH RA
	(command "area" "S" "O" ssSmal "" "")
    	;;;;;;;GOI DIEN TICH VUA 
	(setq H1 (getvar "area"))
    	;;;TINH DIEN TICH TUNG DOI TUONG SINH RA
	(setq DTichLe (+ DTichLe H1))
  )
)
;;;TINH DIEN TICH TONG TAT CA CAC DOI TUONG 
(command "area" "A" "O" "L" "" "")
;;;;;;;GOI DIEN TICH VUA TINH
(setq H1 (getvar "area"))
(setq DTichLe (+ DTichLe (* H1 2)))
;;;;;;XOA CAC POLYLINE SINH RA SAU LENH BOUNDARY
(command "erase" ssSmal "")
;;;(entmake (list (cons 0 "TEXT") (cons 10 Pnt) (cons 40  5) (cons 1  (rtos DTichLe 2 3))))
DTichLe
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;TAO TEXT ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun wtxt (string Point Height Ang justify Layer / Lst)
 (setq Lst (list '(0 . "TEXT")
   (cons 8 (if Layer Layer (getvar "Clayer")))
   (cons 62 (if Color Color 256))
   (cons 10 point)
   (cons 40 Height)
   (cons 1 string)
   (if Ang (cons 50 Ang))
   (cons 7 (if Style Style (getvar "Textstyle"))))
  justify (strcase justify))
 (cond ((= justify "C") (setq Lst (append Lst (list (cons 72 1) (cons 11 point)))))
       		((= justify "L") (setq Lst (append Lst (list (cons 72 0)(cons 73 0) (cons 10 point)))))
        	((= justify "R") (setq Lst (append Lst (list (cons 72 2) (cons 11 point)))))
        	((= justify "M") (setq Lst (append Lst (list (cons 72 4) (cons 11 point)))))
        	((= justify "TL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 3)))))
        	((= justify "TC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 3)))))
        	((= justify "TR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 3)))))   
        	((= justify "ML") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 2)))))
        	((= justify "MC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 2)))))
        	((= justify "MR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 2)))))
        	((= justify "BL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 1)))))
        	((= justify "BC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 1)))))
        	((= justify "BR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 1))))))
 (entmake Lst)
)
;;;;;;;;;;;;;;;;;;;TAO LAYER MOI ;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun MLA ( name colour );;;;MAKE LAYER
    (if (null (tblsearch "LAYER" name))
        (entmake
            (list
               '(0 . "LAYER")
               '(100 . "AcDbSymbolTableRecord")
               '(100 . "AcDbLayerTableRecord")
               '(70 . 0)
                (cons 2 name)
                (cons 62 colour)
            )
        )
    )
)

Công nhận là lisp này tối ưu hơn lisp cũ của mình. Nhưng với lisp cũ thì nó có hiển thị hatch mặt cắt để mình kiểm tra sơ bộ bằng mắt được, lisp của bạn thì nó tự động quá nên không có khâu này, sợ dễ bị nhầm hơn. Bạn có giúp mình hiển thị được hatch mặt cắt không?

 

Lisp FLAT đưa toàn bộ dữ liệu về cùng cao độ bạn có xem topic mình đưa link và giúp mình luôn được không?

Cảm ơn bạn nhiều!


  • 0