Jump to content
InfoFile
Tác giả: KangKung
Bài viết gốc: 231934
Tên lệnh: kk
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

Không ổn đâu KK ơi. Cái này hy vọng chỉ đúng với integer chỉ gồm 1 chữ số như ví dụ của TL, khi gặp integer có hơn 1 chữ số là bị sai.

VD: (kk "1a2.3b4c56") => 1.0a2.3b4.0c5.06.0

Thanks bác Hà đã phát hiện ra lỗi. Cũng tại viết code theo ví dụ của TL nên không phát hiện ra. Đã sửa lại Code...

>>

Không ổn đâu KK ơi. Cái này hy vọng chỉ đúng với integer chỉ gồm 1 chữ số như ví dụ của TL, khi gặp integer có hơn 1 chữ số là bị sai.

VD: (kk "1a2.3b4c56") => 1.0a2.3b4.0c5.06.0

Thanks bác Hà đã phát hiện ra lỗi. Cũng tại viết code theo ví dụ của TL nên không phát hiện ra. Đã sửa lại Code mới rồi đây. Các bác Test thử xem còn lỗi ở đâu nữa không.

(defun C:kk ( / i j kt b)
  (setq a "a1.2b23.4c4567f78.5g34984")
  (setq i 1)
  (while (<= i (strlen a))
    (setq j (- (1+ (strlen a)) i))
    (setq kt 0)
    (while (and (= kt 0) (>= j 1))
      (setq b(substr a i j))
      (if (and (= (vl-string-search "." b) nil)
	       (= (vl-string-search (strcat b ".") a) nil)
	       (= (vl-string-search (strcat "." b) a) nil))
	(if (and (= (read b) (atof b)) (= kt 0))
	  (progn
	    (setq a(strcat (substr a 1 (- i 1)) b ".0" (substr a (+ i j)) ))
	    (setq kt 1)
	    (setq i (+ i (strlen b)))
	    )
	  )
	)
      (setq j(1- j))
      )
    (setq i (1+ i))
    )
  (princ a)
  (princ)
  )

<<

Filename: 231934_kk.lsp
Tác giả: KangKung
Bài viết gốc: 231943
Tên lệnh: kk
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

Quá tam ba bận. Hi vọng lần này sẽ hết lỗi

(defun C:kk ( / i j kt b lst item)
  (setq a (getstring "\n Nhap chuoi:"))
  (setq lst(list))
  (setq i 1)
  (while (<= i (strlen a))
    (setq j (- (1+ (strlen a)) i))
    (setq kt 0)
    (while (and (= kt 0) (>= j 1))
      (setq b(substr a i j))
      (if (/= b ".")
	(if (and (= (read b) (atof b)) (/= (vl-string-search "." b) nil))
	  (progn
	    (setq kt 1)
	    (setq i (+ i (strlen...
>>

Quá tam ba bận. Hi vọng lần này sẽ hết lỗi

(defun C:kk ( / i j kt b lst item)
  (setq a (getstring "\n Nhap chuoi:"))
  (setq lst(list))
  (setq i 1)
  (while (<= i (strlen a))
    (setq j (- (1+ (strlen a)) i))
    (setq kt 0)
    (while (and (= kt 0) (>= j 1))
      (setq b(substr a i j))
      (if (/= b ".")
	(if (and (= (read b) (atof b)) (/= (vl-string-search "." b) nil))
	  (progn
	    (setq kt 1)
	    (setq i (+ i (strlen b)))
	    )
	  )
	)
      (if (and (= (vl-string-search "." b) nil)
	       (= (vl-string-search (strcat b ".") a) nil)
	       (= (vl-string-search (strcat "." b) a) nil))
	(if (and (= (read b) (atof b)) (= kt 0))
	  (progn
	    (setq lst(append lst (List (list i j b))))
	    (setq kt 1)
	    (setq i (+ i (strlen b)))
	    )
	  )
	)
      (setq j(1- j))
      )
    (setq i (1+ i))
    )
  (setq lst(reverse lst))
  (foreach item lst
  (setq a(strcat (substr a 1 (- (car item) 1)) (caddr item) ".0" (substr a (+ (car item) (cadr item)))))
  )
  (alert a)
  (princ)
  )

<<

Filename: 231943_kk.lsp
Tác giả: 2hproduction
Bài viết gốc: 231981
Tên lệnh: btd
[Yêu cầu] Lisp thống kê tọa độ địa chính

Em có bản đo hiện trạng như sau : http://www.cadviet.com/upfiles/3/116164_trich_toa_do.dwg
Em dùng lisp này để trích tọa độ mà sai hoài. ( chiều dài cạnh 1-2 và 23-1)

 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Chuyen gia tri goc tu do sang radian
;;;Cu phap su dung (duy:s_do>radian giatri)
;;;giatri...
>>

Em có bản đo hiện trạng như sau : http://www.cadviet.com/upfiles/3/116164_trich_toa_do.dwg
Em dùng lisp này để trích tọa độ mà sai hoài. ( chiều dài cạnh 1-2 và 23-1)

 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Chuyen gia tri goc tu do sang radian
;;;Cu phap su dung (duy:s_do>radian giatri)
;;;giatri la goc tinh theo do, kq la goc tinh theo radian
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun duy:s_do>radian (gt / gt kq)
(setq kq (* (/ pi 180) gt))
kq)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Tao moi text
;;;Cu phap su dung (duy:t_text diemchen docao gocquay canhle noidung textstyle layer color)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun duy:t_text (d c g cl nd k la co / d c g cl nd k la co)
(cond
((= cl "trai") (setq kcl 0))
((= cl "phai") (setq kcl 2))
((= cl "giua") (setq kcl 1))
)
(cond ((= g "") (setq g 0) ))
(cond ((= cl "") (setq kcl 0) ))
(setq g (duy:s_do>radian g))
(cond ((= k "") (setq k (getvar "TEXTSTYLE")) ))
(cond ((= la "") (setq la (getvar "Clayer")) ))
(cond ((= co "") (setq co 256) ))
(entmake (list (cons 0 "TEXT")(cons 10 d)(cons 11 d)(cons 40 c)(cons 50 g)(cons 72 kcl)(cons 1 nd)(cons 7 k)(cons 8 la)(cons 62 co)))
(princ)
)
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Tao moi line
;;;Cu phap su dung (duy:t_line diemdau diemcuoi layer color ltype ltypescale)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun duy:t_line (a b la co lt slt / a b la co lt slt)
(cond ((= la "") (setq la (getvar "Clayer")) ))
(cond ((= co "") (setq co 256) ))
(cond ((= lt "") (setq lt "bylayer") ))
(cond ((= slt "") (setq slt 1) ))
(entmake (list (cons 0 "LINE")(cons 10 a)(cons 11 B)(cons 8 la)(cons 62 co)(cons 6 lt)(cons 48 slt) ))
(princ)
)
 
(defun c:btd (/ ddt dtn dth)
(command "undo" "be")
(setq dvbd (getpoint "\nCho\U+0323n \u+0110iê\U+0309m che\U+0300n ba\U+0309ng: "))
(duy:t_line dvbd (list (+ (car dvbd) 30) (cadr dvbd)) "" "" "" "")
(duy:t_line (list (car dvbd) (- (cadr dvbd) 5)) (list (+ (car dvbd) 30) (- (cadr dvbd) 5)) "" "" "" "")
(duy:t_line (list (+ (car dvbd) 0) (- (cadr dvbd) 0)) (list (+ (car dvbd) 0) (- (cadr dvbd) 5)) "" "" "" "")
(duy:t_line (list (+ (car dvbd) 5) (- (cadr dvbd) 0)) (list (+ (car dvbd) 5) (- (cadr dvbd) 5)) "" "" "" "")
(duy:t_line (list (+ (car dvbd) 23) (- (cadr dvbd) 0)) (list (+ (car dvbd) 23) (- (cadr dvbd) 5)) "" "" "" "")
(duy:t_line (list (+ (car dvbd) 26.5) (- (cadr dvbd) 0)) (list (+ (car dvbd) 26.5) (- (cadr dvbd) 5)) "" "" "" "")
(duy:t_line (list (+ (car dvbd) 30) (- (cadr dvbd) 0)) (list (+ (car dvbd) 30) (- (cadr dvbd) 5)) "" "" "" "")
(duy:t_line (list (+ (car dvbd) 5) (- (cadr dvbd) 2.5)) (list (+ (car dvbd) 23) (- (cadr dvbd) 2.5)) "" "" "" "")
(duy:t_line (list (+ (car dvbd) 14) (- (cadr dvbd) 2.5)) (list (+ (car dvbd) 14) (- (cadr dvbd) 5)) "" "" "" "")

(duy:t_text (list (+ (car dvbd) 2.5) (- (cadr dvbd) 3)) 1 0 "giua" "§Ønh" "" "" "")
(duy:t_text (list (+ (car dvbd) 14) (- (cadr dvbd) 1.75)) 1 0 "giua" "Täa §é" "" "" "")
(duy:t_text (list (+ (car dvbd) 9.5) (- (cadr dvbd) 4.25)) 1 0 "giua" "X (m)" "" "" "")
(duy:t_text (list (+ (car dvbd) 18.5) (- (cadr dvbd) 4.25)) 1 0 "giua" "Y (m)" "" "" "")
(duy:t_text (list (+ (car dvbd) 24.75) (- (cadr dvbd) 1.75)) 1 0 "giua" "Tªn" "" "" "")
(duy:t_text (list (+ (car dvbd) 28.25) (- (cadr dvbd) 1.75)) 1 0 "giua" "C¹nh" "" "" "")
(duy:t_text (list (+ (car dvbd) 24.75) (- (cadr dvbd) 4.25)) 1 0 "giua" "C¹nh" "" "" "")
(duy:t_text (list (+ (car dvbd) 28.25) (- (cadr dvbd) 4.25)) 1 0 "giua" "(m)" "" "" "")
 
(setq dvbd (list (car dvbd) (- (cadr dvbd) 5)))
(duy:t_line (list (car dvbd) (- (cadr dvbd) 2)) (list (+ (car dvbd) 23) (- (cadr dvbd) 2)) "" "" "" "")
(duy:t_line (list (+ (car dvbd) 23) (- (cadr dvbd) 3)) (list (+ (car dvbd) 30) (- (cadr dvbd) 3)) "" "" "" "")
 
(setq ddt (getpoint "\nCho\U+0323n \u+0110i\U+0309nh 1: "))
(setq dtn ddt)
(setq sttn 1)
(duy:t_text (list (+ (car dvbd) 2.5) (- (cadr dvbd) 1.5)) 1 0 "giua" "1" "" "" "")
(duy:t_text (list (+ (car dvbd) 9.5) (- (cadr dvbd) 1.5)) 1 0 "giua" (rtos (cadr dtn) 2 3) "" "" "")
(duy:t_text (list (+ (car dvbd) 18.5) (- (cadr dvbd) 1.5)) 1 0 "giua" (rtos (car dtn) 2 3) "" "" "")
 
(while (setq dth (getpoint dtn(strcat "\nCho\U+0323n \U+0110i\U+0309nh " (rtos (+ sttn 1) 2 0) " <Enter \u+0110ê\U+0309 kê\U+0301t thu\U+0301c!>")  ))
(grdraw dtn dth 7)
(duy:t_line (list (car dvbd) (- (- (cadr dvbd) (* 2 sttn)) 2)) (list (+ (car dvbd) 23) (- (- (cadr dvbd) (* 2 sttn)) 2)) "" "" "" "")
(duy:t_text (list (+ (car dvbd) 2.5) (- (- (cadr dvbd) (* 2 sttn)) 1.5)) 1 0 "giua" (rtos (+ sttn 1) 2 0) "" "" "")
(duy:t_text (list (+ (car dvbd) 9.5) (- (- (cadr dvbd) (* 2 sttn)) 1.5)) 1 0 "giua" (rtos (cadr dth) 2 3) "" "" "")
(duy:t_text (list (+ (car dvbd) 18.5) (- (- (cadr dvbd) (* 2 sttn)) 1.5)) 1 0 "giua" (rtos (car dth) 2 3) "" "" "")
(duy:t_text (list (+ (car dvbd) 24.8) (- (- (cadr dvbd) (* 2 sttn)) 0.5)) 1 0 "giua" (strcat (rtos sttn 2 0) "-" (rtos (+ sttn 1) 2 0)) "" "" "")
(duy:t_text (list (+ (car dvbd) 28.3) (- (- (cadr dvbd) (* 2 sttn)) 0.5)) 1 0 "giua" (rtos (distance dtn dth) 2 2) "" "" "")
(duy:t_line (list (+ (car dvbd) 23) (- (- (cadr dvbd) (* 2 sttn)) 3)) (list (+ (car dvbd) 30) (- (- (cadr dvbd) (* 2 sttn)) 3)) "" "" "" "")
 
(setq dtn dth)
(setq sttn (+ sttn 1))
)
(command ".erase" "last" "")
(duy:t_line (list (car dvbd) (- (- (cadr dvbd) (* 2 sttn)) 2)) (list (+ (car dvbd) 30) (- (- (cadr dvbd) (* 2 sttn)) 2)) "" "" "" "")
(duy:t_text (list (+ (car dvbd) 2.5) (- (- (cadr dvbd) (* 2 sttn)) 1.5)) 1 0 "giua" "1" "" "" "")
(duy:t_text (list (+ (car dvbd) 9.5) (- (- (cadr dvbd) (* 2 sttn)) 1.5)) 1 0 "giua" (rtos (cadr ddt) 2 3) "" "" "")
(duy:t_text (list (+ (car dvbd) 18.5) (- (- (cadr dvbd) (* 2 sttn)) 1.5)) 1 0 "giua" (rtos (car ddt) 2 3) "" "" "")
(duy:t_text (list (+ (car dvbd) 24.8) (- (- (cadr dvbd) (* 2 sttn)) 0.5)) 1 0 "giua" (strcat (rtos sttn 2 0) "-" "1") "" "" "")
(duy:t_text (list (+ (car dvbd) 28.3) (- (- (cadr dvbd) (* 2 sttn)) 0.5)) 1 0 "giua" (rtos (distance dtn ddt) 2 2) "" "" "")
 
(command "undo" "end")
(Princ)
)
  

 

Bác nào biết vào giúp em với ạ (hình như lisp này của bác @duy782006) Hình như nó không cho bắt điểm giao thì phải.
Em xin cảm ơn!


<<

Filename: 231981_btd.lsp
Tác giả: draftsman38751
Bài viết gốc: 181607
Tên lệnh: oval
[Nhờ chỉnh sửa]Lisp vẽ hình oval
Nhờ các bác chỉnh sửa giúp em lisp này với!Cảm ơn các bác nhiều!!

(defun main
FasStringtables 0
FasStringtables 1
(defun main
nil
(setq C:OVAL <Func> C:OVAL)
(vl-ACAD-defun C:OVAL)
(defun C:OVAL
(_al-bind-alist '(*OVL:ERR* C_E C1 C2 R ANG O1 O2 O3 O4 CE))
(defun *OVL:ERR*
(M)
(cond (MEMBER M '("Function cancelled" "quit / exit abort" "console break")) (
>>
Nhờ các bác chỉnh sửa giúp em lisp này với!Cảm ơn các bác nhiều!!

(defun main
FasStringtables 0
FasStringtables 1
(defun main
nil
(setq C:OVAL <Func> C:OVAL)
(vl-ACAD-defun C:OVAL)
(defun C:OVAL
(_al-bind-alist '(*OVL:ERR* C_E C1 C2 R ANG O1 O2 O3 O4 CE))
(defun *OVL:ERR*
(M)
(cond (MEMBER M '("Function cancelled" "quit / exit abort" "console break")) (
(cond (PROMPT (STRCAT "\n< " M " >\n")) (
it's OR skip next 6 bytes -> 81
it's OR skip next 6 bytes -> 81
T
(ENTDEL CE)
(SETVAR Then OR Else C_E)
(setq *ERROR* *E*)
(setq *OVL:ERR* <Func> *OVL:ERR*)
(cond *E* (
(cond *ERROR* (
normal cond
normal cond
(setq *E* nil)
(setq *ERROR* *OVL:ERR*)
(setq C_E (GETVAR "cmdecho"))
(setq C1 (GETPOINT "\nFirst end of oval <center point>: "))
(PROMPT "\nOval width <point>: ")
(SETVAR "cmdecho" 0)
(ads-cmd "circle")
(ads-cmd C1)
(ads-cmd PAUSE)
(setq CE (ENTLAST ))
(PROMPT "\nOther end of oval: ")
(ads-cmd "move")
(ads-cmd "l")
(ads-cmd "")
(ads-cmd C1)
(ads-cmd PAUSE)
(setq C2 (CDR (ASSOC 10 (ENTGET (ENTLAST )))))
(setq R (CDR (ASSOC 40 (ENTGET (ENTLAST )))))
(setq ANG (ANGLE C1 C2))
(setq O1 (POLAR C1 (+ ANG (/ PI 2)) R))
(setq O2 (POLAR C1 (- ANG (/ PI 2)) R))
(setq O3 (POLAR C2 (- ANG (/ PI 2)) R))
(setq O4 (POLAR C2 (+ ANG (/ PI 2)) R))
(ENTDEL CE)
(ads-cmd "pline")
(ads-cmd O1)
(ads-cmd "w")
(ads-cmd 0)
(ads-cmd 0)
(ads-cmd "a")
(ads-cmd "ce")
(ads-cmd C1)
(ads-cmd O2)
(ads-cmd "l")
(ads-cmd O3)
(ads-cmd "a")
(ads-cmd O4)
(ads-cmd "l")
(ads-cmd "c")
(SETVAR Then OR Else C_E)
(setq *ERROR* *E*)

<<

Filename: 181607_oval.lsp
Tác giả: KangKung
Bài viết gốc: 232028
Tên lệnh: kk
Tác giả: KangKung
Bài viết gốc: 232187
Tên lệnh: goc
[yêu cầu] LISP xuất lần lược các góc của tuyến

Theo tôi bạn nên vẽ tuyến đó bằng PLINE (hoặc dùng Lisp nối các Line rời rạc đó thành PLINE) rồi dùng Lisp dưới đây.

http://www.cadviet.com/upfiles/3/71162_lisp_thong_ke_goc_cua_pline.lsp

;==========LISP THONG KE GOC CUA PLINE==========
;=============KANGKUNG 18/04/2013===============
(defun C:Goc ( / i plsel pldata verts...
>>

Theo tôi bạn nên vẽ tuyến đó bằng PLINE (hoặc dùng Lisp nối các Line rời rạc đó thành PLINE) rồi dùng Lisp dưới đây.

http://www.cadviet.com/upfiles/3/71162_lisp_thong_ke_goc_cua_pline.lsp

;==========LISP THONG KE GOC CUA PLINE==========
;=============KANGKUNG 18/04/2013===============
(defun C:Goc ( / i plsel pldata verts bend)
  (vl-load-com)
  (setq bendlist(list))
  (while (not (setq plsel (ssget '((0 . "LWPOLYLINE,POLYLINE"))))))
  (setq pldata (entget (ssname plsel 0)) verts (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) pldata)))
  (setq i 1)
  (while (> (length verts) 2)
    (setq ang1 (angle (car verts) (cadr verts)) ang2 (angle (cadr verts) (caddr verts))
	  bend (if (> (abs (- ang2 ang1)) pi)
		 (+ (min ang1 ang2) (- (* pi 2) (max ang1 ang2)))
		 (abs (- ang2 ang1)))
	  bendlist (append bendlist (list (strcat "\nGoc " (itoa i) ": " (rtos (- pi bend)))))
	  verts (cdr verts)
	  i(1+ i))
    )
  (foreach x bendlist (princ (strcat x " ")))
  (princ)
)
(princ "\n              KangKung - 18/04/2013\n")
(princ "\n           Nhap GOC de chay chuong trinh\n")

<<

Filename: 232187_goc.lsp
Tác giả: duy782006
Bài viết gốc: 232202
Tên lệnh: edd
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

Mình làm lisp như sau:

Để sửa các đối tượng là text, att trong block thuộc tính, giá trị dim.

Nhưng ko biết sai chổ nào mà dim không tài nào sửa được.

Các bác xoi giúp với. Cám ơn!

(defun duy:docgt (/ dchon)
(setq dchon (car (nentselp "\nChon")))
(while
(or
(null dchon)
(and (= (cdr (assoc 1 (entget dchon))) nil)
)
)
(princ "\nDoi tuong khong hop le")
(setq dchon (car (nentselp...
>>

Mình làm lisp như sau:

Để sửa các đối tượng là text, att trong block thuộc tính, giá trị dim.

Nhưng ko biết sai chổ nào mà dim không tài nào sửa được.

Các bác xoi giúp với. Cám ơn!

(defun duy:docgt (/ dchon)
(setq dchon (car (nentselp "\nChon")))
(while
(or
(null dchon)
(and (= (cdr (assoc 1 (entget dchon))) nil)
)
)
(princ "\nDoi tuong khong hop le")
(setq dchon (car (nentselp "\nChon")))
)
dchon)



(defun c:edd (/ doituong noidung suathanh DTMs)
(command "undo" "be")
(setq doituong (duy:docgt))
(setq noidung (cdr (assoc 1 (entget doituong))))
(setq suathanh (lisped noidung))
(setq DTMs (subst (cons 1 suathanh) (assoc 1 (entget doituong)) (entget doituong)))
(entmod DTMs)
(command ".move" doituong "" "_non" (list 0 0 0) "_non" (list 0 0 0))
(command "undo" "end")
(princ)
)


<<

Filename: 232202_edd.lsp
Tác giả: Tue_NV
Bài viết gốc: 232217
Tên lệnh: edd
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

Mình làm lisp như sau:

Để sửa các đối tượng là text, att trong block thuộc tính, giá trị dim.

Nhưng ko biết sai chổ nào mà dim không tài nào sửa được.

Các bác xoi giúp với. Cám ơn!

(defun duy:docgt (/ dchon)
(setq dchon (car (nentselp "\nChon")))
(while
(or
(null dchon)
(and (= (cdr...
>>

Mình làm lisp như sau:

Để sửa các đối tượng là text, att trong block thuộc tính, giá trị dim.

Nhưng ko biết sai chổ nào mà dim không tài nào sửa được.

Các bác xoi giúp với. Cám ơn!

(defun duy:docgt (/ dchon)
(setq dchon (car (nentselp "\nChon")))
(while
(or
(null dchon)
(and (= (cdr (assoc 1 (entget dchon))) nil)
)
)
(princ "\nDoi tuong khong hop le")
(setq dchon (car (nentselp "\nChon")))
)
dchon)



(defun c:edd (/ doituong noidung suathanh DTMs)
(command "undo" "be")
(setq doituong (duy:docgt))
(setq noidung (cdr (assoc 1 (entget doituong))))
(setq suathanh (lisped noidung))
(setq DTMs (subst (cons 1 suathanh) (assoc 1 (entget doituong)) (entget doituong)))
(entmod DTMs)
(command ".move" doituong "" "_non" (list 0 0 0) "_non" (list 0 0 0))
(command "undo" "end")
(princ)
)

 

Em Xơi giúp anh đây : (né dùng vl....)  :lol:

 
(defun duy:docgt (/ dchon)
(setq dchon (nentselp "\nChon"))
(if (eq (type (car(last dchon))) 'ENAME) (setq dchon (car (last dchon))) (setq dchon (car dchon)) )
(while
(or
(null dchon)
(and (= (cdr (assoc 1 (entget dchon))) nil)
)
)
(princ "\nDoi tuong khong hop le")
(setq dchon (nentselp "\nChon"))
(if (eq (type (car(last dchon))) 'ENAME) (setq dchon (car (last dchon))) (setq dchon (car dchon)) )
)
dchon
)
;;;;;
(defun c:edd (/ doituong noidung suathanh DTMs)
(command "undo" "be")
(setq doituong (duy:docgt))
(setq noidung (cdr (assoc 1 (entget doituong))))
(setq suathanh (lisped noidung))
(setq DTMs (subst (cons 1 suathanh) (assoc 1 (entget doituong)) (entget doituong)))
(entmod DTMs)
(command ".move" doituong "" "_non" (list 0 0 0) "_non" (list 0 0 0))
(command "undo" "end")
(princ)
)

<<

Filename: 232217_edd.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 231041
Tên lệnh: edtblk
[Yêu cầu] nhờ sửa thêm phần gọi Block text và cho nó song song đoạn thẳng

dạ, cảm ơn anh!

http://www.cadviet.com/upfiles/3/62465_ten_duong.dwg

Bạn hãy thử lisp này xem có cần chỉnh sửa gì không nhé.

Bạn lưu ý là phải sửa lại đường dẫn tới file chứa mtext của bạn cho phù hợp với vị trí lưu file trên máy của bạn...

>>

dạ, cảm ơn anh!

http://www.cadviet.com/upfiles/3/62465_ten_duong.dwg

Bạn hãy thử lisp này xem có cần chỉnh sửa gì không nhé.

Bạn lưu ý là phải sửa lại đường dẫn tới file chứa mtext của bạn cho phù hợp với vị trí lưu file trên máy của bạn trước khi chạy lisp nhé. Đường dẫn này nằm trong dòng code:

(command "insert" "D:\\Dowload\\62465_ten_duong.dwg" (getpoint "\n Chon diem bat ky tren ban ve") 1 1 0)

Cái thằng  "D:\\Dowload\\62465_ten_duong.dwg" là cái đường dẫn tới file chứa mtext bạn gửi, chỉ có trên máy của mình. Đưa vào máy của bạn sẽ có thể bị lỗi đó.

Chúc bạn vui và có một tuần làm việc thành công.

 

(defun c:edtblk (/ edt e1 e2 p1 p2 p3 etxt goc etxt)
(vl-load-com)
(setq oldos (getvar "osmode"))
(setvar "osmode" 512)
(setq edt (entsel "\n Pick < diem dat text > tren tim duong") 
          e1 (car edt)
          p1 (cadr edt)
          p2 (getpoint p1 "\n Chon diem xac dinh huong dat text")
          p3 (acet-geom-midpoint p1 p2)
          goc (angle p1 p2)
)
;;(entmake (list (cons 0 "mtext") (cons 100  "AcDbEntity") (assoc 8 etxt) (cons 100  "AcDbMText")  
                       ;; (cons 10 p3)  (assoc 40 etxt) (cons 71 5) (assoc 72 etxt) (assoc 1 etxt)
                       ;; (assoc 7 etxt) (cons 50 goc) (assoc 73 etxt)   ) )
(command "insert" "D:\\Dowload\\62465_ten_duong.dwg" (getpoint "\n Chon diem bat ky tren ban ve") 1 1 0)
(command "explode" (entlast) "")
(setq e2 (entlast))
(setq  etxt (entget e2)
           etxt (subst (cons 10 p3) (assoc 10 etxt) etxt)
           etxt (subst (cons 50 goc) (assoc 50 etxt) etxt) )
(entmod etxt)
(entupd e2)
(command "ddedit" e2 pause)
(setvar "osmode" oldos)
(princ)
)

<<

Filename: 231041_edtblk.lsp
Tác giả: KangKung
Bài viết gốc: 232251
Tên lệnh: goc
[yêu cầu] LISP xuất lần lược các góc của tuyến

1. Bác lồng thêm vào phần đầu: sau khi chọn một số line, nó sẽ chuyển nhóm line đó thành pline trước khi thao tác, sau đó, khi thao tác xong rồi, lại explode pline đó trả ra lại thành các line thành phần như lúc đầu.

 

2. Ngoài ra, không biết điều em sắp đòi hỏi tiếp theo có quá...

>>

1. Bác lồng thêm vào phần đầu: sau khi chọn một số line, nó sẽ chuyển nhóm line đó thành pline trước khi thao tác, sau đó, khi thao tác xong rồi, lại explode pline đó trả ra lại thành các line thành phần như lúc đầu.

 

2. Ngoài ra, không biết điều em sắp đòi hỏi tiếp theo có quá đáng lắm không nữa, giả định chưa biết trước là Pline có bao nhiêu đoạn line thành phần cấu thành, đặt là n. Sau khi LISP chạy xong sẽ gán cho các biến a1 = giá trị góc thứ nhất; a2 = giá trị góc thứ hai; ...; an = giá trị góc thứ n. Em tính lấy hàm này làm một hàm con, từ các giá trị góc xuất ra, em tính toán một giá trị khác.

1. Đã sửa theo ý bạn. Sau khi chọn Lisp sẽ nối các Line thành PLine và phá vỡ khi chạy xong.

2. Sau khi chạy xong thì toàn bộ giá trị góc được lưu trong danh sách bendlist, bạn cần giá trị nào chỉ việc gọi ra thôi. Ví dụ:

a1 = (nth 0 bendlist) 

a2 = (nth 1 bendlist)

a3 = (nth 2 bendlist)

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

an = (nth (- n 1) bendlist)

http://www.cadviet.com/upfiles/3/71162_lisp_thong_ke_goc_cua_pline_rev1.lsp


;==========LISP THONG KE GOC CUA PLINE==========
;=============KANGKUNG 18/04/2013===============
(defun C:Goc ( / i plsel pldata verts bend taphop )
  (vl-load-com)
  (setq taphop (ssget '((0 . "LINE"))))
  (command "PEDIT" (ssname taphop 0) "Y" "J" taphop "" "")
  (setq plsel (entlast) bendlist(list))
  (setq pldata (entget plsel) verts (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) pldata)))
  (setq i 1)
  (while (> (length verts) 2)
    (setq ang1 (angle (car verts) (cadr verts)) ang2 (angle (cadr verts) (caddr verts))
	  bend (if (> (abs (- ang2 ang1)) pi)
		 (+ (min ang1 ang2) (- (* pi 2) (max ang1 ang2)))
		 (abs (- ang2 ang1)))
	  bendlist(append bendlist (list (- pi bend)))
	  verts (cdr verts)
	  i(1+ i))
    )
  (command "EXPLODE" plsel)
  (princ)
)
(princ "\n              KangKung - 18/04/2013\n")
(princ "\n           Nhap GOC de chay chuong trinh\n")

<<

Filename: 232251_goc.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 232322
Tên lệnh: ha
Keywords used: Buying car DVD players!

Nếu nhằm mục đích tính biểu thức Cal của 1 String thì TL dùng cái này xem:

 

(defun C:HA (/ str ent)
 (vl-load-com)
 (setq str (getstring "\nCong thuc CAL: "))
 (setq ent (entmakex (list (cons 0 "TEXT") (cons 10 '(0 0)) (cons 40 1.) (cons 1 "HA"))))
 (vla-put-TextString (vlax-ename->vla-object ent)
  (strcat "%<\\AcExpr (" (vl-string-subst (strcat "%<\\AcObjProp...
>>

Nếu nhằm mục đích tính biểu thức Cal của 1 String thì TL dùng cái này xem:

 

(defun C:HA (/ str ent)
 (vl-load-com)
 (setq str (getstring "\nCong thuc CAL: "))
 (setq ent (entmakex (list (cons 0 "TEXT") (cons 10 '(0 0)) (cons 40 1.) (cons 1 "HA"))))
 (vla-put-TextString (vlax-ename->vla-object ent)
  (strcat "%<\\AcExpr (" (vl-string-subst (strcat "%<\\AcObjProp Object(%<\\_ObjId " (itoa (vla-get-ObjectID (vlax-ename->vla-object ent))) ">%).TextString>%") "" str)")>%"))
 (princ (cdr (assoc 1 (entget (entlast)))))
 (entdel (entlast))
 (princ))

<<

Filename: 232322_ha.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 219387
Tên lệnh: ha
Vẽ hình chữ nhật bao quanh khung nhìn hiện tại trong Model
Lisp vẽ rectangle bao quanh khung nhìn model (toàn màn hình):

Filename: 219387_ha.lsp
Tác giả: khaosat2009
Bài viết gốc: 102379
Tên lệnh: rft
[Yêu cầu] lisp Phun tọa độ các điểm từ file txt vào CAD

Cập nhật theo yêu cầu :
Lisp tạo ra 1 đ/tuợng POINT và 3 đ/tuợng TEXT như sau :
1. Lớp Point có kí hiệu điểm (cột 2-3)
2. Lớp Sothutu : TEXT Số thứ tự (cột 1)
3. Lớp Caodo : TEXT Cao độ (cột 4)
4. Lớp Code : TEXT Code (cột 5)

với định dạng của file điểm đo : STT X Y Z Code ,
chấp nhận kí tự phân biệt giữa các giá trị trong file điểm đo : dấu cách, dấu...
>>

Cập nhật theo yêu cầu :
Lisp tạo ra 1 đ/tuợng POINT và 3 đ/tuợng TEXT như sau :
1. Lớp Point có kí hiệu điểm (cột 2-3)
2. Lớp Sothutu : TEXT Số thứ tự (cột 1)
3. Lớp Caodo : TEXT Cao độ (cột 4)
4. Lớp Code : TEXT Code (cột 5)

với định dạng của file điểm đo : STT X Y Z Code ,
chấp nhận kí tự phân biệt giữa các giá trị trong file điểm đo : dấu cách, dấu Tab, dấu phẩy.

Mình load RFT về, không biết tại sao mình lại không xuất các điểm ra Cad được,
file tọa độ của mình đây :
http://www.cadviet.com/upfiles/3/toado9.txt
http://www.cadviet.com/upfiles/3/ntdau.txt
Mong được anh giúp và hướng dẫn cho. Cám ơn
<<

Filename: 102379_rft.lsp
Tác giả: KangKung
Bài viết gốc: 232393
Tên lệnh: cvp
[Nhờ giúp đỡ] lisp chia viewport trong layout

Chào bạn Engineer0405! Ý tưởng rất hay. Vote bạn.

Còn đây là Lisp viết theo ý tưởng của bạn.

Khi dùng chỉ cần đánh lệnh rồi chọn Viewport (chọn bao nhiêu thì tùy ý nhưng chỉ có cái đầu tiên được chia thôi). Sau đó Lisp sẽ chia viewport đó thành 2 viewport nhỏ dựa theo điểm chia (điểm này có thể chọn bất kì trên đường thẳng đứng). Chia xong Lisp sẽ chờ người sử dụng chọn...

>>

Chào bạn Engineer0405! Ý tưởng rất hay. Vote bạn.

Còn đây là Lisp viết theo ý tưởng của bạn.

Khi dùng chỉ cần đánh lệnh rồi chọn Viewport (chọn bao nhiêu thì tùy ý nhưng chỉ có cái đầu tiên được chia thôi). Sau đó Lisp sẽ chia viewport đó thành 2 viewport nhỏ dựa theo điểm chia (điểm này có thể chọn bất kì trên đường thẳng đứng). Chia xong Lisp sẽ chờ người sử dụng chọn tiếp Viewport khác. Nếu không chọn nữa thì bấm Space, Esc, Enter hoặc chuột phải.

;==========LISP CHIA 1 VIEWPORT THANH 2 VIEWPORT==========
;==================KANGKUNG 20/04/2013====================
(defun C:CVP ( / Viewport vpdata centerpoint VP_Width VP_Height pt cPWp utObj mPt xPt lbCon trCon verLst tyle P1 P2)
  (vl-load-com)
  (if (= (getvar "TILEMODE") 0)
    (progn
      (if (/= (getvar "cvport") 1) (command "PSPACE"))
      (command "UNDO" "BE")
      (while (setq Viewport (ssget '((0 . "VIEWPORT"))))
	(setq vpdata(entget (ssname Viewport 0)))
	(setq n(cdr(assoc 69 vpdata)))
	(command "MSPACE") (setvar "cvport" n) (command "PSPACE")
	(setq centerpoint(cdr(assoc 10 vpdata))) (setq VP_Width(cdr(assoc 40 vpdata))) (setq VP_Height(cdr(assoc 41 vpdata)))
	(setq pt(getpoint "\n Chon diem chia: "))
	(if (not dist) (setq dist(atof(lisped "\n Nhap khoang cach giua cac Vport vao day.")))
	  (setq dist(atof(lisped (rtos dist 2 2)))))
	(setq cPWp(vlax-ename->vla-object (ssname Viewport 0))
	      utObj(vla-get-Utility(vla-get-ActiveDocument(vlax-get-acad-Object))))
	(vla-GetBoundingBox cPWp 'mPt 'xPt)
	(setq lbCon(vla-TranslateCoordinates utObj mPt acPaperSpaceDCS acDisplayDCS :vlax-false)
	      trCon(vla-TranslateCoordinates utObj xPt acPaperSpaceDCS acDisplayDCS :vlax-false))
	(if(and lbCon trCon) (setq verLst(list (vlax-safearray->list(vlax-variant-value lbCon)) (vlax-safearray->list(vlax-variant-value trCon)))))
	(setq os(getvar "OSMODE"))
	(setvar "OSMODE" 0)
	(setq tyle(/ VP_Width (- (car(cadr verLst)) (car(car verLst)))))
	(setq P1(list (+ (car (car verLst)) (/ (+ (/ VP_Width 2) (- (car pt) (car centerpoint))) tyle))
		      (cadr (cadr verLst)))
	       P2(list (car P1) (cadr (car verLst))))
	(command "MVIEW" (list (car pt) (+  (cadr centerpoint) (/ VP_Height 2))) (list (- (car centerpoint) (/ VP_Width 2)) (- (cadr centerpoint) (/ VP_Height 2))))
	(command "MSPACE") (command "ZOOM" (car verLst) P1) (command "PSPACE")
	(command "MVIEW" (list (+ (car pt) dist) (+  (cadr centerpoint) (/ VP_Height 2))) (list (+ (car centerpoint) dist (/ VP_Width 2)) (- (cadr centerpoint) (/ VP_Height 2))))
	(command "MSPACE") (command "ZOOM" P2 (cadr verLst)) (command "PSPACE")
	(command "ERASE" (ssname Viewport 0) "")
	(setvar "OSMODE" os)
	(command "UNDO" "END")
	)
      )
    (alert "Chuyen sang Layout truoc khi chay Lisp")
    )
  )
(defun *error* (msg)
  (if (/= os nil) (setvar "OSMODE" os))
  (command "UNDO" "END")
  )
(princ "\n              KangKung - 20/04/2013\n")
(princ "\n           Nhap CVP de chay chuong trinh\n")

<<

Filename: 232393_cvp.lsp
Tác giả: NguyenNgocSon
Bài viết gốc: 218556
Tên lệnh: vd
Lisp xóa điểm trùng và sắp xếp lại đỉnh của LWPolyline

(defun C:vd()
(setq en(car (entsel "\n Select a Polyline :")))
(setq enlist(entget en))
(setq myVertexList(list))
(foreach a enlist
(if(= 10 (car a))
(setq myVertexList
(append myVertexList
(list
(cdr a)
) ...
>>

(defun C:vd()
(setq en(car (entsel "\n Select a Polyline :")))
(setq enlist(entget en))
(setq myVertexList(list))
(foreach a enlist
(if(= 10 (car a))
(setq myVertexList
(append myVertexList
(list
(cdr a)
)
)
)
)
)
'(setq pl(vl-sort(myVertexList)))
(princ)
(princ (vl-sort myVertexList '<))
)

Hiện tại mình mới code chỉ làm được bước 1 => bước 2 + 3 nhờ bác trợ giúp ? Mình mới code mà !
<<

Filename: 218556_vd.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 232455
Tên lệnh: vdd
lisp vẽ đường electrical

Xin Kính Nhờ Các Bác Cao thủ trên diễn đàn giúp đỡ Em.

Hề hề hề,

Bạn dùng thử cái này coi đã đúng ý bạn hay chưa nhé. Do không phải chuyên ngành của bạn nên mình đoán mò theo cái bản vẽ bạn gửi lên thôi, không rõ có đúng ý đồ của bạn hay không. Mình gửi lên để bạn kiểm tra , nếu...

>>

Xin Kính Nhờ Các Bác Cao thủ trên diễn đàn giúp đỡ Em.

Hề hề hề,

Bạn dùng thử cái này coi đã đúng ý bạn hay chưa nhé. Do không phải chuyên ngành của bạn nên mình đoán mò theo cái bản vẽ bạn gửi lên thôi, không rõ có đúng ý đồ của bạn hay không. Mình gửi lên để bạn kiểm tra , nếu được sẽ hoàn chỉnh sau.

Bạn lưu ý cần sửa lại cái file csv để CAD có thể không nhầm lẫn như sau:

1/- Xóa toàn bộ các dòng tiêu đề, chỉ để lại các dòng dữ liệu sử dụng.

2/- Sửa các text ghi góc lái, bỏ dấu " sau con số chỉ giây hoặc bạn đổi các giá trị này về giá trị thập phân của độ. Tỷ như 38o29'54" thành 38o29'54 hoặc 38.49833 độ. Lưu ý rằng khi bạn không chuyển về giá trị thập phân theo độ thì CAD sẽ chỉ nhận góc chẵn độ đễ tính toán tức là 38 độ còn số lẻ sẽ bị bỏ qua.

Hãy test thử và nếu có gì chưa ưng ý hãy post lên để mình xem lại.

 

(defun c:vdd ()
(setq  fn (getfiled "Select Data File" "" "csv" 0)
            f (open fn "r")
            k 1 
)
(command "undo" "be")
(setq p1 (getpoint "\n Nhap diem bat dau ve"))
(setq a1 (getreal "\n Nhap goc bat dau ve theo radian: "))
(while (and  (/= (setq str (read-line f)) nil) (/= (atof str) 0.0))
       (setq lst (separate str (chr 44)))
       (setq lst1 (separate (nth 2 lst) "="))
       (if (> (length lst1) 1)
           (progn
                    (if (= (nth 0 lst1) "T")
                        (progn 
                                 (command "insert" (nth 3 lst)  p1 1 1 (+ (/ (* 180 a1) pi) (/ (atof (nth 1 lst1)) 2 )))
                                 (command "pline" p1 (setq p1 (polar p1 (setq a1 (+ a1 (/ (* pi (atof (nth 1 lst1))) 180))) (atof (nth 1 lst)))) "")
                                 
                        )
                        (progn
                                 (command "insert" (nth 3 lst)  p1 1 1 (- (/ (* 180 a1) pi) (/ (atof (nth 1 lst1)) 2)))
                                 (command "pline" p1 (setq p1 (polar p1 (setq a1 (-  a1 (/ (* pi (atof (nth 1 lst1))) 180))) (atof (nth 1 lst)))) "")
                                 
                        )
                    )
          )
          (progn   
                    (command "insert" (nth 3 lst)  p1 1 1 (+ (/ (* 180 a1) pi) (atof (nth 2 lst))))                 
                    (command "pline" p1 (setq p1 (polar p1 (+ a1 (atof (nth 2 lst))) (atof (nth 1 lst)))) "")
                    
          )
       )
)
(command "undo" "e")
)
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun Separate (S sym / i L ch)
(setq i 0 L nil)
(while (< i (strlen S))
      (setq i (1+ i) ch (substr S i 1))
      (if (= ch sym) (progn
(setq
     L (append L (list (substr S 1 (- i 1))))
     S (substr S (1+ i) (- (strlen S) i))
     i 0
)
      ))
)
(append L (list S))
)      

<<

Filename: 232455_vdd.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 232492
Tên lệnh: vdd
lisp vẽ đường electrical

Cám ơn Bác Bình Và Bác Hà Giúp Em . Em Chạy Lisp của Bác Đúng Với Công Việc của Em rồi. Nhưng Bác giúp em bổ sung cho em thêm 1 số ý như sau:

+ Như Ý Bác Hà Ngợi Ý lấy giá trị góc kiểu 1d2'3'' Bác Ạ.

+ Bác bổ sung cho em thứ tự cột và khoảng cách cột nữa.

Cám ơn các Bác chúc các bác có 1 ngày chủ...

>>

Cám ơn Bác Bình Và Bác Hà Giúp Em . Em Chạy Lisp của Bác Đúng Với Công Việc của Em rồi. Nhưng Bác giúp em bổ sung cho em thêm 1 số ý như sau:

+ Như Ý Bác Hà Ngợi Ý lấy giá trị góc kiểu 1d2'3'' Bác Ạ.

+ Bác bổ sung cho em thứ tự cột và khoảng cách cột nữa.

Cám ơn các Bác chúc các bác có 1 ngày chủ nhật vui vẻ !

Hề hề hề,

1/- Cái việc bắt lisp phải cắt không phải quá khó, song quả thực chả biết chủ thớt còn những kiểu ghi góc gì nữa nên hơi lười. Theo góp ý của bác DoanVanHa mình đã bổ sung việc này, song nếu chủ thớt lại đổi kiểu ghi góc lái thì lisp này sẽ thua.

2/- Bổ sung thêm phần ghi khoảng cách giữa các cột và đánh số cột. Tuy nhiên cũng do lười nên mình không sử dụng hàm con cho nó nên code hơi rườm rà. Chủ thớt hoặc các bác khác có thể gom thành một hàm con để làm việc này thì code sẽ gọn gàng và oai hơn nhiều.

 

Hề hề hề,

 

 

(defun c:vdd (/ fn f p1 a1 lst lst1)
(setq  fn (getfiled "Select Data File" "" "csv" 0)
            f (open fn "r")
)
(command "undo" "be")
(setq p1 (getpoint "\n Nhap diem bat dau ve"))
(setq a1 (getreal "\n Nhap goc bat dau ve theo radian: "))
(while (and  (/= (setq str (read-line f)) nil) (/= (atof str) 0.0))
       (setq lst (separate str (chr 44)))
       (setq lst1 (separate (substr (nth 2 lst) 2 (- (strlen (nth 2 lst)) 2)) "="))
       (if (> (atof (nth 1 lst)) 0.0)
       (if  (> (length lst1) 1) 
           (progn
                    (if (= (nth 0 lst1) "T")
                        (progn 
                                 (command "insert" (nth 3 lst)  p1 1 1 (+ (/ (* 180 a1) pi) (/ (atof (nth 1 lst1)) 2 )))
                                 (setvar "cecolor" "6")
                                 (command "circle" (polar p1 (-  a1 (/ pi 2)) 10) 5)
                                 (setvar "cecolor" "0")
                                 (command "text" "j" "mc" (polar p1 (- a1 (/ pi 2)) 10) 4 (* 180 (/ a1 pi)) (itoa (1- (atoi (nth 0 lst)))))
                                 (command "pline" p1 (setq p1 (polar p1 (setq a1 (+ a1 (/ (* pi (atof (nth 1 lst1))) 180))) (atof (nth 1 lst)))) "")
                                 (command "text" "j" "mc" (polar (polar p1 (- a1 pi) (/ (atof (nth 1 lst)) 2)) (+ a1 (/ pi 2)) 5) 2.5 (* 180 (/ a1 pi)) 
 
(nth 1 lst))
                        )
                        (progn
                                 (command "insert" (nth 3 lst)  p1 1 1 (- (/ (* 180 a1) pi) (/ (atof (nth 1 lst1)) 2)))
                                 (setvar "cecolor" "6")
                                 (command "circle" (polar p1 (-  a1 (/ pi 2)) 10) 5)
                                 (setvar "cecolor" "0")
                                 (command "text" "j" "mc" (polar p1 (- a1 (/ pi 2)) 10) 4 (* 180 (/ a1 pi)) (itoa (1- (atoi (nth 0 lst)))))
                                 (command "pline" p1 (setq p1 (polar p1 (setq a1 (-  a1 (/ (* pi (atof (nth 1 lst1))) 180))) (atof (nth 1 lst)))) "")
                                 (command "text" "j" "mc" (polar (polar p1 (- a1 pi) (/ (atof (nth 1 lst)) 2)) (+ a1 (/ pi 2)) 5) 2.5 (* 180 (/ a1 pi)) 
 
(nth 1 lst))
                        )
                    )
          )
          (progn   
                    (command "insert" (nth 3 lst)  p1 1 1 (+ (/ (* 180 a1) pi) (atof (nth 2 lst)))) 
                    (setvar "cecolor" "6")
                    (command "circle" (polar p1 (-  a1 (/ pi 2)) 10) 5)
                    (setvar "cecolor" "0")
                    (command "text" "j" "mc" (polar p1 (- a1 (/ pi 2)) 10) 4 (* 180 (/ a1 pi)) (itoa (1- (atoi (nth 0 lst)))))
                    (command "pline" p1 (setq p1 (polar p1 (+ a1 (atof (nth 2 lst))) (atof (nth 1 lst)))) "")
                    (command "text" "j" "mc" (polar (polar p1 (- a1 pi) (/ (atof (nth 1 lst)) 2)) (+ a1 (/ pi 2)) 5) 2.5 (* 180 (/ a1 pi)) (nth 1 
 
lst))
          )
       )
       )
)
(command "insert" (nth 3 lst)  p1 1 1 (+ (/ (* 180 a1) pi) (atof (nth 2 lst)))) 
(setvar "cecolor" "6")
(command "circle" (polar p1 (-  a1 (/ pi 2)) 10) 5)
(setvar "cecolor" "0")
(command "text" "j" "mc" (polar p1 (- a1 (/ pi 2)) 10) 4 (* 180 (/ a1 pi)) (nth 0 lst))
(command "undo" "e")
)
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun Separate (S sym / i L ch)
(setq i 0 L nil)
(while (< i (strlen S))
      (setq i (1+ i) ch (substr S i 1))
      (if (= ch sym) (progn
(setq
     L (append L (list (substr S 1 (- i 1))))
     S (substr S (1+ i) (- (strlen S) i))
     i 0
)
      ))
)
(append L (list S))
)      

<<

Filename: 232492_vdd.lsp
Tác giả: Skywings
Bài viết gốc: 232523
Tên lệnh: t1
Bạn nào có ý tưởng nào hay về thuật toán để giải quyết vấn đề này không ?

Một bài toán hay, lâu rùi mới có hứng thú lại với Lisp ^^. Đây là giải pháp của mình dựa trên thuật toán của các bác đưa ra, nếu viết có luộm thuộm các bác thông cảm :D . Chưa có thời gian test kỹ, các bác dùng thử nhé ^_^ .

* Lưu ý kích thước MN quá nhỏ so với PQ có thể gây ra lỗi xác định diện tích, nếu PQ có nhiều điểm cực tiểu, chương trình chỉ tính toán cho điểm điểm...

>>

Một bài toán hay, lâu rùi mới có hứng thú lại với Lisp ^^. Đây là giải pháp của mình dựa trên thuật toán của các bác đưa ra, nếu viết có luộm thuộm các bác thông cảm :D . Chưa có thời gian test kỹ, các bác dùng thử nhé ^_^ .

* Lưu ý kích thước MN quá nhỏ so với PQ có thể gây ra lỗi xác định diện tích, nếu PQ có nhiều điểm cực tiểu, chương trình chỉ tính toán cho điểm điểm cực tiểu thấp nhất.

;; Skywings - Revised 240412
(vl-load-com)
(defun c:t1 (/           AREALST     ENDPNT       ENDPNTMN  FROMPNT
         FUZZ      I0     I1       I2         I3
         INTPNTS   IX     IY       LWP0         LWP1
         LWPENT    LWPOBJ     MN       MNDIST    MSPACE
         PNT0      PNT1     PQ       S0         S1
         S2           S3     STARTPNT  STARTPNTMN
         STARTPNTPQ         SUB01       SUB01NEW  SUB32
         SUB32NEW  THISDRAWING       TMPLWP    TOPNTX
         TOPNTY    MAXPOINT     MINPOINT  ISFLIPED  TMPLWPOBJ
         BOTPNT    MINMAXPNTS       TOPPNT    N
        )
  ;; Thiet lap
  (setq thisdrawing (vla-get-activedocument (vlax-get-acad-object)))
  (setq mspace (vla-get-modelspace thisdrawing))
  (vla-startundomark thisdrawing)
  (setvar "CMDECHO" 0)
  (if (null MNdistSv)
    (setq MNdistSv 5)
  )
  (if (null fuzzSv)
    (setq fuzzSv 0.1)
  )
  ;; Du lieu dau vao
  (initget (+ 2 4))
  (setq    MNdist (getreal    (strcat    "\nXac dinh chieu dai MN: <"
                (rtos MNdistSv 2 2)
                ">"
            )
           )
  )
  (if (null MNdist)
    (setq MNdist MNdistSv)
    (setq MNdistSv MNdist)
  )
  (initget (+ 2 4))
  (setq    fuzz (getreal (strcat "\nXac dinh do chinh xac dien tich: <"
                  (rtos fuzzSv 2 2)
                  ">"
              )
         )
  )
  (if (null fuzz)
    (setq fuzz fuzzSv)
    (setq fuzzSv fuzz)
  )
  (while (null
       (setq lwpEnt (car (entsel "\nChon duong cong tich luy: ")))
     )
    (setq lwpEnt (car (entsel "\nChon duong cong tich luy: ")))
  )
  (setq lwpObj (vlax-ename->vla-object lwpEnt))
  (setq    startPnt (vlax-curve-getStartPoint lwpObj)
    endPnt     (vlax-curve-getEndPoint lwpObj)
  )
  ;; Kiem tra diem cuc tieu
  (setq MinMaxPnts (LM:CurveMinMax lwpObj 1e-8))
  (setq    TopPnt (cadr MinMaxPnts)
    BotPnt (car MinMaxPnts)
  )
  (if (or (equal (distance BotPnt startPnt) 0.0 0.01)
      (equal (distance BotPnt endPnt) 0.0 0.01)
      )
    (progn
      (setq tmpLwpObj (vla-mirror
            lwpObj
            (vlax-3d-point startPnt)
            (vlax-3d-point (polar startPnt 0 0.1))
              )
              ;; lat bung
      )
      (vla-delete lwpObj)
      (setq lwpObj   tmpLwpObj
        isFliped 1
      )
      (setq startPnt (vlax-curve-getStartPoint lwpObj)
        endPnt   (vlax-curve-getEndPoint lwpObj)
      )
    )
  )
  (vla-GetBoundingBox lwpObj 'minpoint 'maxpoint)
  (vla-ZoomWindow (vlax-get-acad-object) minpoint maxpoint)
  ;; Xac dinh duong PQ
  (if (< (cadr startPnt) (cadr endPnt))
    (setq startPntPQ startPnt)
    (setq startPntPQ endPnt)
  )
  (setq    tmpLwp (AddLwpolyline
         (list startPntPQ (polar startPntPQ 0 1))
         0
         mspace
           )
  )
  (setq intPnts (LM:Intersections tmpLwp lwpObj acExtendThisEntity))
  (if (> (length intPnts) 1)
    (setq PQ (AddLwpolyline intPnts 0 mspace))
    (progn
      (vla-delete tmpLwp)
      (reset)
      (exit)
    )
  )
  (vla-delete tmpLwp)
  ;; Chieu dai doan MN
  (if (= isFliped 1)
    (setq BotPnt (car (LM:CurveMinMax lwpObj 1e-8)))
  )
  (setq    startPntMN (polar BotPnt pi (/ MNdist 2))
    endPntMN   (polar BotPnt 0 (/ MNdist 2))
  )
  (setq MN (AddLwpolyline (list startPntMN endPntMN) 0 mspace))
  ;; Xac dinh 2 duong giong tu MN den PQ
  (setq    pnt0 (vlax-curve-getClosestPointTo PQ startPntMN)
    pnt1 (vlax-curve-getClosestPointTo PQ endPntMN)
  )
  (setq    lwp0 (AddLwpolyline (list startPntMN pnt0) 0 mspace)
    lwp1 (AddLwpolyline (list endPntMN pnt1) 0 mspace)
  )
  ;; Kiem tra dien tich
  (setq AreaLst (CalArea (list pnt0 startPntMN endPntMN pnt1) lwpObj))
  (setq    s0 (nth 0 AreaLst)
    s1 (nth 1 AreaLst)
    s2 (nth 2 AreaLst)
    s3 (nth 3 AreaLst)
  )
  (if (and (< s0 s1)
       (< s3 s2)
      )
    (progn
      (alert "Khong the dieu chinh!")
      (reset)
      (exit)
    )
  )
  ;; Can bang so bo 1 cap dien tich
  (textscr)
  (setq iY (- 0 (/ (distance startPntMN pnt0) 20)))
                    ; buoc nhay phuong doc
  (setq    FromPnt    (vlax-3d-point pnt0)
    ToPntY    (vlax-3d-point (polar pnt0 (/ pi 2) iY))
  )
  (while (and (>= (nth 0 AreaLst) (nth 1 AreaLst))
          (>= (nth 3 AreaLst) (nth 2 AreaLst))
     )
    (vla-move PQ FromPnt ToPntY)
    (setq pnt0 (polar pnt0 (/ pi 2) iY)
      pnt1 (polar pnt1 (/ pi 2) iY)
    )
    (setq AreaLst (CalArea (list pnt0 startPntMN endPntMN pnt1) lwpObj))
  )
  (if (> (- (nth 0 AreaLst) (nth 1 AreaLst))
     (- (nth 3 AreaLst) (nth 2 AreaLst))
      )
    (setq i0 3
      i1 2
      i2 1
      i3 0
    )
    (setq i0 0
      i1 1
      i2 2
      i3 3
    )
  )
  (setq n 0)
  (setq sub32 (- (nth i3 AreaLst) (nth i2 AreaLst)))
  ;; Can bang dien tich dua tren dich chuyen PQ
  (while (not (equal (nth i3 AreaLst) (nth i2 AreaLst) fuzz))
    (if    (> n 100) ;; Gioi han so vong lap
      (progn
    (alert "Vuot qua gioi han 100 lan thu!")
    (reset)
    (exit)
      )
    )
    (vla-move PQ
          (vlax-3d-point pnt0)
          (vlax-3d-point (polar pnt0 (/ pi 2) iY))
    )
    (setq pnt0 (polar pnt0 (/ pi 2) iY)
      pnt1 (polar pnt1 (/ pi 2) iY)
    )
    (setq iX (/ MNdist 20.00))            ; buoc nhay phuong ngang
    (setq AreaLst (reverse (CalArea (list pnt0 startPntMN endPntMN pnt1) lwpObj)))
    (setq sub01    (- (nth i0 AreaLst) (nth i1 AreaLst)))
    (setq FromPnt (vlax-3d-point pnt0)
      ToPntX  (vlax-3d-point (polar pnt0 0 iX))
    )
    ;; Can bang dien tich dua tren dich chuyen MN
    (while (> (abs sub01) (abs sub32))
      (vla-move MN FromPnt ToPntX)
      (vla-move lwp0 FromPnt ToPntX)
      (vla-move lwp1 FromPnt ToPntX)
      (setq pnt0       (polar pnt0 0 iX)
        pnt1       (polar pnt1 0 iX)
        startPntMN (polar startPntMN 0 iX)
        endPntMN   (polar endPntMN 0 iX)
      )
      (setq AreaLst (reverse (CalArea (list pnt0 startPntMN endPntMN pnt1) lwpObj)))
      (setq sub01new (- (nth i0 AreaLst) (nth i1 AreaLst)))
      (if (> (abs sub01new) (abs sub01))
    (setq iX (/ (- 0 iX) 2))
      )
      (setq sub01 sub01new)
      (setq FromPnt (vlax-3d-point pnt0)
        ToPntX  (vlax-3d-point (polar pnt0 0 iX))
      )
    )
    (setq sub32new (- (nth i3 AreaLst) (nth i2 AreaLst)))
    (if    (> (abs sub32new) (abs sub32))
      (setq iY (/ (- 0 iY) 2))
    )
    (setq sub32 sub32new)
    (setq n (1+ n))
    (print AreaLst)
  )
  (vla-zoomprevious (vlax-get-acad-object))
  (reset)
  (princ)
)
(defun reset ()
  (if (= isFliped 1)
    (progn
      (foreach obj (list lwpObj MN PQ lwp0 lwp1)
    (vla-mirror
      obj
      (vlax-3d-point startPnt)
      (vlax-3d-point (polar startPnt 0 0.1))
    )
    (vla-delete obj)
      )
    )
  )
  (vla-endundomark thisdrawing)
  (graphscr)
)

;; Sub function
(defun GetMidPnt (pt0 pt1 / midPnt)
  (setq    midPnt (list (/ (+ (car pt0) (car pt1)) 2)
             (/ (+ (cadr pt0) (cadr pt1)) 2)
             0
           )
  )
  midPnt
)
(defun CalArea (pntLst obj / AreaLst tmpLwp)
  (setq
    midPntLst (mapcar
        '(lambda (x)
           (GetMidPnt x (vlax-curve-getClosestPointTo obj x))
         )
        pntLst
          )
  )
  (foreach pt midPntLst
    (setq HdlEnt (cdr (assoc 5 (entget (entlast)))))
    (command ".boundary" pt "")
    (if    (/= HdlEnt (cdr (assoc 5 (entget (entlast)))))
      (progn
    (setq tmpLwp (vlax-ename->vla-object (entlast)))
    (setq AreaLst (cons (vlax-get-property tmpLwp 'AREA) AreaLst))
    (vla-delete tmpLwp)
      )
      (progn
    (alert "Khong the tao Boundary!")
    (reset)
    (exit)
      )
    )
  )
  AreaLst
)
(defun LM:Intersections    (obj1 obj2 mode / l r)
  (setq l (vlax-invoke obj1 'intersectwith obj2 mode))
  (repeat (/ (length l) 3)
    (setq r (cons (list (car l) (cadr l) (caddr l)) r)
      l (cdddr l)
    )
  )
  (reverse r)
)

(defun AddLwpolyline (lst-pnt layer *model-space* / array-pt myPline)
  (setq    array-pt (list->variantArray
           (apply 'append (mapcar '3dPnt->2dPnt lst-pnt))
         )
    myPline     (vla-AddLightWeightPolyline *model-space* array-pt)
  )
  (vla-put-layer myPline layer)
  myPline
)

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

(defun 3dPnt->2dPnt (3dpt)
  (list (float (car 3dpt)) (float (cadr 3dpt)))
)

(defun LM:CurveMinMax
              (obj         fuzz       /
               _GetBoundingBoxWithOffset   _GroupByNum
               _FlattenPoint a           acdoc
               acspc         lst       obj
               tmp
              )

  (defun _GetBoundingBoxWithOffset (obj o / ll ur)
    (
     (lambda (a)
       (mapcar
     (function
       (lambda (b)
         (mapcar
           (function
         (lambda (c) ((eval c) a))
           )
           b
         )
       )
     )
     '(
       (
        (lambda (x) (- (caar x) o))
        (lambda (x) (- (cadar x) o))
       )
       (
        (lambda (x) (+ (caadr x) o))
        (lambda (x) (- (cadar x) o))
       )
       (
        (lambda (x) (+ (caadr x) o))
        (lambda (x) (+ (cadadr x) o))
       )
       (
        (lambda (x) (- (caar x) o))
        (lambda (x) (+ (cadadr x) o))
       )
      )
       )
     )
      (mapcar 'vlax-safearray->list
          (progn (vla-getboundingbox obj 'll 'ur) (list ll ur))
      )
    )
  )

  (defun _GroupByNum (l n / r)
    (if    l
      (cons
    (reverse (repeat n
           (setq r (cons (car l) r)
             l (cdr l)
           )
           r
         )
    )
    (_GroupByNum l n)
      )
    )
  )

  (defun _FlattenPoint (p)
    (list (car p) (cadr p) 0.0)
  )

  (setq    acdoc (vla-get-activedocument (vlax-get-acad-object))
    acspc (vlax-get-property
        acdoc
        (if (= 1 (getvar 'CVPORT))
          'Paperspace
          'Modelspace
        )
          )
  )
  (cond
    ((not (vlax-method-applicable-p obj 'GetBoundingBox))
    )
    (t
     (setq tmp
        (mapcar
          (function
        (lambda    (x)
          (apply 'vla-addline (cons acspc (mapcar 'vlax-3D-point x)))
        )
          )
          (_GroupByNum
        (mapcar    '_FlattenPoint
            (_GetBoundingBoxWithOffset obj (- fuzz))
        )
        2
          )
        )
     )
     (setq lst
        (mapcar
          (function
        (lambda    (x)
          (car
            (_GroupByNum
              (vlax-invoke obj 'Intersectwith x acExtendOtherEntity)
              3
            )
          )
        )
          )
          tmp
        )
     )
     (mapcar 'vla-delete tmp)
     lst
    )
  )
)

File bản vẽ test

http://www.cadviet.com/upfiles/3/86115_test.dwg


<<

Filename: 232523_t1.lsp
Tác giả: avi612
Bài viết gốc: 232549
Tên lệnh: cd cx cdx
Pro ơi Giúp em về lisp Cut Dim!

Em upload lisp CUT DIM được rồi nhưng khi gõ lệnh CD thì trên con trỏ chuột lại không thấy có lệnh đó xuất hiện mà lại là  cdate, cdorder, cdyndisplaymode. Lúc trước em đã dùng lệnh cutdim được rồi nhưng không hiểu sao lần này không hiệu quả. Rất mong các...

>>

Em upload lisp CUT DIM được rồi nhưng khi gõ lệnh CD thì trên con trỏ chuột lại không thấy có lệnh đó xuất hiện mà lại là  cdate, cdorder, cdyndisplaymode. Lúc trước em đã dùng lệnh cutdim được rồi nhưng không hiểu sao lần này không hiệu quả. Rất mong các pro giúp em!!!

 

Chắc vấn đề ở chổ load lisp của bạn đó...nếu lisp load thành công thì tên lệnh CD sẽ hiện ra cho bạn chọn, còn nếu ko thấy nghĩa là lisp chưa load được roài...
 
Có cái lisp chức năng tương tự share cho bạn...cái này đi lang thang gõ Google có được đó...cho bạn 3 lựa chọn (cắt chân, cắt đường thể hiện, cắt chân và đường thể hiện)
 
(DEFUN C:CD (/ CMD SS LTH DEM PT DS KDL N70 GOCX GOCY PT13 PT14 PTI PT13I PT14I
PT13N PT14N O13 O14 N13 N14 OSM OLDERR PT10 PT11)

(defun myerror (s) ; If an error (such as CTRL-C) occurs
; while this command is active...
(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)
)


(SETQ CMD (GETVAR "CMDECHO"))
(SETQ OSM (GETVAR "OSMODE"))
(SETQ OLDERR *error*
*error* myerror)
(PRINC "Please select Dimension object!")
(SETQ SS (SSGET))
(SETVAR "CMDECHO" 0)
(SETQ PT (GETPOINT "Point to trim or extend:"))
(SETQ PT (TRANS PT 1 0))
(COMMAND "UCS" "W")
(SETQ LTH (SSLENGTH SS))
(SETQ DEM 0)
(WHILE (< DEM LTH)
(PROGN
(SETQ DS (ENTGET (SSNAME SS DEM)))
(SETQ KDL (CDR (ASSOC 0 DS)))
(IF (= "DIMENSION" KDL)
(PROGN
(SETQ PT10 (CDR (ASSOC 10 DS)))
(SETQ PT11 (CDR (ASSOC 11 DS)))
(SETQ PT13 (CDR (ASSOC 13 DS)))
(SETQ PT14 (CDR (ASSOC 14 DS)))
(SETQ N70 (CDR (ASSOC 70 DS)))
(IF (OR (= N70 32) (= N70 33) (= N70 160) (= N70 161))
(PROGN
(SETQ GOCY (ANGLE PT10 PT14))
(SETQ GOCX (+ GOCY (/ PI 2)))
)
)
(SETVAR "OSMODE" 0)
(SETQ PTI (POLAR PT GOCX 2))
(SETQ PT13I (POLAR PT13 GOCY 2))
(SETQ PT14I (POLAR PT14 GOCY 2))
(SETQ PT13N (INTERS PT PTI PT13 PT13I NIL))
(SETQ PT14N (INTERS PT PTI PT14 PT14I NIL))
(SETQ O13 (ASSOC 13 DS))
(SETQ O14 (ASSOC 14 DS))
(SETQ N13 (CONS 13 PT13N))
(SETQ N14 (CONS 14 PT14N))
(SETQ DS (SUBST N13 O13 DS))
(SETQ DS (SUBST N14 O14 DS))
(ENTMOD DS)
)
)
(SETQ DEM (+ DEM 1))
)
)
(COMMAND "UCS" "P")
(SETVAR "CMDECHO" CMD)
(SETVAR "OSMODE" OSM)
(setq *error* OLDERR) ; Restore old *error* handler
(PRINC)
)
;=======================================================
;Cat duong DIM
(DEFUN C:CX (/ CMD SS LTH DEM PT DS KDL N70 GOCX GOCY PT13 PT14 PTI
PT10 PT10I PT10N O10 N10 PT11 PT11N O11 N11 KC OSM OLDERR)

(defun myerror (s) ; If an error (such as CTRL-C) occurs
; while this command is active...
(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)
)

(SETQ CMD (GETVAR "CMDECHO"))
(SETQ OSM (GETVAR "OSMODE"))
(SETQ OLDERR *error*
*error* myerror)
(PRINC "Please select dimension object!")
(SETQ SS (SSGET))
(SETVAR "CMDECHO" 0)
(SETQ PT (GETPOINT "Point to trim or extend:"))
(SETQ PT (TRANS PT 1 0))
(COMMAND "UCS" "W")
(SETQ LTH (SSLENGTH SS))
(SETQ DEM 0)
(WHILE (< DEM LTH)
(PROGN
(SETQ DS (ENTGET (SSNAME SS DEM)))
(SETQ KDL (CDR (ASSOC 0 DS)))
(IF (= "DIMENSION" KDL)
(PROGN
(SETQ PT13 (CDR (ASSOC 13 DS)))
(SETQ PT14 (CDR (ASSOC 14 DS)))
(SETQ PT10 (CDR (ASSOC 10 DS)))
(SETQ PT11 (CDR (ASSOC 11 DS)))
(SETQ N70 (CDR (ASSOC 70 DS)))
(IF (OR (= N70 32) (= N70 33) (= N70 160) (= N70 161))
(PROGN
(SETQ GOCY (ANGLE PT10 PT14))
(SETQ GOCX (+ GOCY (/ PI 2)))
)
)
(SETVAR "OSMODE" 0)
(SETQ PTI (POLAR PT GOCX 2))
(SETQ PT10I (POLAR PT10 GOCY 2))
(SETQ PT10N (INTERS PT PTI PT10 PT10I NIL))
(SETQ KC (DISTANCE PT10 PT10N))
(SETQ O10 (ASSOC 10 DS))
(SETQ N10 (CONS 10 PT10N))
(SETQ DS (SUBST N10 O10 DS))
(SETQ PT11N (POLAR PT11 (ANGLE PT10 PT10N) KC))
(SETQ O11 (ASSOC 11 DS))
(SETQ N11 (CONS 11 PT11N))
(SETQ DS (SUBST N11 O11 DS))
(ENTMOD DS)
)
)
(SETQ DEM (+ DEM 1))
)
)
(COMMAND "UCS" "P")
(SETVAR "CMDECHO" CMD)
(SETVAR "OSMODE" OSM)
(setq *error* OLDERR)
(PRINC)
)

;=======================================================
;Cat chan va duong DIM
(defun c:cdx (/ entdt dcat1 dcat2 sodimsua index sodt ssdt tt)
(defun cdim (entdt pchan pduong / tt old10
old13 old14 new10 new13 new14 p10n
p13n p14n p10o p13o p14o gocduong
gocchan pchanb pduongb loaidim
)
(defun chanvuonggoc (ph p1 p2 / ptemp pkq goc)
(setq
goc (+ (angle p1 p2) (/ pi 2.0))
ptemp (polar ph goc 1000.0)
pkq (inters ph ptemp p1 p2 nil)
)
pkq
)
(setq
tt (entget entdt)
old10 (assoc '10 tt)
old13 (assoc '13 tt)
old14 (assoc '14 tt)
p10o (cdr old10)
p13o (cdr old13)
p14o (cdr old14)
loaidim (logand (cdr (assoc '70 tt)) 7)
gocduong (cond
((= loaidim 1) (angle p13o p14o))
((= loaidim 0) (cdr (assoc '50 tt)))
(t nil)
)
pchan (cond
(pchan (list (car pchan) (cadr pchan) 0.0))
(t pchan)
)
pduong (cond
(pduong (list (car pduong) (cadr pduong) 0.0))
(t pduong)
)

)
(if gocduong
(progn
(if pchan
(setq
pchanb (polar pchan gocduong 1000.0)
p13n (chanvuonggoc (list (car p13o) (cadr p13o) 0.0) pchan pchanb)
p14n (chanvuonggoc (list (car p14o) (cadr p14o) 0.0) pchan pchanb)
new13 (cons 13 p13n)
new14 (cons 14 p14n)
tt (subst new13 old13 tt)
tt (subst new14 old14 tt)
)
)
(if pduong
(setq
pduongb (polar pduong gocduong 1000.0)
p10n (chanvuonggoc (list (car p10o) (cadr p10o) 0.0) pduong pduongb)
new10 (cons 10 p10n)
tt (subst new10 old10 tt)
)
)
(entmod tt)
)
)
gocduong
)
(setq ssdt (ssget '((0 . "DIMENSION")))
dcat1 (getpoint "\n\U+0110i\U+1EC3m c\U+1EAFt chân DIM: ")
dcat2 (getpoint "\n\U+0110i\U+1EC3m c\U+1EAFt \U+0111\U+01B0\U+1EDDng DIM: ")

dcat1 (cond
(dcat1 (trans dcat1 1 0))
(t nil)
)
dcat2 (cond
(dcat2 (trans dcat2 1 0))
(t nil)
)
sodt (sslength ssdt)
index 0
sodimsua 0
)
(repeat sodt
(setq entdt (ssname ssdt index)
index (1+ index)
tt (entget entdt)

)
(if (cdim entdt dcat1 dcat2)
(setq sodimsua (1+ sodimsua))
)
)
(prompt (strcat "\n*** \U+0110ã ch\U+1EC9nh s\U+1EEFa Dimension ***"))
(princ)
(princ)
)
 
nguồn: http://www.tramx.vn/Baiviet.aspx?id=Mr.Cùi422201312006


<<

Filename: 232549_cd_cx_cdx.lsp
Tác giả: nataca
Bài viết gốc: 76557
Tên lệnh: ll lgt lc ln lh l%2F lmh
Lisp các phép tính đại số tự động cập nhật khi giá trị nguồn thay đổi
Lấy ý tưởng từ bài viết ánh xạ text của bác NguyenHoanh và lisp ánh xạ text của anh Giabach. Mình vận dụng để viết một lisp để có thể tính toán trên các ánh xạ text này. Hy vọng nó sẽ giúp cho các bạn trong công việc:


-Lệnh LL (link length): để link giá trị chiều dài của 1 đối tượng vào text (khi chiều dài đối tượng thay đổi thì giá trị text thay đổi theo)
-Lệnh LGT...
>>
Lấy ý tưởng từ bài viết ánh xạ text của bác NguyenHoanh và lisp ánh xạ text của anh Giabach. Mình vận dụng để viết một lisp để có thể tính toán trên các ánh xạ text này. Hy vọng nó sẽ giúp cho các bạn trong công việc:


-Lệnh LL (link length): để link giá trị chiều dài của 1 đối tượng vào text (khi chiều dài đối tượng thay đổi thì giá trị text thay đổi theo)
-Lệnh LGT (link giá trị): để link giá trị của 1 text này cho text khác (khi giá trị text nguồn thay đổi thì giá trị text đích tự cập nhật theo)
-Lệnh LC (link cộng): Pick chọn các số lần lượt sau đó chọn text kết quả thì sẽ tính tổng các giá trị đó (một trong các giá trị nguồn thay đổi thì giá trị tổng thay đổi theo)
-Lệnh LN (link nhân ): Pick chọn các số lần lượt sau đó chọn text kết quả thì sẽ tính tích các giá trị đó (một trong các giá trị nguồn thay đổi thì giá trị tích thay đổi theo)
-Lệnh LH (link hiệu): Quét chọn text số bị trừ, quét chọn số trừ, chọn text giá trị hiệu (một trong các giá trị nguồn thay đổi thì giá trị hiệu thay đổi theo)
-Lệnh L/ (link chia): Quét chọn text số bị chia, quét chọn số chia, chọn text giá trị thương (một trong các giá trị nguồn thay đổi thì giá trị thương thay đổi theo)
-Lệnh LMH (link multi hàng): Tính toán cho nhiều hàng text. Chọn phép tính, chọn cột 1, cột 2...sau đó chọn cột giá trị (trong này có hệ số nhân để tiện khi đổi đơn vị trong lập bảng thống kê)


Đây là file lisp: lisp tính toán với link
Đây là file .vlx đã được biên dịch: tính toán với link

Xin phép bác Nacata sắp xếp lại code để việc hiển thị trang viết được thuận tiện hơn cho người đọc.
<<

Filename: 76557_ll_lgt_lc_ln_lh_l%2F_lmh.lsp

Trang 126/307

126