Jump to content
InfoFile
Tác giả: hiepttr
Bài viết gốc: 328272
Tên lệnh: vet
LISP VẼ ĐƯỜNG ỐNG 3D trên AutoCAD

khà khà :D :D :D

 

Bỏ chạy lâu ngày ko ngoảnh mặt lại, khi trở lại nước đã rút nhưng cứ tưởng rằng chẳng ai cần nên ko code :D

 

>>> Hàng đây, ném đá đi :D :D :D

;lisp ve te theo D & d nhap vao
(defun c:VET()
(setq os (getvar 'osmode)
	  lay (getvar "clayer")
	  cmd (getvar 'cmdecho))
(mapcar 'setvar (list 'osmode 'cmdecho) '(0 0))
;================================
;ham bay...
>>

khà khà :D :D :D

 

Bỏ chạy lâu ngày ko ngoảnh mặt lại, khi trở lại nước đã rút nhưng cứ tưởng rằng chẳng ai cần nên ko code :D

 

>>> Hàng đây, ném đá đi :D :D :D

;lisp ve te theo D & d nhap vao
(defun c:VET()
(setq os (getvar 'osmode)
	  lay (getvar "clayer")
	  cmd (getvar 'cmdecho))
(mapcar 'setvar (list 'osmode 'cmdecho) '(0 0))
;================================
;ham bay loi
(setq temperr *error*)
(defun errorTrap (msg)
    (and os (setvar 'osmode os))
	(and lay (setvar "clayer" lay))
	(and cmd (setvar 'cmdecho cmd))
	(cond
		((tblsearch "ucs" "save_ucs_ve_T") 
			(command "ucs" "na" "r" "save_ucs_ve_T")
			(command "ucs" "na" "d" "save_ucs_ve_T")
			)
	)
    (setq *error* temperr)
	(princ "\n*** Da set lai bien, OK ! ***")
    (princ)
)
(setq *error* errorTrap)
;======het ham bay loi = P1 ============================
;===========================================================================================
(command "ucs" "na" "s" "save_ucs_ve_T")
(setq #D_lon (NGT #D_lon 254. getdist "Nhap duong kinh ong lon (D)")
	  #d_nho (NGT #d_nho 204. getdist "Nhap duong kinh ong nho (d)")
	  bl_name (strcat "T_" (rtos #D_lon 2 0) "_" (rtos #d_nho 2 0))
)
(if (tblsearch "layer" bl_name) 
			(setvar "clayer" bl_name) 
			(command "layer" "m" bl_name "c" "t" "45,159,225" "" "")
			)	;if
;=========================================================================================
(if (not (tblsearch "block" bl_name))
	(progn
		(command "ucs" "na" "w")
		(command "CYLINDER" (list 0 0 (- #d_nho)) (/ #D_lon 2.) (* 2 #d_nho))
		(setq part_1 (entlast))
		(command "ucs" "za" "" '(1 0 0))
		(command "CYLINDER" '(0 0 0) (/ #d_nho 2.) (+ (/ #D_lon 2.) (/ #d_nho 4.)))
		(command "_.union" part_1 (entlast) "")
		(command "ucs" "za" "" '(-1 0 0))
		(command "-block" bl_name '(0 0 0) (entlast) "")
		(command "ucs" "na" "r" "save_ucs_ve_T")
	)
)	;Neu chua co _ tao block Te
;==========================================================================================
(if (and
		(setq base_pt (getpoint "\nChon diem giao tim 02 tuyen ong: "))
		(setq pt1 (getpoint "\nChon diem thuoc tim tuyen ong lon: "))
		(setq pt2 (getpoint "\nChon diem thuoc tim tuyen ong nho: "))
		(not (equal base_pt pt1 (setq fuzz (/ #d_nho 100))))
		(not (equal base_pt pt2 fuzz))
		(not (equal pt2 pt1 fuzz))
	)
	(progn
		(command "ucs" "3p" base_pt pt2 pt1)
		(command "insert" bl_name '(0 0 0) "" "" "")
	)
)
(command "ucs" "na" "r" "save_ucs_ve_T")
(command "ucs" "na" "d" "save_ucs_ve_T")
(setq *error* temperr)
(setvar 'osmode os)
(setvar "clayer" lay)
(setvar 'cmdecho cmd)
(princ "\nOK !")
(princ)
)
;===================================================================================================
(defun NGT(a mac_dinh ham str_nhac / modul)
;;Nhan gia tri
(or a (setq a mac_dinh))
(setq a (cond
	((= "" (setq modul (ham (strcat "\n" str_nhac " <" (vl-princ-to-string a) ">: ")))) a)
	(modul)
	(a)
	)
	)
)

<<

Filename: 328272_vet.lsp
Tác giả: gia_bach
Bài viết gốc: 49865
Tên lệnh: 0
Lisp đổi kiểu nét của Layer bị lỗi trên CAD 2004 với 1 số bản vẽ có định dạng khác !!! Nhờ sửa giúp !

Test trên Cad 2004 và Cad2008 file Km339.dwg với layer Thnhien đều OK.
Thực sự tui không hiểu bạn bị lỗi gì.
LISP sửa lại theo tên mặc định có sẵn từ trước ("Thnhien").

Filename: 49865_0.lsp
Tác giả: thanhduan2407
Bài viết gốc: 328666
Tên lệnh: scl
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

Em hỏi nhờ một chút ạ!

Em viết chương trình thống kê layer theo màu sắc được chọn. Tuy nhiên tốc độ hơi chậm.

Vậy các bác có thể góp ý để nâng cấp tốc...

>>

Em hỏi nhờ một chút ạ!

Em viết chương trình thống kê layer theo màu sắc được chọn. Tuy nhiên tốc độ hơi chậm.

Vậy các bác có thể góp ý để nâng cấp tốc độ nó lên được không ạ?

Vì dụ trong việc lọc để lấy đối tượng đó ạ.

Nó chấp nhận Bylayer và Truecolor (bỏ qua Byblock)

(defun C:SCL(/ ColorObj  ClorChuan  ss L3 L2 e   ColorTest mau  Lts_Clor_Layer           )
(setvar "CMDECHO" 0)
(setq Ent (car (entsel "\nCh\U+1ECDn \U+0111\U+1ED1i t\U+01B0\U+1EE3ng l\U+1EA5y m\U+00E0u s?c \U+0111\U+1EC3 th\U+1ED1ng k\U+00EA: ")))
(setq ColorObj (vla-get-ColorIndex (vla-get-truecolor (vlax-ename->vla-object Ent ))))
(if (= ColorObj 256)
    (setq ClorChuan (_getentitycolour Ent))
    (setq ClorChuan ColorObj)
)

(setq ss (acet-ss-to-list (ssget)))
(setq L2 (list))
(setq L3 (list))
(Foreach e ss
	(setq ColorTest  (vla-get-ColorIndex (vla-get-truecolor (vlax-ename->vla-object e))))
  	(if (= ColorTest 256)
	    (setq mau (_getentitycolour e))
	    (setq mau ColorTest)
	)
  	(setq Layer (cdr (assoc 8 (entget e))))
  	(setq L2 (list mau Layer))
  	(setq L3 (append L3 (list L2)))
)

(setq Lts_Clor_Layer (FILTEROBJ1 (vl-remove nil (mapcar '(lambda(x) (if ( = (car x) ClorChuan) (cadr x) nil)) L3))))
(princ Lts_Clor_Layer)
(princ )
)


(defun FILTEROBJ1 ( l  /)
    (if l
      (cons (car l)
        (FILTEROBJ1
          (vl-remove-if '(lambda ( x ) (= x (car l))) (cdr l))
        )
      )
    )
)



(defun _getentitycolour ( ent / )
    (abs
        (cond
            (   (cdr (assoc 62 (entget ent))))
            (   (cdr (assoc 62 (tblsearch "LAYER" (cdr (assoc 8 (entget ent)))))))
        )
    )
)

<<

Filename: 328666_scl.lsp
Tác giả: trinhhoanghieu090
Bài viết gốc: 328863
Tên lệnh: cb
Chương 6 : Bài Tập

Dạo này ít có thời gian nên sự nghiệp học hành chểnh mảng quá, em tranh thủ làm mấy bài dễ nuốt trước thầy ket ơi. Thầy xem hộ em với nhé chứ nếu đợi khi đủ bài tập thì không biết đến "tết nào" :D.

(defun giaithua( n / i ) ; ham tinh n giai thua
(setq ketqua 1.0
      i      1.0) 
(while (<= i n)
(setq ketqua (* ketqua i)
      i (+ 1.0 i))
)
)
(defun inkytu( string / i) ; in lan...
>>

Dạo này ít có thời gian nên sự nghiệp học hành chểnh mảng quá, em tranh thủ làm mấy bài dễ nuốt trước thầy ket ơi. Thầy xem hộ em với nhé chứ nếu đợi khi đủ bài tập thì không biết đến "tết nào" :D.

(defun giaithua( n / i ) ; ham tinh n giai thua
(setq ketqua 1.0
      i      1.0) 
(while (<= i n)
(setq ketqua (* ketqua i)
      i (+ 1.0 i))
)
)
(defun inkytu( string / i) ; in lan luot cac ky tu cua chuoi ra man hinh
(setq i 1)
(while (<= i (strlen string))
(print (substr string i 1))
(setq i (+ i 1))
)
(princ)
)
(defun string_to_list (string / i lst);
(setq i 1)
(while (<= i (strlen string))
(setq lst (append  (list (substr string i 1)) lst)
      i (+ i 1))
)
(reverse lst)
)
(defun c:cb( / tyle gocnghieng dt tenblock diemchen  ); chen block tai tat ca cac vi tri nguoi dung pick chuot
 (setq tyle (getreal "\nNhap ti le scale:")
	   gocnghieng (getreal "\nNhap goc nghieng:")
	   dt (entget (car(entsel "\nPick Chon Block De Xac Dinh Ten:"))) 
       tenblock (cdr (assoc 2 dt)))
(while (setq diemchen (getpoint "pick diem chen block:"))
       (command "-insert" tenblock diemchen tyle "" gocnghieng )
		)
)

<<

Filename: 328863_cb.lsp
Tác giả: master_worse
Bài viết gốc: 328959
Tên lệnh: ktd
Cần lisp kiểm tra dim bị edit

Dùng 

 

(setq ss (ssget '((-4 . "<AND")(0 . "DIMENSION")(-4 . "<NOT")(1 . ",*<>*")(-4 . "NOT>")(-4 . "AND>"))))

 

để chọn các đường kích thước đã bị chỉnh sửa 

 

trong file lisp bên dưới:

 

layer MW-NOT_PLOT là không in.

các đường kích thước đã ở layer này sẽ không được chọn

 

file Lisp:

>>

Dùng 

 

(setq ss (ssget '((-4 . "<AND")(0 . "DIMENSION")(-4 . "<NOT")(1 . ",*<>*")(-4 . "NOT>")(-4 . "AND>"))))

 

để chọn các đường kích thước đã bị chỉnh sửa 

 

trong file lisp bên dưới:

 

layer MW-NOT_PLOT là không in.

các đường kích thước đã ở layer này sẽ không được chọn

 

file Lisp:

(defun c:ktd (/ ss cmdecho)
  (if (setq ss (ssget '((-4 . "<AND")
                        (0 . "DIMENSION")
                        (-4 . "<NOT")
                        (1 . ",*<>*")
                        (-4 . "NOT>")
                        (-4 . "<NOT")
                        (8 . "MW-NOT_PLOT")
                        (-4 . "NOT>")
                        (-4 . "AND>")
                       )
               )
      )
    (progn
      (princ (strcat "co " (itoa (sslength ss)) " duong kich thuoc da bi thay doi."))
      (or (tblsearch "LAYER" "MW-NOT_PLOT")
          (entmake (list '(0 . "LAYER")
                         '(100 . "AcDbSymbolTableRecord")
                         '(100 . "AcDbLayerTableRecord")
                         '(70 . 0)
                         (cons 2 "MW-NOT_PLOT")
                         (cons 62 203)
                         (cons 6 "Continuous")
                         (cons 290 0)
                   )
          )
      )
      (setq cmdecho (getvar 'cmdecho))
      (setvar 'cmdecho 0)
      (command "._change" ss "" "P" "LA" "MW-NOT_PLOT" "C" "BYLAYER" "")
      (setvar 'cmdecho cmdecho)
      (princ " cac doi tuong nay da duoc chuyen sang layer MW-NOT_PLOT")
    )
  )
  (princ)
)

 

(if (setq ss (ssget '((-4 . "<AND")
                        (0 . "DIMENSION")
                        (-4 . "<NOT")
                        (1 . ",*<>*")
                        (-4 . "NOT>")
                        (-4 . "<NOT")
                        (8 . "MW-NOT_PLOT")
                        (-4 . "NOT>")
                        (-4 . "AND>")
                       )
               )
      )
    (progn
      (princ (strcat "co " (itoa (sslength ss)) " duong kich thuoc da bi thay doi."))
      (or (tblsearch "LAYER" "MW-NOT_PLOT")
          (entmake (list '(0 . "LAYER")
                         '(100 . "AcDbSymbolTableRecord")
                         '(100 . "AcDbLayerTableRecord")
                         '(70 . 0)
                         (cons 2 "MW-NOT_PLOT")
                         (cons 62 203)
                         (cons 6 "Continuous")
                         (cons 290 0)
                   )
          )
      )
      (setq cmdecho (getvar 'cmdecho))
      (setvar 'cmdecho 0)
      (command "._change" ss "" "P" "LA" "MW-NOT_PLOT" "C" "BYLAYER" "")
      (setvar 'cmdecho cmdecho)
      (princ " cac doi tuong nay da duoc chuyen sang layer MW-NOT_PLOT")
    )
  )
  (princ)
 
(defun c:ktd (/ ss cmdecho)
  (if (setq ss (ssget '((-4 . "<AND")
                        (0 . "DIMENSION")
                        (-4 . "<NOT")
                        (1 . ",*<>*")
                        (-4 . "NOT>")
                        (-4 . "<NOT")
                        (8 . "MW-NOT_PLOT")
                        (-4 . "NOT>")
                        (-4 . "AND>")
                       )
               )
      )
    (progn
      (princ (strcat "co " (itoa (sslength ss)) " duong kich thuoc da bi thay doi."))
      (or (tblsearch "LAYER" "MW-NOT_PLOT")
          (entmake (list '(0 . "LAYER")
                         '(100 . "AcDbSymbolTableRecord")
                         '(100 . "AcDbLayerTableRecord")
                         '(70 . 0)
                         (cons 2 "MW-NOT_PLOT")
                         (cons 62 203)
                         (cons 6 "Continuous")
                         (cons 290 0)
                   )
          )
      )
      (setq cmdecho (getvar 'cmdecho))
      (setvar 'cmdecho 0)
      (command "._change" ss "" "P" "LA" "MW-NOT_PLOT" "C" "BYLAYER" "")
      (setvar 'cmdecho cmdecho)
      (princ " cac doi tuong nay da duoc chuyen sang layer MW-NOT_PLOT")
    )
  )
  (princ)
)
(defun c:ktd (/ ss cmdecho)
  (if (setq ss (ssget '((-4 . "<AND")
                        (0 . "DIMENSION")
                        (-4 . "<NOT")
                        (1 . ",*<>*")
                        (-4 . "NOT>")
                        (-4 . "<NOT")
                        (8 . "MW-NOT_PLOT")
                        (-4 . "NOT>")
                        (-4 . "AND>")
                       )
               )
      )
    (progn
      (princ (strcat "co " (itoa (sslength ss)) " duong kich thuoc da bi thay doi."))
      (or (tblsearch "LAYER" "MW-NOT_PLOT")
          (entmake (list '(0 . "LAYER")
                         '(100 . "AcDbSymbolTableRecord")
                         '(100 . "AcDbLayerTableRecord")
                         '(70 . 0)
                         (cons 2 "MW-NOT_PLOT")
                         (cons 62 203)
                         (cons 6 "Continuous")
                         (cons 290 0)
                   )
          )
      )
      (setq cmdecho (getvar 'cmdecho))
      (setvar 'cmdecho 0)
      (command "._change" ss "" "P" "LA" "MW-NOT_PLOT" "C" "BYLAYER" "")
      (setvar 'cmdecho cmdecho)
      (princ " cac doi tuong nay da duoc chuyen sang layer MW-NOT_PLOT")
    )
  )
  (princ)
)

<<

Filename: 328959_ktd.lsp
Tác giả: Tue_NV
Bài viết gốc: 329077
Tên lệnh: example adddimangular
Cách thức đo góc theo kiểu trái-giữa-phải trong autolisp

Em tham khảo ví dụ trong Help :

(vl-load-com)
(defun c:Example_AddDimAngular()
;; This example creates an angular dimension in model space.
(setq acadObj (vlax-get-acad-object))
(setq doc (vla-get-ActiveDocument acadObj))

;; Define the dimension
(setq angVert (vlax-3d-point 0 5 0)
FirstPoint (vlax-3d-point 1 7 0)
SecondPoint (vlax-3d-point 1 3 0)
TextPoint (vlax-3d-point 3 5 0))

;; Create the angular dimension in model space
(setq...
>>

Em tham khảo ví dụ trong Help :

(vl-load-com)
(defun c:Example_AddDimAngular()
;; This example creates an angular dimension in model space.
(setq acadObj (vlax-get-acad-object))
(setq doc (vla-get-ActiveDocument acadObj))

;; Define the dimension
(setq angVert (vlax-3d-point 0 5 0)
FirstPoint (vlax-3d-point 1 7 0)
SecondPoint (vlax-3d-point 1 3 0)
TextPoint (vlax-3d-point 3 5 0))

;; Create the angular dimension in model space
(setq modelSpace (vla-get-ModelSpace doc))
(setq dimObj (vla-AddDimAngular modelSpace angVert FirstPoint SecondPoint TextPoint))
(vla-ZoomAll acadObj)
)

Em nghiên cứu 3 cái tọa độ trong ví dụ trên:

FirstPoint (1 7 0)
SecondPoint (1 3 0)
TextPoint (3 5 0)

 

Là ra vấn đề

(vl-load-com)
(defun c:Example_AddDimAngular()
    ;; This example creates an angular dimension in model space.
    (setq acadObj (vlax-get-acad-object))
    (setq doc (vla-get-ActiveDocument acadObj))
    
    ;; Define the dimension
    (setq angVert (vlax-3d-point 0 5 0)
          FirstPoint (vlax-3d-point 1 7 0)
          SecondPoint (vlax-3d-point 1 3 0)
          TextPoint (vlax-3d-point 3 5 0))
  
    ;; Create the angular dimension in model space
    (setq modelSpace (vla-get-ModelSpace doc))
    (setq dimObj (vla-AddDimAngular modelSpace angVert FirstPoint SecondPoint TextPoint))
    (vla-ZoomAll acadObj)
)

<<

Filename: 329077_example_adddimangular.lsp
Tác giả: ssg
Bài viết gốc: 76590
Tên lệnh: ce
Viết lisp theo yêu cầu [phần 2]

Lisp vẽ cung ellipse. Lưu ý:
1. Cung bắt đầu từ Start Angle đến End Angle theo chiều ngược kim đồng hồ. Các giá trị góc từ 0 đến 360 độ (không nhập số âm)
2. Trục dài theo phương X. Nếu bạn đổi (cons 11 (list R 0 0)) thành (cons 11 (list 0 R 0)) thì trục dài sẽ theo phương Y

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

Srr, cái này mới chính xác.

;----- Nh¾c nhë User chän cho ®Õn khi tho¶, in kÕt qu¶ ra dßng command
(defun LM:SelectIf ( msg pred func keyw / sel )
 (setq pred (eval pred))
 (while
  (progn
   (setvar 'ERRNO 0)
   (if keyw (apply 'initget keyw))
   (setq sel (func msg))
   (cond
   ((= 7 (getvar 'ERRNO)) (princ "\nMissed, Try again."))
   ((eq 'STR (type sel))  nil)
   ((vl-consp sel) (if (and pred (not (pred...
>>

Srr, cái này mới chính xác.

;----- Nh¾c nhë User chän cho ®Õn khi tho¶, in kÕt qu¶ ra dßng command
(defun LM:SelectIf ( msg pred func keyw / sel )
 (setq pred (eval pred))
 (while
  (progn
   (setvar 'ERRNO 0)
   (if keyw (apply 'initget keyw))
   (setq sel (func msg))
   (cond
   ((= 7 (getvar 'ERRNO)) (princ "\nMissed, Try again."))
   ((eq 'STR (type sel))  nil)
   ((vl-consp sel) (if (and pred (not (pred sel))) (princ "\nInvalid Object Selected."))))))
 sel)
;----- VÝ dô nµy nh¾c nhë cho ®Õn khi 1 Line ®­îc chän, nÕu hîp lÖ sÏ in ra dßng command
(defun c:test ( / entity )
 (setq entity (car (LM:SelectIf "\nSelect a Text: " (lambda ( x ) (eq "TEXT" (cdr (assoc 0 (entget (car x)))))) entsel nil))))
 

<<

Filename: 329208_test.lsp
Tác giả: nhu thanh
Bài viết gốc: 14109
Tên lệnh: dtxt
CÓ CÁCH NÀO GIÚP CHO CAD CHẠY NHANH KO ?

------------------
System Information
------------------
Time of this report: 3/13/2008, 16:43:44
Machine name: LAOBAO
Operating System: Windows XP Professional (5.1, Build 2600) Service Pack 2 (2600.xpsp_sp2_rtm.040803-2158)
Language: English (Regional Setting: English)
System Manufacturer: GBT___
System Model: GBTUACPI
BIOS: Award Modular BIOS v6.00PG
Processor: Intel®...
>>

------------------
System Information
------------------
Time of this report: 3/13/2008, 16:43:44
Machine name: LAOBAO
Operating System: Windows XP Professional (5.1, Build 2600) Service Pack 2 (2600.xpsp_sp2_rtm.040803-2158)
Language: English (Regional Setting: English)
System Manufacturer: GBT___
System Model: GBTUACPI
BIOS: Award Modular BIOS v6.00PG
Processor: Intel® Celeron® CPU 2.66GHz
Memory: 240MB RAM
Page File: 316MB used, 267MB available
Windows Dir: C:\WINDOWS
DirectX Version: DirectX 9.0c (4.09.0000.0904)
DX Setup Parameters: Not found
DxDiag Version: 5.03.2600.2180 32bit Unicode

------------
DxDiag Notes
------------
DirectX Files Tab: No problems found.
Display Tab 1: No problems found.
đấy làm theo lời bác máy của em nó như vậy bác xem giúp thử có được ko nha !có cáh nào diệt mấy con virut hay hay bác chỉ em với nha
<<

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

Hàm mẫu chọn 1 đối tượng theo 1 kiểu nhất định. Chừng nào chọn được, hoặc Enter/Space mới kết thúc:

;----- Chon 1 doi tuong thoa man dieu kien. Returns:  selected entity ename if successful, else nil.
(defun LM:Selectif ( foo fun str / e )
 (while
  (progn (setq e (car (fun str)))      
   (cond ((eq 'ENAME (type e)) (if (and foo (not (foo e))) (princ "\n** Doi tuong khong hop le...
>>

Hàm mẫu chọn 1 đối tượng theo 1 kiểu nhất định. Chừng nào chọn được, hoặc Enter/Space mới kết thúc:

;----- Chon 1 doi tuong thoa man dieu kien. Returns:  selected entity ename if successful, else nil.
(defun LM:Selectif ( foo fun str / e )
 (while
  (progn (setq e (car (fun str)))      
   (cond ((eq 'ENAME (type e)) (if (and foo (not (foo e))) (princ "\n** Doi tuong khong hop le **"))))))
 e)
;----- Example
(defun C:TEST()
 (LM:Selectif (lambda (x) (eq "TEXT" (cdr (assoc 0 (entget x))))) nentsel "\nChon 1 Text: "))
 

<<

Filename: 329203_test.lsp
Tác giả: buithengan1
Bài viết gốc: 329623
Tên lệnh: lgt
nhờ sửa lisp link giá trị đối tượng
(defun C:LGT (/ obn Tkq Lob)
	(START_PG)
	(setq obn (vlax-ename->vla-object (car (nentsel "\nChon doi tuong nguon")))
				obd	(vlax-ename->vla-object (car (nentsel "\nChon text dich")))
				Tkq	(strcat "%<\\AcObjProp Object(%<\\_ObjId "
										(rtos (vla-get-objectid obn) 2 0)
										">%).TextString>%"
						)
	)
	(vla-put-textstring obd Tkq)
	(vla-update obd)
	(vl-cmdf "regen")
	(END_PG)
	(princ)
)

lisp này copy text từ...

>>
(defun C:LGT (/ obn Tkq Lob)
	(START_PG)
	(setq obn (vlax-ename->vla-object (car (nentsel "\nChon doi tuong nguon")))
				obd	(vlax-ename->vla-object (car (nentsel "\nChon text dich")))
				Tkq	(strcat "%<\\AcObjProp Object(%<\\_ObjId "
										(rtos (vla-get-objectid obn) 2 0)
										">%).TextString>%"
						)
	)
	(vla-put-textstring obd Tkq)
	(vla-update obd)
	(vl-cmdf "regen")
	(END_PG)
	(princ)
)

lisp này copy text từ đối tượng này sang đối tượng khác và tự động thay đổi khi đối tượng nguồn thay đổi nó có khuyết điểm là chỉ chọn đc 1 đối tượng đích giờ mình muốn chọn nhiều giá trị đích hơn nhờ mọi người sửa giúp mình. cảm ơn


<<

Filename: 329623_lgt.lsp
Tác giả: Tot77
Bài viết gốc: 329736
Tên lệnh: lgt
nhờ sửa lisp link giá trị đối tượng
Bạn thử cái này.
(defun C:LGT (/ obn Tkq Lob)

	(setq obn (vlax-ename->vla-object (car (nentsel "\nChon doi tuong nguon"))))
	(prompt "\nChon text dich")
	(setq	obd	(mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget ))))  )
				Tkq	(strcat "%<\\AcObjProp Object(%%).TextString>%")
	)
	(mapcar '(lambda (x) (vla-put-textstring x Tkq)) obd)
	(vl-cmdf "regen")

	(princ)
)

Filename: 329736_lgt.lsp
Tác giả: Tot77
Bài viết gốc: 329836
Tên lệnh: lgt
nhờ sửa lisp link giá trị đối tượng

Bạn thử cái này.

(defun C:LGT (/ obn Tkq Lob)
(setq obn (vlax-ename->vla-object (car (nentsel "\nChon doi tuong nguon")))
Tkq (strcat "%<\\AcObjProp Object(%<\\_ObjId " (itoa (vla-get-objectid obn)) ">%).TextString>%")
)
(while (setq obd (car (nentsel "\nChon text dich")))
(vla-put-textstring (vlax-ename->vla-object obd) Tkq)
)
(vl-cmdf "regen")
(princ)
)

Filename: 329836_lgt.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 329980
Tên lệnh: cav+nil countattributevalues attsum
Đếm Block thuộc tính!?!?!

Lisp đếm block atrribute sưu tầm. Lệnh CAV.

;;-----------------=={ Count Attribute Values }==-------------;;
;;  Counts the number of occurrences of attribute values in a selection of attributed blocks. Displays result in an AutoCAD Table object.
;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
(defun c:CAV nil (c:CountAttributeValues))
(defun c:CountAttributeValues ( / _Dxf _Assoc++ _SumAttributes ss i alist...
>>

Lisp đếm block atrribute sưu tầm. Lệnh CAV.

;;-----------------=={ Count Attribute Values }==-------------;;
;;  Counts the number of occurrences of attribute values in a selection of attributed blocks. Displays result in an AutoCAD Table object.
;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
(defun c:CAV nil (c:CountAttributeValues))
(defun c:CountAttributeValues ( / _Dxf _Assoc++ _SumAttributes ss i alist )
  (defun _Dxf ( key alist ) (cdr (assoc key alist)))
  (defun _Assoc++ ( key alist )
    ((lambda ( pair )
        (if pair
          (subst (list key (1+ (cadr pair))) pair alist)
          (cons  (list key 1) alist)))
      (assoc key alist)))
  (defun _SumAttributes ( entity alist )
    (while
      (not
        (eq "SEQEND"
          (_dxf 0
            (entget
              (setq entity
                (entnext entity))))))
      (setq alist (_Assoc++ (_Dxf 1 (reverse (entget entity))) alist))))
  (cond
    ((not
        (vlax-method-applicable-p
          (setq space
            (vlax-get-property
              (setq doc
                (vla-get-ActiveDocument (vlax-get-acad-object)))
              (if (= 1 (getvar 'CVPORT)) 'Paperspace 'Modelspace)))
          'AddTable))
      (princ "\n** This Version of AutoCAD Does not Support Tables **"))
    ((and (setq ss (ssget '((0 . "INSERT") (66 . 1))))
        (repeat (setq i (sslength ss))
          (setq alist (_SumAttributes (ssname ss (setq i (1- i))) alist)))
        (setq pt (getpoint "\nPick Point for Table: ")))
      (LM:AddTable space (trans pt 1 0) "Attribute Totals"
        (cons '("Value" "Total")
          (vl-sort
            (mapcar
              (function
                (lambda ( pair )
                  (list (car pair) (itoa (cadr pair)))))
              alist)
            (function (lambda ( a b ) (< (strcase (car a)) (strcase (car b))))))))))
  (princ))
;;-------------------=={ Attribute Sum }==--------------------;;
;;  Sums numerical attributes of the same tag in a selection of attributed blocks. Displays result in AutoCAD Table object.
;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
(defun c:AttSum ( / _assoc+ doc space ss n lst pt )
  (vl-load-com)
  (defun _assoc+ ( key value lst )
    ((lambda ( pair )
        (if pair
          (subst (list key (+ (cadr pair) value)) pair lst)
          (cons  (list key value) lst)))
      (assoc key lst)))
  (cond
    ((not
        (vlax-method-applicable-p
          (setq space
            (vlax-get-property
              (setq doc
                (vla-get-ActiveDocument
                  (vlax-get-acad-object)))
              (if (= 1 (getvar 'CVPORT)) 'Paperspace 'Modelspace)))
          'AddTable))
      (princ "\n** This Version of AutoCAD Does not Support Tables **"))
    ((and (ssget '((0 . "INSERT") (66 . 1)))
        (progn
          (vlax-for obj (setq ss (vla-get-ActiveSelectionSet doc))
            (mapcar
              (function
                (lambda ( attrib )
                  (if (setq n (distof (vla-get-TextString attrib)))
                    (setq lst (_assoc+ (vla-get-TagString attrib) n lst)))))
              (vlax-invoke obj 'GetAttributes)))
          (vla-delete ss)
          (setq lst (mapcar '(lambda ( x ) (list (car x) (rtos (cadr x)))) lst)))
        (setq pt (getpoint "\nPick Point for Table: ")))
      (LM:AddTable space (trans pt 1 0) "Attribute Totals"
        (cons '("Tag" "Total") (vl-sort lst '(lambda ( a b ) (< (strcase (car a)) (strcase (car b)))))))))
  (princ))
;;---------------------=={ Add Table }==----------------------;;
;;  Creates a VLA Table Object at the specified point, populated with title and data.
;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
;;  Arguments:                                                ;;
;;  space - VLA Block Object                                  ;;
;;  pt    - Insertion Point for Table                         ;;
;;  title - Table title                                       ;;
;;  data  - List of data to populate the table                ;;
;;  Returns:  VLA Table Object                                ;;
(defun LM:AddTable ( space pt title data / _itemp ) (vl-load-com)
  (defun _itemp ( collection item )
    (if
      (not
        (vl-catch-all-error-p
          (setq item
            (vl-catch-all-apply 'vla-item (list collection item)))))
      item))
  ((lambda ( table ) (vla-put-StyleName table (getvar 'CTABLESTYLE)) (vla-SetText table 0 0 title)
      ((lambda ( row )
          (mapcar
            (function
              (lambda ( rowitem ) (setq row (1+ row))
                ((lambda ( column )
                    (mapcar
                      (function
                        (lambda ( item )
                          (vla-SetText table row
                            (setq column (1+ column)) item)))
                      rowitem))
                  -1)))
            data))
        0)
      table)
    ((lambda ( textheight )
        (vla-AddTable space (vlax-3D-point pt) (1+ (length data)) (length (car data)) (* 1.8 textheight)
          (* textheight
            (apply 'max
              (cons (/ (strlen title) (length (car data)))
                (mapcar 'strlen (apply 'append data)))))))
      (vla-getTextHeight
        (_itemp
          (_itemp
            (vla-get-Dictionaries
              (vla-get-ActiveDocument (vlax-get-acad-object)))
            "ACAD_TABLESTYLE")
          (getvar 'CTABLESTYLE))
        acDataRow))))
(princ)
 

<<

Filename: 329980_cav+nil_countattributevalues_attsum.lsp
Tác giả: tranchan
Bài viết gốc: 14151
Tên lệnh: ggk
Nhân bản đối tượng theo một đường



Về ý đồ này bác có thể xài copym ngay trong express của bản Cad. Nhưng lệch hay không là do bắt điêm đấy nhé. Copym mã nguôn mở bác có thế tham khảo để cải tiến.

vd: command: copym

Select objects:

Base point:
Second point or
<exit>: *Cancel*

chọn measure ...

Filename: 14151_ggk.lsp
Tác giả: tringuyendn
Bài viết gốc: 14155
Tên lệnh: lg12 lg13
có bác nào biết lệnh tắt để vẽ cầu thang trong cad ko?????????
Bác bemove có câu nói hay nhất trong ngày đó.
Bác xứng đáng bị remove.
Lệnh stair nghe sao lạ quá? <_<

Filename: 14155_lg12_lg13.lsp
Tác giả: trinhhoanghieu090
Bài viết gốc: 330316
Tên lệnh: wgs84 105
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

Các bác ơi cho em hỏi chút, em muốn tự động mở file cad lên khi gõ lệnh lisp nhưng không được,  file cad cần load em đã để trong support file search, code em viết đây ạ, vấn đề ở chỗ hàm open, khi gõ trực tiếp trên command thì được mà viết vào lisp thì lại không được:

(defun c:wgs84_105 ()
(defun start ()
(setvar "filedia" 0)
)
(defun end ()
(setvar "filedia" 1)
)
(defun...
>>

Các bác ơi cho em hỏi chút, em muốn tự động mở file cad lên khi gõ lệnh lisp nhưng không được,  file cad cần load em đã để trong support file search, code em viết đây ạ, vấn đề ở chỗ hàm open, khi gõ trực tiếp trên command thì được mà viết vào lisp thì lại không được:

(defun c:wgs84_105 ()
(defun start ()
(setvar "filedia" 0)
)
(defun end ()
(setvar "filedia" 1)
)
(defun *error* ( aaa)
 (end)
 )
 (start )
(command "open" "WGS84_105") 
 (end )
)

<<

Filename: 330316_wgs84_105.lsp
Tác giả: Ar_Chanwoo
Bài viết gốc: 14160
Tên lệnh: ggu
Paragraph writing namely likewise a sport whether you be versed with after that you can write if only it is complicated apt write.

cảm ơn anh Hoành đã giải thích, nhưng cái mà e đang cần là cái có khả năng liệt kê các lisp hoặc các lệnh bị giới hạn thời gian sử dụng, vì e có nhiều lisp muốn khoá, và lệnh reset để làm mất hoàn toàn chức năng đó chứ ko phải tạo lại vòng lặp đó, e đọc đoạn a hướng dẫn về lệnh FUNC mà vẫn chưa hiểu.

-A có biết lệnh copy muti divide ko, a có thể viết lại lisp đó,...
>>

cảm ơn anh Hoành đã giải thích, nhưng cái mà e đang cần là cái có khả năng liệt kê các lisp hoặc các lệnh bị giới hạn thời gian sử dụng, vì e có nhiều lisp muốn khoá, và lệnh reset để làm mất hoàn toàn chức năng đó chứ ko phải tạo lại vòng lặp đó, e đọc đoạn a hướng dẫn về lệnh FUNC mà vẫn chưa hiểu.

-A có biết lệnh copy muti divide ko, a có thể viết lại lisp đó, thay việc copy đối tượng bất kì thì lisp sẽ copy text số và text chữ ttheo 1 tham số tăng nào đó, riêng text chữ thì nếu copy quá 26 chữ thì quay lại vòng lặp a,b,c....kết quả của lisp này là khi copy theo 2 chế độ muti và divide thì sẽ đc : 1,2,3,4,5,6,7,8,9..........hoặc a,b,c,d,e....
<<

Filename: 14160_ggu.lsp
Tác giả: nhoclangbat
Bài viết gốc: 328430
Tên lệnh: ttl ttk
I am really delighted to glance at this network site posts which includes tons of serviceable information, thanks for providing these statistics.

@Nhoclangbat: Mình có 1 file bị lỗi không dùng được lsp ttl.

Bạn kiểm tra giúp mình được không? Cảm ơn bạn!

- có phải bạn không chọn đc polyline phải ko ^^, nhoc đã sửa lại chắc ok

(vl-load-com)
;==================
(defun c:TTL (/ old lmax lmin ename1 ename2 dai1 dai2 info1 sl info2 ...
>>

@Nhoclangbat: Mình có 1 file bị lỗi không dùng được lsp ttl.

Bạn kiểm tra giúp mình được không? Cảm ơn bạn!

- có phải bạn không chọn đc polyline phải ko ^^, nhoc đã sửa lại chắc ok

(vl-load-com)
;==================
(defun c:TTL (/ old lmax lmin ename1 ename2 dai1 dai2 info1 sl info2  ltb ldelta e1 e2) ;
(setq old (getvar "osmode"))
(setvar "osmode" 0)
(prompt "Chon thanh co chieu dai be nhat:")
(setq lmin (ssget "+.:E:S" '((0 . "*LINE"))))
(if lmin
 (progn
   (setq dai1 0.0)
   (while (setq ename1 (ssname lmin 0))
           (setq dai1 (+ dai1 (Length1 ename1)))
		   (ssdel ename1 lmin))
     (setq dai1 (distof (rtos dai1 2 3)))
  )
)  
 ;=========================================================
(prompt "Chon thanh co chieu dai lon nhat:")
(setq lmax (ssget "+.:E:S" '((0 . "*LINE"))))
(if lmax
 (progn
    (setq dai2 0.0)
   (while (setq ename2 (ssname lmax 0))
           (setq dai2 (+ dai2 (Length1 ename2)))
		   (ssdel ename2 lmax))
     (setq dai2 (distof (rtos dai2 2 3)))
  )
)  
;===========================================================
(setq sl (getint "\nSo luong thanh mun tinh:"))
(setq ltb (distof (rtos (/ (+ dai1 dai2) 2.0) 2 3)))
(if (= (- ltb (fix ltb)) 0.5)
(setq ltb (+ ltb 0.5))
ltb
)
(setq ldelta (* (/ (- dai2 dai1) (- sl 1)) 1000.0))
;==============================================================
(setq e1 (entget (car (entsel "\nchon text ghi ket qua L trung binh:"))))
(princ "\n")
(while (/= (cdr (assoc 0 e1)) "TEXT")
(prompt "Ban chon ko phai la text, ban chon lai hen!!!")
(setq e1 (entget (car (entsel "\nchon text ghi ket qua L trung binh:"))))
(princ "\n")
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(entmod (subst (cons 1 (strcat (itoa sl) "`14, L=" (rtos (* ltb 1000) 2 0))) (assoc 1 e1) e1))
;===============================================================
(setq e2 (entget (car (entsel "\nchon dim ghi ket qua L delta:"))))
(princ "\n")
(while (/= (cdr (assoc 0 e2)) "DIMENSION")
(prompt "doi tuong ban chon ko phai la dim, ban chon lai hen!!!")
(setq e2 (entget (car (entsel "\nchon dim ghi ket qua L delta:"))))
(princ "\n")
)
(entmod (subst (cons 1 (strcat (rtos (* dai1 1000) 2 0) "~" (rtos (* dai2 1000) 2 0) ", \U+0394L=" (rtos ldelta 2 0))) (assoc 1 e2) e2))
;======================================================================
(setvar "osmode" old)
(princ "\n")
(princ)
)
;===============================chon thanh co chieu dai ko doi edit vao text co san
(defun c:ttk(/ lx ename3 info3 dai3 e3 old sl dk)
(setq old (getvar "osmode"))
(setvar "osmode" 0)
(prompt "Chon thanh co chieu dai khong doi:")
(setq lx (ssget "+.:E:S" '((0 . "*LINE"))))
(if lx
 (progn
     (setq dai3 0.0)
	 (while (setq ename3 (ssname lx 0))
           (setq dai3 (+ dai3 (Length1 ename3)))
		   (ssdel ename3 lx))
	     (setq dai3 (distof (rtos dai3 2 3)))
	 )
  )
(setq sl (getint "\nSo luong thanh mun tinh:"))
(setq dk (getstring "\nNhap duong kinh Thep:"))
;====================================================
 (setq e3 (entget (car (entsel "\nchon text ghi ket qua L khong doi:"))))
(princ "\n")
(while (/= (cdr (assoc 0 e3)) "TEXT")
(prompt "Ban chon ko phai la text, ban chon lai hen!!!")
(setq e3 (entget (car (entsel "\nchon text ghi ket qua L khong doi:"))))
(princ "\n")
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(entmod (subst (cons 1 (strcat (itoa sl) dk ", L=" (rtos (* dai3 1000) 2 0))) (assoc 1 e3) e3))
(setvar "osmode" old)
(princ "\n")
(princ)
)
;=============================================
(defun Length1(e) 
(vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)))
;=========================================================

- p/s: nói khó cũng ko khó dễ cũng ko phải dễ ^^,với ai chưa pit về lsp chỉ xem qua code dù nhiều lần cũng khó mà nắm đc để có thể tự sửa, bản thân nhoc lúc trước cũng vậy, có khi mún sửa lại hóa ra phá ^^,anh ndtnv đừng khó khăn quá  :P


<<

Filename: 328430_ttl_ttk.lsp
Tác giả: Tot77
Bài viết gốc: 330669
Tên lệnh: tes
Lisp xóa text (hoặc line) theo thứ tự cách quãng.

Bạn thử lsp này. Khi nó hỏi cách thì nếu muốn giữ 1 xoá 1 thì gõ 1, nếu muốn giữ 1 xoá 2 thì gõ 2.

(defun c:tes()
(command "undo" "be")
(prompt "\nChon text, line can xoa:")
(setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "*TEXT,*LINE"))))))
ss (vl-sort ss '(lambda (x y) (< (car (cdr (assoc 10 (entget x)))) (car (cdr (assoc 10 (entget y)))))))
ck (1+ (getint "\nCach:"))
n -1)
(while (<...
>>

Bạn thử lsp này. Khi nó hỏi cách thì nếu muốn giữ 1 xoá 1 thì gõ 1, nếu muốn giữ 1 xoá 2 thì gõ 2.

(defun c:tes()
(command "undo" "be")
(prompt "\nChon text, line can xoa:")
(setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "*TEXT,*LINE"))))))
ss (vl-sort ss '(lambda (x y) (< (car (cdr (assoc 10 (entget x)))) (car (cdr (assoc 10 (entget y)))))))
ck (1+ (getint "\nCach:"))
n -1)
(while (< (setq n (1+ n)) (length ss))
(and (/= 0 (rem n ck)) (entdel (nth n ss))))
(command "undo" "e") (princ)
)

<<

Filename: 330669_tes.lsp

Trang 187/330

187