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

(defun c:ND()      (setvar "cmdecho" 0)
		   (setq a (getint "Nhap ti le dim: "))
		   (setvar "dimscale" a)	
		   (itoa a)
		   (setq ab (strcat "D" (itoa a)))
		   (command "DIMSTYLE" "s" ab)
)
(defun C:HD()
 (setvar "cmdecho" 0)
		   (setq a (getint "Nhap ti le dim muon lam hien hanh: "))	
		   (itoa a)
		   (setq ab (strcat "D" (itoa a)))
(wcmatch (cdr (assoc 0 lst)) "DIMENSION") (command "DIMSTYLE" "r"...
>>
(defun c:ND()      (setvar "cmdecho" 0)
		   (setq a (getint "Nhap ti le dim: "))
		   (setvar "dimscale" a)	
		   (itoa a)
		   (setq ab (strcat "D" (itoa a)))
		   (command "DIMSTYLE" "s" ab)
)
(defun C:HD()
 (setvar "cmdecho" 0)
		   (setq a (getint "Nhap ti le dim muon lam hien hanh: "))	
		   (itoa a)
		   (setq ab (strcat "D" (itoa a)))
(wcmatch (cdr (assoc 0 lst)) "DIMENSION") (command "DIMSTYLE" "r" ab))))
;(princ))

E có 2 lisp, nd tạo dim mới từ D1, hd chọn dim hiện hành, đều là thao tác nhập từ bàn phím, em muốn gộp thành 1 lệnh thôi, tức là nếu dim chưa có sẵn thì tạo dim mới, nếu dim đã có sẵn thì chọn nó làm hiện hành. Các bác chỉnh sửa giúp em với ạ. Thank nhiều ạ!


<<

Filename: 324611_nd.lsp
Tác giả: ndtnv
Bài viết gốc: 324618
Tên lệnh: mce
Lisp vẽ trục trọng tâm của chi tiết đột cắt hình

Lisp của bạn Doan Van Ha đã áp dụng cho trường hợp đột nhiều lỗ.

Tuần trước tôi đã viết lisp cho nhiều đối tượng đơn, hôm nay định viết tiếp cho đối tượng rỗng nhưng thấy bạn Doan Van Ha đã viết rồi.

Lisp tôi định viết dùng lệnh SUBTRACT của cad, lệnh này tổng quát hơn vì áp dụng đúng cho các đối tượng rời nhau nhưng có bounding box lồng nhau, nhưng thấy Lisp của bạn...

>>

Lisp của bạn Doan Van Ha đã áp dụng cho trường hợp đột nhiều lỗ.

Tuần trước tôi đã viết lisp cho nhiều đối tượng đơn, hôm nay định viết tiếp cho đối tượng rỗng nhưng thấy bạn Doan Van Ha đã viết rồi.

Lisp tôi định viết dùng lệnh SUBTRACT của cad, lệnh này tổng quát hơn vì áp dụng đúng cho các đối tượng rời nhau nhưng có bounding box lồng nhau, nhưng thấy Lisp của bạn Doan Van Ha có cách tính trọng tâm nhanh hơn nên viết theo hướng này. Trong trường hợp các đối tượng rời nhau nhưng có bounding box lồng nhau (ít khi gặp) thì dùng lệnh này nhiều lần.

Đây là lisp vẽ nhiều đường trục đi qua trọng tâm của nhiều hình, các hình chỉ lồng nhau 1 cấp và không giao nhau.

 

(defun c:mce( / rg c  e m o p q r s su x y) ; multi centroid
    (command "undo" "be")
    (setq e (entlast))
    (princ "\nChon nhom doi tuong tao thanh hinh can lay trong tam: ")
    (vl-cmdf "REGION" (ssget '((0 . "Polyline,Lwpolyline,Spline,Circle,Ellipse,Line,Arc"))) "")
    (while (setq e (entnext e))
        (setq o (vlax-ename->vla-object e)    )
        (vla-getboundingbox o 'p 'q)
        (setq rg (cons  (list o (vlax-get o 'Area)(list (vlax-safearray->list p) (vlax-safearray->list q))) rg))
    )
    (setq rg (vl-sort rg '(lambda(e1 e2) (> (cadr e1) (cadr e2)))))
    (while rg
        (setq o (car rg) rg (cdr rg) s (cadr o) su s r (last o) c (vlax-get (car o) 'Centroid) x (* s (car c)) y (* s (cadr c)))
        (foreach o rg
            (if (and (setq m (last o)) (<= (caar r) (caar m)) (<= (cadar r) (cadar m)) (>= (caadr r) (caadr m)) (>= (cadadr r) (cadadr m)))
                    (setq rg (vl-remove o rg) s (cadr o) su (- su s) c (vlax-get (car o) 'Centroid) x (- x (* s (car c))) y (- y (* s (cadr c)))))
        )
        (setq x (/ x su) y (/ y su))
        (entmake (list '(0 . "Line") '(8 . "Tr\U+00F4c t\U+00A9m") (cons 10 (list (caar r) y)) (cons 11 (list (caadr r) y))))
        (entmake (list '(0 . "Line") '(8 . "Tr\U+00F4c t\U+00A9m") (cons 10 (list x (cadar r))) (cons 11 (list x (cadadr r)))))
    )
    (command "undo" "e")
)

 

@Hoằn: yêu cầu này mà gọi là thư giãn thì rất "Funny" đấy.


<<

Filename: 324618_mce.lsp
Tác giả: thanhmom2009
Bài viết gốc: 324615
Tên lệnh: dt
Tính tổng diện tích các hình trên bản vẽ, "Ed" vào text sẵn có

Xin chào các sư huynh! Em đang tính diện tích mcn, sử dụng lisp tính diện tích này (http://www.cadviet.com/upfiles/4/86558_tinh_dien_tich.lsp), 

(defun C:DT (/ pc dt tyle fo)
  (setvar "CMDECHO" 0)
  (if (= fname nil)
    (setq fname (getfiled "Chon tap tin luu so lieu"...
>>

Xin chào các sư huynh! Em đang tính diện tích mcn, sử dụng lisp tính diện tích này (http://www.cadviet.com/upfiles/4/86558_tinh_dien_tich.lsp), 

(defun C:DT (/ pc dt tyle fo)
  (setvar "CMDECHO" 0)
  (if (= fname nil)
    (setq fname (getfiled "Chon tap tin luu so lieu" "//" "txt" 1))
  )
  (setq fo (open fname "a"))
  (princ "Cac dien tich da chon:" fo)
  (princ "\n" fo)
  (if (= tylen nil)
    (progn
      (setq tylen (getreal "\nTy le ban ve 1/<1000>:"))
      (if (= tylen nil)
	(setq tylen 1000.0)
      )
    )
  )
  (setq tyle (/ (* tylen tylen) 1000000.0))
  (setq pc (getpoint "\nChon diem giua:"))
  (while (/= pc nil)
    (command "layer" "n" "dientich" "c" "white" "dientich" "")
    (command "bpoly" pc "")
    (command "Area" "O" "L")
    (command "erase" "L" "")
    (setq dt (getvar "AREA"))
    (setq dt (* dt tyle))
    (setq dt (rtos dt 2 2))
    (command "layer" "s" "dientich" "")
    (setq dt (strcat dt " m2"))
    (command "text" "c" pc 2.3 0.0 dt)
    (princ dt fo)
    (princ " m2")
    (princ "\n" fo)
    (setq pc (getpoint "\nChon diem giua:"))
  )
  (close fo)
  (princ)
 (setvar "CMDECHO" 1)
) 

 

nhưng có nhiều điểm bất tiện em xin nhờ các sư huynh bổ sung giúp em :

A. Lisp trên sử dụng như sau:

1. Load lisp, nhập lệnh "dt"

2. Chọn tập tin lưu số liệu

3. Nhập tỷ lệ

4. Chọn điểm giữa (vùng cần tính diện tích) -> xuất text diện tích 

5. Tính diện tích các vùng khác chỉ cần chọn điểm giữa (bước4 mà không cần nhập lại bước 1,2,3)!

B. Cái em cần bổ sung như sau:

1. Chọn được style text diện tích: font, height (em chưa thấy lisp tính diện tích nào chọn được cái này)

2. Khi tính diện tích đồng thời bo luôn vùng chọn cho mình (em thấy có lisp bo được nhưng lại không tính nhiều diện tích 1 lần nhập lệnh được)

Em xin cảm ơn các sư huynh trước.


<<

Filename: 324615_dt.lsp
Tác giả: nhoclangbat
Bài viết gốc: 324650
Tên lệnh: dt
Tính tổng diện tích các hình trên bản vẽ, "Ed" vào text sẵn có

- y/c của bạn cũng ngộ ngộ, nhoc thử viết như vậy bạn test thử hen ^^

;========================================================================================
(defun ReplaceString (old_str new_str str / m n) (vl-load-com)
(setq m 0 n (strlen new_str))
(while (setq m (vl-string-search old_str str m))
(setq str (vl-string-subst new_str old_str str m))
(setq m (+ n...
>>

- y/c của bạn cũng ngộ ngộ, nhoc thử viết như vậy bạn test thử hen ^^

;========================================================================================
(defun ReplaceString (old_str new_str str / m n) (vl-load-com)
(setq m 0 n (strlen new_str))
(while (setq m (vl-string-search old_str str m))
(setq str (vl-string-subst new_str old_str str m))
(setq m (+ n m))
)
str
)
;========================================================================================
(defun tachsym(str sym / datach kytu dem lstdatach)
  (setq dem 1)
  (while (<= dem (strlen str))
    (setq datach "")
    (setq kytu (substr str dem 1))
    (while (and (/= kytu sym) (<= dem (strlen str)))
      (setq datach (strcat datach kytu))
      (setq dem (+ dem 1))
      (setq kytu (substr str dem 1))
    ); end while con
    (setq dem (+ dem 1))
    (setq lstdatach (append lstdatach (list datach)))
  ) ;end while me
  datach
)
;=============================================================
;======================================================================================================================
(defun K:dsbg (table / lst phu)
(tblnext table t)
(while (setq phu (tblnext table nil))
(setq lst (cons (cdr (assoc 2 phu)) lst))
)
)
;================================
(defun c:dt(/ tl ntl tl2 h k tdt pt pt1 pt5 ss  frome toe cur dt S laos K:text getvalueK lacol ladin dt ss1 ten K:layer K:style ds_style e1 e1 chon)
(vl-load-com)
;=====================================================================
 ;==================================================
;;ham tao text 2
(defun K:text(pt height string justify layer textstyle mau ang / lst)
(setq lst (list '(0 . "TEXT")
                              (cons 10 pt)
							  (cons 40 height)
							  (cons 1 string)
							  (cons 50 (if ang ang 0))
							  (cons 8 layer)
							  (cons 7 textstyle)
							  (cons 62 (if mau mau 256))
							  
			)
			justify (strcase justify))
		(cond   ((= justify "L") (setq Lst (append Lst (list (cons 72 0) (cons 11 pt)))))
		        ((= justify "C") (setq Lst (append Lst (list (cons 72 1) (cons 11 pt)))))
				((= justify "R") (setq Lst (append Lst (list (cons 72 2) (cons 11 pt)))))
				((= justify "M") (setq Lst (append Lst (list (cons 72 4) (cons 11 pt)))))
				)
	(entmakex Lst)
  )	;end K:text
;;--------------------------------------
;; ham luu gia tri
(defun getvalueK ( a giatri dongnhac / astr) 
(or a (setq a giatri))
(cond
	((= (type a) 'INT) (setq a (cond ((getint (strcat "\n" dongnhac "(" (itoa a) ") :")))(a))))
	((= (type a) 'REAL) (setq a (cond ((getreal (strcat "\n" dongnhac "(" (rtos a 2 1) ") :")))(a))))
	((= (type a) 'STR) (setq a (cond ((= "" (setq astr (getstring T (strcat "\n" dongnhac " (" a "): ")))) a) (astr))))
))
;;;;
;=================================================================================
(defun K:layer (ten clr)
(if (null (tblsearch "LAYER" ten))
(entmakex (list 
               '(0 . "LAYER")
               '(100 . "AcDbSymbolTableRecord")
               '(100 . "AcDbLayerTableRecord")
			   '(70 . 0)
                (cons 2 ten)
                (cons 62 clr))
)
)
)
;========================================================================================
;hàm tạo textstyle
(defun K:style (MyStyle MyFont)
(entmake (list    (cons 0 "STYLE")    
(cons 100 "AcDbSymbolTableRecord")    
(cons 100 "AcDbTextStyleTableRecord")    
(cons 2 MyStyle)    (cons 3  MyFont)    
(cons 70 0))))
;=====================================================================================
(if (= fname nil)
    (setq fname (getfiled "Chon tap tin luu so lieu" "//" "txt" 1))
  )
  (setq fo (open fname "a"))
  (princ "Cac dien tich da chon:" fo)
  (princ "\n" fo)
;======================================================================================
 (if (null (tblsearch "layer" "ab-dientich")) (K:layer "ab-dientich" 4))
 (if (null (tblsearch "style" "VAVON")) (K:style "VAVON" "VAVON.ttf"))
;===================================================================================
(setvar "cmdecho" 0)
(command "undo" "begin")
(setq lacol (getvar "CEColor"))
(setq ladin (getvar "dimzin"))
(setq laos (getvar "osmode"))
(setq lacl (getvar 'clayer))  
;================================================================
(setq ds_style (vl-princ-to-string (K:dsbg "style")))
(setq e1 (tachsym ds_style "("))
(setq e2 (Xstrcase (tachsym e1 ")")))
(initget 1 e2)
(setq chon (getkword (strcat "Nh\U+1EADp ch\U+1EEF \U+0111\U+1EA7u t\U+00EAn Style m\U+00FAn set: < "  (ReplaceString " " "/" e2)  " >:")))
;========================================================
(setq tl (getvalueK tl 1000.0 "Mau so Ti le ht "))
(setq ntl (/ 1000 tl))
(setq h (getvalueK h 1.8 "Nhap chieu cao text "))
(setq tl2 (* ntl ntl))
;==================================================================
(setq k 0 tdt 0)
(setvar "dimzin" 0)
(setvar "OSMODE" 0)
;======================================
;;===========================================================
(initget 1 "Thoat")
(setq pt1 (getpoint "\n Chon mien tinh dien tich / Thoat : "))
(while (/= pt1 nil)
;(command "erase" ss "")
(setq k (+ 1 k))
(K:text pt1 h (itoa k) "M" "k-dem" "VAVON" 1 nil)
;-----------------------------------------------------------------------------
(setq frome (entlast));; chon doi tuong cuoi cung truoc khi boundary
(command "cecolor"1 "-boundary" pt1 "");; boundary
(setq toe (entlast));; chon doi tuong cuoi cung sau khi boundary
(setq cur frome	ss (ssadd) S 0)
(while 	(not (eq cur toe));; chon cac doi tuong tu frome den toe

	(setq cur (entnext cur) ss (ssadd cur ss))

	(command "area" "S" "O" ss "" "")

	(setq dt (/ (getvar "AREA") tl2) S (+ S dt))

);while

(command "area" "A" "O" "L" "" "")

(setq dt (/ (getvar "AREA") tl2))

(setq S (+ S (* dt 2))) 
  (setq  tdt (+ s tdt))  
(princ tdt fo)
(princ " m2")
(princ "\n" fo)
(setvar "CEColor" lacol)
;==========================================
;===================================================================
(setq pt1 (getpoint (strcat "\nTong dien tich = " (rtos tdt 2 1) "m2. chon mien do tiep theo...")))
);while
;=======================================================================
;(command "erase" ss "")
;(setq ss nil)
(setvar "DIMZIN" ladin)
;================================================
;=================================================================================
(initget 1) 
(setq pt5 (getpoint "\nChon diem dat ket qua:"))
(K:text pt5 h (strcat (rtos tdt 2 1) "m%%178") "M" "ab-dientich" chon nil nil)
(setq ss1 (ssget "X" '((0 . "TEXT") (8 . "k-dem"))))
(if ss1
 (progn
   (repeat (sslength ss1)
	 (setq ten (ssname ss1 0))
	 (entdel ten)
	 (ssdel ten ss1)
	 )
  )
 )
;===============
(setvar 'clayer lacl)
;=====================
(vl-cmdf "-purge" "layer" "k-dem" "y" "y")
(setvar "OSMODE" laos)
(command "undo" "end")
(close fo)
(setvar "cmdecho" 1)
(princ "\n")
(princ "xong")
(princ)
)
 


<<

Filename: 324650_dt.lsp
Tác giả: nhoclangbat
Bài viết gốc: 324669
Tên lệnh: dt
Tính tổng diện tích các hình trên bản vẽ, "Ed" vào text sẵn có

- ^^ ah quên lsp mình nó tính khác, cái đó chỉ là đánh số vùng đã chọn, diện tích từng hình nó vô file txt chứ ko in ra text ^^, khi nào pick hết enter để chọn điểm ghi ra diện tích tổng các hình đã pick 

- nhoc sữa lại xíu giống với lsp cũ của bạn

;========================================================================================
(defun ReplaceString (old_str new_str str / m...
>>

- ^^ ah quên lsp mình nó tính khác, cái đó chỉ là đánh số vùng đã chọn, diện tích từng hình nó vô file txt chứ ko in ra text ^^, khi nào pick hết enter để chọn điểm ghi ra diện tích tổng các hình đã pick 

- nhoc sữa lại xíu giống với lsp cũ của bạn

;========================================================================================
(defun ReplaceString (old_str new_str str / m n) (vl-load-com)
(setq m 0 n (strlen new_str))
(while (setq m (vl-string-search old_str str m))
(setq str (vl-string-subst new_str old_str str m))
(setq m (+ n m))
)
str
)
;========================================================================================
(defun tachsym(str sym / datach kytu dem lstdatach)
  (setq dem 1)
  (while (<= dem (strlen str))
    (setq datach "")
    (setq kytu (substr str dem 1))
    (while (and (/= kytu sym) (<= dem (strlen str)))
      (setq datach (strcat datach kytu))
      (setq dem (+ dem 1))
      (setq kytu (substr str dem 1))
    ); end while con
    (setq dem (+ dem 1))
    (setq lstdatach (append lstdatach (list datach)))
  ) ;end while me
  datach
)
;=============================================================
;======================================================================================================================
(defun K:dsbg (table / lst phu)
(tblnext table t)
(while (setq phu (tblnext table nil))
(setq lst (cons (cdr (assoc 2 phu)) lst))
)
)
;================================
(defun c:dt(/ tl ntl tl2 h k tdt pt pt1 pt5 ss  frome toe cur dt S laos K:text getvalueK lacol ladin dt ss1 ten K:layer K:style ds_style e1 e1 chon)
(vl-load-com)
;=====================================================================
 ;==================================================
;ham tao text 2
(defun K:text(pt height string justify layer textstyle mau ang / lst)
(setq lst (list '(0 . "TEXT")
                              (cons 10 pt)
							  (cons 40 height)
							  (cons 1 string)
							  (cons 50 (if ang ang 0))
							  (cons 8 layer)
							  (cons 7 textstyle)
							  (cons 62 (if mau mau 256))
							  
			)
			justify (strcase justify))
		(cond   ((= justify "L") (setq Lst (append Lst (list (cons 72 0) (cons 11 pt)))))
		        ((= justify "C") (setq Lst (append Lst (list (cons 72 1) (cons 11 pt)))))
				((= justify "R") (setq Lst (append Lst (list (cons 72 2) (cons 11 pt)))))
				((= justify "M") (setq Lst (append Lst (list (cons 72 4) (cons 11 pt)))))
				)
	(entmakex Lst)
  );end K:text
;--------------------------------------
; ham luu gia tri
(defun getvalueK ( a giatri dongnhac / astr) 
(or a (setq a giatri))
(cond
	((= (type a) 'INT) (setq a (cond ((getint (strcat "\n" dongnhac "(" (itoa a) ") :")))(a))))
	((= (type a) 'REAL) (setq a (cond ((getreal (strcat "\n" dongnhac "(" (rtos a 2 1) ") :")))(a))))
	((= (type a) 'STR) (setq a (cond ((= "" (setq astr (getstring T (strcat "\n" dongnhac " (" a "): ")))) a) (astr))))
))
;;;;
;=================================================================================
(defun K:layer (ten clr)
(if (null (tblsearch "LAYER" ten))
(entmakex (list 
               '(0 . "LAYER")
               '(100 . "AcDbSymbolTableRecord")
               '(100 . "AcDbLayerTableRecord")
			   '(70 . 0)
                (cons 2 ten)
                (cons 62 clr))
)
)
)
;========================================================================================
;hàm t?o textstyle
(defun K:style (MyStyle MyFont)
(entmake (list    (cons 0 "STYLE")    
(cons 100 "AcDbSymbolTableRecord")    
(cons 100 "AcDbTextStyleTableRecord")    
(cons 2 MyStyle)    (cons 3  MyFont)    
(cons 70 0))))
;=====================================================================================
(if (= fname nil)
    (setq fname (getfiled "Chon tap tin luu so lieu" "//" "txt" 1))
  )
  (setq fo (open fname "a"))
  (princ "Cac dien tich da chon:" fo)
  (princ "\n" fo)
;======================================================================================
 (if (null (tblsearch "layer" "ab-dientich")) (K:layer "ab-dientich" 4))
 (if (null (tblsearch "style" "VAVON")) (K:style "VAVON" "VAVON.ttf"))
;===================================================================================
(setvar "cmdecho" 0)
(command "undo" "begin")
(setq lacol (getvar "CEColor"))
(setq ladin (getvar "dimzin"))
(setq laos (getvar "osmode"))
(setq lacl (getvar 'clayer))  
;================================================================
(setq ds_style (vl-princ-to-string (K:dsbg "style")))
(setq e1 (tachsym ds_style "("))
(setq e2 (Xstrcase (tachsym e1 ")")))
(initget 1 e2)
(setq chon (getkword (strcat "Nh\U+1EADp ch\U+1EEF \U+0111\U+1EA7u t\U+00EAn Style m\U+00FAn set: < "  (ReplaceString " " "/" e2)  " >:")))
;========================================================
(setq tl (getvalueK tl 1000.0 "Mau so Ti le ht "))
(setq ntl (/ 1000 tl))
(setq h (getvalueK h 1.8 "Nhap chieu cao text "))
(setq tl2 (* ntl ntl))
;==================================================================
(setq k 0 tdt 0)
(setvar "dimzin" 0)
(setvar "OSMODE" 0)
;======================================
;===========================================================
(initget 1)
(setq pt1 (getpoint "\n Chon mien tinh dien tich: "))
(while (/= pt1 nil)
;(command "erase" ss "")
(setq k (+ 1 k))
;-----------------------------------------------------------------------------
(setq frome (entlast));; chon doi tuong cuoi cung truoc khi boundary
(command "cecolor"1 "-boundary" pt1 "");; boundary
(setq toe (entlast));; chon doi tuong cuoi cung sau khi boundary
(setq cur frome	ss (ssadd) S 0)
(while 	(not (eq cur toe));; chon cac doi tuong tu frome den toe

	(setq cur (entnext cur) ss (ssadd cur ss))

	(command "area" "S" "O" ss "" "")

	(setq dt (/ (getvar "AREA") tl2) S (+ S dt))

);while

(command "area" "A" "O" "L" "" "")

(setq dt (/ (getvar "AREA") tl2))

(setq S (+ S (* dt 2))) 
(setq  tdt (+ s tdt))
(K:text pt1 h (strcat (rtos tdt 2 1) "m%%178") "M" "ab-dientich" chon nil nil)  
(princ tdt fo)
(princ " m2")
(princ "\n" fo)
(setvar "CEColor" lacol)
;==========================================
;===================================================================
(setq pt1 (getpoint (strcat "\nTong dien tich = " (rtos tdt 2 1) "m2. chon mien do tiep theo...")))
);while
;=======================================================================
;(command "erase" ss "")
;(setq ss nil)
(setvar "DIMZIN" ladin)
;================================================
;=================================================================================
;===============
(setvar 'clayer lacl)
;=====================
(setvar "OSMODE" laos)
(command "undo" "end")
(close fo)
(setvar "cmdecho" 1)
(princ "\n")
(princ "xong")
(princ)
)
 

<<

Filename: 324669_dt.lsp
Tác giả: nhoclangbat
Bài viết gốc: 324719
Tên lệnh: roo
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

- hihi Hieu có ghé ngang qua xem thử, nhoc mới học hàm grread, cũng thử múa rìu xíu tận dụng lsp roo của Hieu chỉnh lại = grread, vấn đề giới hạn góc nhập thì nhoc chưa xử đc, nhưng giữ được sợi thun quay quay cho Hieu ^^, quay tới đầu sẽ hiển thị góc phương vị tại chỗ đó ^^ dưới dòng command, khi nào ok, pick chuột trái tại vị trí mún xác định thì đoạn thẳng cũ sẽ chuyển tới đó, mấy...

>>

- hihi Hieu có ghé ngang qua xem thử, nhoc mới học hàm grread, cũng thử múa rìu xíu tận dụng lsp roo của Hieu chỉnh lại = grread, vấn đề giới hạn góc nhập thì nhoc chưa xử đc, nhưng giữ được sợi thun quay quay cho Hieu ^^, quay tới đầu sẽ hiển thị góc phương vị tại chỗ đó ^^ dưới dòng command, khi nào ok, pick chuột trái tại vị trí mún xác định thì đoạn thẳng cũ sẽ chuyển tới đó, mấy anh có hứng giúp nhoc cải tiến phần nhập dữ liệu cho nhoc học hỏi thêm ^^, mò sáng giờ vẫn chưa pit với grread thì xử sao ^^

(defun c:roo(/ doigoc start end *error* vars ovars nvars dt db dh dg tt ent lst px pg p nhap edd info)
 (defun doigoc(goc)
  (rem (- 450.0 goc) 360.0))
 (defun start()
  (setq vars '("osmode" "cmdecho" "angdir" "angbase"))
  (setq ovars (mapcar 'getvar vars)
        nvars (mapcar 'setvar vars (list 0 0 1 (/ pi 2)))))
 (defun end()
  (and ovars (mapcar 'setvar vars ovars)))
 (defun *error* (ABC)
  (end))
 (vl-load-com) 
 (princ "Chon Doi Tuong Can Quay: ") 
 (setq dt (ssget)
       db (getpoint "\nChon BasePoint:")
       ent (ssname dt 0)
	   info (entget ent)
       lst (mapcar 'cdr (vl-remove-if-not '(lambda(x) (or (= (car x) 10) (= (car x) 11))) (entget ent))))
 (command "undo" "be")    
 (start)
 ;=========================================================================================
 (if (< (distance db (setq px (car lst))) (distance db (setq pg (cadr lst))))
 (alert (strcat "\nPhuong Vi cu <" (rtos (doigoc (* 180.0 (/ 1 pi) (angle px pg))) 2 2) ">"))
 (alert (strcat "\nPhuong Vi cu <" (rtos (doigoc (* 180.0 (/ 1 pi) (angle pg px))) 2 2) ">"))
 )
 ;=========================================================================================
 (if (< (distance db (setq px (car lst))) (distance db (setq pg (cadr lst))))
  (progn 
 ;==================================================================================================
(while (/= (car (setq nhap (grread t 15 0))) 3)
       (redraw)
	   (if (= (car nhap) 5)
	     (progn
	        (setq p (cadr nhap))
		   	(grdraw db p 1 1)
			(prompt (strcat "\nPhuong Vi hien la <" (rtos (doigoc (* 180.0 (/ 1 pi) (angle db p))) 2 2) ">"))
		 )
		)
)
p
(setq ang (angle db p))
(setq edd (entmod (append info (list (cons 10 db) (cons 11 (polar db ang (distance px pg)))))))
;====================================================================================================   
      (redraw)
   )
;======================================================================================================
  (progn 
 ;====================================================================================================
(while (/= (car (setq nhap (grread t 15 0))) 3)
       (redraw)
	   (if (= (car nhap) 5)
	     (progn
	        (setq p (cadr nhap))
		    (grdraw db p 1 1)
			(prompt (strcat "\nPhuong Vi hien la <" (rtos (doigoc (* 180.0 (/ 1 pi) (angle db p))) 2 2) ">"))
		 )
		)
)
p
(setq ang (angle db p))
(setq edd (entmod (append info (list (cons 10 db) (cons 11 (polar db ang (distance px pg)))))))
;===================================================================================================   
     (redraw)
   )
 ;-------------------------------------------------------
 ) ;end if 
 (end)
 (command "undo" "e")
 )
 

<<

Filename: 324719_roo.lsp
Tác giả: nhoclangbat
Bài viết gốc: 324095
Tên lệnh: khide khien khides khiens ktroll chopchop khl tronbox tronxao tronkhac tronkk
Chương 10.3 : Grdraw, Grvecs, Grtext

- hi tối nay rãnh nhoc tranh thủ mò tí anh Ket với mấy bạn góp ý cho nhoc hen ^^, anh Ket nhoc nộp Ch10-2-3

; 1- an doi tuong
(defun c:khide(/ i )
(prompt "Ch\U+1ECDn c\U+00E1c \U+0111\U+1ED1i t\U+01B0\U+1EE3ng m\U+00FAn \U+1EA9n:")
(setq doit (ssget))
(if doit
(progn
(setq i 0)
(repeat (sslength doit)
 (setq ent (ssname doit i))
 (redraw ent 2)
 (setq i (1+ i))
 )
 )
 )
 )
;========================== hien doi tuong...
>>

- hi tối nay rãnh nhoc tranh thủ mò tí anh Ket với mấy bạn góp ý cho nhoc hen ^^, anh Ket nhoc nộp Ch10-2-3

; 1- an doi tuong
(defun c:khide(/ i )
(prompt "Ch\U+1ECDn c\U+00E1c \U+0111\U+1ED1i t\U+01B0\U+1EE3ng m\U+00FAn \U+1EA9n:")
(setq doit (ssget))
(if doit
(progn
(setq i 0)
(repeat (sslength doit)
 (setq ent (ssname doit i))
 (redraw ent 2)
 (setq i (1+ i))
 )
 )
 )
 )
;========================== hien doi tuong =================================
(defun c:khien (/ i)
(if doit
(progn
(setq i 0)
(repeat (sslength doit)
 (setq ent (ssname doit i))
 (redraw ent 1)
 (setq i (1+ i))
 )
 )
 )
 )
;===========================================an nhieu nhom doi tuong=================
(defun c:khides(/ i ss2ent doit)
;=====================================================
(defun ss2ent (ss / i Le e) 
(setq i 0)
(repeat (sslength ss)     
(setq e (ssname ss i)        
Le (append Le (list e))        
i (1+ i)    ))
Le)
;====================================================
(prompt "Ch\U+1ECDn l\U+1EA7n l\U+01B0\U+1EE3t c\U+00E1c nh\U+00F3m \U+0111\U+1ED1i t\U+01B0\U+1EE3ng m\U+00FAn \U+1EA9n: ")
(setq doit (ssget))
(if doit
(progn
(setq i 0)
(setq lst_ent (ss2ent doit))
(setq nhom_hide (append lst_ent nhom_hide))
(repeat (length lst_ent)
 (setq ent (nth i lst_ent))
 (redraw ent 2)
 (setq i (1+ i))
 )
 )
 )
 )
;===========================hien lai nhieu nhom doi tuong===============================
(defun c:khiens (/ i nhom_hide doit)
(if nhom_hide
(progn
(setq i 0)
(repeat (length nhom_hide)
 (setq ent (nth i nhom_hide))
 (redraw ent 1)
 (setq i (1+ i))
 )
 )
 )
 )
 ;==================================
 ;==================
(defun K:redraw (ss ma / i ent)
(setq i 0)
(repeat (sslength ss)     
(setq ent (ssname ss i))
(redraw ent ma)        
(setq i (1+ i))     
)
)
;=========================xoa tat ca doi tuong tren man hinh, de lai dong text  sau do nhap please de hien lai==============
(defun c:ktroll (/ doit str)
(vl-load-com)
(setvar 'cmdecho 0)
;==================
(defun K:redraw (ss ma / i ent)
(setq i 0)
(repeat (sslength ss)     
(setq ent (ssname ss i))
(redraw ent ma)        
(setq i (1+ i))     
)
)
;===========================
;=====================================
(setq doit (ssget "X"))
(if doit
(progn
   (K:redraw doit 2)
   (vl-cmdf ".text" '(0 0) (getvar "textsize") 0 "Ban ve cua ban da bi xoa het ^^")
   (vl-cmdf ".zoom" "o" "last" "")
   )
 )
;==============================================
(while (or (not str) (/= str "Vuilong"))
(setq str (getstring "\nB\U+1EA1n nh\U+1EADp \U+0111\U+00FAng t\U+1EEB \"Vuilong\" \U+0111\U+1EC3 tr\U+1EA3 l\U+1EA1i vi\U+1EC7c \U+0111ang l\U+00E0m: ")))
(if (= str "Vuilong")
(progn
(vl-cmdf ".erase" "last" "")
(K:redraw doit 1)
(vl-cmdf ".zoom" "e")
)
)
(setvar 'cmdecho 1)
(princ)
)

;========================================================
;=================bai nhap nhay doi tuong=============
(defun c:chopchop(/ doit xnhay vnhay trove)
(vl-load-com)
(setvar 'cmdecho 0)
(setq doit (ssget))
(if doit
(progn
(setq xnhay (getint "\nNhap so lan nhay:"))
(setq vnhay (getint "\nNhap so lan nhay bao nhieu lan / 1s :"))
(repeat xnhay
(K:redraw doit 2)
(vl-cmdf "delay" (/ 500 vnhay))
(K:redraw doit 1)
(vl-cmdf "delay" (/ 500 vnhay))
)
(textscr)
(princ (strcat "so doi tuong da chon chop chop : " (itoa (sslength doit))))
(princ "\n")
(princ (strcat "thoi gian chay la : " (rtos (/ (* xnhay 2 (/ 500 vnhay)) 1000.0) 2 1) " giay"))
(princ "\n")
(setq trove (getstring "\nBan nhap phim bat ky or enter de tro ve man hinh chinh :"))
(if trove 
(graphscr))
)
)
(setvar 'cmdecho 1)
(princ)
)
;===============================
;1- ham lay ten cac phan tu trong 1 tab
(defun K:dsbg (table / lst phu)
(tblnext table t)
(while (setq phu (tblnext table nil))
(setq lst (cons (cdr (assoc 2 phu)) lst))
)
)
;===================================
(defun K:get (table ten)
(entget (tblobjname table ten))
)
;==================================
; 3 - bat tat layer
(defun K:btlay(tenlayer / phu)
(setq phu (K:get "layer" tenlayer))
(entmod (subst (cons 62 (* -1 (cdr (assoc 62 phu)))) (assoc 62 phu) phu))
)
;===============================bai hightlight tat ca doi tuong tru layer 0=================
(defun c:khl (/ doit ds_lay ds_layoff lay_off)
(vl-load-com)
(setvar 'cmdecho 0)
(vl-cmdf ".zoom" "e")
(setq doit (ssget "X" '((8 . "~0"))))
(if doit
 (progn
 
;==========================================
(setq ds_lay (K:dsbg "layer"))
(foreach x ds_lay
(if (< (cdr (assoc 62 (K:get "layer" x))) 0)
(progn
(setq lay_off x)
(setq ds_layoff (cons lay_off ds_layoff)))
)) ;end foreach ds_lay
;==========================
(foreach k ds_layoff
(K:btlay k))
(K:redraw doit 3)
(while (or (not str) (/= str "")) (setq str (getstring "\nBan nhan Enter de tro ve trang thai cu :")))
(if (= str "")
(progn
(foreach d ds_layoff
(K:btlay d))
(K:redraw doit 4)
)
)
;======================================================================
)
)
(setvar 'cmdecho 1)
(princ)
)
;===========================================================================END 10-2====================================================
;;;hàm lư giá trị mặc định 3
(defun getvalueK ( a giatri dongnhac / astr) 
(or a (setq a giatri))
(cond
	((= (type a) 'INT) (setq a (cond ((getint (strcat "\n" dongnhac "(" (itoa a) ") :")))(a))))
	((= (type a) 'REAL) (setq a (cond ((getreal (strcat "\n" dongnhac "(" (rtos a 2 1) ") :")))(a))))
	((= (type a) 'STR) (setq a (cond ((= "" (setq astr (getstring T (strcat "\n" dongnhac " (" a "): ")))) a) (astr))))
))
;=================================================================BEGIN 10-3 ============================================================
;=== ve duong bao xung quan vong tron====
(defun c:tronbox(/ doit i tam bk d ptt ptp pdt pdp ds_ent)
(prompt "Chon duong tron:")
(setq doit (ssget '((0 . "CIRCLE"))))
(if doit
       (progn
	       (setq ofset (getvalueK ofset 0.0 "Nhap khoang offset")
                 clr (getvalueK clr 1 "Nhap mau khung")
                  i 0)
           (repeat (sslength doit)
              (setq ds_ent (entget (ssname doit i))
			        tam (cdr (assoc 10 ds_ent))
					bk (cdr (assoc 40 ds_ent))
					d (+ bk ofset)
					ptt (mapcar '+ tam (list (- d) d))
					ptp (mapcar '+ tam (list d d))
					pdt (mapcar '+ tam (list (- d) (- d)))
					pdp (mapcar '+ tam (list d (- d)))
				)
			 (grdraw ptt ptp clr 1)
			 (grdraw pdt pdp clr 1)
			 (grdraw ptt pdt clr 1)
			 (grdraw ptp pdp clr 1)
			 (setq i (1+ i))
			 )
		)
)
(princ)
)
;================================
;=======ve duong tron ao==========
(defun c:tronxao (/ i dau pt1 pt2 f ds_pt)
(setq tam (getpoint "\nChon tam:")
      bk (getvalueK bk 5.0 "Nhap ban kinh "))
(setq dau (polar tam 0 bk))
(setq i 0)
(repeat 360
(setq ds_pt (cons dau ds_pt))
(setq dau (polar tam (/ (* (setq i (1+ i)) pi) 180.0) bk))
)
(setq f 0)
(repeat 360
(setq pt1 (nth f ds_pt))
(setq pt2 (nth (setq f (rem (1+ f) 360)) ds_pt))
(grdraw pt1 pt2 1 1)
)
(princ)
) 
;================================================================
;=== ve duong bao xung quan vong tron====GRVECS==================
(defun c:tronkhac(/ doit i tam bk d ptt ptp pdt pdp ds_ent)
(prompt "Chon duong tron:")
(setq doit (ssget '((0 . "CIRCLE"))))
(if doit
       (progn
	       (setq ofset (getvalueK ofset 0.0 "Nhap khoang offset")
                 clr (getvalueK clr 1 "Nhap mau khung")
                  i 0)
           (repeat (sslength doit)
              (setq ds_ent (entget (ssname doit i))
			        tam (cdr (assoc 10 ds_ent))
					bk (cdr (assoc 40 ds_ent))
					d (+ bk ofset)
					ptt (mapcar '+ tam (list (- d) d))
					ptp (mapcar '+ tam (list d d))
					pdt (mapcar '+ tam (list (- d) (- d)))
					pdp (mapcar '+ tam (list d (- d)))
				)
			 (grvecs (list clr ptt ptp ptp pdp pdp pdt pdt ptt))
			 (setq i (1+ i))
			 )
		)
)
(princ)
)
;================================
;=======ve duong tron ao==========GRVECS=================
(defun c:tronkk (/ i dau clr ds_pt tam)
(grtext -1 (strcat "Hello " (getvar 'loginname)))
  (setq tam (getpoint "\nChon tam:")
        bki (getvalueK bki 10.0 "Nhap bk: ")
  )
  (setq dau (polar tam 0 bki))
  (setq ds_pt (list 1 dau))
  (setq i 1)
  (setq clr 2)
  (repeat 359
    (setq dau (polar tam (/ (* i pi) 180.0) bki))
    (setq ds_pt (append ds_pt (list dau clr dau)))
    (setq i (1+ i))
    (setq clr (rem (1+ clr) 256))
  )
  (setq ds_pt (append ds_pt (list (polar tam 0 bki))))
  (grvecs ds_pt)
  (princ)
  (grtext)
)
;==================================END C10-3=====================================

-p/s: cái vòng tròn cuối thêm màu vô nhìn ảo dịu thật ^^

104473_fsdft43333333333333333333333.png


<<

Filename: 324095_khide_khien_khides_khiens_ktroll_chopchop_khl_tronbox_tronxao_tronkhac_tronkk.lsp
Tác giả: nhoclangbat
Bài viết gốc: 324958
Tên lệnh: rrr
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

- Vẽ pline qua các điểm đó chắc đc ^^ nhưng nhoc chưa pit cách add đc Z của từng điểm vào pline, nhoc cũng chưa hiểu cách chuyển từ text sang lst của Hieu như thế nào, quét tới đâu chuyển tới đó hay quét hết 1 lúc rùi chuyển lun, nhoc có code mấy  dòng Hieu thử xem sao

(defun c:rrr(/ )
(setq a '(1 2 3 4))
(setq b '(2 7 8 9))
(setq lst_new (mapcar '(lambda (x) (cdr x)) (list a b)))
(K:pline...
>>

- Vẽ pline qua các điểm đó chắc đc ^^ nhưng nhoc chưa pit cách add đc Z của từng điểm vào pline, nhoc cũng chưa hiểu cách chuyển từ text sang lst của Hieu như thế nào, quét tới đâu chuyển tới đó hay quét hết 1 lúc rùi chuyển lun, nhoc có code mấy  dòng Hieu thử xem sao

(defun c:rrr(/ )
(setq a '(1 2 3 4))
(setq b '(2 7 8 9))
(setq lst_new (mapcar '(lambda (x) (cdr x)) (list a b)))
(K:pline lst_new nil nil nil)
) 
;;;;;;;;;;;============================================================
(defun K:pline (listpoint closed Layer clr / Lst)
	(setq Lst (list '(0 . "LWPOLYLINE")'(100 . "AcDbEntity")
	(cons 8 (if Layer Layer (getvar "Clayer")))
	(cons 62 (if clr clr 256))
    '(100 . "AcDbPolyline")
	(cons 90 (length listpoint))
	(cons 70 (if closed 1 0))))
	(foreach PP listpoint	(setq Lst (append Lst (list (cons 10 PP)))))
(entmakex Lst))
	;end;================================= 

- biến a, b giả sử tương ứng với các lst tọa độ trả về của Hieu


<<

Filename: 324958_rrr.lsp
Tác giả: tsanhthi
Bài viết gốc: 324970
Tên lệnh: thu
Nhờ các cao thủ xem giúp!

Không thấy file lsp bạn ơi, bạn cho code vào trong dấu <> bên dưới mặt cười nhé

Mình gởi code, cảm ơn bạn nhiều, mình mới tham gia diễn đàn nên không rành lắm ^^

(defun c:thu ()
(setq p1 (getpoint "\nchon diem bat dau:"))
(setq pt1 (list (+ (car p1) 6000) (+ (cadr p1)...
>>

Không thấy file lsp bạn ơi, bạn cho code vào trong dấu <> bên dưới mặt cười nhé

Mình gởi code, cảm ơn bạn nhiều, mình mới tham gia diễn đàn nên không rành lắm ^^

(defun c:thu ()
(setq p1 (getpoint "\nchon diem bat dau:"))
(setq pt1 (list (+ (car p1) 6000) (+ (cadr p1) 4300)))
(setq pt2 (list (+ (car pt1) 8000) (+ (cadr pt1) 0)))
(setq pt3 (list (+ (car pt2) 0) (+ (cadr pt2) 9000)))
(setq e1 (entlast))
(command ".line" p1 pt1 pt2 pt3 "" )
(setq e2 (sssetfirst nil (acet-ss-new e1)))
(command "block" "thu" pt3 e2 "")
)

<<

Filename: 324970_thu.lsp
Tác giả: tnmtpc
Bài viết gốc: 13957
Tên lệnh: xoa
LandCadViet Utility

*.tab vẫn là text file thôi, việc tùy chọn thứ tự các trường trong phần nhập dữ liệu là do khi xử lý số liệu thô, lưu file dữ liệu, mỗi anh mỗi khác, kể cả thứ tự các trường cũng vậy. Do vậy trong hộp thoại input, có 5 listbox, trong mỗi listbox có 5 tùy chọn trường, thao tác viên sẽ chọn cho phù hợp với định dạng file dữ liệu của mình. Nếu chương trình không nhận dạng được...
>>

*.tab vẫn là text file thôi, việc tùy chọn thứ tự các trường trong phần nhập dữ liệu là do khi xử lý số liệu thô, lưu file dữ liệu, mỗi anh mỗi khác, kể cả thứ tự các trường cũng vậy. Do vậy trong hộp thoại input, có 5 listbox, trong mỗi listbox có 5 tùy chọn trường, thao tác viên sẽ chọn cho phù hợp với định dạng file dữ liệu của mình. Nếu chương trình không nhận dạng được thì buột file dữ liệu phải theo một cấu trúc chuẩn
<<

Filename: 13957_xoa.lsp
Tác giả: Nguyen Hoanh
Bài viết gốc: 1942
Tên lệnh: a
Dọn dẹp và lưu trữ file với lisp
Tôi hiểu ý bạn muốn. Nhưng không nghĩ là mạo hiểm như thế, nên mới viết lệnh cho người sử dụng lựa chọn.

Sau đây là lược bớt mã lệnh trên. Khi bạn gõ lệnh A, tất cả các file DWG trong thư mục của bản vẽ hiện hành sẽ bị xóa trừ bản vẽ hiện hành.

Filename: 1942_a.lsp
Tác giả: thanhduan2407
Bài viết gốc: 325047
Tên lệnh: gct2
cần hướng dẫn giúp gộp file.dcl vào trong file.lsp

Không biết mọi người có tham khảo được gì ở LISP này không? 

;;;TAO TEXTSTYLE
(command "-Style" "Times New Roman"  "Times New Roman" 0 1 0 "" "" "" )
(vl-load-com)
;;;KHI LOAD LISP SE HIEN LEN THONG BAO TEN LENH
(Prompt (strcat "\nL\U+1EC7nh ghi ch\U+00FA Text l\U+00E0: GCT2"))

(defun C:GCT2(  / file tmp dch return );;;;;;;GHI CHU TEXT CACH 2
    (cond
      (
        (not
          (and (setq file (open (setq tmp...
>>

Không biết mọi người có tham khảo được gì ở LISP này không? 

;;;TAO TEXTSTYLE
(command "-Style" "Times New Roman"  "Times New Roman" 0 1 0 "" "" "" )
(vl-load-com)
;;;KHI LOAD LISP SE HIEN LEN THONG BAO TEN LENH
(Prompt (strcat "\nL\U+1EC7nh ghi ch\U+00FA Text l\U+00E0: GCT2"))

(defun C:GCT2(  / file tmp dch return );;;;;;;GHI CHU TEXT CACH 2
    (cond
      (
        (not
          (and (setq file (open (setq tmp (vl-filename-mktemp nil nil ".dcl")) "w"))
            (write-line
              (strcat
	"	GHICHU"
	"	: dialog"
	"	{"
	"	label = \"Ch\U+01B0\U+01A1ng tr\U+00ECnh vi\U+1EBFt ghi ch\U+00FA Text\";"
	"	            : boxed_column"
	"	            {"
	"	                        : edit_box"
	"	                        {"
	"	                            label = \"Nh\U+1EADp t\U+00EAn c\U+1EA7n vi\U+1EBFt ghi ch\U+00FA\";key = \"Text_ghichu\"; edit_width = 25; alignment = left; value = \"Nh\U+1EADp n\U+1ED9i dung ghi ch\U+00FA v\U+00E0o \U+0111\U+00E2y\";"
	"	                        }"
	"	                        : edit_box"
	"	                        {"
	"	                            label = \"Nh\U+1EADp chi\U+1EC1u cao ch\U+1EEF:\"; key = \"Height_Text\"; edit_width = 3.0; alignment = left; value = 1;"
	"	                        }"
	"	            }"
	"	            : boxed_column"
	"	            {"
	"	            : row"
	"	                        {"
	"	                         : column"
	"	                         {"
	"	                              : popup_list"
	"	                              {"
	"	                                  label = \"L\U+1EF1a ch\U+1ECDn Layer\" ; key = \"LTSLAY\" ; edit_width  = 25 ; list = \"\" ; alignment = left;"
	"	                              }"
	"	                              : popup_list"
	"	                              {"
	"	                                  label = \"L\U+1EF1a ch\U+1ECDn TextStyle\" ; key = \"LTSTEXTSTYLE\" ; edit_width  = 25 ; list = \"\" ; alignment = left;"
	"	                              }"
	"				      spacer;spacer;"
	"				      :row"
	"				      { "
	"					: text"
	"					{"
	"						label = \"Ch\U+1ECDn Color\"; alignment =left;"
	"					}"
	"					: image_button"
	"					{"
	"						key = \"color\"; alignment = centered; height = 1.5; width = 1.0;	fixed_width = false;   fixed_height = true;"
	"					}"
	"				       }"
	"		                         }"
	"	                        }"
	"	            }"
	"	spacer;"
	"	            ok_cancel;"
	"	spacer;spacer;"
	"	:text"
	"	{"
	"		label= \"Ng\U+01B0\U+1EDDi vi\U+1EBFt: Nguy\U+1EC5n Th\U+00E0nh Du\U+00E2n - \U+0110\U+1ECBa Ch\U+00EDnh K48 - 0972.0168.25\";"
	"		alignment= left;"
	"	}"
	"	}"
              )
              file
            )
            (not (close file)) (< 0 (setq dch (load_dialog tmp))) (new_dialog "GHICHU" dch)
          )
        )
      )
      (t
		(action_tile "Text_ghichu"  "(setq TextGhiChu $value)")
		;;;;;;CHO PHEP NHAP NOI DUNG VAO
		(mode_tile "Text_ghichu" 2)
		;;;GAN BIEN CHO TEXTBOX CAO CHU
		(action_tile "Height_Text"  "(setq #Height $value)")
		;;;;;;CHO PHEP NHAP NOI DUNG VAO
		(mode_tile "Height_Text" 2)
		;;;TAO 1 DANH SACH CHUA CAC LAYER CO TRONG BAN VE
		(start_list "LTSLAY")
		(mapcar 'add_list (setq LstLayer (Getlayer)))
		(end_list)


		(if TextGhiChu
			(set_tile "Text_ghichu" TextGhiChu)
			(set_tile "Text_ghichu" "Nh\U+1EADp n\U+1ED9i dung ghi ch\U+00FA v\U+00E0o \U+0111\U+00E2y")
		)

		;;;;GAN LAYER 
		(if #CurLay
			(set_tile "LTSLAY" #CurLay)
			(set_tile "LTSLAY"  "0")
		)
       		(if #Height
			(set_tile "Height_Text" #Height)
			(set_tile "Height_Text"  "1.0")
		)
		(action_tile "LTSLAY" "(setq #CurLay $value)")
		;;;GAN MAU SAC
		(if (null #Color) (setq #Color 2))
		(fill-rec "color" #Color )
		(action_tile "color" "(if (setq #color (acad_colordlg #color)) (fill-rec \"color\" #color ))")
		 
		 ;;;;TAO 1 DANH SACH CHUA CAC TEXTSTYLE
		(start_list "LTSTEXTSTYLE")
		(mapcar 'add_list (setq LstTextStyle (GetTextStyle)))
		(end_list)
		  
		 ;;;;GAN TEXTSTYLE
		(if #CurStyle
			(set_tile "LTSTEXTSTYLE" #CurStyle)
			(set_tile "LTSTEXTSTYLE" "Standard")
		)

		  
		(action_tile "LTSTEXTSTYLE" "(setq #CurStyle $value)")
		;;;;GAN CAC BIEN CHO NOI DUNG GHI CHU, LAYER, TEXTSTYLE
		(if (not TextGhiChu) (setq TextGhiChu (get_tile "Text_ghichu")))
       		(if (not #Height) (setq #Height (get_tile "Height_Text")))
		(if (not #CurLay) (setq #CurLay (get_tile "LTSLAY")))
		(if (not #CurStyle) (setq #CurStyle (get_tile "LTSTEXTSTYLE")))
		;;;;GAN HANH DONG CHO BUTTON OK
		(action_tile "accept" "(setq userclick T)(done_dialog)")
		;;GAN HANH DONG CHO BUTTON CANCEL
		(action_tile "cancel" "(setq userclick nil)(done_dialog)(exit)")

        
      )
    )
    (start_dialog)
    (unload_dialog dch)
    (if (setq tmp (findfile tmp)) (vl-file-delete tmp))
	(if userclick
		(progn
			(GCT1 TextGhiChu #Height #CurLay #CurStyle #Color)
		 )
	)
  )


(defun Getlayer ( / lyr l)
(setq l nil)
(vlax-for lyr
	(vla-get-layers
		(vla-get-activedocument
			(vlax-get-acad-object)
		)
	)
	(setq l (cons (vla-get-name lyr) l))
)
  l
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;HAM CON - LAY RA CAC TEXTSTYLE CO TRONG BAN VE;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun GetTextStyle ( / styl_ l)
(setq l nil)
(vlax-for styl_
	(vla-get-textstyles
		(vla-get-activedocument
			(vlax-get-acad-object)
		)
	)
	(setq l (cons (vla-get-name styl_) l))
)
  l
)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;HAM CON GHI CHU TEXT;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun GCT1 (TextGhiChu h LayerText TextStyle col / i Olmode Gocxoay);;;;GHI CHU TEXT
(setq Olmode (getvar "OSMODE"))
(setvar "OSMODE" 0)
(while  (setq P1 (Getpoint "\nCh\U+1ECDn \U+0111i\U+1EC3m ch\U+00E8n TEXT ghi ch\U+00FA: "))
	(setq P2 (Getpoint  P1 "\nChon huong ghi chu TEXT: "))
	(setq Gocxoay (Angle (trans P1 1 0)
	                     (trans P2 1 0)
	              )
	)
	(entmake (list  (cons 0 "TEXT") (cons 10 P1) (cons 8 (nth (atoi LayerText) LstLayer))
			(cons 40 (atof h)) (cons 50 Gocxoay)
			(cons 7 (nth (atoi TextStyle) LstTextStyle)) (cons 1 TextGhiChu) (cons 62 col) ))
)
(setvar "OSMODE" Olmode)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;TAO MOT PICTURE BOX GAN MAU SAC;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun fill-rec (MyTile col / x y)
(start_image MyTile)
(setq x (dimx_tile MyTile) y (dimy_tile MyTile))
(fill_image 0 0 x y col)
(end_image)
)


<<

Filename: 325047_gct2.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 325070
Tên lệnh: ha2
Hi to every one, the contents existing by this network site are actually awesome for people knowledge, well,keep up the appealing work fellows.

Lisp đổi tên tất cả layout thành các số nguyên từ 1 đến n và thêm tiền tố chung.

;Doan Van Ha - CADViet.com - Ngay 04/12/2014
;Chuc nang: Thay doi ten tat ca layouts va them tien to, tu: HA-1->HA--2->HA-3...HA-n
(defun C:HA2(/ acdoc aclay actab i)
 (vl-load-com)
 (setq tto (getstring "\nTien to chung cua cac...
>>

Lisp đổi tên tất cả layout thành các số nguyên từ 1 đến n và thêm tiền tố chung.

;Doan Van Ha - CADViet.com - Ngay 04/12/2014
;Chuc nang: Thay doi ten tat ca layouts va them tien to, tu: HA-1->HA--2->HA-3...HA-n
(defun C:HA2(/ acdoc aclay actab i)
 (vl-load-com)
 (setq tto (getstring "\nTien to chung cua cac layouts: ")) 
 (setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object))
       actab (strcase (getvar 'CTAB)))
 (vlax-for l (vla-get-layouts acdoc)
  (if (not (eq actab (strcase (vla-get-name l))))
   (setq aclay (cons (cons (vla-get-name l) l) aclay))))
 (setq aclay (vl-sort aclay '(lambda(a b) (< (vla-get-taborder (cdr a)) (vla-get-taborder (cdr b))))))
 (setq i 100000000)
 (foreach n aclay
  (vla-put-name (cdr n) (itoa (setq i (1+ i))))
  (vlax-release-object (cdr n)))
 (setq aclay nil)
 (setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object))
       actab (strcase (getvar 'CTAB)))
 (vlax-for l (vla-get-layouts acdoc)
  (if (not (eq actab (strcase (vla-get-name l))))
   (setq aclay (cons (cons (vla-get-name l) l) aclay))))
 (setq aclay (vl-sort aclay '(lambda(a b) (< (vla-get-taborder (cdr a)) (vla-get-taborder (cdr b))))))
 (setq i 0)
 (foreach n aclay
  (vla-put-name (cdr n) (strcat tto (itoa (setq i (1+ i)))))
  (vlax-release-object (cdr n)))
 (princ))
 
 

<<

Filename: 325070_ha2.lsp
Tác giả: thuynguyet009
Bài viết gốc: 325098
Tên lệnh: ha
đo chiều dài đường cong tại hai điểm bất kỳ

l

 

Đây bạn.

 

(defun C:HA( / obj1 obj2 p1 p2)
 (vl-load-com)
 (setq obj1 (car (entsel "\nChon duong cong: "))
       p1 (getpoint "\nP1: ")
  p2 (getpoint p1 "\nP2: ")
       obj2 (vlax-ename->vla-object (car (entsel "\nChon text: "))))
 (vla-put-TextString obj2 (rtos (abs (- (vlax-curve-getDistAtPoint obj1 p1) (vlax-curve-getDistAtPoint obj1 p2))) 2))
 (vla-put-Color obj2 1)
 (princ))
 

Bác...

>>

l

 

Đây bạn.

 

(defun C:HA( / obj1 obj2 p1 p2)
 (vl-load-com)
 (setq obj1 (car (entsel "\nChon duong cong: "))
       p1 (getpoint "\nP1: ")
  p2 (getpoint p1 "\nP2: ")
       obj2 (vlax-ename->vla-object (car (entsel "\nChon text: "))))
 (vla-put-TextString obj2 (rtos (abs (- (vlax-curve-getDistAtPoint obj1 p1) (vlax-curve-getDistAtPoint obj1 p2))) 2))
 (vla-put-Color obj2 1)
 (princ))
 

Bác ơi có thể sửa lại một chút là mình đo được ra kết quả như một đường kích thước bình thường không? Cảm ơn bác rất nhiều.


<<

Filename: 325098_ha.lsp
Tác giả: nhoclangbat
Bài viết gốc: 325230
Tên lệnh: caodo
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

- ^^, khó phết anh Tue nhỉ, khuya rùi nhoc mới mò đc vậy ko biết  có ổn ko, nhưng hơi dài kaka,mai lại bận cả ngày ko có thời gian ngâm tiếp ^^

(defun c:caodo(/ chon hh kk c_do c)
(setq chon (car (entsel "\nchon cao do chuan:")))
(if (= chon nil)
(progn
(setq hh (getvar "lastprompt"))
(setq kk (strlen "chon cao do chuan: "))
(setq c_do (distof (substr hh kk)))
)
(setq c_do (distof (cdr (assoc 1 (entget...
>>

- ^^, khó phết anh Tue nhỉ, khuya rùi nhoc mới mò đc vậy ko biết  có ổn ko, nhưng hơi dài kaka,mai lại bận cả ngày ko có thời gian ngâm tiếp ^^

(defun c:caodo(/ chon hh kk c_do c)
(setq chon (car (entsel "\nchon cao do chuan:")))
(if (= chon nil)
(progn
(setq hh (getvar "lastprompt"))
(setq kk (strlen "chon cao do chuan: "))
(setq c_do (distof (substr hh kk)))
)
(setq c_do (distof (cdr (assoc 1 (entget chon)))))
)
(princ (setq c (+ 0.5 c_do)))
(princ)
)

<<

Filename: 325230_caodo.lsp
Tác giả: Tot77
Bài viết gốc: 313774
Tên lệnh: test
Một số hàm con VL- hữu ích

Đánh lệnh vlide, bấm f1, vào ActiveX and VBA reference > Objects > Line object. Bên phần Properties bạn thấy 1 dãy. Tất cả những cái đó đều có thể ghép với vla-get- để biết thuộc tính của line, nhưng chỉ 1 số có thể ghép với vla-put- để thay đổi thuộc tính. Muốn biết cái nào dùng dc với vla-put- thi bạn cứ ghép thử, thấy cái nào chuyển màu xanh là ok, còn màu đen là not ok.

Dưới đây...

>>

Đánh lệnh vlide, bấm f1, vào ActiveX and VBA reference > Objects > Line object. Bên phần Properties bạn thấy 1 dãy. Tất cả những cái đó đều có thể ghép với vla-get- để biết thuộc tính của line, nhưng chỉ 1 số có thể ghép với vla-put- để thay đổi thuộc tính. Muốn biết cái nào dùng dc với vla-put- thi bạn cứ ghép thử, thấy cái nào chuyển màu xanh là ok, còn màu đen là not ok.

Dưới đây là lsp test, tôi chỉ lấy vài cái prop đẻ thử thôi. bạn vẽ 1 line rồi chạy lsp.

 

(defun c:test ()
  (defun v2p (a)  (vlax-safearray->list (vlax-variant-value a)))
  (setq a (car (entsel "\nChon Line:"))
obj (vlax-ename->vla-object a))
  (alert  (strcat "\nAngle : " (rtos (vla-get-Angle obj))
 "\nDelta : " (vl-prin1-to-string (v2p (vla-get-Delta obj)))
 "\nLength : " (rtos (vla-get-Length obj))
 "\nStartPoint : " (vl-prin1-to-string (setq dd (v2p (vla-get-StartPoint obj))))
 "\nEndPoint : " (vl-prin1-to-string (setq dc (v2p (vla-get-EndPoint obj))))
 "\nLayer : " (vla-get-Layer obj)
 "\nLinetype : " (vla-get-Linetype obj)
 "\nLinetypeScale : " (rtos (vla-get-LinetypeScale obj))
 "\nLineweight : " (rtos (vla-get-Lineweight obj))      
   ))
  (vla-put-StartPoint obj (vlax-3d-point (polar dd 0 1)))
  (vla-put-EndPoint obj (vlax-3d-point (polar dc 0 -1)))
  (alert  (strcat "\nNew StartPoint : " (vl-prin1-to-string  (v2p (vla-get-StartPoint obj)))
 "\nNew EndPoint : " (vl-prin1-to-string  (v2p (vla-get-EndPoint obj)))))
)

<<

Filename: 313774_test.lsp
Tác giả: nhoclangbat
Bài viết gốc: 325322
Tên lệnh: test
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

- hi mấy anh trợ giúp nhoc với, bài toán text né line, nhoc mót nhặt từ nhiều nơi tới đc đây mà vẫn còn xíu gì đó nhoc vẫn chưa hiểu ^^, chạy vẫn chưa đc như ý.

- vd: vẽ 1 rectang sau đó viết text trên các đỉnh, justy là middle, mã 11 trùng với đỉnh. khi chạy quét từng text thì nó chạy đúng ý nhoc là 45 độ là góc đầu tiên, còn quét 1 lần để duyệt thì mỗi text lại chạy khác nhau đúng...

>>

- hi mấy anh trợ giúp nhoc với, bài toán text né line, nhoc mót nhặt từ nhiều nơi tới đc đây mà vẫn còn xíu gì đó nhoc vẫn chưa hiểu ^^, chạy vẫn chưa đc như ý.

- vd: vẽ 1 rectang sau đó viết text trên các đỉnh, justy là middle, mã 11 trùng với đỉnh. khi chạy quét từng text thì nó chạy đúng ý nhoc là 45 độ là góc đầu tiên, còn quét 1 lần để duyệt thì mỗi text lại chạy khác nhau đúng ra đều 45 độ hết, mặc dù xung quanh đang trống chưa có vật cản nào ^^

(defun move_text (position height / r ang found pt1 pt2 ssobj newpos)

  (setq	r (* 1.2 height)
	ang   (/ pi 4)
	found nil
  )

  (while (and (not found) (<= ang (* 2 pi)))

    (setq newpos (polar position ang r)
	  pt1	 (list (- (car newpos) (/ height 2.0)) (- (cadr newpos) (/ height 2.0)) 0.0)
	  pt2	 (list (+ (car newpos) (/ height 2.0)) (+ (cadr newpos) (/ height 2.0)) 0.0)
    )

    (setq ssobj (ssget "_C" pt1 pt2))

    (if	(= ssobj nil)
      (setq found T)
    )


    (setq ang (+ ang (/ pi 9)))
  )

  (if found
    newpos
    nil
  )

)
;--------------------------------------------------------------------------------------------------
(defun c:test (/ sstext ssl ent enx newvt pos)
(setq sstext (ssget '((0 . "TEXT"))))
(if sstext
(progn
;---------------------------------
(setq	ssl (sslength sstext))
	  
  (repeat ssl
    (setq ent  (ssname sstext 0)
	  enx  (entget ent)
	  pos  (cdr (assoc 11 enx))
	 )
     
    (setq newvt (move_text pos 3.5))
    (if	newvt
    (entmod (subst (cons 11 newvt) (assoc 11 enx) enx))
	(princ "Ko ne dc\n")
    )

    (ssdel ent sstext)
  )
  ) ;end progn
 ) ;end if sstext
 (princ)
)

<<

Filename: 325322_test.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 325259
Tên lệnh: ha
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

Cái này cũng tàm tạm nè!

(defun C:HA(/ ent cd)
 (if (setq ent (car (entsel "\nChon hoac nhap cao do: ")))
  (while (not (setq cd (distof (cdr (assoc 1 (entget ent))))))
   (if (setq ent (car (entsel "\nChon hoac nhap cao do: ")))
    (setq cd (distof (cdr (assoc 1 (entget ent)))))))
  (setq cd (distof (substr (getvar "lastprompt") (strlen "Chon hoac nhap cao do: ")))))
 cd) 
 

Filename: 325259_ha.lsp
Tác giả: huunhantvxdts
Bài viết gốc: 325241
Tên lệnh: caod
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

- ^^, khó phết anh Tue nhỉ, khuya rùi nhoc mới mò đc vậy ko biết  có ổn ko, nhưng hơi dài kaka,mai lại bận cả ngày ko có thời gian ngâm tiếp ^^

(defun c:caodo(/ chon hh kk c_do c)
(setq chon (car (entsel "\nchon cao do chuan:")))
(if (= chon nil)
(progn
(setq hh (getvar "lastprompt"))
(setq kk (strlen "chon cao do chuan: "))
(setq c_do (distof (substr hh kk)))
)
(setq c_do (distof (cdr (assoc 1 (entget...
>>

- ^^, khó phết anh Tue nhỉ, khuya rùi nhoc mới mò đc vậy ko biết  có ổn ko, nhưng hơi dài kaka,mai lại bận cả ngày ko có thời gian ngâm tiếp ^^

(defun c:caodo(/ chon hh kk c_do c)
(setq chon (car (entsel "\nchon cao do chuan:")))
(if (= chon nil)
(progn
(setq hh (getvar "lastprompt"))
(setq kk (strlen "chon cao do chuan: "))
(setq c_do (distof (substr hh kk)))
)
(setq c_do (distof (cdr (assoc 1 (entget chon)))))
)
(princ (setq c (+ 0.5 c_do)))
(princ)
)

Đã đúng như yêu cầu rồi

Bây giờ muốn ràng buộc điều kiện vào cho nó nhưng làm hoài mà không xong mới được 50%

muốn chọn đối tượng là text còn cao hơn nữa bắt buộc text đó phải là số

Đây là lisp chế thêm

(defun c:caod () ;(/ chon hh kk c_do c)
(setq chon (car (entsel "\nCao do chuan chon hoac nhap so:")))
(if (/= chon nil)
(while
 	 (or
	 (null chon)
   	 (/= "TEXT" (cdr (assoc 0 (entget chon))))
	 )
	(princ "\nDoi tuong khong phai la text! Chon lai")
	(setq chon (car (entsel "\nCao do chuan chon hoac nhap so:")))
)
)
(if (= chon nil)
(progn
(setq hh (getvar "lastprompt"))
(setq kk (strlen "Cao do chuan chon hoac nhap so: "))
(setq c_do (distof (substr hh kk)))
)
(setq c_do (distof (cdr (assoc 1 (entget chon)))))
)
(princ (setq c (+ 0.5 c_do)))
(princ)
)

<<

Filename: 325241_caod.lsp
Tác giả: tien2005
Bài viết gốc: 325395
Tên lệnh: mov
Nhờ các bạn am hiểu lisp giúp mình với.

Bạn dùng cái này nhé. Lệnh MOV

 

;; txt2num from http://www.cadviet.com/forum/index.php?showtopic=54635
(defun txt2num (str / num pos)
  (setq pos (vl-string-search (setq num (vl-list->string (vl-remove-if-not '(lambda (x) (or (< 44 x 47)(< 47 x 58)))(vl-string->list str))))str))
  (list
    (substr str 1  pos)
    (if (vl-string-search "." num)(atof num)(atoi num))
    (substr str (+ 1 pos (strlen num)))
    )
  )
(defun DXF (code...
>>

Bạn dùng cái này nhé. Lệnh MOV

 

;; txt2num from http://www.cadviet.com/forum/index.php?showtopic=54635
(defun txt2num (str / num pos)
  (setq pos (vl-string-search (setq num (vl-list->string (vl-remove-if-not '(lambda (x) (or (< 44 x 47)(< 47 x 58)))(vl-string->list str))))str))
  (list
    (substr str 1  pos)
    (if (vl-string-search "." num)(atof num)(atoi num))
    (substr str (+ 1 pos (strlen num)))
    )
  )
(defun DXF (code ent) (cdr (assoc code (entget ent))))
(defun c:mov (/ tl ss txtss txt dy)
  (setq tl (getreal "\nTi le ban ve: "))
  (while
    (and (setq ss (car (entsel "\nChon LINE so sanh: ")))
	 (setq txtss (car (entsel "\nChon text cao do so sanh: ")))
	 (setq txt (car (entsel "\nChon text cao do dat line moi: ")))
    )
     (setq txtss (cadr (txt2num (dxf 1 txtss)))
	   txt	 (cadr (txt2num (dxf 1 txt)))
	   dy	 (/ (- txt txtss) 0.001 tl)
     )
     (entmakex
       (list '(0 . "LINE")
	     (cons 62 1)		; 1 - mau do
	     (cons 10 (mapcar '+ (dxf 10 ss) (list 0 dy 0)))
	     (cons 11 (mapcar '+ (dxf 11 ss) (list 0 dy 0)))
       )
     )
  )
  (princ)
)




<<

Filename: 325395_mov.lsp

Trang 184/330

184