Viết Lisp theo yêu cầu

Tháng 6 19, 2009

Chào bạn xuantran
việc đo chiều dài từ điểm gấp khúc đến điểm đâu nếu viết theo dạng K?+??? thì cũng không khó, chỉ cần bạn nói ra quy luật của nó.

Ở đây Tue_NV viết L= tính từ điiêrm đầu PLine đến điểm đang xét

Trước tiên cám ơn bác đã nhiệt tình giúp đỡ. :lol2:

Khi mình test lisp của bác thì xảy ra một số lỗi. Các lỗi này mình sẽ nói rõ trong file test lisp dưới đây.

File kiem tra lisp

P/S: Ngoài ra nó còn có thêm lỗi này nữa bác:

Command: ggoc

Chon Polyline :

Nhap chieu cao chu :2

Yes or No, please.

; error: Function cancelled

Vertical?

"style1" is now the current text style.

Bác vào xem và sửa lại giúp mình chút nhé. :lol2:

Tháng 6 19, 2009

Hôm nay em mạn phép xin các Bác chỉnh sửa giúp em đoạn lisp có trên diễn đàn cadviet một chút để phù hợp với công việc của em hơn. Thank các Bác trước.

- Đoạn lisp 1 của Bác SSG dùng để vẽ bảng Toạ Độ Góc Ranh có lệnh : vc

---Yêu cầu 1: thêm hình tròn có tô hatch tại các đỉnh ( nếu được thì mong Bác có thể cho người dùng nhập đường kính vòng tròn)

---Yêu cầu 2: chuyển lại font chữ giũa kích thước và số TT ( số TT cho font chữ nghiêng và kích thước cho font chữ thẳng và tô đậm)

---Yêu cầu 3: mong Bác có thể cho người dùng được chọn save lại hay không save lại bảng TĐGR ngay tại thư mục đã mở bản vẽ ra bằng file excel từng cột để cần thì có thể phục vụ cho công tác sau này.

Dưới đây là đường link file mẫu:

http://www.cadviet.com/upfiles/Mau_2.dwg

- Đoạn lisp 2 em không nhớ không lầm là của Bác PNQ Duy dùng để đưa các đối tượng từ bản vẽ 3D về 2D có lệnh: ve0

---Yêu cầu: các đối tượng có chiều cao z thì được dời sang trục x hay y 1 khoảng cách mà người thực hiện nhập số vào

Dưới đây là đường link file mẫu:

http://www.cadviet.com/upfiles/Mau_2_2.dwg

Mong nhận được sự hồi âm sớm của các Bác. một lần nữa xin cá mơn các Bác, nếu có gì sai xót xin các Bác thông cảm bỏ qua

Tháng 6 19, 2009

- Đoạn lisp 2 em không nhớ không lầm là của Bác PNQ Duy dùng để đưa các đối tượng từ bản vẽ 3D về 2D có lệnh: ve0

Bạn nhớ lầm rồi cái lisp ve0 là của bác nguyenhoanh nếu mình có dính líu vào thì chắc là mình chỉ chổ cho bạn load về thôi!

Tháng 6 19, 2009

các bác nào có lisp tính diện tích HATCH được ko vậy?

Tháng 6 19, 2009

Hix, cho em xin được đính chính lại là lisp ve0 là của bác Nguyen Hoanh, em mới đọc lại, xin Bác tha lỗi .!

Tháng 6 19, 2009

các bác nào có lisp tính diện tích HATCH được ko vậy?

Thiep nghĩ nếu hatch của bạn lỡ bị mất đường bao thì dùng lisp boundbh.lsp có trên mạng để tái tạo lại, sau đó pick vào đường bao và ^1 thì sẽ thấy được diện tích. Nếu có đảo thì phải trừ diện tích đường bao đảo.

Tháng 6 19, 2009

các bác nào có lisp tính diện tích HATCH được ko vậy?

Lấy dt hatch cũng như lấy dt polyline mà ( lệnh area trong CAD cho phép chọn cả hatch)

Còn đây là lisp: Tên lệnh "DT", chọn các đối tượng --> chọn lỗ thủng (đối tượng cần trừ dt) --> Chọn text hoặc chỉ điểm chèn kết quả

(defun myerror (s)
 (cond
   ((= s "quit / exit abort") (princ))
   ((/= s "Function cancelled") (princ (strcat "\nError: " s)))
 )
 (setvar "cmdecho" CMD)		; Restore saved modes
 (setvar "osmode" OSM)
 (setq *error* OLDERR)			; Restore old *error* handler
 (princ)
)

(defun bocchu (ss1 c)
 (setq ob (entget (ssname ss1 c)))
 (setq ts (assoc 1 ob))
 (setq a (cdr ts))
)
(defun sothanhchuint (num)
 (if (> num 0)
   (strcat "+" (rtos num 2 2))
   (rtos num 2 2)
 )
)
(defun sothanhchuintreal (num) (rtos num 2 2))
(defun sothanhchuintreal1 (num) (rtos num 2 0))


(defun Noichu (Ob newstr key)
 (setq txtstr (assoc 1 Ob))
 (setq newstr (cons 1 (strcat (cdr txtstr) key newstr)))
 (entmod (subst newstr txtstr Ob))
)

(defun thaychu (Ob newstr / obtmp)
 (setq txtstr (assoc 1 Ob))
 (setq	newstr (cons 1 newstr)
obtmp  (entmod (subst newstr txtstr Ob))
 )
 (entupd (cdr (assoc -1 obtmp)))
)
(defun chonchu (dongnhac)
 (prompt dongnhac)
 (ssget
   '((-4 . "      (0 . "text")
     (0 . "mtext")
     (0 . "ATTRIB")
     (-4 . "OR>")
    )
 )
)

(defun chon1chu	(dongnhac / obj objtype)
 (if (setq obj (nentsel dongnhac))
   (setq obj	  (entget (car obj))
  objtype (cdr (assoc 0 obj))
   )
 )
 (if (member objtype '("ATTRIB" "MTEXT" "TEXT"))
   (setq obj obj)
 )
)


(defun chon (str) (ssget '((cons (0 str)))))
(defun bamchon (st) (entget (car (entsel st))))
(defun bocdt (ss1 c) (entget (ssname ss1 c)))
;;;;================================================
;;;====================================================== 
;;;Tinh dien tich bang cach chon doi tuong

(defun C:dt (/ pt1 Objare objtxt dtich dtich1 ss1 ss2 ss3 lacol)

 (command "UCS" "W" "")
 (command "Undo" "Mark")
 (setq oldos (getvar "OsMODE"))

 (princ "\nChän ®èi tîng cÇn lÊy diÖn tÝch")
 (setq Objare (car (nentsel)))
 (while
   (not
     (member (cdr (assoc 0 (entget objare)))
      '("POLYLINE" "LWPOLYLINE" "SPLINE" "CIRCLE" "HATCH")
     )
   )
    (prompt
      "\n§èi tîng kh«ng ®óng kiÓu! Chän l¹i ®èi tîng cÇn lÊy diÖn tÝch ..."
    )
    (setq objare (car (nentsel))
    )
 )
 (command "area" "o" Objare)
 (setq dtich (getvar "Area"))

 (princ "\nChän ®èi tîng cÇn lÊy diÖn tÝch tiÕp theo (Enter ®Ó dõng l¹i)")
 (setq Objare (car (nentsel)))

 (while (/= Objare nil)
   (if
     (not
(member	(cdr (assoc 0 (entget objare)))
	'("POLYLINE" "LWPOLYLINE" "SPLINE" "CIRCLE" "HATCH")
)
     )
      (prompt
 "\n§èi tîng kh«ng ®óng kiÓu! Chän l¹i ®èi tîng cÇn lÊy diÖn tÝch ..."
      )
      (progn
 (command "area" "o" Objare)
 (setq dtich1 (getvar "Area")
       dtich  (+ dtich dtich1)
 )
      )
   )
   (princ "\nChän ®èi tîng cÇn lÊy diÖn tÝch tiÕp theo (Enter ®Ó dõng l¹i)")
   (setq Objare (car (nentsel)))

 )

 (princ "\nChän ®èi tîng lç thñng (cÇn trõ diÖn tÝch)...")
 (setq Objare (car (nentsel)))

 (while (/= Objare nil)
   (if
     (not
(member	(cdr (assoc 0 (entget objare)))
	'("POLYLINE" "LWPOLYLINE" "SPLINE" "CIRCLE" "HATCH")
)
     )
      (prompt
 "\n§èi tîng kh«ng ®óng kiÓu! Chän l¹i ®èi tîng ..."
      )
      (progn
 (command "area" "o" Objare)
 (setq dtich1 (* -1 (getvar "Area"))
       dtich  (+ dtich dtich1)
 )

      )
   )
   (princ "\nChän ®èi tîng lç thñng tiÕp theo (Enter ®Ó dõng l¹i)")
   (setq Objare (car (nentsel)))

 )

 (setq objtxt (chon1chu "\nChän text chøa kÕt qu¶ diÖn tÝch (Enter ®Ó t¹o text míi)"))
 (if (/= objtxt nil)
   (progn
     (setq st (sothanhchuintreal dtich))
     (thaychu objtxt st)
   )
   (progn
     (setq st (sothanhchuintreal dtich))
     (setq pt1 (getpoint "\n Diem dat text: "))
     (command "text" pt1 "" "" st)
   )
 )
)

Chú ý với Tiếng Việt ở Command line :lol2:

Tháng 6 19, 2009

Số lượng câu hỏi cũng như câu trả lời nhiều quá
Nên mình không biết tìm ở đâu

Mình đang cần lish

đưa các pline thẳng hàng nhau thành 1 pline

và lish

Nhập tỷ lệ Standard Scale của khung viewport bên layout bằng bàn phím

Thanks mng nhiều

Xin hỏi luôn, có cách nào insert 1 hình chữ nhật không phải block vào bản vẽ hay không

Ai ơi giúp mình với

Tháng 6 19, 2009

Chú ý với Tiếng Việt ở Command line :lol2:

Lisp post lên codebox rất hay bị lỗi ở code DXF -4 nên bác post file lisp lên cho chuẩn. Cái nữa là bác dùng font tiếng Việt ở dòng nhắc mà ko hướng dẫn anh em cách chuyển font tiếng Việt cho dòng Command thì thiếu sót quá :lol2:

Tháng 6 19, 2009

Thiep nghĩ nếu hatch của bạn lỡ bị mất đường bao thì dùng lisp boundbh.lsp có trên mạng để tái tạo lại, sau đó pick vào đường bao và ^1 thì sẽ thấy được diện tích. Nếu có đảo thì phải trừ diện tích đường bao đảo.

sao mình search quài mà ko thấy cái lisp boundbh.lsp này vậy bạn?bạn cho mình link dc ko?thanks!

Tháng 6 19, 2009

Chào các bác, :lol2:
Mình có 1 vấn đề cần nhờ các bác. Mình có một đường Polyline với nhiều đoạn cong, tại các đoạn cong có các góc đo khác nhau. Nhờ các bác viết cho mình một cái lisp mà khi thực hiện lệnh thì nó sẽ cho ra kết quả là góc tại điểm gấp khúc và khoảng cách từ điểm đó đến điểm đầu của PL. Mình mô tả cụ thể như sau:

1/ gõ lệnh và enter

2/ pick chọn đối tượng PL

Sau khi chọn đối tượng PL lisp sẽ thực hiện việc tính toán cho n điểm gấp khúc để cho ra kết quả là: n Góc trong (Góc nhỏ hơn) tại chổ gấp khúc trên PL S=AđộB'C", và cho biết khoảng cách từ điểm đó đến điểm đầu của PL là bao nhiêu đơn vị (L=bao nhiêu hoặc Kn+xyz).

3/ Các giá trị tính toán được tự động chèn vào đúng chổ tại điểm gấp khúc trên PL

4/ Kiểu Text, độ lớn text lấy theo Texstyle hiện hành.

....................

Chào xuantran15

Bạn chạy thử LISP "Add Text Pline"

;ATP -> Add Text Pline
(defun c:ATP (/ cEnt cObj param kc_txt dd dg dc vt ang km met)
 (vl-load-com)
 (if (and (setq cEnt (car (entsel "\nSelect Polyline: ")))
          (eq "AcDbPolyline"
            (vla-get-ObjectName
              (setq cObj (vlax-ename->vla-object cEnt)))))
   (progn
     (setq param 1
    dd (vlax-curve-getStartPoint cObj)
    kc_txt (* 1.5 (getvar "TEXTSIZE")))
     (if (< (cadr dd)(cadr (vlax-curve-getPointAtParam cObj (1+ param))))
  (setq vt (polar dd (/ pi 2) kc_txt))
  (setq vt (polar dd (/ pi -2) kc_txt))
  )
     (Make_Text vt "K0+000")
     (while (< param (vlax-curve-getEndParam cObj))
(setq len (vlax-curve-getDistAtParam cObj param)
      dg (vlax-curve-getPointAtParam cObj param)
      dc (vlax-curve-getPointAtParam cObj (1+ param))
      ang (abs (- (angle dg dc) (angle dg dd) ) )	      
      km (fix (/ len 1000))
      met (- len (* km 1000)))
(setq ang (angtos ang 1) dd dg)
(if (> (cadr dg)(cadr dc))
  (setq vt (polar dg (/ pi 2) kc_txt))
  (setq vt (polar dg (/ pi -2) kc_txt))
  )
(Make_Text vt (strcat "K" (rtos km 2 0) "+"(rtos met 2 0)))
(Make_Text (polar vt (/ pi -2) kc_txt) (strcat "S" (rtos param 2 0) "=" ang))
(setq param (1+ param ))
)
     )
   (princ "\n<< No Polyline Selected >>"))
 (princ))

(defun Make_Text  (pt val )
 (entmake (list (cons 0 "TEXT")
                (cons 62 2);color
                (cons 10 pt)
                (cons 40 (getvar "TEXTSIZE"))
                (cons 1 val)
                '(71 . 0)
                '(72 . 1)
                '(73 . 1)
	 (cons 11 pt)
                )))

Tháng 6 19, 2009

Lấy dt hatch cũng như lấy dt polyline mà ( lệnh area trong CAD cho phép chọn cả hatch)
..........................

Chào Snowman

Chú ý : với CAD 2004 trở về truớc : lệnh area không cho phép chọn hatch

Selected object does not have an area

-> LISP báo lỗi.

Tháng 6 19, 2009

Chào bác gia bạch!

Mình đã thử lisp của bác và thấy nó chạy ra kết quả tương đối tốt. Nhưng có một số ý kiến mong các bác quan tâm.

1/ Một số số đo góc bị nhầm lẫn trong việc lấy góc. Vì góc cần lấy là góc nhỏ hơn trong hai góc. (Góc này luôn bé hơn 180độ)

2/ Bác cho số đo góc chính xác tới giây luôn nhé.

3/ Lisp chạy luôn lấy giá trị dímstyle của standar thì phải, và chiều cao text không thay đổi được bác à.

Cám ơn các bác nhiều :lol2:

Tháng 6 19, 2009

Mình có 1 vấn đề cần nhờ các bác. Mình có một đường Polyline với nhiều đoạn cong, tại các đoạn cong có các góc đo khác nhau. Nhờ các bác viết cho mình một cái lisp mà khi thực hiện lệnh thì nó sẽ cho ra kết quả là góc tại điểm gấp khúc và khoảng cách từ điểm đó đến điểm đầu của PL. Mình mô tả cụ thể như sau:

1/ gõ lệnh và enter

2/ pick chọn đối tượng PL

Sau khi chọn đối tượng PL lisp sẽ thực hiện việc tính toán cho n điểm gấp khúc để cho ra kết quả là: n Góc trong (Góc nhỏ hơn) tại chổ gấp khúc trên PL S=AđộB'C", và cho biết khoảng cách từ điểm đó đến điểm đầu của PL là bao nhiêu đơn vị (L=bao nhiêu hoặc Kn+xyz).

3/ Các giá trị tính toán được tự động chèn vào đúng chổ tại điểm gấp khúc trên PL

4/ Kiểu Text, độ lớn text lấy theo Texstyle hiện hành.

....................

Tue_NV đã chỉnh sửa tất cả lại

Bạn test thử nhé :

;; free lisp from cadviet.com

(defun c:ggoc(/ oldos curve cao ddau ddau1 pre i diem1 diem2 gocA gocB gocC 
do dotinh phut giay diemchen1 diemchen2 diemchen10 chuoido L)
(setvar "cmdecho" 0)
(command "undo" "be")
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq curve (car(entsel "\n Chon Polyline :")))
(setq cao (getvar "textsize"))
(setq ddau (vlax-curve-getStartPoint curve) i 1)
(setq ddau1 ddau)
(setq pre (vlax-curve-getEndParam curve))

(while (
(setq diem1 (vlax-curve-getPointAtParam curve i))
(setq diem2 (vlax-curve-getPointAtParam curve (1+ i))) 


(setq gocA (/ (* (angle diem1 ddau) 180) pi))
(setq gocB (/ (* (angle diem1 diem2) 180) pi))
(if ((setq gocC (abs(- gocA gocB)))
(setq gocC (- 360 (abs(- gocA gocB))))
)
(setq do (fix gocC))

(setq dotinh (* (- gocC do) 3600))
(setq phut (fix (/ dotinh 60)))
(setq giay (fix (rem dotinh 60)))

(if (> (cadr diem1) (cadr diem2))
(progn
(setq diemchen1 (list (car diem1) (+ (cadr diem1) (* 3.0 cao)) 0))
(setq diemchen2 (list (car diem1) (+ (cadr diem1) (* 1.5 cao)) 0)) 
)
(progn
(setq diemchen1 (list (car diem1) (- (cadr diem1) (* 1.5 cao)) 0))
(setq diemchen2 (list (car diem1) (- (cadr diem1) (* 3.0 cao)) 0))
)
)
(setq chuoido (strcat (rtos do 2 0) (chr 176) (rtos phut 2 0) "'" (rtos giay 2 0) "''"))
(setq L (vlax-curve-getDistAtPoint curve diem1))

(wtxt chuoido diemchen1)
(wtxt (strcat "L = " (rtos L 2 0)) diemchen2)

(setq i (1+ i))
(setq ddau diem1)
)
(setq diemchen10 (list (car ddau1) (- (cadr ddau1) (* 1.5 cao)) 0))
(wtxt (strcat "L = " (rtos (vlax-curve-getDistAtPoint curve ddau1) 2 0)) diemchen10)

(setvar "osmode" oldos)
(command "undo" "end")
(princ)
)
;
;

;
(defun wtxt (txt p / sty d h)
(setq
    sty (getvar "textstyle")
    d (tblsearch "style" sty)
    h (cdr (assoc 40 d))
)
(entmake (list (cons 0 "TEXT") (cons 7 sty) (cons 1 txt) (cons 10 p) (cons 11 p) (cons 72 1) (cons 73 2)
          (if (> h 0) (cons 40 h) (assoc 40 d)) (assoc 41 d))
)
)

:lol2:

Tháng 6 19, 2009

Tue_NV đã chỉnh sửa tất cả lại

Bạn test thử nhé :

;; free lisp from cadviet.com

(defun c:ggoc(/ oldos curve cao ddau ddau1 pre i diem1 diem2 gocA gocB gocC 
do dotinh phut giay diemchen1 diemchen2 diemchen10 chuoido L)
(setvar "cmdecho" 0)
(command "undo" "be")
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq curve (car(entsel "\n Chon Polyline :")))
(setq cao (getvar "textsize"))
(setq ddau (vlax-curve-getStartPoint curve) i 1)
(setq ddau1 ddau)
(setq pre (vlax-curve-getEndParam curve))

(while (< i pre)

(setq diem1 (vlax-curve-getPointAtParam curve i))
(setq diem2 (vlax-curve-getPointAtParam curve (1+ i))) 
(setq gocA (/ (* (angle diem1 ddau) 180) pi))
(setq gocB (/ (* (angle diem1 diem2) 180) pi))
(if (< (abs(- gocA gocB)) 180) 
(setq gocC (abs(- gocA gocB)))
(setq gocC (- 360 (abs(- gocA gocB))))
)
(setq do (fix gocC))

(setq dotinh (* (- gocC do) 3600))
(setq phut (fix (/ dotinh 60)))
(setq giay (fix (rem dotinh 60)))

(if (> (cadr diem1) (cadr diem2))
(progn
(setq diemchen1 (list (car diem1) (+ (cadr diem1) (* 3.0 cao)) 0))
(setq diemchen2 (list (car diem1) (+ (cadr diem1) (* 1.5 cao)) 0)) 
)
(progn
(setq diemchen1 (list (car diem1) (- (cadr diem1) (* 1.5 cao)) 0))
(setq diemchen2 (list (car diem1) (- (cadr diem1) (* 3.0 cao)) 0))
)
)
(setq chuoido (strcat (rtos do 2 0) (chr 176) (rtos phut 2 0) "'" (rtos giay 2 0) "''"))
(setq L (vlax-curve-getDistAtPoint curve diem1))

(wtxt chuoido diemchen1)
(wtxt (strcat "L = " (rtos L 2 0)) diemchen2)

(setq i (1+ i))
(setq ddau diem1)
)
(setq diemchen10 (list (car ddau1) (- (cadr ddau1) (* 1.5 cao)) 0))
(wtxt (strcat "L = " (rtos (vlax-curve-getDistAtPoint curve ddau1) 2 0)) diemchen10)

(setvar "osmode" oldos)
(command "undo" "end")
(princ)
)
;
;

;
(defun wtxt (txt p / sty d h)
(setq
    sty (getvar "textstyle")
    d (tblsearch "style" sty)
    h (cdr (assoc 40 d))
)
(entmake (list (cons 0 "TEXT") (cons 7 sty) (cons 1 txt) (cons 10 p) (cons 11 p) (cons 72 1) (cons 73 2)
          (if (> h 0) (cons 40 h) (assoc 40 d)) (assoc 41 d))
)
)

:D

Rất tuyệt bác Tuệ à. chỉ còn một lỗi nhỏ là khi chiều cao text lớn thì hai dòng text gần trùng lên nhau. Nếu có thể bác khắc phục hiện tượng này luôn nhé. Cám ơn tất cả mọi người rất nhiều, có cái này mình giảm được ít nhất 30phút cho mỗi bản vẽ :lol2: :lol2:

Tháng 6 19, 2009

sao mình search quài mà ko thấy cái lisp boundbh.lsp này vậy bạn?bạn cho mình link dc ko?thanks!

Xin lỗi, thiep nhầm, nó là hatchb.lsp:

;----Tao boundary cho Hatch
(defun c:hb () (c:hatchb))
; this line can be commented out if there is an existing command called hb
(defun c:hatchb	(/	    es	       blay	  ed1	     ed2
	 loops1	    bptf       part	  et	     noe
	 plist	    ic	       bul	  nr	     ang1
	 ang2	    obj	       *ModelSpace*
	 *PaperSpace*	       space	  cw	     errexit
	 undox	    olderr     oldcmdecho ss1	     lastent
	 en1	    en2	       ss	  lwp
	 list->variantArray    3dPoint->2dPoint	     A2k
	 ent	    i	       ss2	  knot-list
	 controlpoint-list     kn	  cn	     pos
	)
 (setq A2k (wcmatch (getvar "ACADVER") "17.0s (LMS Tech)"))
 (if A2k
   (defun list->variantArray (ptsList / arraySpace sArray)
     (setq arraySpace
     (vlax-make-safearray
       vlax-vbdouble
       (cons 0 (- (length ptsList) 1))
     )
     )
     (setq sArray (vlax-safearray-fill arraySpace ptsList))
     (vlax-make-variant sArray)
   )
 )
 (if A2k
   (defun 3dPoint->2dPoint (3dpt)
     (list (float (car 3dpt)) (float (cadr 3dpt)))
   )
 )

 (defun errexit (s)
   (princ "\nError:  ")
   (princ s)
   (restore)
 )

 (defun undox ()
   (command "._ucs" "_p")
   (command "._undo" "_E")
   (setvar "cmdecho" oldcmdecho)
   (setq *error* olderr)
   (princ)
 )

 (setq	olderr	*error*
restore	undox
*error*	errexit
 )
 (setq oldcmdecho (getvar "cmdecho"))
 (setvar "cmdecho" 0)
 (command "._UNDO" "_BE")
 (if A2k
   (progn
     (vl-load-com)
     (setq *ModelSpace* (vla-get-ModelSpace
		   (vla-get-ActiveDocument (vlax-get-acad-object))
		 )
    *PaperSpace* (vla-get-PaperSpace
		   (vla-get-ActiveDocument (vlax-get-acad-object))
		 )
     )
   )
 )
 (if (/= (setq ss2 (ssget '((0 . "HATCH")))) nil)
   (progn
     (setq i 0)
     (while (setq ent (ssname ss2 i))
(setq ed1 (entget ent))
(if (not (equal (assoc 210 ed1) '(210 0.0 0.0 1.0)))
  (princ "\nHatch not in WCS!")
)
(command "._ucs" "_w")
(setq loops1 (cdr (assoc 91 ed1)))
				; number of boundary paths (loops)
(if (and A2k (= (strcase (cdr (assoc 410 ed1))) "MODEL"))
  (setq space *ModelSpace*)
  (setq space *PaperSpace*)
)
(repeat	loops1
  (setq ed1 (member (assoc 92 ed1) ed1))
  (setq bptf (cdr (car ed1)))	; boundary path type flag
  (setq ic (cdr (assoc 73 ed1))) ; is closed
  (setq noe (cdr (assoc 93 ed1))) ; number of edges
  (setq ed1 (member (assoc 72 ed1) ed1))
  (setq bul (cdr (car ed1)))	; bulge
  (setq plist nil)
  (setq blist nil)
  (cond
    ((> (boole 1 bptf 2) 0)	; polyline
     (repeat noe
       (setq ed1 (member (assoc 10 (cdr ed1)) ed1))
       (setq plist (append plist (list (cdr (assoc 10 ed1)))))
       (setq blist (append blist
			   (if (> bul 0)
			     (list (cdr (assoc 42 ed1)))
			     nil
			   )
		   )
       )
     )
     (if A2k
       (progn
	 (setq polypoints
		(apply 'append
		       (mapcar '3dPoint->2dPoint plist)
		)
	 )
	 (setq VLADataPts (list->variantArray polypoints))
	 (setq
	   obj (vla-addLightweightPolyline space VLADataPts)
	 )
	 (setq nr 0)
	 (repeat (length blist)
	   (if (/= (nth nr blist) 0)
	     (vla-setBulge obj nr (nth nr blist))
	   )
	   (setq nr (1+ nr))
	 )
	 (if (= ic 1)
	   (vla-put-closed obj T)
	 )
       )
       (progn
	 (if (= ic 1)
	   (entmake '((0 . "LWPOLYLINE") (66 . 1) (70 . 1)))
	   (entmake '((0 . "LWPOLYLINE") (66 . 1)))
	 )
	 (setq nr 0)
	 (repeat (length plist)
	   (if (= bul 0)
	     (entmake (list (cons 0 "VERTEX")
			    (cons 10 (nth nr plist))
		      )
	     )
	     (entmake (list (cons 0 "VERTEX")
			    (cons 10 (nth nr plist))
			    (cons 42 (nth nr blist))
		      )
	     )
	   )
	   (setq nr (1+ nr))
	 )
	 (entmake '((0 . "SEQEND")))
       )
     )
    )
    (t				; not polyline
     (setq lastent (entlast))
     (setq lwp T)
     (repeat noe
       (setq et (cdr (assoc 72 ed1)))
       (cond
	 ((= et 1)		; line
	  (setq ed1 (member (assoc 10 (cdr ed1)) ed1))
	  (if A2k
	    (vla-AddLine
	      space
	      (vlax-3d-point (cdr (assoc 10 ed1)))
	      (vlax-3d-point (cdr (assoc 11 ed1)))
	    )
	    (entmake
	      (list (cons 0 "LINE")
		    (assoc 10 ed1)
		    (assoc 11 ed1)
	      )
	    )
	  )
	  (setq ed1 (cddr ed1))
	 )
	 ((= et 2)		; circular arc
	  (setq ed1 (member (assoc 10 (cdr ed1)) ed1))
	  (setq ang1 (cdr (assoc 50 ed1)))
	  (setq ang2 (cdr (assoc 51 ed1)))
	  (setq cw (cdr (assoc 73 ed1)))
	  (if (equal ang2 6.28319 0.00001)
	    (progn
	      (if A2k
		(vla-AddCircle
		  space
		  (vlax-3d-point (cdr (assoc 10 ed1)))
		  (cdr (assoc 40 ed1))
		)
		(entmake (list (cons 0 "CIRCLE")
			       (assoc 10 ed1)
			       (assoc 40 ed1)
			 )
		)
	      )
	      (setq lwp nil)
	    )
	    (if	A2k
	      (vla-AddArc
		space
		(vlax-3d-point (cdr (assoc 10 ed1)))
		(cdr (assoc 40 ed1))
		(if (= cw 0)
		  (- 0 ang2)
		  ang1
		)
		(if (= cw 0)
		  (- 0 ang1)
		  ang2
		)
	      )
	      (entmake (list (cons 0 "ARC")
			     (assoc 10 ed1)
			     (assoc 40 ed1)
			     (cons 50
				   (if (= cw 0)
				     (- 0 ang2)
				     ang1
				   )
			     )
			     (cons 51
				   (if (= cw 0)
				     (- 0 ang1)
				     ang2
				   )
			     )
		       )
	      )
	    )
	  )
	  (setq ed1 (cddddr ed1))
	 )
	 ((= et 3)		; elliptic arc
	  (setq ed1 (member (assoc 10 (cdr ed1)) ed1))
	  (setq ang1 (cdr (assoc 50 ed1)))
	  (setq ang2 (cdr (assoc 51 ed1)))
	  (setq cw (cdr (assoc 73 ed1)))
	  (if A2k
	    (progn
	      (setq obj	(vla-AddEllipse
			  space
			  (vlax-3d-point (cdr (assoc 10 ed1)))
			  (vlax-3d-point (cdr (assoc 11 ed1)))
			  (cdr (assoc 40 ed1))
			)
	      )
	      (vla-put-startangle
		obj
		(if (= cw 0)
		  (- 0 ang2)
		  ang1
		)
	      )
	      (vla-put-endangle
		obj
		(if (= cw 0)
		  (- 0 ang1)
		  ang2
		)
	      )
	    )
	    (princ "\nElliptic arc not supported!")
	  )
	  (setq lwp nil)
	 )
	 ((= et 4)		; spline
	  (setq ed1 (member (assoc 94 (cdr ed1)) ed1))
	  (setq knot-list nil)
	  (setq controlpoint-list nil)
	  (setq kn (cdr (assoc 95 ed1)))
	  (setq cn (cdr (assoc 96 ed1)))
	  (setq pos (vl-position (assoc 40 ed1) ed1))
	  (repeat kn
	    (setq
	      knot-list	(cons (cons 40 (cdr (nth pos ed1)))
			      knot-list
			)
	    )
	    (setq pos (1+ pos))
	  )
	  (setq pos (vl-position (assoc 10 ed1) ed1))
	  (repeat cn
	    (setq controlpoint-list
		   (cons
		     (cons 10 (cdr (nth pos ed1)))
		     controlpoint-list
		   )
	    )
	    (setq pos (1+ pos))
	  )
	  (setq knot-list (reverse knot-list))
	  (setq controlpoint-list (reverse controlpoint-list))
	  (entmake (append
		     (list '(0 . "SPLINE"))
		     (list (cons 100 "AcDbEntity"))
		     (list (cons 100 "AcDbSpline"))
		     (list (cons 70
				 (+ 1
				    8
				    (* 2 (cdr (assoc 74 ed1)))
				    (* 4 (cdr (assoc 73 ed1)))
				 )
			   )
		     )
		     (list (cons 71 (cdr (assoc 94 ed1))))
		     (list (cons 72 kn))
		     (list (cons 73 cn))
		     knot-list
		     controlpoint-list
		   )
	  )
	  (setq ed1 (member (assoc 10 ed1) ed1))
	  (setq lwp nil)
	 )
       )			; end cond
     )				; end repeat noe
     (if lwp
       (progn
	 (setq en1 (entnext lastent))
	 (setq ss (ssadd))
	 (ssadd en1 ss)
	 (while	(setq en2 (entnext en1))
	   (ssadd en2 ss)
	   (setq en1 en2)
	 )
	 (command "_.pedit" (entlast) "_Y" "_J" ss "" "")
       )
     )
    )				; end t
  )				; end cond
)				; end repeat loops1
(setq i (1+ i))
     )
   )
 )
 (restore)
 (princ)
)

Lisp rất hay ở chỗ khôi phục lại bound cho hatch kể cả đường SPLINE, ARC, CIRCLE...

Không hiểu chiều nay không upload được, bạn copy từ codebox vậy. Nếu có lỗi gì, ngày mai mạng tốt, mình sẽ up vậy.

Tháng 6 19, 2009

Xin lỗi, thiep nhầm, nó là hatchb.lsp:

;----Tao boundary cho Hatch
(defun c:hb () (c:hatchb))
; this line can be commented out if there is an existing command called hb
(defun c:hatchb	(/	    es	       blay	  ed1	     ed2
	 loops1	    bptf       part	  et	     noe
	 plist	    ic	       bul	  nr	     ang1
	 ang2	    obj	       *ModelSpace*
	 *PaperSpace*	       space	  cw	     errexit
	 undox	    olderr     oldcmdecho ss1	     lastent
	 en1	    en2	       ss	  lwp
	 list->variantArray    3dPoint->2dPoint	     A2k
	 ent	    i	       ss2	  knot-list
	 controlpoint-list     kn	  cn	     pos
	)
 (setq A2k (wcmatch (getvar "ACADVER") "17.0s (LMS Tech)"))
 (if A2k
   (defun list->variantArray (ptsList / arraySpace sArray)
     (setq arraySpace
     (vlax-make-safearray
       vlax-vbdouble
       (cons 0 (- (length ptsList) 1))
     )
     )
     (setq sArray (vlax-safearray-fill arraySpace ptsList))
     (vlax-make-variant sArray)
   )
 )
 (if A2k
   (defun 3dPoint->2dPoint (3dpt)
     (list (float (car 3dpt)) (float (cadr 3dpt)))
   )
 )

 (defun errexit (s)
   (princ "\nError:  ")
   (princ s)
   (restore)
 )

 (defun undox ()
   (command "._ucs" "_p")
   (command "._undo" "_E")
   (setvar "cmdecho" oldcmdecho)
   (setq *error* olderr)
   (princ)
 )

 (setq	olderr	*error*
restore	undox
*error*	errexit
 )
 (setq oldcmdecho (getvar "cmdecho"))
 (setvar "cmdecho" 0)
 (command "._UNDO" "_BE")
 (if A2k
   (progn
     (vl-load-com)
     (setq *ModelSpace* (vla-get-ModelSpace
		   (vla-get-ActiveDocument (vlax-get-acad-object))
		 )
    *PaperSpace* (vla-get-PaperSpace
		   (vla-get-ActiveDocument (vlax-get-acad-object))
		 )
     )
   )
 )
 (if (/= (setq ss2 (ssget '((0 . "HATCH")))) nil)
   (progn
     (setq i 0)
     (while (setq ent (ssname ss2 i))
(setq ed1 (entget ent))
(if (not (equal (assoc 210 ed1) '(210 0.0 0.0 1.0)))
  (princ "\nHatch not in WCS!")
)
(command "._ucs" "_w")
(setq loops1 (cdr (assoc 91 ed1)))
				; number of boundary paths (loops)
(if (and A2k (= (strcase (cdr (assoc 410 ed1))) "MODEL"))
  (setq space *ModelSpace*)
  (setq space *PaperSpace*)
)
(repeat	loops1
  (setq ed1 (member (assoc 92 ed1) ed1))
  (setq bptf (cdr (car ed1)))	; boundary path type flag
  (setq ic (cdr (assoc 73 ed1))) ; is closed
  (setq noe (cdr (assoc 93 ed1))) ; number of edges
  (setq ed1 (member (assoc 72 ed1) ed1))
  (setq bul (cdr (car ed1)))	; bulge
  (setq plist nil)
  (setq blist nil)
  (cond
    ((> (boole 1 bptf 2) 0)	; polyline
     (repeat noe
       (setq ed1 (member (assoc 10 (cdr ed1)) ed1))
       (setq plist (append plist (list (cdr (assoc 10 ed1)))))
       (setq blist (append blist
			   (if (> bul 0)
			     (list (cdr (assoc 42 ed1)))
			     nil
			   )
		   )
       )
     )
     (if A2k
       (progn
	 (setq polypoints
		(apply 'append
		       (mapcar '3dPoint->2dPoint plist)
		)
	 )
	 (setq VLADataPts (list->variantArray polypoints))
	 (setq
	   obj (vla-addLightweightPolyline space VLADataPts)
	 )
	 (setq nr 0)
	 (repeat (length blist)
	   (if (/= (nth nr blist) 0)
	     (vla-setBulge obj nr (nth nr blist))
	   )
	   (setq nr (1+ nr))
	 )
	 (if (= ic 1)
	   (vla-put-closed obj T)
	 )
       )
       (progn
	 (if (= ic 1)
	   (entmake '((0 . "LWPOLYLINE") (66 . 1) (70 . 1)))
	   (entmake '((0 . "LWPOLYLINE") (66 . 1)))
	 )
	 (setq nr 0)
	 (repeat (length plist)
	   (if (= bul 0)
	     (entmake (list (cons 0 "VERTEX")
			    (cons 10 (nth nr plist))
		      )
	     )
	     (entmake (list (cons 0 "VERTEX")
			    (cons 10 (nth nr plist))
			    (cons 42 (nth nr blist))
		      )
	     )
	   )
	   (setq nr (1+ nr))
	 )
	 (entmake '((0 . "SEQEND")))
       )
     )
    )
    (t				; not polyline
     (setq lastent (entlast))
     (setq lwp T)
     (repeat noe
       (setq et (cdr (assoc 72 ed1)))
       (cond
	 ((= et 1)		; line
	  (setq ed1 (member (assoc 10 (cdr ed1)) ed1))
	  (if A2k
	    (vla-AddLine
	      space
	      (vlax-3d-point (cdr (assoc 10 ed1)))
	      (vlax-3d-point (cdr (assoc 11 ed1)))
	    )
	    (entmake
	      (list (cons 0 "LINE")
		    (assoc 10 ed1)
		    (assoc 11 ed1)
	      )
	    )
	  )
	  (setq ed1 (cddr ed1))
	 )
	 ((= et 2)		; circular arc
	  (setq ed1 (member (assoc 10 (cdr ed1)) ed1))
	  (setq ang1 (cdr (assoc 50 ed1)))
	  (setq ang2 (cdr (assoc 51 ed1)))
	  (setq cw (cdr (assoc 73 ed1)))
	  (if (equal ang2 6.28319 0.00001)
	    (progn
	      (if A2k
		(vla-AddCircle
		  space
		  (vlax-3d-point (cdr (assoc 10 ed1)))
		  (cdr (assoc 40 ed1))
		)
		(entmake (list (cons 0 "CIRCLE")
			       (assoc 10 ed1)
			       (assoc 40 ed1)
			 )
		)
	      )
	      (setq lwp nil)
	    )
	    (if	A2k
	      (vla-AddArc
		space
		(vlax-3d-point (cdr (assoc 10 ed1)))
		(cdr (assoc 40 ed1))
		(if (= cw 0)
		  (- 0 ang2)
		  ang1
		)
		(if (= cw 0)
		  (- 0 ang1)
		  ang2
		)
	      )
	      (entmake (list (cons 0 "ARC")
			     (assoc 10 ed1)
			     (assoc 40 ed1)
			     (cons 50
				   (if (= cw 0)
				     (- 0 ang2)
				     ang1
				   )
			     )
			     (cons 51
				   (if (= cw 0)
				     (- 0 ang1)
				     ang2
				   )
			     )
		       )
	      )
	    )
	  )
	  (setq ed1 (cddddr ed1))
	 )
	 ((= et 3)		; elliptic arc
	  (setq ed1 (member (assoc 10 (cdr ed1)) ed1))
	  (setq ang1 (cdr (assoc 50 ed1)))
	  (setq ang2 (cdr (assoc 51 ed1)))
	  (setq cw (cdr (assoc 73 ed1)))
	  (if A2k
	    (progn
	      (setq obj	(vla-AddEllipse
			  space
			  (vlax-3d-point (cdr (assoc 10 ed1)))
			  (vlax-3d-point (cdr (assoc 11 ed1)))
			  (cdr (assoc 40 ed1))
			)
	      )
	      (vla-put-startangle
		obj
		(if (= cw 0)
		  (- 0 ang2)
		  ang1
		)
	      )
	      (vla-put-endangle
		obj
		(if (= cw 0)
		  (- 0 ang1)
		  ang2
		)
	      )
	    )
	    (princ "\nElliptic arc not supported!")
	  )
	  (setq lwp nil)
	 )
	 ((= et 4)		; spline
	  (setq ed1 (member (assoc 94 (cdr ed1)) ed1))
	  (setq knot-list nil)
	  (setq controlpoint-list nil)
	  (setq kn (cdr (assoc 95 ed1)))
	  (setq cn (cdr (assoc 96 ed1)))
	  (setq pos (vl-position (assoc 40 ed1) ed1))
	  (repeat kn
	    (setq
	      knot-list	(cons (cons 40 (cdr (nth pos ed1)))
			      knot-list
			)
	    )
	    (setq pos (1+ pos))
	  )
	  (setq pos (vl-position (assoc 10 ed1) ed1))
	  (repeat cn
	    (setq controlpoint-list
		   (cons
		     (cons 10 (cdr (nth pos ed1)))
		     controlpoint-list
		   )
	    )
	    (setq pos (1+ pos))
	  )
	  (setq knot-list (reverse knot-list))
	  (setq controlpoint-list (reverse controlpoint-list))
	  (entmake (append
		     (list '(0 . "SPLINE"))
		     (list (cons 100 "AcDbEntity"))
		     (list (cons 100 "AcDbSpline"))
		     (list (cons 70
				 (+ 1
				    8
				    (* 2 (cdr (assoc 74 ed1)))
				    (* 4 (cdr (assoc 73 ed1)))
				 )
			   )
		     )
		     (list (cons 71 (cdr (assoc 94 ed1))))
		     (list (cons 72 kn))
		     (list (cons 73 cn))
		     knot-list
		     controlpoint-list
		   )
	  )
	  (setq ed1 (member (assoc 10 ed1) ed1))
	  (setq lwp nil)
	 )
       )			; end cond
     )				; end repeat noe
     (if lwp
       (progn
	 (setq en1 (entnext lastent))
	 (setq ss (ssadd))
	 (ssadd en1 ss)
	 (while	(setq en2 (entnext en1))
	   (ssadd en2 ss)
	   (setq en1 en2)
	 )
	 (command "_.pedit" (entlast) "_Y" "_J" ss "" "")
       )
     )
    )				; end t
  )				; end cond
)				; end repeat loops1
(setq i (1+ i))
     )
   )
 )
 (restore)
 (princ)
)

Lisp rất hay ở chỗ khôi phục lại bound cho hatch kể cả đường SPLINE, ARC, CIRCLE...

Không hiểu chiều nay không upload được, bạn copy từ codebox vậy. Nếu có lỗi gì, ngày mai mạng tốt, mình sẽ up vậy.

Thấy cái lisp hay mình test thử và đã xuất hiện lỗi bác à. :lol2:

Thu lisp

Tháng 6 22, 2009

Thấy cái lisp hay mình test thử và đã xuất hiện lỗi bác à. :lol2:
Thu lisp

Vâng xuântran15 nói đúng, lisp này thiep sưu tầm từ tác giả Jimmy Bergmark, ver 2.5

Nó chỉ đúng một cách tương đối, khi biên là 1 curve kín thì lisp này làm việc đúng, khi biên có nhiều curve (có đường cong trơn tham gia) thì lisp sẽ tạo ra nhiều curve không trật tự. Nhưng phải nói: Lisp hatchb này cho ta học hỏi rất nhiều về cách tạo các loại đường phức tạp từ hàm Entmake.

Tháng 6 22, 2009

Em cũng biết là các Bác rất bận, nhưng vẫn mong các Bác coi sơ qua và chỉnh dùm em 2 đoạn lisp VC - VE0. Em xin các mơn các Bác trước, em ở TP.HCM ko biết Bác nào ở TP.HCM có thể học tập kinh nghiệm viết lisp của các Bác. :lol2:

Tháng 6 22, 2009

Em cũng biết là các Bác rất bận, nhưng vẫn mong các Bác coi sơ qua và chỉnh dùm em 2 đoạn lisp VC - VE0. Em xin các mơn các Bác trước, em ở TP.HCM ko biết Bác nào ở TP.HCM có thể học tập kinh nghiệm viết lisp của các Bác. :lol2:

bạn up lên 2 cái lisp đó và nói lại yêu cầu.

Tháng 6 22, 2009

Chào bác gia bạch!
Mình đã thử lisp của bác và thấy nó chạy ra kết quả tương đối tốt. Nhưng có một số ý kiến mong các bác quan tâm.

1/ Một số số đo góc bị nhầm lẫn trong việc lấy góc. Vì góc cần lấy là góc nhỏ hơn trong hai góc. (Góc này luôn bé hơn 180độ)

2/ Bác cho số đo góc chính xác tới giây luôn nhé.

3/ Lisp chạy luôn lấy giá trị dímstyle của standar thì phải, và chiều cao text không thay đổi được bác à.

Cám ơn các bác nhiều :lol2:

Chào xuantran15

Gửi bạn LISP đã cập nhật theo yêu cầu.

............
4/ Kiểu Text, độ lớn text lấy theo Texstyle hiện hành.

..........

;ATP -> Add Text Pline
(defun c:ATP (/ vl ov cEnt cObj param kc_txt dd dg dc vt ang km met)
 (vl-load-com)
   (setq vl '("CMDECHO" "OSMODE" "AUPREC") ; Sys Var list
  ov (mapcar 'getvar vl)) ; Get Old values
 (mapcar 'setvar vl '(0 0 3)) ; Set new values

 (if (and (setq cEnt (car (entsel "\nSelect Polyline: ")))
          (eq "AcDbPolyline"
            (vla-get-ObjectName
              (setq cObj (vlax-ename->vla-object cEnt)))))
   (progn
     (if (not (setq chcao (getreal (strcat "\nNhap chieu cao Text <" (rtos (getvar "TEXTSIZE") 2 1) "> :")) ))
(setq chcao (getvar "TEXTSIZE") )	
)
     (setq param 1
    dd (vlax-curve-getStartPoint cObj)
    kc_txt (* 1.5 chcao))
     (if (< (cadr dd)(cadr (vlax-curve-getPointAtParam cObj (1+ param))))
  (setq vt (polar dd (/ pi 2) kc_txt))
  (setq vt (polar dd (/ pi -2) kc_txt))
  )
     (Make_Text vt "K0+000" chcao)
     (while (< param (vlax-curve-getEndParam cObj))
(setq len (vlax-curve-getDistAtParam cObj param)
      dg (vlax-curve-getPointAtParam cObj param)
      dc (vlax-curve-getPointAtParam cObj (1+ param))
      ang (abs (- (angle dg dc) (angle dg dd) ) )	      
      km (fix (/ len 1000))
      met (- len (* km 1000)))
(if (< ang pi)
  (setq ang (angtos ang 1))
  (setq ang (angtos (- (* 2 pi)ang) 1))
  )
(if (> (cadr dg)(cadr dc))
  (setq vt (polar dg (/ pi 2) kc_txt))
  (setq vt (polar dg (/ pi -2) kc_txt))
  )
(Make_Text vt (strcat "K" (rtos km 2 0) "+"(rtos met 2 0)) chcao)
(Make_Text (polar vt (/ pi -2) kc_txt) (strcat "S" (rtos param 2 0) "=" ang) chcao)
(setq param (1+ param )
      dd dg )
)
     )
   (princ "\n<< No Polyline Selected >>"))
 (mapcar 'setvar vl ov) ; reset Sys Vars
 (princ))

(defun Make_Text  (pt val h)
 (entmake (list (cons 0 "TEXT")
                (cons 62 2);color
                (cons 10 pt);position
                (cons 40 h);height
                (cons 1 val)
                '(71 . 0)
                '(72 . 1)
                '(73 . 1)
	 (cons 11 pt)
                )))

Tháng 6 22, 2009

Chào xuantran15

Gửi bạn LISP đã cập nhật theo yêu cầu.

;ATP -> Add Text Pline
(defun c:ATP (/ vl ov cEnt cObj param kc_txt dd dg dc vt ang km met)
 (vl-load-com)
   (setq vl '("CMDECHO" "OSMODE" "AUPREC") ; Sys Var list
  ov (mapcar 'getvar vl)) ; Get Old values
 (mapcar 'setvar vl '(0 0 3)) ; Set new values

 (if (and (setq cEnt (car (entsel "\nSelect Polyline: ")))
          (eq "AcDbPolyline"
            (vla-get-ObjectName
              (setq cObj (vlax-ename->vla-object cEnt)))))
   (progn
     (if (not (setq chcao (getreal (strcat "\nNhap chieu cao Text <" (rtos (getvar "TEXTSIZE") 2 1) "> :")) ))
(setq chcao (getvar "TEXTSIZE") )	
)
     (setq param 1
    dd (vlax-curve-getStartPoint cObj)
    kc_txt (* 1.5 chcao))
     (if (< (cadr dd)(cadr (vlax-curve-getPointAtParam cObj (1+ param))))
  (setq vt (polar dd (/ pi 2) kc_txt))
  (setq vt (polar dd (/ pi -2) kc_txt))
  )
     (Make_Text vt "K0+000" chcao)
     (while (< param (vlax-curve-getEndParam cObj))
(setq len (vlax-curve-getDistAtParam cObj param)
      dg (vlax-curve-getPointAtParam cObj param)
      dc (vlax-curve-getPointAtParam cObj (1+ param))
      ang (abs (- (angle dg dc) (angle dg dd) ) )	      
      km (fix (/ len 1000))
      met (- len (* km 1000)))
(if (< ang pi)
  (setq ang (angtos ang 1))
  (setq ang (angtos (- (* 2 pi)ang) 1))
  )
(if (> (cadr dg)(cadr dc))
  (setq vt (polar dg (/ pi 2) kc_txt))
  (setq vt (polar dg (/ pi -2) kc_txt))
  )
(Make_Text vt (strcat "K" (rtos km 2 0) "+"(rtos met 2 0)) chcao)
(Make_Text (polar vt (/ pi -2) kc_txt) (strcat "S" (rtos param 2 0) "=" ang) chcao)
(setq param (1+ param )
      dd dg )
)
     )
   (princ "\n<< No Polyline Selected >>"))
 (mapcar 'setvar vl ov) ; reset Sys Vars
 (princ))

(defun Make_Text  (pt val h)
 (entmake (list (cons 0 "TEXT")
                (cons 62 2);color
                (cons 10 pt);position
                (cons 40 h);height
                (cons 1 val)
                '(71 . 0)
                '(72 . 1)
                '(73 . 1)
	 (cons 11 pt)
                )))

Cám ơn bác rất nhiều. :lol2: Chúc bác cùng mọi nguời luôn vui vẻ luôn mát mẻ trong những ngày nóng bức thế này :lol2:

Tháng 6 22, 2009

bạn up lên 2 cái lisp đó và nói lại yêu cầu.

Em xin nói lại yêu cầu của em:

- Đoạn lisp 1 của Bác SSG dùng để vẽ bảng Toạ Độ Góc Ranh có lệnh : vc

---Yêu cầu 1: thêm hình tròn có tô hatch tại các đỉnh ( nếu được thì mong Bác có thể cho người dùng nhập đường kính vòng tròn)

---Yêu cầu 2: chuyển lại font chữ giũa kích thước và số TT ( số TT cho font chữ nghiêng và kích thước cho font chữ thẳng và tô đậm)

---Yêu cầu 3: mong Bác có thể cho người dùng được chọn save lại hay không save lại bảng TĐGR ngay tại thư mục đã mở bản vẽ ra bằng file excel từng cột để cần thì có thể phục vụ cho công tác sau này.

Dưới đây là đường link file mẫu:

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Chuong trinh danh so va lap bang toa do ho so thua dat dia chinh
;;;Bang toa do tao thanh block, duoc dat ten theo so thu tu 1, 2, 3...
;;;Chap nhan cac doi tuong la Region, Polyline, Line va Arc khep kin
;;;Written by ssg and elleHCSC - January 2009 - www.cadviet.com
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;PUBLIC FUNCTIONS
;;;-------------------------------------------------------------------------------
(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 getVert (e / i L) ;;;Return list of all vertex from pline e
(setq i 0 L nil)
(vl-load-com)
(repeat (fix (+ (vlax-curve-getEndParam e) 1))
(setq L (append L (list (vlax-curve-getPointAtParam e i))))
(setq i (1+ i))
)
L
)
;;;-------------------------------------------------------------------------------
(defun wtxtMC (txt p h) ;;;Write text Middle Center, specify text, point, height
(entmake (list (cons 0 "TEXT") (cons 7 (getvar "textstyle"))
(cons 1 txt) (cons 10 p) (cons 11 p) (cons 40 h) (cons 72 1) (cons 73 2)))
)
;;;-------------------------------------------------------------------------------
(defun Collect(e / e2 SS) ;;;Selection set from e to entlast
(setq SS (ssadd))
(ssadd e SS)
(while (setq e2 (entnext e)) (ssadd e2 SS) (setq e e2))
SS
)
;;;-------------------------------------------------------------------------------
(defun Collect1(e / ss)
;;;Selection set after e to entlast. If e nil, select all from fist entity of drawing.
(if (= e nil) (setq ss (collect (entnext)))
(progn (setq ss (collect e)) (ssdel e ss))
)
)
;;;-------------------------------------------------------------------------------

;;;PRIVATE FUNCTIONS
;;;-------------------------------------------------------------------------------
(defun txt1(txtL / p1 p2 p3 p4 pL i) ;;;Write texts in 1 row
(setq
p1 (list (+ (car p0) (* 2 h)) (- (cadr p0) (* 1.5 h)))
p2 (polar p1 0 (* 8 h))
p3 (polar p2 0 (* 12 h))
p4 (polar p3 0 (* 10 h))
pL (list p1 p2 p3 p4)
i 0
)
(repeat 4
(wtxtMC (nth i txtL) (nth i pL) h)
(setq i (1+ i))
)
)
;;;-------------------------------------------------------------------------------
(defun txt2(txtL / p1 p2 p3 p4 pL i) ;;;Write texts in 1 row
(setq
p1 (list (+ (car p0) (* 2 h)) (- (cadr p0) (* 1.5 h)))
p2 (polar p1 0 (* 8 h))
p3 (polar p2 0 (* 12 h))
p4 (polar p3 0 (* 10 h))
p4 (polar p4 (* 0.5 pi) (* 1.5 h))
pL (list p1 p2 p3 p4)
i 0
)
(repeat 4
(wtxtMC (nth i txtL) (nth i pL) h)
(setq i (1+ i))
)
)
;;;-------------------------------------------------------------------------------


;;;MAIN PROGRAM
;;;-------------------------------------------------------------------------------
(defun C:VC( / h p et p0 p00 p01 p02 pt pvL n j pv num txtL ss bn ntp)
;;;Vertex Co-ordinate

;;;GET TEXT HEIGHT
(if (not h0) (setq h0 1))
(setq h (getreal (strcat "\nChon chieu cao text <" (rtos h0) ">:")))
(if (not h) (setq h h0) (setq h0 h))

;;;GET DECIMAL PRECISION
(if (not ntp0) (setq ntp0 2))
(setq ntp (getint (strcat "\nSo chu so thap phan <" (itoa ntp0) ">:")))
(if (not ntp) (setq ntp ntp0) (setq ntp0 ntp))

;;;PICK & BASE POINT
(setq p (getpoint "\nPick 1 diem giua mien kin:"))
(command "boundary" p "")
(setq et (entlast))
(redraw et 3)
(setq
p00 (getpoint "\nDiem chuan bang toa do (phia tren ben trai):")
p0 p00
p01 (polar p00 (* 1.5 pi) (* h 3))
pvL (reverse (getvert et))
n (length pvL)
p02 (polar p01 (* 1.5 pi) (* n h 3))
oldos (getvar "osmode")
)
(setvar "osmode" 0)

;;;HEADER
(linepx p0 (* 38 h))
(command "copy" "L" "" "m" p00 p01 p02 "")
(linepy p0 (* (+ n 1) -3 h))
(command "copy" "L" "" "m" p0
(list(+ (car p0) (* 4 h)) (cadr p0))
(list(+ (car p0) (* 16 h)) (cadr p0))
(list(+ (car p0) (* 28 h)) (cadr p0))
(list(+ (car p0) (* 38 h)) (cadr p0))
""
)

(txt1 (list "TT" "X (m)" "Y (m)" "S (m)"))
(setq p0 (polar p0 (* 1.5 pi) (* 3 h)))

;;;MAKE RECORDS
(setq j 0 pt nil)
(repeat n
(setq
pv (nth j pvL)
num (itoa (1+ j))
)
(if pt (setq S (rtos (distance pt pv) 2 ntp)) (setq S ""))
(setq txtL (list num (rtos (cadr pv) 2 ntp) (rtos (car pv) 2 ntp) S))
(txt2 txtL)
(setq p0 (polar p0 (* 1.5 pi) (* 3 h)))
(setq pt pv)
(setq j (1+ j))
(if (= j (- n 1)) (setq j 0))
)

;;;MAKE BLOCK
(setq ss (collect1 et))
(setq bn "1")
(while (tblsearch "block" bn) (setq bn (itoa (1+ (atoi bn)))))
(command "block" bn p00 ss "")
(command "insert" bn p00 "" "" "")

;;;WRITE POINT NAME
(setq j 0)
(repeat (1- n)
(setq
pv (nth j pvL)
num (itoa (1+ j))
)
(wtxtMC num (polar pv 0 h) h)
(setq j (1+ j))
)

;;;GHI CANH THUA
(ghicanh et)
(command "erase" et "")

;;;FINISH
(setvar "osmode" oldos)
(princ)
)
;;;-------------------------------------------------------------------------------



;;;PHAN BO SUNG CUA elleHCSC
;;;------------------------------------------------------------------------------------
(defun Text_canh_TCA (S p a) ;;;Entmake text S at p with angle A - Top Center
(if (/= p nil)
(entmake (list
(cons 0 "TEXT")
(cons 62 5)
(cons 10 p)
(cons 40 h)
(cons 1 S)
(cons 50 a)
(cons 41 0.7)
(cons 51 (DTR 18))
(cons 7 (getvar "textstyle"))
(cons 72 1)
(cons 11 p)
(cons 73 3)
)
)
)
)
;;;------------------------------------------------------------------------------------
(defun Text_canh_BCA (S p a) ;;;Entmake text S at p with angle A - Bottom Center
(if (/= p nil)
(entmake (list
(cons 0 "TEXT")
(cons 62 5)
(cons 10 p)
(cons 40 h)
(cons 1 S)
(cons 50 a)
(cons 41 0.7)
(cons 51 (DTR 18))
(cons 7 (getvar "textstyle"))
(cons 72 1)
(cons 11 p)
(cons 73 1)
)
)
)
)
;;;-------------------------------------------------------------------------------
(defun Ghicanh (e / i pvL k p1 p2 dist rad x_mp y_mp mp)
(setq
i 0
pvL (reverse (getvert e))
k (1- (length pvL))
)
(repeat k
(setq
p1 (nth i pvL)
p2 (nth (+ i 1) pvL)
dist (distance p1 p2)
rad (angle p1 p2)
x_mp (* (+ (car p1) (car p2)) 0.5)
y_mp (* (+ (cadr p1) (cadr p2)) 0.5)
mp (list x_mp y_mp)
)
(if (and (> rad (* 0.5 pi)) (<= rad (* 1.5 pi)))
(setq mp (polar mp (+ rad (* 0.5 pi)) (* 0.3 h) ))
)
(if (and (> rad (* 0.5 pi)) (<= rad (* 1.5 pi)))
(progn
(setq rad (+ rad pi))
(Text_canh_TCA (rtos dist 2 2) mp rad)
)
(Text_canh_BCA (rtos dist 2 2) mp rad)
)
(setq i (1+ i))
);; repeat k;
)
;;;--------------------------

http://www.cadviet.com/upfiles/Mau_2.dwg

- Đoạn lisp 2 em là của Bác Nguyen Hoanh viết dùng để đưa các đối tượng từ bản vẽ 3D về 2D có lệnh: ve0

---Yêu cầu: các đối tượng có chiều cao z thì được dời sang trục x hay y 1 khoảng cách mà người thực hiện nhập số vào

Dưới đây là đường link file mẫu:

;Dung chuyen ban ve 3d thanh 2d
(defun c:ve0 ()
(defun suadinhPl(thongtin / index doituong doituongmoi
toado)
(setq
doituong (assoc '38 thongtin)
doituongmoi
(cons 38 0.)
)
(subst doituongmoi doituong
thongtin)
)
(defun suadinh (thongtin / index doituong
doituongmoi toado)
(setq thongtinmoi nil)
(foreach doituong
thongtin
(if (and (>= (car doituong) 10)
(<= (car
doituong) 36)
)
(setq doituongmoi
(list (car
doituong)
(cadr doituong)
(caddr
doituong)
0.0
)
)
(setq doituongmoi
doituong)
)
(setq thongtinmoi (append thongtinmoi (list
doituongmoi)))
)
(setq thongtinmoi thongtinmoi)
)
(defun
tendoituong (ssdt /)
(cdr (assoc '0 (entget
ssdt)))
)
(setq
tapdoituong (ssget)
sodt (sslength tapdoituong)
index 0
ta
(chr 8)
stxoa (strcat ta ta ta ta ta ta ta ta ta ta ta ta ta ta
ta ta ta ta ta ta)
stxuly "Xu ly duoc: "
ptcu
nil
)
(repeat sodt
(setq
ssdt (ssname tapdoituong
index)
pt (* (/ (* index 1.0) sodt) 100.0)
index (1+
index)
)
(if (/= pt ptcu)
(progn
(princ (strcat stxoa
stxuly (rtos pt 2 0) "%"))
(setq ptcu pt)
)
)
(if (or
(= (tendoituong ssdt) "SPLINE")
(= (tendoituong ssdt) "LINE")

(= (tendoituong ssdt) "CIRCLE")
(= (tendoituong ssdt)
"ARC")
(= (tendoituong ssdt) "POLYLINE")
(= (tendoituong ssdt)
"ELLIPSE")
(= (tendoituong ssdt) "TEXT")
(= (tendoituong ssdt)
"DIMENSION")
(= (tendoituong ssdt) "ATTDEF")
(= (tendoituong
ssdt) "SOLID")
(= (tendoituong ssdt) "INSERT")
(= (tendoituong
ssdt) "ATTRIB")
(= (tendoituong ssdt)
"HATCH")
)
(progn
(setq thongtin (entget ssdt)
thongtin
(suadinh thongtin)
)
(entmod thongtin)
)
)
(if (=
(tendoituong ssdt) "LWPOLYLINE")
(progn
(setq thongtin (entget
ssdt)
thongtin (suadinhPL thongtin)
)
(entmod
thongtin)
)
)
(princ)
)
)

http://www.cadviet.com/upfiles/Mau_2_2.dwg

Do hôm nay Upload file len cadviet ko được nên nếu bài có dài quá thì mong các Bác thông cảm, do em chưa biết cách cho bài vào box

Tháng 6 22, 2009

Em xin nói lại yêu cầu của em:
- Đoạn lisp 1 của Bác SSG dùng để vẽ bảng Toạ Độ Góc Ranh có lệnh : vc

---Yêu cầu 1: thêm hình tròn có tô hatch tại các đỉnh ( nếu được thì mong Bác có thể cho người dùng nhập đường kính vòng tròn)

---Yêu cầu 2: chuyển lại font chữ giũa kích thước và số TT ( số TT cho font chữ nghiêng và kích thước cho font chữ thẳng và tô đậm)

---Yêu cầu 3: mong Bác có thể cho người dùng được chọn save lại hay không save lại bảng TĐGR ngay tại thư mục đã mở bản vẽ ra bằng file excel từng cột để cần thì có thể phục vụ cho công tác sau này.

bạn test thử lệnh vc sửa.

;; free lisp from cadviet.com

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Chuong trinh danh so va lap bang toa do ho so thua dat dia chinh
;;;Bang toa do tao thanh block, duoc dat ten theo so thu tu 1, 2, 3...
;;;Chap nhan cac doi tuong la Region, Polyline, Line va Arc khep kin
;;;Written by ssg and elleHCSC - January 2009 - www.cadviet.com
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;PUBLIC FUNCTIONS
;;;-------------------------------------------------------------------------------
(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 getVert (e / i L)
;;;Return list of all vertex from pline e
 (setq	i 0
L nil
 )
 (vl-load-com)
 (repeat (fix (+ (vlax-curve-getEndParam e) 1))
   (setq L (append L (list (vlax-curve-getPointAtParam e i))))
   (setq i (1+ i))
 )
 L
)

;;;-------------------------------------------------------------------------------
(defun wtxtMC (txt p h k)
;;;Write text Middle Center, specify text, point, height
 (entmake (list (cons 0 "TEXT")
	 (cons 7 (getvar "textstyle"))
	 (cons 1 txt)
	 (cons 10 p)
	 (cons 11 p)
	 (cons 40 h)
	 (cons 72 1)
	 (cons 73 2)
	 (if k (cons 51 (DTR 18)) (cons 51 0))
   )
 )
)
;;;-------------------------------------------------------------------------------
(defun Collect (e / e2 SS)
;;;Selection set from e to entlast
 (setq SS (ssadd))
 (ssadd e SS)
 (while (setq e2 (entnext e)) (ssadd e2 SS) (setq e e2))
 SS
)
;;;-------------------------------------------------------------------------------
(defun Collect1	(e / ss)
;;;Selection set after e to entlast. If e nil, select all from fist entity of drawing.
 (if (= e nil)
   (setq ss (collect (entnext)))
   (progn (setq ss (collect e)) (ssdel e ss))
 )
)
;;;-------------------------------------------------------------------------------

;;;PRIVATE FUNCTIONS
;;;-------------------------------------------------------------------------------
(defun txt1 (txtL / p1 p2 p3 p4 pL i)
;;;Write texts in 1 row
 (setq
   p1 (list (+ (car p0) (* 2 h)) (- (cadr p0) (* 1.5 h)))
   p2 (polar p1 0 (* 8 h))
   p3 (polar p2 0 (* 12 h))
   p4 (polar p3 0 (* 10 h))
   pL (list p1 p2 p3 p4)
   i  0
 )
 (repeat 4
   (wtxtMC (nth i txtL) (nth i pL) h t)
   (setq i (1+ i))
 )
)
;;;-------------------------------------------------------------------------------
(defun txt2 (txtL / p1 p2 p3 p4 pL i)
;;;Write texts in 1 row
 (setq
   p1 (list (+ (car p0) (* 2 h)) (- (cadr p0) (* 1.5 h)))
   p2 (polar p1 0 (* 8 h))
   p3 (polar p2 0 (* 12 h))
   p4 (polar p3 0 (* 10 h))
;;;    p4 (polar p4 (* 0.5 pi) (* 1.5 h))
   p4 (polar p4 (* 0.5 pi) h)
   pL (list p1 p2 p3 p4)
   i  0
 )
 (repeat 4
   (wtxtMC (nth i txtL) (nth i pL) h t)
   (setq i (1+ i))
 )
)
;;;-------------------------------------------------------------------------------


;;;MAIN PROGRAM
;;;-------------------------------------------------------------------------------
(defun C:VC ();/ h p et p0 p00 p01 p02 pt pvL n j pv num txtL ss bn ntp)
;;;Vertex Co-ordinate

;;;GET TEXT HEIGHT
 (if (not h0)  (setq h0 1))
 (setq h (getreal (strcat "\nChon chieu cao text <" (rtos h0) ">:")))
 (if (not h)  (setq h h0)  (setq h0 h))

;;;GET DECIMAL PRECISION
 (if (not ntp0)  (setq ntp0 2))
 (setq ntp (getint (strcat "\nSo chu so thap phan <" (itoa ntp0) ">:")))
 (if (not ntp)  (setq ntp ntp0)  (setq ntp0 ntp))

;;;GET CIRCLE RADIUS
 (if (not cr0)  (setq cr0 0.3))
 (setq cr (getreal (strcat "\nBan kinh vong tron <" (rtos cr0) ">:")))
 (if cr (setq cr0 cr))

;;;PICK & BASE POINT
 (setq p (getpoint "\nPick 1 diem giua mien kin:"))
 (command "boundary" p "")
 (setq et (entlast))
 (redraw et 3)
 (setq
   p00	  (getpoint "\nDiem chuan bang toa do (phia tren ben trai):")
   p0	  p00
   p01	  (polar p00 (* 1.5 pi) (* h 3))
   pvL	  (reverse (getvert et))
   n	  (length pvL)
   p02	  (polar p01 (* 1.5 pi) (+ (* h 3) (* (1- n) h 2)))
   oldos (getvar "osmode")
 )
 (setvar "osmode" 0)

;;;HEADER
 (linepx p0 (* 38 h))
 (command "copy" "L" "" "m" p00 p01 p02 "")
 (linepy p0 (- (distance p0 p02)))
 (command "copy" "L" "" "m"  p0
   (list (+ (car p0) (* 4 h)) (cadr p0))
   (list (+ (car p0) (* 16 h)) (cadr p0))
   (list (+ (car p0) (* 28 h)) (cadr p0))
   (list (+ (car p0) (* 38 h)) (cadr p0))
   "")
 (setq Lkqua nil)
 (txt1 (setq Lkq (list "TT" "X (m)" "Y (m)" "S (m)")))
 (setq Lkqua (append Lkqua (list Lkq)))
 (setq p0 (polar p0 (* 1.5 pi) (* 3 h)))

;;;MAKE RECORDS
 (setq	j  0
pt nil)
 (repeat n
   (setq
     pv  (nth j pvL)
     num (itoa (1+ j))
   )
   (if	pt
     (setq S (rtos (distance pt pv) 2 ntp))
     (setq S "")
   )
   (setq
     txtL (list num (rtos (cadr pv) 2 ntp) (rtos (car pv) 2 ntp) S)
     Lkqua (append Lkqua (list txtL))
   )
   (txt2 txtL)
   (setq p0 (polar p0 (* 1.5 pi) (* 2 h)))
   (setq pt pv)
   (setq j (1+ j))
   (if	(= j (- n 1))  (setq j 0))
 )

;;;MAKE BLOCK
 (setq ss (collect1 et))
 (setq bn "1")
 (while (tblsearch "block" bn)
   (setq bn (itoa (1+ (atoi bn))))
 )
 (command "block" bn p00 ss "")
 (command "insert" bn p00 "" "" "")

;;;WRITE POINT NAME
 (setq j 0)
 (repeat (1- n)
   (setq
     pv  (nth j pvL)
     num (itoa (1+ j))
   )
   (wtxtMC num (polar pv 0 h) h t)
   (command "circle" pv cr0)
   (command "hatch" "S" (entlast) "")
   (setq j (1+ j))
 )

;;;GHI CANH THUA
 (ghicanh et)
 (command "erase" et "")

;;;FINISH
 (initget 1 "Y N")
 (setq save (getkword "Save:"))
 (if (= save "Y")
   (progn
     (setq file (open (strcat (getvar "dwgprefix")
 (vl-filename-base (vl-string-right-trim "\\" (getvar "dwgname"))) ".txt") "w"))
     (foreach line Lkqua
(setq line1 "")
(foreach it line
  (setq line1 (strcat line1 " " it)))
(write-line line1 file)
     )
     (close file)
   )
 )
 (setvar "osmode" oldos)
 (princ)
)
;;;-------------------------------------------------------------------------------



;;;PHAN BO SUNG CUA elleHCSC
;;;------------------------------------------------------------------------------------
(defun Text_canh_TCA (S p a)
;;;Entmake text S at p with angle A - Top Center
 (if (/= p nil)
   (entmake (list
       (cons 0 "TEXT")
       (cons 62 5)
       (cons 10 p)
       (cons 40 h)
       (cons 1 S)
       (cons 50 a)
       (cons 41 0.7)
       (cons 7 (getvar "textstyle"))
       (cons 72 1)
       (cons 11 p)
       (cons 73 3)
     )
   )
 )
)
;;;------------------------------------------------------------------------------------
(defun Text_canh_BCA (S p a)
;;;Entmake text S at p with angle A - Bottom Center
 (if (/= p nil)
   (entmake (list
       (cons 0 "TEXT")
       (cons 62 5)
       (cons 10 p)
       (cons 40 h)
       (cons 1 S)
       (cons 50 a)
       (cons 41 0.7)
       (cons 7 (getvar "textstyle"))
       (cons 72 1)
       (cons 11 p)
       (cons 73 1)
     )
   )
 )
)
;;;-------------------------------------------------------------------------------
(defun Ghicanh (e / i pvL k p1 p2 dist rad x_mp y_mp mp)
 (setq
   i	0
   pvL	(reverse (getvert e))
   k	(1- (length pvL))
 )
 (repeat k
   (setq
     p1   (nth i pvL)
     p2   (nth (+ i 1) pvL)
     dist (distance p1 p2)
     rad  (angle p1 p2)
     x_mp (* (+ (car p1) (car p2)) 0.5)
     y_mp (* (+ (cadr p1) (cadr p2)) 0.5)
     mp   (list x_mp y_mp)
   )
   (if	(and (> rad (* 0.5 pi)) (<= rad (* 1.5 pi)))
     (setq mp (polar mp (+ rad (* 0.5 pi)) (* 0.3 h)))
   )
   (if	(and (> rad (* 0.5 pi)) (<= rad (* 1.5 pi)))
     (progn
(setq rad (+ rad pi))
(Text_canh_TCA (rtos dist 2 2) mp rad)
     )
     (Text_canh_BCA (rtos dist 2 2) mp rad)
   )
   (setq i (1+ i))
 )
 ;; repeat k;
)
;;;--------------------------

Tháng 6 23, 2009

Trước tiên xin cá mon Bác q228 đã chỉnh sữa đoạn lisp vc dùm em, sau khi chạy thử thì em thấy chạy rất tốt, như bên cạnh đó còn một số thắc mắc sau nhờ Bác chỉnh thêm dùm em 1 chút.

- Những thửa nhỏ thì chạy rất tốt, còn thửa lớn như trong file mẫu thì chạy xong rồi mất ranh luôn Bác oi.

- Trước khi chạy thì nó kiểm tra xem có layer kichthuoc, stt, bangtd, nếu có rồi thì thôi, nếu chư có thì tạo. Kích thước thửa đất thì gán cho layer: kichthuoc, số TT và vòng tròn thì gán cho layer: stt và bảng TĐGR thì gán cho layer: bangtd

- Vị trí điểm thứ tự đầu tiên thì cho người sử dụng được chọn. ( do đôi lúc có những thửa đất nằm ngay mặt tiền đường thỉ phải chạy từ hướng mặt tiền rồi mới đến các vị trí khác trên thửa đất )

- Thêm chử : < BẢNG LIỆT KÊ TỌA ĐỘ GÓC RANH> phía trên bảng tọa độ

- Khung text STT thì để nguyên, khung tọa độ x-y thì cho khoảng cách 10, còn khung khoảng cách thì cho 8 ( để bảng TĐGr được đẹp hơn )

File dwg mẫu:

http://www.cadviet.com/upfiles/mau_2.dwg

Đăng nhập

Viết Lisp theo yêu cầu

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

xuantran15 112

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

xuandao0708 9

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

duy782006 1.526

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

truongthanh 7

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

xuandao0708 9

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

thiep 365

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

Snowman 92

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

ph168xd 313

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

nataca 554

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

truongthanh 7

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

gia_bach 1.548

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

gia_bach 1.548

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

xuantran15 112

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

Tue_NV 3.912

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

xuantran15 112

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

thiep 365

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

xuantran15 112

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

thiep 365

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

xuandao0708 9

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

q288 166