Jump to content
InfoFile
Tác giả: hoacomay70
Bài viết gốc: 367361
Tên lệnh: ttt
Sửa lisp tự động extend và trim các đường Pline

 

Bạn thử xem nhé!

(defun C:TTT (   /  LTSPLINE X)
  (defun *error* (msg)
    (if	Olmode
      (setvar...
>>

 

Bạn thử xem nhé!

(defun C:TTT (   /  LTSPLINE X)
  (defun *error* (msg)
    (if	Olmode
      (setvar 'osmode Olmode)
    )
    (if	(not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
      (princ (strcat "\nError: " msg))
    )
    (princ)
  )
  (setq Olmode (getvar "OSMODE"))
  (setq LtsPline (CV:ss-to-list (ssget (list (cons 0 "*LWPOLYLINE,POLYLINE"))) nil))
  (command "Zoom" "e")
  (mapcar '(lambda(x)(Ttt1 x)) LtsPline)
(setvar "OSMODE" Olmode)
(princ)
)

(defun Ttt1 (ent  / A  CMD ENTTTT HV KC12 LENT LENTL LEPT LINT LSPT P1 P2 PNT_D PNT_T SSET TV)
  (vl-load-com)
  (setq cmd (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)
  (setvar "OSMODE" 0)
  (command "UNDO" "Begin")
;;;  (while (not ent)
;;;    (setq ent (car (entsel "Select edge line: ")))
;;;    (if	ent
;;;      (progn
;;;	(setq entl (entget ent))
;;;      )
;;;    )
;;;  )
  (if ent
    (progn
      (redraw ent 3)
      (setq a 0)
      (setq HV (LM:ssboundingbox (CV:List-to-ss (list ent))))
      (setq P1 (car HV))
      (setq P2 (cadr HV))
      (setq KC12 (distance P1 P2))
      (setq TV (list (/ (+ (car P1) (car P2)) 2) (/ (+ (cadr P1) (cadr P2)) 2)))
      (setq Pnt_T (list (- (car TV) (/ KC12 2)) (+ (cadr TV) (/ KC12 2))))
      (setq Pnt_D (list (+ (car TV) (/ KC12 2)) (- (cadr TV) (/ KC12 2))))
      (setq sset (ssget "W" Pnt_T Pnt_D (list (cons 0 "LINE"))))
      (if sset
	(repeat	(sslength sset)
	  (setq	lentl (entget (setq lent (ssname sset a)))
		lspt  (cdr (assoc 10 lentl))
		lept  (cdr (assoc 11 lentl))
	  )
	  (setq entttt (ssname sset a))
	  (setq lint (nth 0 (x_intlst ent entttt acExtendOtherEntity)))
	  (if lint
	    (progn

	      (if (< (distance lint lspt) (distance lint lept))
		(entmod	(subst
			  (cons 10 lint)
			  (assoc 10 lentl)
			  lentl
			)
		)
		(entmod	(subst
			  (cons 11 lint)
			  (assoc 11 lentl)
			  lentl
			)
		)
	      )
	    )
	  )
	  (setq a (1+ a))
	)
	
      )
      (redraw ent 4)
    )
  )
  (setvar "CMDECHO" cmd)
  (command "UNDO" "End")
  (princ)
)

;;; by kuangdao at xdcad
(defun x_intlst	(obj1 obj2 param / intlst1 intlst2 ptlst)

  (if (= 'ENAME (type obj1))
    (setq obj1 (vlax-ename->vla-object obj1))
  )
  (if (= 'ENAME (type obj2))
    (setq obj2 (vlax-ename->vla-object obj2))
  )
  (setq
    intlst1 (vlax-variant-value (vla-intersectwith obj1 obj2 param))
  )
  (if (< 0 (vlax-safearray-get-u-bound intlst1 1))
    (progn
      (setq intlst2 (vlax-safearray->list intlst1))
      (while (> (length intlst2) 0)
	(setq ptlst   (cons (list (car intlst2) (cadr intlst2) (caddr intlst2))
			    ptlst
		      )
	      intlst2 (cdddr intlst2)
	)
      )
    )
  )
  ptlst
)

(defun LM:ssboundingbox ( s / a b i m n o )
    (repeat (setq i (sslength s))
        (if
            (and
                (setq o (vlax-ename->vla-object (ssname s (setq i (1- i)))))
                (vlax-method-applicable-p o 'getboundingbox)
                (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list o 'a 'b))))
            )
            (setq m (cons (vlax-safearray->list a) m)
                  n (cons (vlax-safearray->list b) n)
            )
        )
    )
    (if (and m n)
        (mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list m n))
    )
)

(defun CV:List-to-ss (lst / ss)
(setq ss (ssadd))
(foreach item lst
  (or (= (type item ) 'Ename)
   (setq item (vlax-vla-object->ename  item)))
  (setq ss (ssadd item ss))
)
ss
)

(defun CV:ss-to-list (ss vla / n e l)
  (setq n (sslength ss))
  (while (setq e (ssname ss (setq n (1- n))))
	(setq l (cons (if vla (vlax-ename->vla-object e) e) l))
  ) 
)

Bac oi minh chi duoc quet chon doi tuong mot lan thoi a? Cach dung the nao vay a. Em quet chon thi khong thay gi ca. Bac xem giup em duoc khong. Cam on bac rat nhieu.


<<

Filename: 367361_ttt.lsp
Tác giả: ahdvip
Bài viết gốc: 184635
Tên lệnh: getpr
HỎI>Cách xuất tọa độ file cad sang text

Hề hề hề,

Chả biết cái bạn cần có giống cái này không??? Song do bạn trình bày hơi ..... tiết kiệm nên mình chỉ có...

>>

Hề hề hề,

Chả biết cái bạn cần có giống cái này không??? Song do bạn trình bày hơi ..... tiết kiệm nên mình chỉ có thể đoán mò, Trúng thì là hên xui, trật thì là cái để bạn có thể rút kinh nghiệm trình bày sao cho người đọc khỏi phải ..... mò.


(defun c:getpr (/ ssl fn fw els name lay col txt p1 p2 pt x y z x1 x2 y1 y2 z1 z2 bk )
(setq ssl (acet-ss-to-list (ssget))
         fn (getfiled "Chon file de save" "" "txt" 1)
         fw (open fn "w") )
(princ " Bang liet ke thuoc tinh co ban cua doi tuong \n " fw)
(foreach en ssl
  	(setq els (entget en)
    			name (cdr (assoc 0 els))
    			lay (cdr (assoc 8 els))
    			col (if (assoc 62 els) (rtos (cdr (assoc 62 els)) 2 0) (rtos (cdr (assoc 62 (tblsearch "layer" lay))) 2 0))
    			txt (strcat name "," lay "," col )
       )
  	(cond
  			((= name "LINE") (setq p1 (cdr (assoc 10 els))  p2 (cdr (assoc 11 els))
                                          			x1 (rtos (car p1) 2 2)  x2 (rtos (car p2) 2 2)
                                          			y1 (rtos (cadr p1) 2 2)  y2 (rtos (cadr p2) 2 2)
                                          			z1 (rtos (caddr p1) 2 2)  z2 (rtos (caddr p2) 2 2)
                                                     txt (strcat txt "," x1 "," y1 "," z1 "," x2 "," y2 "," z2) ) )
  			((= name "CIRCLE") (setq bk (rtos (cdr (assoc 40 els)) 2 2)  pt (cdr (assoc 10 els))
                                                     x (rtos (car pt) 2 2) y (rtos (cadr pt) 2 2) z (rtos (caddr pt) 2 2)
                                                     txt (strcat txt ","  bk  "," x "," y "," z) ) )
  			((= name "LWPOLYLINE") (foreach el els
                                                                   (if (= (car el) 10)
                                                                       (progn
                                                                             (setq  z (rtos (cdr (assoc 38 els)) 2 2)
                                                                            			x (rtos (cadr el) 2 2) y (rtos (caddr el) 2 2)
                                                                                       txt (strcat txt ","  x  ","  y  ","  z) )                                                                              
                                                                       )
                                                        			)
                                                                 ) )
             ((= name "POLYLINE") (setq en (entnext en))
                                                     (while (/= (cdr (assoc 0 (entget en))) "SEQEND")
                                                    			(setq x (rtos (cadr (assoc 10 (entget en))) 2 2)
                                                              			y (rtos (caddr (assoc 10 (entget en))) 2 2)
                                                              			z (rtos (cadddr (assoc 10 (entget en))) 2 2)
                                                                         txt (strcat txt ","  x  ","  y  ","  z)
                                                                         en (entget en) ) ) )
             (T nil)
       )


       (princ (strcat txt "\n") fw)
)
(close fw)
(princ)
)

Cái này mình cóp pi, nhặt mót của các bác trên diễn đàn, mỗi người một tí, rồi ghép lại để bạn xài tạm. Tuy chưa được ngay ngắn lắm, nhưng thôi thì của nhà trồng được, bạn hẵng xơi tạm cho đỡ nóng ruột nhé.

Hề hề hề,..

thanks anh trước đã.

Nhưng mà chưa đúng anh ơi.

hôm qua em viết bài để nói rõ hơn cho anh rồi nhưng mà sao lại bị xóa mất rồi. Hic

file cad vd : http://www.cadviet.c..._drawing1_1.dwg

trong đó có các đường line, cicle, spline(đường này em muốn nếu là đường spline thì dùng lệnh c2p để chuyển thành pline với n đoạn thẳng(đây là lisp c2p : http://www.cadviet.c...02600_c2p_1.lsp))

 

trong file cad ví dụ em đã dùng lệnh c2p thủ công rồi nha anh. Anh giúp em cứ gặp đường spline là tự động dùng lệnh đó.

 

em download được 1 cái lisp xuất tọa độ các đỉnh nhưng bảng tọa độ nằm trong cad luôn http://www.cadviet.c...102600_vc_1.lsp

 

file kết quả như mong muốn http://www.cadviet.c...600_ket_qua.doc

xuất ra .txt hoặc excel cũng được anh ak. thanks anh.


<<

Filename: 184635_getpr.lsp
Tác giả: lp_hai
Bài viết gốc: 152713
Tên lệnh: ton
lisp vẽ tôn

Của bạn đây:

(defun c:ton()
 (setq oldos (getvar "osmode"))
 (setvar "osmode" 0)
 (setq p1 (getpoint "Chon diem 1:...
>>

Của bạn đây:

(defun c:ton()
 (setq oldos (getvar "osmode"))
 (setvar "osmode" 0)
 (setq p1 (getpoint "Chon diem 1: ")
p2 (getpoint p1 "Chon diem 2: ")
d (distance p1 p2)
sm (rtos(/ d 130) 2 0)
)
 (command "pline")
 (command p1)
    (repeat (atoi sm)
      (command "@15,30" "@30,0" "@15,-30" "@70,0")
      )
 (command "")
 (setvar "osmode" oldos)
 )

hay that. cam on bac nhé


<<

Filename: 152713_ton.lsp
Tác giả: billgateviet
Bài viết gốc: 65257
Tên lệnh: dstt
Đánh số thứ tự tăng dần
Tue_NV mới viết cái Lisp này.

Hy vọng bạn hài lòng :

(defun c:dstt(/ dau tong po po1 ent i)
(prompt "\n Danh so thu tu dang n/m ")
(setvar "cmdecho" 0)

(setq dau...
>>
Tue_NV mới viết cái Lisp này.

Hy vọng bạn hài lòng :

(defun c:dstt(/ dau tong po po1 ent i)
(prompt "\n Danh so thu tu dang n/m ")
(setvar "cmdecho" 0)

(setq dau (getint "\n Danh so bat dau (n) :"))
(setq tong (getint "\n Danh so tong (m) :"))

(setq po (getpoint (strcat "\n Cho diem chen cua so : " (itoa dau) "/" (itoa tong))) i 1)
(wtxt (strcat (itoa dau) "/" (itoa tong)) po)

(Repeat (- tong dau)
(setq po1 (getpoint po (strcat "\n Cho diem chen cua so : " (itoa (+ dau i)) "/" (itoa tong))))

(command "copy" "L" "" po po1) 
(setq ent (entget(entlast)))
(setq ent (subst (cons 1 (strcat(itoa (+ dau i)) "/" (itoa tong))) (assoc 1 ent) ent))
(entmod ent)
(setq i (1+ i))
(setq po po1)
)
(princ)
)
;
(defun wtxt (txt p / sty d h)
(setq sty (getvar "textstyle")
d (tblsearch "style" sty)
h (cdr (assoc 40 d)))
(entmake (list (cons 0 "TEXT") (cons 7 sty) (cons 1 txt) (cons 10 p) (cons 11 p) 
(cons 72 1) (cons 73 2)
(if (> h 0) (cons 40 h) (assoc 40 d)) (assoc 41 d))
)
)

Hay quá , cảm ơn bác Tue_NV nhé .


<<

Filename: 65257_dstt.lsp
Tác giả: hhhhgggg
Bài viết gốc: 122188
Tên lệnh: x
Nhờ cao thủ sửa giúp em đoạn list Explode !
Chào bạn hhhhgggg,

Bạn xài thử cái này coi sao nhé

(defun c:x ( / ss i n e el)
(command "undo" "be")
( setq ss (ssget) )
(setq i 0
       n (sslength...
>>
Chào bạn hhhhgggg,

Bạn xài thử cái này coi sao nhé

(defun c:x ( / ss i n e el)
(command "undo" "be")
( setq ss (ssget) )
(setq i 0
       n (sslength ss)
)
(while (< i n)
       (setq e (ssname ss i)
                el (entget e)
       )
       (if (= (cdr (assoc 0 el )) "INSERT")
           (expl e)
       )
       (setq i (1+ i))
)  
(command "undo" "e") 
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun expl (ent / els bln en )
(setq els (entget ent))
(if (= (cdr (assoc 0 els)) "INSERT")
  (progn
        (setq bln (cdr (assoc 2 els))) 
        (setq en (cdr (assoc -2 (tblsearch "block" bln))))
        (setq en (entnext en))
        (command "explode" ent )
   )
)
        (while en                
               (if (= (cdr (assoc 0 (entget en))) "INSERT")
                   (expl en)
               )
               (setq en (entnext en))
        )

)

 

Có gì chưa ổn hãy post lên nhé. Bạn lưu ý là mình sử dụng lại cái lisp của bạn nên vẫn giữ nguyên lệnh chạy lisp là X . Phải coi chừng việc trùng với lệnh của CAD đó. Tốt nhất bạn nên thay cái tên lệnh này đi nhé.

:undecided: hic hic ! Bác check lại giúp em cái. Nó không chạy. E chủ ý thay lệnh của CAD mà. Như thế "X" cho nó vỡ tan ra !!!


<<

Filename: 122188_x.lsp
Tác giả: gia_bach
Bài viết gốc: 80329
Tên lệnh: rp
Thay đổi máy in
.....................................

Bạn nào quan tâm có thể tham khảo:

;;;-------------------------------------------------------
(defun C:RP( / MyPrinter AcObj ADoc ALay...
>>
.....................................

Bạn nào quan tâm có thể tham khảo:

;;;-------------------------------------------------------
(defun C:RP( / MyPrinter AcObj ADoc ALay PSize) ;;;Reset Printer
(vl-load-com)
(setq
   MyPrinter "HP Laser Jet 5100 PCL 6 on PHAMBAHUNG-CK"
   AcObj (vlax-get-acad-object) ;;;AutoCAD Object
   ADoc (vla-get-ActiveDocument AcObj) ;;;ActiveDocument
   ALay (vla-get-ActiveLayout ADoc) ;;;ActiveLayout
   PSize (vlax-get-property ALay 'CanonicalMediaName) ;;;PaperSize
)
(vla-put-ConfigName ALay MyPrinter) ;;;Set MyPrinter
(vlax-put-property ALay 'CanonicalMediaName PSize) ;;;Reset PaperSize
(command "qsave")
(princ)
)
;;;-------------------------------------------------------

 

Dùng tốt, chỉ có chỗ chưa hài lòng lắm là biến MyPrinter phải làm thủ công, đang thử tìm cách lấy tự động nhưng chưa được. Tạm thời chấp nhận như vậy (ssg đang còn rất nhiều việc khác phải làm).

Bạn nào biết cách lấy thông tin này xin chỉ giúp (tên máy in đang "Set As Default" trong Control Panel của System)

Cám ơn.

Chào Bác Ssg

Gửi bác Lisp lấy tên máy in đang "Set As Default" trong Control Panel của System

 

(setq prn "HKEY_CURRENT_USER\\Software\\Microsoft\\Windows NT\\CurrentVersion\\Windows"

prn (vl-registry-read prn "Device")

prn (substr prn 1 (vl-string-search "," prn)))

 

đã kiểm tra trên Win XP & CAD2010

 

Từ Lisp trên chúng ta có thể mở rộng cho tất cả các thông số khác đuợc ghi trong REGISTRY, nếu biết đuờng dẫn trong registry của thông số đó.

Chúc bác sức khỏe.


<<

Filename: 80329_rp.lsp
Tác giả: hatieu
Bài viết gốc: 40721
Tên lệnh: ga
Nhờ các bác lisp tính diện tích, chu vi, khối lượng của một tiết diện

Đây là cái bạn cần:

;;--- GA.lsp   -   GetArea
;;;
;;;
;;;--- Select a spot on the interior of an enclosed area and this program
;;;	will write the Plot Number, Area, and...
>>
Đây là cái bạn cần:

;;--- GA.lsp   -   GetArea
;;;
;;;
;;;--- Select a spot on the interior of an enclosed area and this program
;;;	will write the Plot Number, Area, and Perimeter on that spot.
;;;
;;;
;;;--- This program uses the -bhatch command to create a hatch over the area.
;;;	It then gets a list of all of the control points for the hatch and
;;;	creates a polyline boundary (using the ENTMAKE) function.  The area
;;;	command is used on the polyline to find the area and perimeter.
;;;	No islands are taken into consideration.
;;;
;;;
;;;--- Created on 8/6/04
;;;	Copyright 2004 by JefferyPSanders.com
;;;	All rights reserved.
;;;
;;;
;;;--- Program is issued as is without gauranties of the accuracy nor of
;;;	damages resulting from use of the program.
;;;
;;;
;;;--- Tested with AutoCAD Release 14 and 2004
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;																		;;;
;;;	 888	   888		  888		   8888888	  8888   888	;;;
;;;	 8888	 8888		 88888			888		88888  888	;;;
;;;	 88888   88888		888 888		   888		888888 888	;;;
;;;	 888888 888888	   888   888		  888		888 888888	;;;
;;;	 888 88888 888	  88888888888		 888		888  88888	;;;
;;;	 888  888  888	 888	   888	  8888888	  888   8888	;;;
;;;																		;;;
;;;																		;;;
;;;				888			888888888		888888888			;;;
;;;			   88888		   888   888		888   888			;;;
;;;			  888 888		  888   888		888   888			;;;
;;;			 888   888		 888888888		888888888			;;;
;;;			88888888888		888			  888					 ;;;
;;;		   888	   888	   888			  888					 ;;;
;;;																		;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun C:GA()

;;;--- Turn the command echo off
 (setvar "cmdecho" 0)

;;;--- Inform the user of the plot number
 (princ "\n Starting Number is ")(princ (getvar "useri1"))
 (princ ".   To change this, reset the system variable USERI1")

;;;--- Get the interior selection point
 (setq pt(getpoint "\n Select Interior of Area : "))

;;;--- Create a hatch pattern in the area
 (command "-bhatch" "Advanced" "Island" "No" "Nearest" "" pt "")

;;;--- If the hatch pattern was created...
 (if(setq en(entlast))
(progn

;;;--- Get the dxf group codes from the hatch entity
  (setq enlist(entget en))

;;;--- Build a list to eventually make a polyline entity
  (setq plist(list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline")))

;;;--- Set up an empty list, a flag, and a counter
  (setq newList(list) flag 0 cntr 0)

;;;--- Cycle through every item in the hatch's dxf group codes
  (while(< cntr (length enlist))

  ;;;--- Get the first item
	(setq a(nth cntr enlist))

  ;;;--- If it is the first group code 10, increment the flag and proceed
	(if (= (car a) 10)(setq flag(+ flag 1)))

  ;;;--- Skip the first group code 10 in the entity list
	(if (> flag 1)

	;;;--- If the dxf group code number is 10, then...
	  (if(= (car a) 10)
		(progn

		;;;--- Start a temporary list holding the dxf group codes for a VERTEX entity
		;;;	Add codes 0 and 10
		  (setq tmp(list (cons 0 "VERTEX") a))

		;;;--- In case there are bulges, look for codes 42 and 50 while the next code isn't
		;;;	a group code 10 and there are more items in the dxf group codes to look for.
		  (while(and (< cntr (length enlist))(/= (car (nth (+ cntr 1) enlist)) 10))

		  ;;;--- Increment the counter to get to the 42 and 50 codes
			(setq cntr(+ cntr 1))

		  ;;;--- Get the next code 
			(setq b(nth cntr enlist))

		  ;;;--- If it is a 42 or 50 code...
			(if(or (= (car b) 42)(= (car b) 50))

			;;;--- Add it to the temporary list
			  (setq tmp(append tmp (list b)))

			)
		  )

		;;;--- Add the temporary list to the new list
		  (setq newList(append newList (list tmp)))
		)
	  )
	)

  ;;;--- Increment the counter to get the next group 10 code
	(setq cntr(+ cntr 1))
  )

;;;--- In order to close the polyline, we will need to save the start point
;;;	and use it later as the end point of the polyline
  (setq lastPt(car newList))

;;;--- Strip off the last point, which is the point selected during the hatch command
  (setq newList(reverse(cdr(reverse newList))))

;;;--- Delete the hatch pattern
  (entdel en)

;;;--- Start creating the polyline entity
  (entmake 
	(list 
	  (cons 0 "POLYLINE") ; Object type
	  (cons 66 1)		 ; Vertices follow
	)
  )

;;;--- Add each vertex to the polyline entity...
  (foreach a newList
	(entmake a )
  )

;;;--- Close the polyline by adding the first point
  (entmake lastPt)

;;;--- Finally add the SEQEND to create the polyline
  (entmake (list (cons 0 "SEQEND")))	

;;;--- Get the entity name of the polyline just created
  (setq en(entlast))

;;;--- Use the area command on the polyline
  (command "area" "Object" en)

;;;--- Get the Area of the Polyline
  (setq myArea(getvar "area"))	
;;;--- NOTE: Here would be a good place to do any manipulation of the area.
;;;	Such as converting it to square feet or acres.
;;;--- Get the perimeter of the polyline
  (setq myPerim (getvar "perimeter"))

;;;--- Get the weight of the polyline
  (setq myWeigh (/ (* myArea 2.7) 1000))

;;;--- NOTE: Here would be a good place to do any manipulation of the perimeter.
;;;		  Such as converting to feet or meters.


;;;--- Get the plot number to use from the USERI1 system variable.
  (setq myNum(getvar "useri1"))

;;;--- Don't start with zero, which is Autocad's default
  (if(= myNum 0)(setq myNum 1))

;;;--- Increment the counter before saving for next time
  (setvar "useri1" (+ myNum 1))

;;;--- Convert the number to a string
  (setq myNum(itoa myNum))

;;;--- Grab the current textsize
  (setq tht(getvar "textsize"))

;;;--- Get the current text style
  (setq csty(getvar "textstyle"))

;;;--- See if the text style has a preset height
  (if(= 0 (cdr(assoc 40(tblsearch "style" csty))))
	(progn

	;;;--- Insert the text with a height parameter
	  (command "text" "Justify" "Center" Pt tht 0 myNum)
	  (command "text" "Justify" "Center" (polar Pt (* pi 1.5) (* tht 1.5)) tht 0 (strcat "AREA=" (rtos myArea 2 2) "(m2)"))
	  (command "text" "Justify" "Center" (polar Pt (* pi 1.5) (* 2.0(* tht 1.5))) tht 0 (strcat "PERIMETER=" (rtos myPerim 2 2) "(m)"))
  (command "text" "Justify" "Center" (polar Pt (* pi 1.5) (* 3.0(* tht 1.5))) tht 0 (strcat "WIEGHT=" (rtos myWeigh 2 3) "(kg/m)"))
	)
	(progn

	;;;--- Else, Insert the text without a height parameter
	  (command "text" "Justify" "Center" Pt 0 myNum)
	  (command "text" "Justify" "Center" (polar Pt (* pi 1.5) (* tht 1.5)) 0 (strcat "AREA=" (rtos myArea 2 2) "(m2)"))
	  (command "text" "Justify" "Center" (polar Pt (* pi 1.5) (* 2.0(* tht 1.5))) 0 (strcat "PERIMETER=" (rtos myPerim 2 2) "(m)"))
  (command "text" "Justify" "Center" (polar Pt (* pi 1.5) (* 3.0(* tht 1.5))) tht 0 (strcat "WIEGHT=" (rtos myWeigh 2 3) "(kg/m)"))

	)
  )

;;;--- Delete the polyline entity
  (entdel en)
)
(alert "Hatch pattern could not be created.  Make sure the area is enclosed.")
 )

;;;--- Turn the command echo back on
 (setvar "cmdecho" 1)

;;;--- Suppress the last echo for a clean exit
 (princ)
)

 

Cảm ơn anh, nhưng cái của anh bị lỗi phần tính weight kết quả toàn bằng 0, mà có lúc làm tiết diện của em bị biến dạng

Đây là tiết diện của em anh thử xem. Anh xem lại và sửa lỗi hộ em nha.

Tiet dien


<<

Filename: 40721_ga.lsp
Tác giả: traigtmientay
Bài viết gốc: 214713
Tên lệnh: gd
Lisp Cắt Chân Dim (E đã Seach Nhưng Không Tìm được Lisp Như Ý)

bacs

Lisp cũ :

(defun C:GD (/ dim_ch ll_ d13_ d14_ d4_ d2_ point_cat old_osm  d10_n cat_h ang_h
        		ang_n dis_1 ang_g ang_d...
>>

bacs

Lisp cũ :

(defun C:GD (/ dim_ch ll_ d13_ d14_ d4_ d2_ point_cat old_osm  d10_n cat_h ang_h
        		ang_n dis_1 ang_g ang_d dim_l dim_new dis_h old_ang)
(setq old_err *error* *error* ctd_err)
(setvar "Cmdecho" 0)
(setq old_osm(getvar "Osmode") old_ang(getvar "Angdir"))
(setvar "Angdir" 0); (setvar "Osmode" 0)
(prompt "\nChon Dim <Aligned-Liner-Hor-Ver> dinh giong hang.")
(if(and(setq dim_ch(ssget '((0 . "DIMENSION"))))
  	(setq point_cat(getpoint "\nDiem moc giong hang <New>: ")) )
  (progn
(setq ll_ 0 tol_(sslength dim_ch) total 0.0)
(while (< ll_ tol_)
(setq d2_(ssname dim_ch ll_) d3_(entget d2_) d4_(cdr(assoc 1 d3_)) )
   	(prompt "\nDiem giong moi")
(if(and d3_ d4_)
(setq d13_(cdr(assoc 13 d3_))
        		d10_(cdr(assoc 10 d3_))
     	d14_(cdr(assoc 14 d3_))
        		ang_n(angle d10_ d13_)
        		dis_1(distance d10_ d13_)
        		ang_g(angle d10_ d14_)
        		ang_d(- ang_g (dtr 90)) ) ;setq
)
   	(if (and d3_ point_cat)
       	(progn
      		(setq dis_h(distance d10_ point_cat)
            		ang_h(angle d10_ point_cat)
            		cat_h(* (sin (- ang_h ang_d)) dis_h)
            		d10_n(polar d10_ ang_g cat_h) )
      		(if (and d10_ d3_ d10_n)
          		(progn
            		(setq d3_(subst (cons '10 d10_n) (cons '10 d10_) d3_) )
            		(entmod d3_)(prompt "..... OK !")
          		) (princ "\n..... Khong thuc hien !")
      		)
       	)
   	)
   	(setq ll_(+ ll_ 1))
);while
  )
)
(setvar "Osmode" old_osm)(setvar "Angdir" old_ang)
(setq *error* old_err)
(princ)
)

bác ketxu có thể sửa lạ hộ e cái lisp này dc ko với bản vẽ này thì lip này dim bi nhay ko nhu ý muốnhttp://www.cadviet.com/upfiles/3/113313_km231_1.dwg


<<

Filename: 214713_gd.lsp
Tác giả: qh2qa06
Bài viết gốc: 314542
Tên lệnh: tbcc
Lisp tính giá trị trung bình của các Text !!!!

 

- bạn cứ test thử nhiều trường hợp có lỗi pm nhoc hen ^^

;; free lisp from cadviet.com
;;; this...
>>

 

- bạn cứ test thử nhiều trường hợp có lỗi pm nhoc hen ^^

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/13750-lisp-tinh-gia-tri-trung-binh-cua-cac-text/page-3
(defun mktext (point height string justify style  mau / lst)
(setq lst (list '(0 . "TEXT")
                              (cons 10 point)
							  (cons 40 height)
							  (cons 7 style)
							  (cons 1 string)
							  (cons 62 mau)
			)
			justify (strcase justify))
		(cond   ((= justify "L") (setq Lst (append Lst (list (cons 72 0) (cons 11 point)))))
		        ((= justify "C") (setq Lst (append Lst (list (cons 72 1) (cons 11 point)))))
				((= justify "R") (setq Lst (append Lst (list (cons 72 2) (cons 11 point)))))
				((= justify "M") (setq Lst (append Lst (list (cons 72 4) (cons 11 point)))))
				)
	(entmakex Lst)
  )	;end mktext
;;;;
(prompt "Lenh tinh trung binh cong cac so: TBCC")
(defun C:tbcc(/ c tong mstbc num ss pt ctext kq old sty)
(setq old (getvar "osmode"))
(setq sty (getvar "textstyle"))
(setq c -1 tong 0 mstbc 0)
(if (setq ss (ssget '((0 . "TEXT"))))
 (progn
    (while (setq ename (ssname ss (setq c (1+ c))))
      (if (setq num (distof (cdr (assoc 1 (entget ename)))))
	      
          (setq tong (+ tong num) mstbc (1+ mstbc))
      );if
	  (if ename
	  (progn
	  (setq ctext (cdr (assoc 40 (entget ename))))
	  ;(setq glayer (cdr (assoc 8 (entget ename))))
	  ;(setq gstyle (cdr (assoc 7 (entget ename))))
	  )
	  )
	  
    );while
	
	
	(if (null (zerop mstbc))
	(progn
	(setq kq (/ tong mstbc))
	(setvar "osmode" 0)
	(setq pt (getpoint "\nchon diem dat ket qua:"))
    (mktext pt ctext (rtos kq 2 3) "L" sty 1)
     );progn
    );if	 
	
  );progn
  (alert "\nChua co doi tuong dc chon hoac ban chi chon toan text chu ^^")
);if    
(setvar "osmode" old)
(princ)
)

Cảm ơn bạn! Mình kiểm tra sơ bộ thấy kết quả tốt rồi.


<<

Filename: 314542_tbcc.lsp
Tác giả: ssg
Bài viết gốc: 49149
Tên lệnh: get-example put-example
Kết hợp Excel-AutoLisp-AutoCAD
Các đoạn code này PP thấy trong trang http://web2.airmail.net/terrycad , ngoài ra còn có nhiều CODE khác nữa. Hope this...
>>
Các đoạn code này PP thấy trong trang http://web2.airmail.net/terrycad , ngoài ra còn có nhiều CODE khác nữa. Hope this help.

;-------------------------------------------------------------------------------
; Program Name: GetExcel.lsp 
; Created By:   Terry Miller (Email: terrycadd@yahoo.com)
;               (URL: http://web2.airmail.net/terrycad)
; Date Created: 9-20-03
; Function:     Several functions to get and put values into Excel cells.
;-------------------------------------------------------------------------------
; Revision History
; Rev  By     Date    Description
;-------------------------------------------------------------------------------
; 1    TM   9-20-03   Initial version
; 2    TM   8-20-07   Rewrote GetExcel.lsp and added several new sub-functions
;                     including ColumnRow, Alpha2Number and Number2Alpha written
;                     by Gilles Chanteau from Marseille, France.
; 3    TM   12-1-07   Added several sub-functions written by Gilles Chanteau
;                     including Cell-p, Row+n, and Column+n. Also added his
;                     revision of the PutCell function.
; 4    GC   9-20-08   Revised the GetExcel argument MaxRange$ to accept a nil
;                     and get the current region from cell A1.
;-------------------------------------------------------------------------------
; Overview of Main functions
;-------------------------------------------------------------------------------
; GetExcel - Stores the values from an Excel spreadsheet into *ExcelData@ list
;   Syntax:  (GetExcel ExcelFile$ SheetName$ MaxRange$)
;   Example: (GetExcel "C:\\Folder\\Filename.xls" "Sheet1" "L30")
; GetCell - Returns the cell value from the *ExcelData@ list
;   Syntax:  (GetCell Cell$)
;   Example: (GetCell "H15")
; Function example of usage:
; (defun c:Get-Example ()
;   (GetExcel "C:\\Folder\\Filename.xls" "Sheet1" "L30");<-- Edit Filename.xls
;   (GetCell "H21");Or you can just use the global *ExcelData@ list
; );defun
;-------------------------------------------------------------------------------
; OpenExcel - Opens an Excel spreadsheet
;   Syntax:  (OpenExcel ExcelFile$ SheetName$ Visible)
;   Example: (OpenExcel "C:\\Folder\\Filename.xls" "Sheet1" nil)
; PutCell - Put values into Excel cells
;   Syntax:  (PutCell StartCell$ Data$) or (PutCell StartCell$ DataList@)
;   Example: (PutCell "A1" (list "GP093" 58.5 17 "Base" "3'-6 1/4\""))
; CloseExcel - Closes Excel session
;   Syntax:  (CloseExcel ExcelFile$)
;   Example: (CloseExcel "C:\\Folder\\Filename.xls")
; Function example of usage:
; (defun c:Put-Example ()
;   (OpenExcel "C:\\Folder\\Filename.xls" "Sheet1" nil);<-- Edit Filename.xls
;   (PutCell "A1" (list "GP093" 58.5 17 "Base" "3'-6 1/4\""));Repeat as required
;   (CloseExcel "C:\\Folder\\Filename.xls");<-- Edit Filename.xls
;   (princ)
; );defun
;-------------------------------------------------------------------------------
; Note: Review the conditions of each argument in the function headings
;-------------------------------------------------------------------------------
; GetExcel - Stores the values from an Excel spreadsheet into *ExcelData@ list
; Arguments: 3
;   ExcelFile$ = Path and filename
;   SheetName$ = Sheet name or nil for not specified
;   MaxRange$ = Maximum cell ID range to include or nil to get the current region from cell A1
; Syntax examples:
; (GetExcel "C:\\Temp\\Temp.xls" "Sheet1" "E19") = Open C:\Temp\Temp.xls on Sheet1 and read up to cell E19
; (GetExcel "C:\\Temp\\Temp.xls" nil "XYZ123") = Open C:\Temp\Temp.xls on current sheet and read up to cell XYZ123
;-------------------------------------------------------------------------------
(defun GetExcel (ExcelFile$ SheetName$ MaxRange$ / Column# ColumnRow@ Data@ ExcelRange^
 ExcelValue ExcelValue ExcelVariant^ MaxColumn# MaxRow# Range$ Row# Worksheet)
 (if (= (type ExcelFile$) 'STR)
   (if (not (findfile ExcelFile$))
     (progn
       (alert (strcat "Excel file " ExcelFile$ " not found."))
       (exit)
     );progn
   );if
   (progn
     (alert "Excel file not specified.")
     (exit)
   );progn
 );if
 (gc)
 (if (setq *ExcelApp% (vlax-get-object "Excel.Application"))
   (progn
     (alert "Close all Excel spreadsheets to continue!")
     (vlax-release-object *ExcelApp%)(gc)
   );progn
 );if
 (setq ExcelFile$ (findfile ExcelFile$))
 (setq *ExcelApp% (vlax-get-or-create-object "Excel.Application"))
 (vlax-invoke-method (vlax-get-property *ExcelApp% 'WorkBooks) 'Open ExcelFile$)
 (if SheetName$
   (vlax-for Worksheet (vlax-get-property *ExcelApp% "Sheets")
     (if (= (vlax-get-property Worksheet "Name") SheetName$)
       (vlax-invoke-method Worksheet "Activate")
     );if
   );vlax-for
 );if
 (if MaxRange$
   (progn
     (setq ColumnRow@ (ColumnRow MaxRange$))
     (setq MaxColumn# (nth 0 ColumnRow@))
     (setq MaxRow# (nth 1 ColumnRow@))
   );progn
   (progn
     (setq CurRegion (vlax-get-property (vlax-get-property
       (vlax-get-property *ExcelApp% "ActiveSheet") "Range" "A1") "CurrentRegion")
     );setq
     (setq MaxRow# (vlax-get-property (vlax-get-property CurRegion "Rows") "Count"))
     (setq MaxColumn# (vlax-get-property (vlax-get-property CurRegion "Columns") "Count"))
   );progn
 );if
 (setq *ExcelData@ nil)
 (setq Row# 1)
 (repeat MaxRow#
   (setq Data@ nil)
   (setq Column# 1)
   (repeat MaxColumn#
     (setq Range$ (strcat (Number2Alpha Column#)(itoa Row#)))
     (setq ExcelRange^ (vlax-get-property *ExcelApp% "Range" Range$))
     (setq ExcelVariant^ (vlax-get-property ExcelRange^ 'Value))
     (setq ExcelValue (vlax-variant-value ExcelVariant^))
     (setq ExcelValue
       (cond
         ((= (type ExcelValue) 'INT) (itoa ExcelValue))
         ((= (type ExcelValue) 'REAL) (rtosr ExcelValue))
         ((= (type ExcelValue) 'STR) (vl-string-trim " " ExcelValue))
         ((/= (type ExcelValue) 'STR) "")
       );cond
     );setq
     (setq Data@ (append Data@ (list ExcelValue)))
     (setq Column# (1+ Column#))
   );repeat
   (setq *ExcelData@ (append *ExcelData@ (list Data@)))
   (setq Row# (1+ Row#))
 );repeat
 (vlax-invoke-method (vlax-get-property *ExcelApp% "ActiveWorkbook") 'Close :vlax-False)
 (vlax-invoke-method *ExcelApp% 'Quit)
 (vlax-release-object *ExcelApp%)(gc)
 (setq *ExcelApp% nil)
 *ExcelData@
);defun GetExcel
;-------------------------------------------------------------------------------
; GetCell - Returns the cell value from the *ExcelData@ list
; Arguments: 1
;   Cell$ = Cell ID
; Syntax example: (GetCell "E19") = value of cell E19
;-------------------------------------------------------------------------------
(defun GetCell (Cell$ / Column# ColumnRow@ Return Row#)
 (setq ColumnRow@ (ColumnRow Cell$))
 (setq Column# (1- (nth 0 ColumnRow@)))
 (setq Row# (1- (nth 1 ColumnRow@)))
 (setq Return "")
 (if *ExcelData@
   (if (and (>= (length *ExcelData@) Row#)(>= (length (nth 0 *ExcelData@)) Column#))
     (setq Return (nth Column# (nth Row# *ExcelData@)))
   );if
 );if
 Return
);defun GetCell
;-------------------------------------------------------------------------------
; OpenExcel - Opens an Excel spreadsheet
; Arguments: 3
;   ExcelFile$ = Excel filename or nil for new spreadsheet
;   SheetName$ = Sheet name or nil for not specified
;   Visible = t for visible or nil for hidden
; Syntax examples:
; (OpenExcel "C:\\Temp\\Temp.xls" "Sheet2" t) = Opens C:\Temp\Temp.xls on Sheet2 as visible session
; (OpenExcel "C:\\Temp\\Temp.xls" nil nil) = Opens C:\Temp\Temp.xls on current sheet as hidden session
; (OpenExcel nil "Parts List" nil) =  Opens a new spreadsheet and creates a Part List sheet as hidden session
;-------------------------------------------------------------------------------
(defun OpenExcel (ExcelFile$ SheetName$ Visible / Sheet$ Sheets@ Worksheet)
 (if (= (type ExcelFile$) 'STR)
   (if (findfile ExcelFile$)
     (setq *ExcelFile$ ExcelFile$)
     (progn
       (alert (strcat "Excel file " ExcelFile$ " not found."))
       (exit)
     );progn
   );if
   (setq *ExcelFile$ "")
 );if
 (gc)
 (if (setq *ExcelApp% (vlax-get-object "Excel.Application"))
   (progn
     (alert "Close all Excel spreadsheets to continue!")
     (vlax-release-object *ExcelApp%)(gc)
   );progn
 );if
 (setq *ExcelApp% (vlax-get-or-create-object "Excel.Application"))
 (if ExcelFile$
   (if (findfile ExcelFile$)
     (vlax-invoke-method (vlax-get-property *ExcelApp% 'WorkBooks) 'Open ExcelFile$)
     (vlax-invoke-method (vlax-get-property *ExcelApp% 'WorkBooks) 'Add)
   );if
   (vlax-invoke-method (vlax-get-property *ExcelApp% 'WorkBooks) 'Add)
 );if
 (if Visible
   (vla-put-visible *ExcelApp% :vlax-true)
 );if
 (if (= (type SheetName$) 'STR)
   (progn
     (vlax-for Sheet$ (vlax-get-property *ExcelApp% "Sheets")
       (setq Sheets@ (append Sheets@ (list (vlax-get-property Sheet$ "Name"))))
     );vlax-for
     (if (member SheetName$ Sheets@)
       (vlax-for Worksheet (vlax-get-property *ExcelApp% "Sheets")
         (if (= (vlax-get-property Worksheet "Name") SheetName$)
           (vlax-invoke-method Worksheet "Activate")
         );if
       );vlax-for
       (vlax-put-property (vlax-invoke-method (vlax-get-property *ExcelApp% "Sheets") "Add") "Name" SheetName$)
     );if
   );progn
 );if
 (princ)
);defun OpenExcel
;-------------------------------------------------------------------------------
; PutCell - Put values into Excel cells
; Arguments: 2
;   StartCell$ = Starting Cell ID
;   Data@ = Value or list of values
; Syntax examples:
; (PutCell "A1" "PART NUMBER") = Puts PART NUMBER in cell A1
; (PutCell "B3" '("Dim" 7.5 "9.75")) = Starting with cell B3 put Dim, 7.5, and 9.75 across
;-------------------------------------------------------------------------------
(defun PutCell (StartCell$ Data@ / Cell$ Column# ExcelRange Row#)
 (if (= (type Data@) 'STR)
   (setq Data@ (list Data@))
 )
 (setq ExcelRange (vlax-get-property *ExcelApp% "Cells"))
 (if (Cell-p StartCell$)
   (setq Column# (car (ColumnRow StartCell$))
         Row# (cadr (ColumnRow StartCell$))
   );setq
   (if (vl-catch-all-error-p
         (setq Cell$ (vl-catch-all-apply 'vlax-get-property
           (list (vlax-get-property *ExcelApp% "ActiveSheet") "Range" StartCell$))
         );setq
       );vl-catch-all-error-p
       (alert (strcat "The cell ID \"" StartCell$ "\" is invalid."))
       (setq Column# (vlax-get-property Cell$ "Column")
             Row# (vlax-get-property Cell$ "Row")
       );setq
   );if
 );if
 (if (and Column# Row#)
   (foreach Item Data@
     (vlax-put-property ExcelRange "Item" Row# Column# (vl-princ-to-string Item))
     (setq Column# (1+ Column#))
   );foreach
 );if
 (princ)
);defun PutCell
;-------------------------------------------------------------------------------
; CloseExcel - Closes Excel spreadsheet
; Arguments: 1
;   ExcelFile$ = Excel saveas filename or nil to close without saving
; Syntax examples:
; (CloseExcel "C:\\Temp\\Temp.xls") = Saveas C:\Temp\Temp.xls and close
; (CloseExcel nil) = Close without saving
;-------------------------------------------------------------------------------
(defun CloseExcel (ExcelFile$ / Saveas)
 (if ExcelFile$
   (if (= (strcase ExcelFile$) (strcase *ExcelFile$))
     (if (findfile ExcelFile$)
       (vlax-invoke-method (vlax-get-property *ExcelApp% "ActiveWorkbook") "Save")
       (setq Saveas t)
     );if
     (if (findfile ExcelFile$)
       (progn
         (vl-file-delete (findfile ExcelFile$))
         (setq Saveas t)
       );progn
       (setq Saveas t)
     );if
   );if
 );if
 (if Saveas
   (vlax-invoke-method (vlax-get-property *ExcelApp% "ActiveWorkbook")
     "SaveAs" ExcelFile$ -4143 "" "" :vlax-false :vlax-false nil
   );vlax-invoke-method
 );if
 (vlax-invoke-method (vlax-get-property *ExcelApp% "ActiveWorkbook") 'Close :vlax-False)
 (vlax-invoke-method *ExcelApp% 'Quit)
 (vlax-release-object *ExcelApp%)(gc)
 (setq *ExcelApp% nil *ExcelFile$ nil)
 (princ)
);defun CloseExcel
;-------------------------------------------------------------------------------
; ColumnRow - Returns a list of the Column and Row number
; Function By: Gilles Chanteau from Marseille, France
; Arguments: 1
;   Cell$ = Cell ID
; Syntax example: (ColumnRow "ABC987") = '(731 987)
;-------------------------------------------------------------------------------
(defun ColumnRow (Cell$ / Column$ Char$ Row#)
 (setq Column$ "")
 (while (< 64 (ascii (setq Char$ (strcase (substr Cell$ 1 1)))) 91)
   (setq Column$ (strcat Column$ Char$)
         Cell$ (substr Cell$ 2)
   );setq
 );while
 (if (and (/= Column$ "") (numberp (setq Row# (read Cell$))))
   (list (Alpha2Number Column$) Row#)
   '(1 1);default to "A1" if there's a problem
 );if
);defun ColumnRow
;-------------------------------------------------------------------------------
; Alpha2Number - Converts Alpha string into Number
; Function By: Gilles Chanteau from Marseille, France
; Arguments: 1
;   Str$ = String to convert
; Syntax example: (Alpha2Number "ABC") = 731
;-------------------------------------------------------------------------------
(defun Alpha2Number (Str$ / Num#)
 (if (= 0 (setq Num# (strlen Str$)))
   0
   (+ (* (- (ascii (strcase (substr Str$ 1 1))) 64) (expt 26 (1- Num#)))
      (Alpha2Number (substr Str$ 2))
   );+
 );if
);defun Alpha2Number
;-------------------------------------------------------------------------------
; Number2Alpha - Converts Number into Alpha string
; Function By: Gilles Chanteau from Marseille, France
; Arguments: 1
;   Num# = Number to convert
; Syntax example: (Number2Alpha 731) = "ABC"
;-------------------------------------------------------------------------------
(defun Number2Alpha (Num# / Val#)
 (if (< Num# 27)
   (chr (+ 64 Num#))
   (if (= 0 (setq Val# (rem Num# 26)))
     (strcat (Number2Alpha (1- (/ Num# 26))) "Z")
     (strcat (Number2Alpha (/ Num# 26)) (chr (+ 64 Val#)))
   );if
 );if
);defun Number2Alpha
;-------------------------------------------------------------------------------
; Cell-p - Evaluates if the argument Cell$ is a valid cell ID
; Function By: Gilles Chanteau from Marseille, France
; Arguments: 1
;   Cell$ = String of the cell ID to evaluate
; Syntax examples: (Cell-p "B12") = t, (Cell-p "BT") = nil
;-------------------------------------------------------------------------------
(defun Cell-p (Cell$)
 (and (= (type Cell$) 'STR)
   (or (= (strcase Cell$) "A1")
     (not (equal (ColumnRow Cell$) '(1 1)))
   );or
 );and
);defun Cell-p
;-------------------------------------------------------------------------------
; Row+n - Returns the cell ID located a number of rows from cell
; Function By: Gilles Chanteau from Marseille, France
; Arguments: 2
;   Cell$ = Starting cell ID
;   Num# = Number of rows from cell
; Syntax examples: (Row+n "B12" 3) = "B15", (Row+n "B12" -3) = "B9"
;-------------------------------------------------------------------------------
(defun Row+n (Cell$ Num#)
 (setq Cell$ (ColumnRow Cell$))
 (strcat (Number2Alpha (car Cell$)) (itoa (max 1 (+ (cadr Cell$) Num#))))
);defun Row+n
;-------------------------------------------------------------------------------
; Column+n - Returns the cell ID located a number of columns from cell
; Function By: Gilles Chanteau from Marseille, France
; Arguments: 2
;   Cell$ = Starting cell ID
;   Num# = Number of columns from cell
; Syntax examples: (Column+n "B12" 3) = "E12", (Column+n "B12" -1) = "A12"
;-------------------------------------------------------------------------------
(defun Column+n (Cell$ Num#)
 (setq Cell$ (ColumnRow Cell$))
 (strcat (Number2Alpha (max 1 (+ (car Cell$) Num#))) (itoa (cadr Cell$)))
);defun Column+n
;-------------------------------------------------------------------------------
; rtosr - Used to change a real number into a short real number string
; stripping off all trailing 0's.
; Arguments: 1
;   RealNum~ = Real number to convert to a short string real number
; Returns: ShortReal$ the short string real number value of the real number.
;-------------------------------------------------------------------------------
(defun rtosr (RealNum~ / DimZin# ShortReal$)
 (setq DimZin# (getvar "DIMZIN"))
 (setvar "DIMZIN" 8)
 (setq ShortReal$ (rtos RealNum~ 2 8))
 (setvar "DIMZIN" DimZin#)
 ShortReal$
);defun rtosr
;-------------------------------------------------------------------------------
(princ);End of GetExcel.lsp

Giống như cái mà bạn tuananh đã nêu. Trong code người ta hướng dẫn rất kỹ, bạn cứ đọc sẽ hiểu cách dùng. Để hiểu tất cả các dòng code trong đó, cần phải có kiến thức tương đối sâu và rộng về lisp. Ở góc độ ứng dụng, không nhất thiết phải hiểu hết, bạn chỉ cần biết cách dùng (cung cấp đủ và đúng các arguments theo yêu cầu) là có thể phát huy hiệu quả.

Bạn có thể tham khảo thêm về quan điểm đó ở topic này:

http://www.cadviet.com/forum/index.php?sho...t=0&start=0


<<

Filename: 49149_get-example_put-example.lsp
Tác giả: kiwi
Bài viết gốc: 50399
Tên lệnh: xy
Lấy toạ độ X,Y cùng lúc
Bạn dùng lisp này. Lệnh XY:

 

(defun C:XY( / p1 p2)
(setq
    p1 (getpoint "\nFirst point:")
    p2 (getpoint p1 "\nNext point:")
)
(command "qleader" p1 p2 "" "" (strcat (rtos...
>>
Bạn dùng lisp này. Lệnh XY:

 

(defun C:XY( / p1 p2)
(setq
    p1 (getpoint "\nFirst point:")
    p2 (getpoint p1 "\nNext point:")
)
(command "qleader" p1 p2 "" "" (strcat (rtos (car p1)) "\\P" (rtos (cadr p1))) "")
(princ)
)

bác ơi sao số không nằm trên mũi tên hả bác, và cái này không chỉnh sửa trong Dimention được .


<<

Filename: 50399_xy.lsp
Tác giả: thanhduan2407
Bài viết gốc: 123282
Tên lệnh: trai giua phai
Căn lề text + Mtext, Căn lề đối tượng
Trước giờ, e vẫn dùng lisp ft của bác Đường Thái để căn lề cho text, cảm thấy rất ưng ý rồi, cứ ngỡ rằng như thế là đủ...Vừa rồi lớ ngớ mò vào trang Nhật...
>>
Trước giờ, e vẫn dùng lisp ft của bác Đường Thái để căn lề cho text, cảm thấy rất ưng ý rồi, cứ ngỡ rằng như thế là đủ...Vừa rồi lớ ngớ mò vào trang Nhật Bổn, mót được cái này,e liền làm thử bài đánh giá, thấy tốc độ khá tốt, các bác thử chém gió xem sao, và vì code dài nên e cũng chẳng hiểu tại sao ^^

 

Mạn phép bác Thái,E xin post lại lisp ft của bác, thêm dòng check time :

 

(defun c:ft()
(setq txt (ssget '((0 . "*TEXT"))))
(setq mau (entget (car (entsel "\nChon text chuan"))))
(command "undo" "begin")
(setq oldos (getvar "osmode"))
(setq olcol (getvar "CEColor"))
(setq ollay (getvar "Clayer"))
(setq olstyle (getvar "textstyle"))
(setq TB  (textbox mau) LC  (car TB) RC (cadr TB) di (distance LC RC) i 0)
(setq h (cdr(assoc 40 mau)))
(setq x1 (cdr(assoc 10 mau)))
(setq x2 (list (+ (car x1) (* di 0.5) (* -0.03 h)) (cadr x1)))
(setq x3 (list (+ (car x1) di (* -0.06 h)) (cadr x1)))
(setq canle (cond (canle) ("Left")))
(initget "Left Center Right Fit")
(setq canle (cond ((getkword (strcat "\Vi tri can le <" canle ">"))) (canle)))
(setq oldang (getvar "Angbase"))
(command "angbase" 0 "ucs" "w")

(setq time (getvar "MILLISECS"))

(repeat (sslength txt)
(setq txt_ent (entget (ssname txt i)))
(setq txt_val (cdr(assoc 1 txt_ent)))
(setq txt_st (cdr(assoc 7 txt_ent)))
(setq txt_lay (cdr(assoc 8 txt_ent)))
(setq txt_h (cdr(assoc 40 txt_ent)))
(setq txt_fctr (cdr(assoc 41 txt_ent)))
(setq txt_clr (cdr(assoc 62 txt_ent)))
(setq y1 (cdr(assoc 10 txt_ent)))
(if (cdr(assoc 43 txt_ent)) (setq txt_fctr 1 y1 (list (car y1) (- (cadr y1) txt_h))))
(setq pt1 (list (car x1) (cadr y1)))
(setq pt2 (list (car x2) (cadr y1)))
(setq pt3 (list (car x3) (cadr y1)))
(command "-style" txt_st "" 0 txt_fctr "" "" "" "" "clayer" txt_lay "color" txt_clr "osmode" 0)
(if (eq canle "Left") (command "text" pt1 txt_h 0 txt_val))
(if (eq canle "Center") (command "text" "C" pt2 txt_h 0 txt_val))
(if (eq canle "Right") (command "text" "R" pt3 txt_h 0 txt_val))
(if (eq canle "Fit") (command "text" "F" pt1 pt3 txt_h txt_val))
(setq i (+ i 1))
(command "color" "bylayer")
);repeat
(command "ucs" "p")
(setvar "textstyle" olstyle)
(setvar "angbase" oldang)
(setvar "Clayer" ollay)
(setvar "CECOLOR" olcol)
(setvar "osmode" oldos)
(command "erase" txt "")

(setq time (/ (- (getvar "MILLISECS") time) 1000.0))
(princ (strcat "\nThoi gian thuc hien (giay) :" (rtos time)))

(prompt"\nText da duoc sap xep lai\n")
(command "undo" "end")
);defun

 

Bên dưới là code khác,dài hơn,cũng với chức năng tương tự (và đổi Insert point của text) :


(defun c:trai ( / ObjSet ObjName ObjName0 Data Value72_73_71 Co AssocL
						Data0 Ang1 AngT Ang2 Pt0 Pt0_U Pt0_O i)

(princ "\n Change Insetion point to Left and align to Left")					
(setq Value72_73_71  '(0 0 7))
(setq AssocL '(10 10))
(Procedure)
(princ)
)

(defun c:giua ( / ObjSet ObjName ObjName0 Data Value72_73_71 Co AssocL
						Data0 Ang1 AngT Ang2 Pt0 Pt0_U Pt0_O i)

(princ "\n Change Insetion point to Center and align to Center")							
(setq Value72_73_71 '(1 0 8))
(setq AssocL '(11 10))
(Procedure)
(princ)
)

(defun c:phai ( / ObjSet ObjName ObjName0 Data Value72_73_71 Co AssocL
						Data0 Ang1 AngT Ang2 Pt0 Pt0_U Pt0_O i)
(princ "\n Change Insetion point to Right and align to Right")							

(setq Value72_73_71 '(2 0 9))
(setq AssocL '(11 10))
(Procedure)
(princ)
)

;***************************************************
(defun Procedure ()
(while (= ObjSet nil)
	(setq ObjSet (ssget '((-4 . ""))))
)
(setq ObjName0 (car (entsel "\n")))	
(setq i 0)
(setq time (getvar "MILLISECS"))
(repeat (sslength ObjSet)
	(setq ObjName (ssname ObjSet i))
	(setq Data (entget	ObjName))
	(cond 	((= (cdr(assoc 0 Data)) "TEXT")
				(TextInsP_Text ObjName Value72_73_71)	
				(setq Co (car AssocL))
			)
			(	(= (cdr(assoc 0 Data)) "MTEXT")		
				(TextInsP_MText ObjName Value72_73_71)	
				(setq Co (cadr AssocL))
			)
	)
	(setq i (1+ i))
)


(setq Data0 (entget ObjName0))
(setq Ang1 (angle '(0 0) (getvar "UCSXDIR")))
(cond 	((= (cdr(assoc 0 Data0)) "TEXT")
		(setq AngT (cdr(assoc 50 Data0)))				
		(setq Ang2 (- AngT Ang1))					
		(setq Co (car AssocL))
		)
		((= (cdr(assoc 0 Data0)) "MTEXT")
		(setq Ang2 (cdr(assoc 50 Data0)))			
		(setq AngT (+ Ang1 Ang2))					
		(setq Co (cadr AssocL))
		)
)
(setq Pt0 (cdr (assoc Co Data0)))		
(setq Pt0_U (trans Pt0 0 1))			
(setq Pt0_O (SD1862 Pt0_U Ang2))	

(setq i 0)
(repeat (sslength ObjSet)
	(setq Data (entget (setq ObjName (ssname ObjSet i))))
	(cond 	((= (cdr(assoc 0 Data)) "TEXT")(setq Co (car AssocL)))
			((= (cdr(assoc 0 Data)) "MTEXT")(setq Co (cadr AssocL)))
	)
	(setq Pt1 (cdr (assoc Co Data)))				
	(setq Pt1_U (trans Pt1 0 1))				
	(setq Pt1_O (SD1862 Pt1_U Ang2))		
	(setq Delta_O (- (car Pt0_O) (car Pt1_O)))		
	(setq Delta_U (SD8446 (list Delta_O 0) '(0 0) AngT))	
	(setq Data (subst (cons Co (mapcar '+ Pt1 Delta_U))(assoc Co Data) Data))		
	(entmod Data)
	(setq i (1+ i))
)
(setq time (/ (- (getvar "MILLISECS") time) 1000.0))
(princ (strcat "\nThoi gian thuc hien (giay) :" (rtos time)))	
(princ)
)
(defun TextInsP_Text ( ObjName Value72_73_71 / Data OrgPosition NewPosition Org_11 New_11 )

	(setq Data (entget	ObjName))				
	(setq OrgPosition (cdr (assoc 10 Data)))		
	(setq Org_11 (cdr (assoc 11 Data)))			
	(setq Data (subst (cons 72 (car Value72_73_71)) (assoc 72 Data) Data))
	(setq Data (subst (cons 73 (cadr Value72_73_71)) (assoc 73 Data) Data))
	(entmod Data)
	‚ª–³‚¢j
	(setq NewPosition (cdr (assoc 10 (entget  ObjName))))	
	(setq Delta (mapcar '- OrgPosition NewPosition))				
	(setq New_11 (mapcar '+ Org_11 Delta))		
	(setq Data (entget	ObjName))					
	(setq Data (subst (cons 11 New_11) (assoc 11 Data)	Data))	
	(entmod Data)
)
(defun TextInsP_MText ( ObjName Value72_73_71 / Data X_Old X_New Y_Old Y_New Scale Base0 W_42 Ang_50 Delta )
	(setq Data (entget	ObjName))
	(setq InsP (cdr (assoc 10 Data)))
	(setq W_42	(cdr (assoc 42 (entget ObjName))))
	(setq H_43	 	(cdr (assoc 43 (entget ObjName))))
	(setq Ang (cdr (assoc 50 Data)))		
	(setq AngU (angle '(0 0) (getvar "UCSXDIR")))	
	(setq OldIP (cdr (assoc 71 Data)))			
	(setq NewIP (caddr Value72_73_71))		

	(setq Data (subst (cons 71 NewIP) (assoc 71 Data) Data))
	(entmod Data)


	(setq X_Old (- (+ OldIP 2) (* (fix ( / (+ OldIP 2) 3)) 3)))
	(setq X_New (- (+ NewIP 2) (* (fix ( / (+ NewIP 2) 3)) 3)))


	(setq Y_Old (fix ( / (- OldIP 1) 3)))
	(setq Y_New (fix ( / (- NewIP 1) 3)))

	(setq IncUnit (list (- X_New X_Old)(- Y_Old Y_New )))
	(setq Delta (mapcar '* IncUnit (list (* 0.5 W_42)(* 0.5 H_43))))

	(setq Delta (SD8446 Delta '(0 0) Ang))

·
	(setq Delta (SD1862 Delta (* -1.0 AngU)))

	(setq Data (subst (cons 10 (mapcar '+ InsP Delta))(assoc 10 Data) Data))
	(entmod Data)

)

 

Tiếp theo, thực hiện test so sánh :

Lần 1: với 100 text và sắp xếp bên trái :

 

-> gần như là ngay tức thì

 

Lần 2, e chơi sang làm hẳn 1000 text + Mtext đi .Lần này thì :

 

- > :undecided:

 

Vậy là tương quan,2 lisp chênh nhau về thời gian xử lý khoảng 50 lần.Tất nhiên, ngoài thực tế ít khi ta gặp 1 đoạn văn bản CAD dài như vậy, nhưng nhiều khi, 1 vấn đề đã cũ,mà vẫn có nhiều lựa chọn giải quyết.

 

PS :Còn đoạn code FIT + code sắp xếp Đối tượng cũng khù khoằm như vậy,tí rỗi e post típ ^^

bạn ketxu rất hăng hái trong diễn đàn. Cảm ơn bài viết của bạn. Mình ủng hộ bạn


<<

Filename: 123282_trai_giua_phai.lsp
Tác giả: 18011985
Bài viết gốc: 123353
Tên lệnh: ft
Căn lề text + Mtext, Căn lề đối tượng
Trước giờ, e vẫn dùng lisp ft của bác Đường Thái để căn lề cho text, cảm thấy rất ưng ý rồi, cứ ngỡ rằng như thế là đủ...Vừa rồi lớ ngớ mò vào trang Nhật...
>>
Trước giờ, e vẫn dùng lisp ft của bác Đường Thái để căn lề cho text, cảm thấy rất ưng ý rồi, cứ ngỡ rằng như thế là đủ...Vừa rồi lớ ngớ mò vào trang Nhật Bổn, mót được cái này,e liền làm thử bài đánh giá, thấy tốc độ khá tốt, các bác thử chém gió xem sao, và vì code dài nên e cũng chẳng hiểu tại sao ^^

 

Mạn phép bác Thái,E xin post lại lisp ft của bác, thêm dòng check time :

 

(defun c:ft()
(setq txt (ssget '((0 . "*TEXT"))))
(setq mau (entget (car (entsel "\nChon text chuan"))))
(command "undo" "begin")
(setq oldos (getvar "osmode"))
(setq olcol (getvar "CEColor"))
(setq ollay (getvar "Clayer"))
(setq olstyle (getvar "textstyle"))
(setq TB  (textbox mau) LC  (car TB) RC (cadr TB) di (distance LC RC) i 0)
(setq h (cdr(assoc 40 mau)))
(setq x1 (cdr(assoc 10 mau)))
(setq x2 (list (+ (car x1) (* di 0.5) (* -0.03 h)) (cadr x1)))
(setq x3 (list (+ (car x1) di (* -0.06 h)) (cadr x1)))
(setq canle (cond (canle) ("Left")))
(initget "Left Center Right Fit")
(setq canle (cond ((getkword (strcat "\Vi tri can le <" canle ">"))) (canle)))
(setq oldang (getvar "Angbase"))
(command "angbase" 0 "ucs" "w")

(setq time (getvar "MILLISECS"))

(repeat (sslength txt)
(setq txt_ent (entget (ssname txt i)))
(setq txt_val (cdr(assoc 1 txt_ent)))
(setq txt_st (cdr(assoc 7 txt_ent)))
(setq txt_lay (cdr(assoc 8 txt_ent)))
(setq txt_h (cdr(assoc 40 txt_ent)))
(setq txt_fctr (cdr(assoc 41 txt_ent)))
(setq txt_clr (cdr(assoc 62 txt_ent)))
(setq y1 (cdr(assoc 10 txt_ent)))
(if (cdr(assoc 43 txt_ent)) (setq txt_fctr 1 y1 (list (car y1) (- (cadr y1) txt_h))))
(setq pt1 (list (car x1) (cadr y1)))
(setq pt2 (list (car x2) (cadr y1)))
(setq pt3 (list (car x3) (cadr y1)))
(command "-style" txt_st "" 0 txt_fctr "" "" "" "" "clayer" txt_lay "color" txt_clr "osmode" 0)
(if (eq canle "Left") (command "text" pt1 txt_h 0 txt_val))
(if (eq canle "Center") (command "text" "C" pt2 txt_h 0 txt_val))
(if (eq canle "Right") (command "text" "R" pt3 txt_h 0 txt_val))
(if (eq canle "Fit") (command "text" "F" pt1 pt3 txt_h txt_val))
(setq i (+ i 1))
(command "color" "bylayer")
);repeat
(command "ucs" "p")
(setvar "textstyle" olstyle)
(setvar "angbase" oldang)
(setvar "Clayer" ollay)
(setvar "CECOLOR" olcol)
(setvar "osmode" oldos)
(command "erase" txt "")

(setq time (/ (- (getvar "MILLISECS") time) 1000.0))
(princ (strcat "\nThoi gian thuc hien (giay) :" (rtos time)))

(prompt"\nText da duoc sap xep lai\n")
(command "undo" "end")
);defun

 

Bên dưới là code khác,dài hơn,cũng với chức năng tương tự (và đổi Insert point của text) :


(defun c:trai ( / ObjSet ObjName ObjName0 Data Value72_73_71 Co AssocL
						Data0 Ang1 AngT Ang2 Pt0 Pt0_U Pt0_O i)

(princ "\n Change Insetion point to Left and align to Left")					
(setq Value72_73_71  '(0 0 7))
(setq AssocL '(10 10))
(Procedure)
(princ)
)

(defun c:giua ( / ObjSet ObjName ObjName0 Data Value72_73_71 Co AssocL
						Data0 Ang1 AngT Ang2 Pt0 Pt0_U Pt0_O i)

(princ "\n Change Insetion point to Center and align to Center")							
(setq Value72_73_71 '(1 0 8))
(setq AssocL '(11 10))
(Procedure)
(princ)
)

(defun c:phai ( / ObjSet ObjName ObjName0 Data Value72_73_71 Co AssocL
						Data0 Ang1 AngT Ang2 Pt0 Pt0_U Pt0_O i)
(princ "\n Change Insetion point to Right and align to Right")							

(setq Value72_73_71 '(2 0 9))
(setq AssocL '(11 10))
(Procedure)
(princ)
)

;***************************************************
(defun Procedure ()
(while (= ObjSet nil)
	(setq ObjSet (ssget '((-4 . ""))))
)
(setq ObjName0 (car (entsel "\n")))	
(setq i 0)
(setq time (getvar "MILLISECS"))
(repeat (sslength ObjSet)
	(setq ObjName (ssname ObjSet i))
	(setq Data (entget	ObjName))
	(cond 	((= (cdr(assoc 0 Data)) "TEXT")
				(TextInsP_Text ObjName Value72_73_71)	
				(setq Co (car AssocL))
			)
			(	(= (cdr(assoc 0 Data)) "MTEXT")		
				(TextInsP_MText ObjName Value72_73_71)	
				(setq Co (cadr AssocL))
			)
	)
	(setq i (1+ i))
)


(setq Data0 (entget ObjName0))
(setq Ang1 (angle '(0 0) (getvar "UCSXDIR")))
(cond 	((= (cdr(assoc 0 Data0)) "TEXT")
		(setq AngT (cdr(assoc 50 Data0)))				
		(setq Ang2 (- AngT Ang1))					
		(setq Co (car AssocL))
		)
		((= (cdr(assoc 0 Data0)) "MTEXT")
		(setq Ang2 (cdr(assoc 50 Data0)))			
		(setq AngT (+ Ang1 Ang2))					
		(setq Co (cadr AssocL))
		)
)
(setq Pt0 (cdr (assoc Co Data0)))		
(setq Pt0_U (trans Pt0 0 1))			
(setq Pt0_O (SD1862 Pt0_U Ang2))	

(setq i 0)
(repeat (sslength ObjSet)
	(setq Data (entget (setq ObjName (ssname ObjSet i))))
	(cond 	((= (cdr(assoc 0 Data)) "TEXT")(setq Co (car AssocL)))
			((= (cdr(assoc 0 Data)) "MTEXT")(setq Co (cadr AssocL)))
	)
	(setq Pt1 (cdr (assoc Co Data)))				
	(setq Pt1_U (trans Pt1 0 1))				
	(setq Pt1_O (SD1862 Pt1_U Ang2))		
	(setq Delta_O (- (car Pt0_O) (car Pt1_O)))		
	(setq Delta_U (SD8446 (list Delta_O 0) '(0 0) AngT))	
	(setq Data (subst (cons Co (mapcar '+ Pt1 Delta_U))(assoc Co Data) Data))		
	(entmod Data)
	(setq i (1+ i))
)
(setq time (/ (- (getvar "MILLISECS") time) 1000.0))
(princ (strcat "\nThoi gian thuc hien (giay) :" (rtos time)))	
(princ)
)
(defun TextInsP_Text ( ObjName Value72_73_71 / Data OrgPosition NewPosition Org_11 New_11 )

	(setq Data (entget	ObjName))				
	(setq OrgPosition (cdr (assoc 10 Data)))		
	(setq Org_11 (cdr (assoc 11 Data)))			,0,0j
	(setq Data (subst (cons 72 (car Value72_73_71)) (assoc 72 Data) Data))
	(setq Data (subst (cons 73 (cadr Value72_73_71)) (assoc 73 Data) Data))
	(entmod Data)

	(setq NewPosition (cdr (assoc 10 (entget  ObjName))))	
	(setq Delta (mapcar '- OrgPosition NewPosition))				
	(setq New_11 (mapcar '+ Org_11 Delta))		
	(setq Data (entget	ObjName))					
	(setq Data (subst (cons 11 New_11) (assoc 11 Data)	Data))	
	(entmod Data)
)
(defun TextInsP_MText ( ObjName Value72_73_71 / Data X_Old X_New Y_Old Y_New Scale Base0 W_42 Ang_50 Delta )
	(setq Data (entget	ObjName))
	(setq InsP (cdr (assoc 10 Data)))
	(setq W_42	(cdr (assoc 42 (entget ObjName))))
	(setq H_43	 	(cdr (assoc 43 (entget ObjName))))
	(setq Ang (cdr (assoc 50 Data)))		
	(setq AngU (angle '(0 0) (getvar "UCSXDIR")))	
	(setq OldIP (cdr (assoc 71 Data)))			
	(setq NewIP (caddr Value72_73_71))		

	(setq Data (subst (cons 71 NewIP) (assoc 71 Data) Data))
	(entmod Data)


	(setq X_Old (- (+ OldIP 2) (* (fix ( / (+ OldIP 2) 3)) 3)))
	(setq X_New (- (+ NewIP 2) (* (fix ( / (+ NewIP 2) 3)) 3)))


	(setq Y_Old (fix ( / (- OldIP 1) 3)))
	(setq Y_New (fix ( / (- NewIP 1) 3)))

	(setq IncUnit (list (- X_New X_Old)(- Y_Old Y_New )))
	(setq Delta (mapcar '* IncUnit (list (* 0.5 W_42)(* 0.5 H_43))))

	(setq Delta (SD8446 Delta '(0 0) Ang))

·
	(setq Delta (SD1862 Delta (* -1.0 AngU)))

	(setq Data (subst (cons 10 (mapcar '+ InsP Delta))(assoc 10 Data) Data))
	(entmod Data)

)

(defun SD1862 (OldPt Ang / NewCs)
(setq NewCs (SD8446 '(1 0) '(0 0) Ang))
(setq NewPt (trans OldPt 0 NewCs))
(setq NewPt (list (nth 2 NewPt)(nth 0 NewPt)))
NewPt
)

(defun SD8446 ( PointA PointB Ang / XA YA XB YB PointC)
(setq	XA2(- (car PointA) (car PointB))
		YA2(- (cadr PointA) (cadr PointB))
)
(setq PointC (list (- (* XA2 (cos Ang))(* YA2 (sin Ang))) (+ (* XA2 (sin Ang))(* YA2 (cos Ang)))))
(setq PointC (mapcar '+ PointC PointB))
PointC
)

 

Tiếp theo, thực hiện test so sánh :

Lần 1: với 100 text và sắp xếp bên trái :

 

-> gần như là ngay tức thì

 

Lần 2, e chơi sang làm hẳn 1000 text + Mtext đi .Lần này thì :

 

- > :undecided:

 

Vậy là tương quan,2 lisp chênh nhau về thời gian xử lý khoảng 50 lần.Tất nhiên, ngoài thực tế ít khi ta gặp 1 đoạn văn bản CAD dài như vậy, nhưng nhiều khi, 1 vấn đề đã cũ,mà vẫn có nhiều lựa chọn giải quyết.

 

PS :Còn đoạn code FIT + code sắp xếp Đối tượng cũng khù khoằm như vậy,tí rỗi e post típ ^^

 

P/S 2 : hình như 4room lại trục trặc, e post file lisp đây

Lisp

hì hì các bác cho em tham gia thử với http://www.cadviet.com/forum/index.php?showtopic=24188


<<

Filename: 123353_ft.lsp
Tác giả: tientracdia
Bài viết gốc: 229366
Tên lệnh: chuyenlay cvml
Vấn đề về màu layer

 

Lệnh là: CHUYENLAY

 

2032013143351344.jpg

Nó...

>>

 

Lệnh là: CHUYENLAY

 

2032013143351344.jpg

Nó dài thòn thòn là do làm cho hiện cái bảng danh sách layer hiện có trong bản vẽ để bạn chọn làm layer đích chứ còn bạn muốn chỉ định cố định layer đích thì chỉ cần dùng lệnh: CVML

và sửa

(nth (atoi duy:bienluu_tenlayer) dsso)

Thành "tenlayer" là được!

 

(defun duy:vht_modau (tieudeht / tieudeht)
(setq sogan 2)
(setq solistgan 1)
(setq solistganb 1)
(setq soanhgan 1)
(setq soanhggan 1)
(setq filedcl (open "D:/htd.dcl" "w"))
(write-line (strcat "duyhopthoai : dialog { label = " "\"" tieudeht "\"" "\;") filedcl)
(setq filelsp (open "D:/ganhtd.lsp" "w"))
(write-line (strcat "\(" "defun ght " "\(" "\)") filelsp)
(setq filelsps (open "D:/ganhtds.lsp" "w"))
(write-line (strcat "\(" "defun ghts " "\(" "\)") filelsps)
(write-line (strcat "\(" "setq phepchon " "\(" "start_dialog" "\)" "\)") filelsps)
(write-line (strcat "\(" "cond") filelsps)
)

(defun duy:vht_ketthuckhongnut (noidung / noidung)
(write-line (strcat ": text {alignment  = centered" "\;" " label = " "\"" noidung "\"" "\;" "}") filedcl)
(write-line (strcat "}") filedcl)
(close filedcl)
(write-line "\)" filelsp)
(close filelsp)
(write-line "\))" filelsps)
(close filelsps)
)

(defun duy:vht_nutthoat (tennut dorong / tennut dorong)
(write-line (strcat ": button {alignment  = centered" "\;" " is_cancel = true" "\;" " width = " dorong "\;" " label = " "\"" tennut "\"" "\;" " key = " "\"" " accept" "\"" "\;" " is_default = true" "\;" "}") filedcl)
)

(defun duy:vht_textso (tieude dorong lisththi vitrimd gtnhan / tieude dorong lisththi vitrimd gtnhan)
(write-line (strcat ": popup_list {alignment  = centered" "\;" " edit_width = " dorong "\;" " label = " "\"" tieude "\"" "\;" " key = " "\"" "listthu" (itoa solistgan) "\"" "\;" "}") filedcl)
(write-line (strcat "\(" "start_list " "\"" "listthu" (itoa solistgan) "\"" "\)") filelsp)
(write-line (strcat "\(" "mapcar " "\'" "add_list " lisththi "\)") filelsp)
(write-line (strcat "\(" "end_list" "\)") filelsp)
(write-line (strcat "\(" "set_tile " "\"" "listthu" (itoa solistgan) "\" " "\(" "itoa " vitrimd "\)" "\)") filelsp)
(write-line (strcat "\(" "action_tile " "\"" "listthu" (itoa solistgan) "\" " "\"" "\(setq " gtnhan " \(get_tile " "\\" "\"" "listthu" (itoa solistgan) "\\" "\"" "\)" "\)" "\"" "\)") filelsp)
(setq solistgan (+ solistgan 1))
)   

(defun duy:vht_nut (tennut hamgoi dorong / tennut hamgoi dorong)
(write-line (strcat ": button {alignment  = centered" "\;" " width = " dorong "\;" " label = " "\"" tennut "\"" "\;" " key = " "\"" hamgoi "\"" "\;" "}") filedcl)
(write-line (strcat "\(" "action_tile " "\"" hamgoi "\" "  "\"" "\(" "done_dialog " (itoa sogan) "\)" "\"" "\)") filelsp)
(write-line (strcat "\(" "\(" "= phepchon " (itoa sogan) "\) " "\(" "c:" hamgoi "\)" "\)") filelsps)
(setq sogan (+ 1 sogan))
)

(defun duy:vht_goihopthoai (/ nda)
(setq DCL_ID (load_dialog "D:/htd.dcl"))
(new_dialog "duyhopthoai" DCL_ID)
(setq fileganhtd (open "D:/ganhtd.lsp" "r"))
(repeat 2
(setq nda (read-line fileganhtd))
)
(close fileganhtd)
(cond
((= nda "\)") (start_dialog) (unload_dialog dcl_id))
((/= nda "\)") (load "D:/ganhtd.lsp") (load "D:/ganhtds.lsp") (ght) (ghts))
)
)

(defun duy:taolist (kieu / kieu nl lkq)
(setq lkq'())
(setq nl (tblnext kieu T))
(while nl
(setq lkq (append lkq (list (cdr (assoc 2 nl)))))
(setq nl (tblnext kieu))
)
lkq)

(defun c:chuyenlay ()
(duy:vht_modau "Chuyen layer")
(duy:vht_nut "Chon doi tuong" "cvml" "0")
(setq dsso (duy:taolist "layer"))
(cond
((= nill duy:bienluu_tenlayer) (setq tenlayerluu "0") (setq duy:bienluu_tenlayer "0"))
((/= nill duy:bienluu_tenlayer) (setq tenlayerluu duy:bienluu_tenlayer))
)
(duy:vht_textso "Layer:" "12" "dsso" tenlayerluu "duy:bienluu_tenlayer")
(duy:vht_nutthoat "Thoat" "0")
(duy:vht_ketthuckhongnut "Viet boi: Duy782006")
(duy:vht_goihopthoai)
(Princ))

(defun c:cvml ()
(princ "Chon cac doi tuong muon chuyen layer !")
(setq dchon (ssget))

(setq sttd 0)
(while (setq LAY (ssname dchon sttd))

(setq kqcolor (cdr (assoc 62 (entget LAY))))
  (Cond
  ((= kqcolor nill) 
  (setq kqcolor (cdr (assoc 62 (entget (TBLOBJNAME "LAYER" (cdr (assoc 8 (entget LAY))))))))
  )
  ((/= kqcolor nill) 
  (setq kqcolor kqcolor)
  )
  )

(command "chprop" LAY "" "layer" (nth (atoi duy:bienluu_tenlayer) dsso) "color" kqcolor "")

(setq sttd (1+ sttd))
)

(princ))

Cám ơn Bạn. Lisp rất hay.

Xin nhờ bạn viết thêm để chuyển màu, kểu đường và lục nét.

Rất cám ơn


<<

Filename: 229366_chuyenlay_cvml.lsp
Tác giả: pawuta
Bài viết gốc: 346021
Tên lệnh: thkl
Nhờ viết lisp thông kê giá trị trong block ATT

 

Mạn phép anh giabach Tue_NV sửa lại chút đỉnh cho  phù hợp với y/c của bạn pawuta

(defun c:ThKl...
>>

 

Mạn phép anh giabach Tue_NV sửa lại chút đỉnh cho  phù hợp với y/c của bạn pawuta

(defun c:ThKl (/ doc)
  (vl-load-com)
  (princ "\nChon Block can tong hop :")
  (if (ssget (list (cons 0 "INSERT")(cons 66 1)))
    (tkatt (vla-get-ActiveSelectionSet (setq doc (vla-get-ActiveDocument (vlax-get-Acad-Object))))
  (vla-get-modelspace doc) "DK" "TCD" "TKL" )
    (princ "\nKhong chon duoc Block thuoc tinh."))
  (princ))
(defun tkatt (ssets msp idTag val1tag val2tag / asoc h i id lst pt row tblobj val1 val2 width)
    ;;  By : Gia_Bach, www.CadViet.com 2015 ;;
  (vlax-for obj ssets
    (setq id nil val1 nil val2 nil)
    (foreach att (vlax-invoke obj 'GetAttributes)
      (cond
( (= (vla-get-TagString att) idTag)
 (setq id (vla-get-TextString att)) )
( (= (vla-get-TagString att) val1Tag)
 (setq val1 (vla-get-TextString att)) )
( (= (vla-get-TagString att) val2Tag)
 (setq val2 (vla-get-TextString att)) ) ))
    (if (and id (distof id 2) val1 val2(setq val1 (distof val1 2))(setq val2 (distof val2 2)))
      (if (setq asoc (assoc id lst))
(setq lst (subst (cons id (list (+ val1 (car(cdr asoc))) (+ val2 (cadr(cdr asoc))))) asoc lst))
(setq lst (append lst (list (cons id (list val1 val2)))) )) ))
  (cond
    ( (not lst )
      (princ "\nKhong tim duoc so lieu.") )
    ( (> (atof (substr (getvar "ACADVER") 1 4)) 16.0)
      (if (setq pt (getpoint "\nDiem dat Bang tong hop:"))
(progn
 (setq h 1.8 width (* 6 h)
TblObj (vla-addtable msp (vlax-3d-point pt) (length lst) 4 (* 2 h) width))
(vla-unMergeCells TblObj 0 0 0 3)
 (vla-put-regeneratetablesuppressed TblObj :vlax-false)
 (vla-put-vertcellmargin TblObj (* 0.75 h))
 (mapcar '(lambda (x)(vla-setTextHeight TblObj x h))
 (list acTitleRow acHeaderRow acDataRow) )
 (mapcar '(lambda (x)(vla-setAlignment TblObj x 8))
 (list acTitleRow acHeaderRow acDataRow))
 
 
 
 ;(vla-setText TblObj 0 0 "Bang tong hop")
 ;(vla-setText TblObj 1 0 "STT")
 ;(vla-setText TblObj 0 0 idTag)
 ;(vla-setText TblObj 1 2 val1Tag)
 ;(vla-setText TblObj 1 3 val2Tag)
 (setq row 0 i 1)
 (foreach pt (vl-sort lst '(lambda (x y) (< (car x) (car y))))
   (vla-setText TblObj row 0 (itoa i))
   (vla-setText TblObj row 1 (car pt))
   (vla-setText TblObj row 2 (rtos(car(cdr pt))2 2))
   (vla-setText TblObj row 3 (rtos(cadr(cdr pt))2 2))
   (setq row (1+ row) i (1+ i)) )
 (vla-put-regeneratetablesuppressed TblObj :vlax-false)
 (vlax-release-object TblObj)     )))
    ( t
      (foreach it (vl-sort lst '(lambda (x y) (< (car x) (car y))))
(princ (strcat "\n"(car it) " : " (rtos(car(cdr it))2 2) " : " (rtos(cadr(cdr it))2 2))))  ) )
  )

Cảm ơn bạn Tue_NV nhiều nhé, lisp chạy oke rồi, một lần nữa cảm ơn mọi người đã quan tâm tới bài viết. Chỉ còn phần link giá trị nữa là thoả mãn cuộc tình luôn, khi nào các bạn có dịp ghé lại bài viết này thì thêm phần link giá trị nữa nhé! Chúc các bạn luôn thành công trong cuộc sống


<<

Filename: 346021_thkl.lsp
Tác giả: trinhhoanghieu090
Bài viết gốc: 310027
Tên lệnh: tim
-Mong các Bro giúp đỡ

Thể theo yêu cầu của bác Ha, tôi viết lại như sau:

 

 

(defun c:tim()  (defun ssfrom (sl / ss0)...
>>

Thể theo yêu cầu của bác Ha, tôi viết lại như sau:

 

 

(defun c:tim()  (defun ssfrom (sl / ss0) (setq ss0 (ssadd)) (mapcar '(lambda(x) (ssadd x ss0)) sl) ss0)  (setq gtt (getstring t "\nNhap bieu thuc :")lso "-.1234567890"so  (read (strcat "(" (vl-list->string (mapcar '(lambda(x) (if (vl-string-search (chr x) lso) x 32)) (vl-string->list gtt))) ")"))chu (car (read (strcat "(" (vl-list->string (mapcar '(lambda(x) (if (vl-string-search (chr x) lso) 32 x)) (vl-string->list gtt))) ")")))  )    (sssetfirst nil (ssfrom (vl-remove-if-not '(lambda(x)(if (= 1 (length so))  ((eval chu) (atof (cdr (assoc 1 (entget x)))) (car so))  (and ((eval chu) (car so) (atof (cdr (assoc 1 (entget x)))) (last so)))))    (vl-remove-if-not '(lambda(x) (distof (cdr (assoc 1 (entget x)))))      (vl-remove-if 'listp (mapcar 'cadr (ssnamex  (ssget (list '(0 . "*TEXT") ))))))))))
 

Các biểu thức so sánh hợp lệ là  <, <=, >, >=, =, /= (khác),

Thanks bác nhé. Đúng cái em cần, rất linh hoạt trong việc chọn lọc số. Nhưng mà sau nhập biểu thức so sánh vào thì không ngắt lệnh bằng phím cách ( space bar) được, Mong bác xử lý nốt cái này nữa là lisp cực kỳ hoàn hảo.

Với lại nếu thực hiện hai lệnh tìm liên tiếp thì thỉnh thoảng bị lỗi:

 

Command: tim

Nhap bieu thuc :>=-44

Select objects: Specify opposite corner: 996 found

Select objects:

(nil <Selection set: 3d6>)

Command:

Command:

TIM

Nhap bieu thuc :<=-44.5

291 found

(nil <Selection set: 530>)

Command:


<<

Filename: 310027_tim.lsp
Tác giả: giaptk3
Bài viết gốc: 14338
Tên lệnh: mx
Xin lisp tách và ghép bản vẽ
Lệnh MX (MultiXclip) dưới đây có thể sẽ giúp bạn.

 

Lệnh này yêu cầu bạn pick vào 1 block, sau đó yêu cầu bạn nhập các rectangle khung. Lệnh sẽ tạo ra...

>>
Lệnh MX (MultiXclip) dưới đây có thể sẽ giúp bạn.

 

Lệnh này yêu cầu bạn pick vào 1 block, sau đó yêu cầu bạn nhập các rectangle khung. Lệnh sẽ tạo ra các block bị cắt cúp trong các khung rectangle vừa bạn vừa nhập. Nếu công trình dạng tuyến của bạn chưa phải là block, bạn phải block nó trước khi dùng lệnh này.

 

(defun c:mx (/ ent ssr lstr tt)
 (setq
   ent	(car (entsel "\nHay pick vao block: "))
   tt	(entget ent)
   tt	(vl-remove '(102 . "{ACAD_XDICTIONARY") tt)
   tt	(vl-remove (assoc 360 tt) tt)
   tt	(vl-remove '(102 . "}") tt)
 )

 (redraw ent 3)
 (while (= (length lstr) 0)
   (princ "\nHay chon cac Polyline: ")
   (setq
     ssr  (ssget '((0 . "LWPOLYLINE") (90 . 4)))
     lstr (ss2ent ssr)
   )
 )
 (redraw ent 4)

 (foreach entr	lstr
   (redraw entr 3)
   (entmake tt)
   (command ".xclip" (entlast) "" "n" "s" entr)
   (redraw entr 4)
 )
 (command ".erase" ent "")
)

(defun ss2ent (ss / sodt index lstent ent)
 (setq
   sodt  (if ss
    (sslength ss)
    0
  )
   index 0
 )
 (repeat sodt
   (setq ent	 (ssname ss index)
  index	 (1+ index)
  lstent (cons ent lstent)
   )
 )
 (reverse lstent)
)

bác Hoành đúng là siêu thật

mọi hôm em phải tách cả trăm bản hnay e mới thấy đựơc có lênh đó sẽ bớt thề nào


<<

Filename: 14338_mx.lsp
Tác giả: AGi
Bài viết gốc: 57920
Tên lệnh: nbpl
Thêm node vào đường Pline
Đây là đoạn Code Tue_NV viết theo ý bạn. Hy vọng bạn hài lòng.

Có thể hiện sáng đối tượng khi bạn pick điểm.

Hãy chạy thử xem nhé :

>>
Đây là đoạn Code Tue_NV viết theo ý bạn. Hy vọng bạn hài lòng.

Có thể hiện sáng đối tượng khi bạn pick điểm.

Hãy chạy thử xem nhé :

(defun c:NBPL()
(vl-load-com)
(setq ss (car (entsel "\n Pick chon doi tuong : ")))
(Hli ss)
(setq po (getpoint  "\n Chon diem cat : "))
(setq ddau (vlax-curve-getStartPoint ss))
(setq dcuoi (vlax-curve-getEndPoint ss))
(Command "break" ss po "@")
(Command "Pedit" "m" ddau dcuoi "" "j" "0" "")
(Hli ss)
(while po (setq po (getpoint  "\n Chon diem cat tiep theo : "))
(Command "select" ddau dcuoi "")
(setq ss (ssget "P"))
(Command "break"  ss po "@")
(Command "Pedit" "m" ddau dcuoi "" "j" "0" "")
(sssetfirst ss ss)
)
(princ)
)
;
(defun HLI(ent)
(sssetfirst (ssadd ent (ssadd)) (ssadd ent (ssadd)))
)

Đúng rồi đó, nhưng bạn có thể sửa thêm tí nữa đc ko? Vì đối với đường Pline khép kín khi thêm node nó lại bẻ gãy đường Pline thành 2 (hoặc nhiều hơn) đường Pline riêng biệt. Mình muốn nó vẫn là 1 Pline duy nhất như đối với đường Pline hở.

Cám ơn bạn rất nhiều, chúc bạn vui, khoẻ và thành công.


<<

Filename: 57920_nbpl.lsp
Tác giả: truongkhai
Bài viết gốc: 230977
Tên lệnh: kk
chỉnh thuộc tính cho nhiều block

 

Trong bản vẽ bạn gửi có 4 cái block attribute. 4 cái này có chung gốc rễ là cái block toadodiemxenhe (bạn bấm i enter...

>>

 

Trong bản vẽ bạn gửi có 4 cái block attribute. 4 cái này có chung gốc rễ là cái block toadodiemxenhe (bạn bấm i enter rồi xem thì biết). Chung 1 block thuộc tính thì lẽ ra tất cả các đối tượng Text trong các block trên bản vẽ phải cùng Layer với block gốc nhưng không hiểu bạn hay là người gửi File cho bạn đã chỉnh một số Text trong block về Layer DEFPOINTS. Đây là Layer mặc định không thể in được. Để in được bạn dùng Lisp sau chuyển tất cả đối tượng Text về Layer bất kì (Layer "0" chẳng hạn).

;============CHUYEN DOI TUONG TU LAYER DEFPOINTS TRONG BLOCK ATTRIBUTE VE LAYER "0"=========
;=======================KANGKUNG 05/04/2013=========================
(defun c:KK()
  (vl-load-com)
  (setq taphop(ssget "_X" '((0 . "INSERT"))) i 0)
  (while (< i (sslength taphop))
    (SETQ EN2(ENTNEXT(ssname taphop i)))
    (SETQ ENLIST2(ENTGET EN2))
    (while (/= (cdr(assoc 0 enlist2)) "SEQEND")
      (setq en2(entnext en2))
      (setq enlist2(entget en2))
      (setq obj(vlax-ename->vla-object en2))
      (if (= "DEFPOINTS" (vla-get-layer obj))
	(vla-put-Layer obj "0")))
    (setq i(1+ i))
    )
  (alert "Well Done")
  )
(princ "\n                Written By KangKung - 05/04/2013\n")
(princ "\n                  Nhap KK de chay chuong trinh\n")

Cảm ơn anh đã quan tâm, bữa trước không in được em cũng chỉ in ra tên điểm rồi thống kê excel thôi. Em có lưu lại lisp a viết thành 1 file kk.lisp rồi load lên mà nó chạy báo lỗi sao đó"error: bad argument type: lentityp nil"; em vẫn chưa in được.


<<

Filename: 230977_kk.lsp
Tác giả: khanh10
Bài viết gốc: 420798
Tên lệnh: test
lisp dùng lệnh hatch!

Nhờ mấy bạn giúp mình lệnh hatch đối tượng bằng lisp với? Mình có đoạn lisp dùng hatch thì bình thường như sau:

(defun c:test (/ p d1 d2 d3 tm1 tm2)
(command "cmdecho" 0)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq a (getpoint "\Chon diem dat:"))
(setq b (polar p (/ (* pi 90) 180) 2000))
(setq c (polar p 0 2000))
(setq d (polar p (/ (* pi 45) 180) 1000))
(command...
>>

Nhờ mấy bạn giúp mình lệnh hatch đối tượng bằng lisp với? Mình có đoạn lisp dùng hatch thì bình thường như sau:

(defun c:test (/ p d1 d2 d3 tm1 tm2)
(command "cmdecho" 0)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq a (getpoint "\Chon diem dat:"))
(setq b (polar p (/ (* pi 90) 180) 2000))
(setq c (polar p 0 2000))
(setq d (polar p (/ (* pi 45) 180) 1000))
(command "pline" p d1 d2 p "")
(setq tm1 (entlast))
(command "hatch" "ANSI31" 500 0 tm1 "")
(setvar "osmode" oldos)
(princ)
)

nhưng vấn đề là mình muốn chọn vùng hatch bằng cách pick điểm trong vùng kín thì làm như thế nào ah!
Cám ơn nhiều!


<<

Filename: 420798_test.lsp

Trang 246/330

246