Bài 5 + 6:

;;;Bai5:Chen mot block lien tiep tai cac vi tri nguoi dung pick chuot.
;;; ti le, goc nghieng da dc chi dinh truoc do & luu lai cho lan sau:
(defun c:ib( / lst_va old b_name)
;insert block
(setq lst_va '("osmode" "cmdecho" "ANGDIR" "ANGBASE" "AUNITS"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0 0 0 0))
(if (and (setq b_name (getstring "\nNhap ten block se chen: " T))
		 (tblsearch "block" b_name)
	)
	(progn
		;;ti...
>>

Bài 5 + 6:

;;;Bai5:Chen mot block lien tiep tai cac vi tri nguoi dung pick chuot.
;;; ti le, goc nghieng da dc chi dinh truoc do & luu lai cho lan sau:
(defun c:ib( / lst_va old b_name)
;insert block
(setq lst_va '("osmode" "cmdecho" "ANGDIR" "ANGBASE" "AUNITS"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0 0 0 0))
(if (and (setq b_name (getstring "\nNhap ten block se chen: " T))
		 (tblsearch "block" b_name)
	)
	(progn
		;;ti le:
		(or #scale (setq #scale 1.0))
		(setq #scale (cond ((getreal (strcat "\nNhap ti le scale block <" (rtos #scale) ">: "))) (#scale)))
		;;end_ ti le
		;;goc nghieng:
		(or #ang (setq #ang 0.0))
		(setq #ang (cond ((getreal (strcat "\nNhap goc nghieng block <" (rtos #ang) "> (degree): "))) (#ang)))
		;;end_ goc nghieng
		(while (setq pt (getpoint "\nPick: "))
			(command "-insert" b_name pt #scale "" #ang)
		) ;while
	)
	(princ (strcat "\n*** Block " b_name " khong ton tai ***"))
)
(mapcar 'setvar lst_va old)
(princ)
)

;;;Bai6: Viet len man hinh chuoi cac so tang dan
;cac chi so: so bat dau, so luong, gia so, goc nghieng, chieu cao chu, khoang cach dc luu lai cho lan sau:
(defun c:VIET( / pt)
(setq lst_va '("osmode" "cmdecho" "ANGDIR" "ANGBASE" "AUNITS"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0 0 0 0))
(if (setq pt (getpoint "\nPick diem chen: "))
    (progn
        ;;so bat dau:
        (or #start (setq #start 2.0))
        (setq #start (cond ((getreal (strcat "\nNhap so bat dau <" (rtos #start) ">: "))) (#start)))
        ;;so luong:
        (or #num (setq #num 4))
        (setq #num (cond ((getint (strcat "\nNhap so luong <" (rtos #num) ">: "))) (#num)))
        ;;gia so:
        (or #d (setq #d 2.0))
        (setq #d (cond ((getreal (strcat "\nNhap gia so <" (rtos #d) ">: "))) (#d)))
        ;;goc nghieng:
        (or #ang1 (setq #ang1 0))
        (setq #ang1 (cond ((getreal (strcat "\nNhap goc nghieng <" (rtos #ang1) "> (degree): "))) (#ang1)))
        ;;chieu cao chu:
        (or #h (setq #h 2.0))
        (setq #h (cond ((getreal (strcat "\nNhap cao chu <" (rtos #h) ">: "))) (#h)))
        ;;khoang cach:
        (or #dist (setq #dist 2.0))
        (setq #dist (cond ((getreal (strcat "\nNhap khoang cach <" (rtos #dist) ">: "))) (#dist)))
        ;;;;;;;;;;;;;;;
        ;;;;;;;;;;;;;;;
        (repeat #num
            (command ".text" pt #h 0 (rtos #start 2 1))
            (setq pt (polar pt (/ (* pi #ang1) 180) #dist)
                  #start (+ #d #start))
        )
    )
)
(mapcar 'setvar lst_va old)
(princ)
)

Bạn xem được chưa. LTSCALE = ĐK/100

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/90791-help-lisp-ve-duong-tron-chi-1-cai-pick/

(defun MakeText (point string Height Wid Ang justify Style Layer Color xdata / Lst); Ang: Radial

    (setq Lst (list '(0 . "TEXT")

                                    (cons 8 (if Layer Layer (getvar...
>>

Bạn xem được chưa. LTSCALE = ĐK/100

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/90791-help-lisp-ve-duong-tron-chi-1-cai-pick/

(defun MakeText (point string Height Wid Ang justify Style Layer Color xdata / Lst); Ang: Radial

    (setq Lst (list '(0 . "TEXT")

                                    (cons 8 (if Layer Layer (getvar "Clayer")))

                                    (cons 62 (if Color Color 256))

                                    (cons 10 point)

                                    (cons 40 Height)

                                    (cons 41 Wid)                                    

                                    (cons 1 string)

                                    (if Ang (cons 50 Ang))

                                    (cons 7 (if Style Style (getvar "Textstyle")))

                                    (cons -3 (if xdata (list xdata) nil)))

                justify (strcase justify))

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

                ((= justify "TL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 3)))))

                ((= justify "TC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 3)))))

                ((= justify "TR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 3)))))    

                ((= justify "ML") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 2)))))

                ((= justify "MC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 2)))))

                ((= justify "MR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 2)))))

                ((= justify "BL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 1)))))

                ((= justify "BC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 1)))))

                ((= justify "BR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 1))))))

    (entmakex Lst));end

;=================================

(defun C:ttt(/ dia disadd pleft pright pup pdown p1 dimz ltsc)
  (setq dimz (getvar "dimzin"))

    (if (not dia0) (setq dia0 30.0))

    (setq dia (getdist (strcat "\nNhap duong kinh <" (rtos dia0 2 2) ">:")))

    (if (not dia)

        (setq dia dia0)

        (setq dia0 dia)

    )

    (setq disadd (/ dia 10.0)
	  ltsc (/ dia 100.0);ltscale bang dk/100
	   )
	(setvar "dimzin" 9)
    (while (setq p1 (getpoint "\nPick diem"))

        (setq pleft (polar p1 pi (+ (* 0.5 dia) disadd)))

        (setq pright (polar p1 0 (+ (* 0.5 dia) disadd)))

        (setq pup (polar p1 (/ pi 2) (+ (* 0.5 dia) disadd)))

        (setq pdown (polar p1 (/ pi -2) (+ (* 0.5 dia) disadd)))

        (entmake (list (cons 0 "CIRCLE") (cons 10 p1) (cons 40 (/ dia 2.0))(cons 62 7)(cons 370 20)))

        (entmake (list (cons 0 "LINE") (cons 10 pleft) (cons 11 pright)(cons 6 "CENTER2")(cons 48 ltsc)(cons 62 10)(cons 370 9)))

        (entmake (list (cons 0 "LINE") (cons 10 pup) (cons 11 pdown)(cons 6 "CENTER2")(cons 48 ltsc)(cons 62 10)(cons 370 9)))

        (MakeText p1 (strcat "D" (rtos dia 2 2)) (/ dia 3.0) 0.7 0 "BC" nil nil nil nil)

    )
	(setvar "dimzin" dimz)
    (princ "\nViet boi hochoaivandot-Cadviet.com")
  (princ)

)

Phiên bản AutoLisp/VisualLisp, enjoy :)!

;; Written by Skywings 301213
(vl-load-com)
(princ "\n>>Skwg: Type DMB to start!")
(defun c:DMB (/ ANG DIST I INSPNT LWPSS N P0 P1 TXTH VERTEXS)
  ;; Initialize
  (if (null *ActiveDocument*)
    (setq *ActiveDocument*
	   (vla-get-ActiveDocument (vlax-get-Acad-object))
    )
  )
  (if (null *ModelSpace*)
    (setq *ModelSpace* (vla-get-ModelSpace *ActiveDocument*))
  )
  (if (null (tblsearch "LAYER"...
>>

Phiên bản AutoLisp/VisualLisp, enjoy :)!

;; Written by Skywings 301213
(vl-load-com)
(princ "\n>>Skwg: Type DMB to start!")
(defun c:DMB (/ ANG DIST I INSPNT LWPSS N P0 P1 TXTH VERTEXS)
  ;; Initialize
  (if (null *ActiveDocument*)
    (setq *ActiveDocument*
	   (vla-get-ActiveDocument (vlax-get-Acad-object))
    )
  )
  (if (null *ModelSpace*)
    (setq *ModelSpace* (vla-get-ModelSpace *ActiveDocument*))
  )
  (if (null (tblsearch "LAYER" "Skwg-Info"))
    (vla-add (vla-get-Layers *ActiveDocument*) "Skwg-Info")
  )
  (if (null (tblsearch "BLOCK" "Skwg-BlkInfo"))
    (DefBlkInfo)
  )
  (if (null *SkwgSettingSav*)
    (setq *SkwgSettingSav* (list 10.0 2.0))
  )
  ;; Get input
  (while (null LwpSs)
    (setq LwpSs (ssget '((0 . "LWPOLYLINE"))))
  )
  (setq	Dist (getreal (strcat "Distance: <"
			      (rtos (car *SkwgSettingSav*) 2 1)
			      ">"
		      )
	     )
  )
  (if (null Dist)
    (setq Dist (car *SkwgSettingSav*))
    (setq *SkwgSettingSav*
	   (subst Dist
		  (car *SkwgSettingSav*)
		  *SkwgSettingSav*
	   )
    )
  )
  (initget 4)
  (setq	TxtH (getreal (strcat "Text height: <"
			      (rtos (cadr *SkwgSettingSav*) 2 1)
			      ">"
		      )
	     )
  )
  (if (null TxtH)
    (setq TxtH (cadr *SkwgSettingSav*))
    (setq *SkwgSettingSav*
	   (subst TxtH
		  (cadr *SkwgSettingSav*)
		  *SkwgSettingSav*
	   )
    )
  )
  ;; Process & Output
  (setq n 0)
  (repeat (sslength LwpSs)
    (setq vertexs (mapcar 'cdr
			  (vl-remove-if-not
			    '(lambda (vertex) (= (car vertex) 10))
			    (entget (ssname LwpSs n))
			  )
		  )
    )
    (setq i 0)
    (repeat (1- (length vertexs))
      (setq p0 (nth i vertexs)
	    p1 (nth (1+ i) vertexs)
      )
      (setq ang (angle p0 p1))
      (setq insPnt
	     (polar
	       (mapcar (function (lambda (a b) (/ (+ a b) 2))) p0 p1)
	       (+ (/ pi 2) ang)
	       Dist
	     )
      )
      (vla-SetWidth
	(utl:CreateLwp
	  (mapcar
	    (function (lambda (x) (polar insPnt ang (* TxtH x))))
	    (list -4 4 5)
	  )
	  "Skwg-Info"
	)
	1
	(/ TxtH 2.5)
	0
      )
      (utl:PutTag
	(utl:AddBlkRef insPnt "Skwg-BlkInfo" (/ TxtH 2) ang "Skwg-Info")
	(list "D100" (rtos (distance p0 p1) 2 2) "i%=0.01%")
      )
      (setq i (1+ i))
    )
    (setq n (1+ n))
  )
  (princ)
)

;; Define BlockAtt Skwg-BlkInfo
(defun DefBlkInfo (/ BLKDEF TXTOBJ)
  (setq
    BlkDef (vla-Add (vla-get-Blocks *ActiveDocument*)
		    (vlax-3d-point (list 0.0 0.0 0.0))
		    "Skwg-BlkInfo"
	   )
  )
  (setq	TxtObj (vla-AddText
		 BlkDef
		 "-"
		 (vlax-3d-point (list 0.0 1.0 0.0))
		 2
	       )
  )
  (utl:PutMulProps
    TxtObj
    (list 'Alignment 'TextAlignmentPoint 'Color)
    (list acAlignmentCenter
	  (vlax-3d-point (list 0.0 1.0 0.0))
	  150
    )
  )
  (foreach propVals (list (list	2
				acAttributeModePreset
				"PipeType"
				(vlax-3d-point (list -0.75 1.0 0.0))
				"TYPE"
				"D100"
				acAlignmentRight
				256
			  )
			  (list	2
				acAttributeModePreset
				"Length"
				(vlax-3d-point (list 0.75 1.0 0.0))
				"LENGTH"
				"0.0"
				acAlignmentLeft
				256
			  )
			  (list	2
				acAttributeModePreset
				"i%"
				(vlax-3d-point (list 0.0 -1.0 0.0))
				"I%"
				"i=0.00%"
				acAlignmentTopCenter
				51
			  )
		    )
    (utl:AddAtt BlkDef propVals)
  )
)
;;-----------;;
;; Utilities ;;
;;-----------;;

;; Put multiple properties
(defun utl:PutMulProps (obj props vals)
  (mapcar (function
	    (lambda (prop val) (vlax-put-property obj prop val))
	  )
	  props
	  vals
  )
)
;; Add Attribute
(defun utl:AddAtt (obj args / ATTDEF)
  (setq	AttDef (vla-AddAttribute
		 obj
		 (nth 0 args)		; height
		 (nth 1 args)		; mode
		 (nth 2 args)		; prompt
		 (nth 3 args)		; InsertionPoint
		 (nth 4 args)		; tag
		 (nth 5 args)		; value
	       )
  )
  (utl:PutMulProps
    AttDef
    (list 'Alignment 'Color 'LockPosition)
    (list (nth 6 args) (nth 7 args) T)
  )
  (if (/= (nth 6 args) acAlignmentLeft)
    (vla-put-TextAlignmentPoint AttDef (nth 3 args))
  )
  AttDef
)
;; Create lwpolyline
(defun utl:CreateLwp (lst-pnt layer / lwp)
  (setq	lwp (vla-AddLightWeightPolyline
	      *ModelSpace*
	      (utl:lst2vArray
		(apply 'append lst-pnt)
	      )
	    )
  )
  (vla-put-layer lwp layer)
  lwp
)
;; List to variant array
(defun utl:Lst2vArray (ptsList / arraySpace sArray)
  (setq	arraySpace
	 (vlax-make-safearray
	   vlax-vbdouble
	   (cons 0
		 (- (length ptsList) 1)
	   )
	 )
  )
  (setq sArray (vlax-safearray-fill arraySpace ptsList))
  (vlax-make-variant sArray)
)
;; Insert Block Reference
(defun utl:AddBlkRef (Pnt BlkName scl ro LayName / BlkRef)
  (setq	BlkRef (vla-InsertBlock
		 *ModelSpace*
		 (vlax-3d-point Pnt)
		 BlkName
		 scl
		 scl
		 scl
		 ro
	       )
  )
  (vlax-put-property BlkRef 'Layer LayName)
  BlkRef
)

;; Put Tag
(defun utl:PutTag (i textstring / atts tag sp:n)
  (if (and
	(= (vla-get-hasattributes i) :vlax-true)
	(safearray-value
	  (setq	atts
		 (vlax-variant-value
		   (vla-getattributes i)
		 )
	  )
	)
      )
    (progn
      (setq sp:n 0)
      (foreach tag (vlax-safearray->list atts)
	(vla-put-TextString tag (nth sp:n textstring))
	(setq sp:n (1+ sp:n))
      )
    )
    (vla-update i)
  )
)

Bài 8:

;;;Bai8: Viet chuong trinh ve cau thang co dinh kem text danh so bac. Cac thong so da neu deu phai dc ghi nho cho lan sau:
(defun c:VCT2( / pt i lst_va old)
(if (not (tblsearch "style" "STT_cau_thang")) 
	(command ".style" "STT_cau_thang" ".vnArial" 20 "" "" "" "")
)
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0))
(if (setq pt (getpoint "\nPick diem chen: "))
	(progn
	;;chieu cao bac:
		(or #ht...
>>

Bài 8:

;;;Bai8: Viet chuong trinh ve cau thang co dinh kem text danh so bac. Cac thong so da neu deu phai dc ghi nho cho lan sau:
(defun c:VCT2( / pt i lst_va old)
(if (not (tblsearch "style" "STT_cau_thang")) 
	(command ".style" "STT_cau_thang" ".vnArial" 20 "" "" "" "")
)
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0))
(if (setq pt (getpoint "\nPick diem chen: "))
	(progn
	;;chieu cao bac:
		(or #ht (setq #ht 170))
		(setq #ht (cond ((getreal (strcat "\nNhap chieu cao bac <" (rtos #ht) ">: "))) (#ht)))
	;;chieu rong bac:
		(or #bt (setq #bt 250))
		(setq #bt (cond ((getreal (strcat "\nNhap chieu rong bac <" (rtos #bt) ">: "))) (#bt)))
	;;so bac:
		(or #n (setq #n 20))
		(setq #n (cond ((getint (strcat "\nNhap so bac <" (itoa #n) ">: "))) (#n)))
	;;ve:
		(setq i 0)
		(repeat #n
			(command ".text" "s" "STT_cau_thang" (polar pt (/ pi 2) (+ 5 #ht)) "" (itoa (setq i (1+ i))))
			(command ".line" pt (polar pt (/ pi 2) #ht) (setq pt (polar (polar pt (/ pi 2) #ht) 0 #bt)) "")
		)
	(command ".zoom" "e")
	)
)
(mapcar 'setvar lst_va old)
(princ)
)

Bài 7:

;;;Bai7: Viet chuong trinh ve m/c doc cau thang 1 ve, biet truoc:
;;a: So bac, kich thuoc bac
;;b: Chieu cao nha, so bac, be rong mat bac
;;c: Chieu cao nha, so bac, goc nghieng thang
(defun c:VCT( / pt lst_va old C R n h goc ang)
(setq lst_va '("osmode" "cmdecho" "ANGDIR" "ANGBASE"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0 0 0))
(initget 1 "Sobackichthuocbac Chieucaonhasobacberongmatbac chieucaonhasobacGocnghiengthang _A B...
>>

Bài 7:

;;;Bai7: Viet chuong trinh ve m/c doc cau thang 1 ve, biet truoc:
;;a: So bac, kich thuoc bac
;;b: Chieu cao nha, so bac, be rong mat bac
;;c: Chieu cao nha, so bac, goc nghieng thang
(defun c:VCT( / pt lst_va old C R n h goc ang)
(setq lst_va '("osmode" "cmdecho" "ANGDIR" "ANGBASE"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0 0 0))
(initget 1 "Sobackichthuocbac Chieucaonhasobacberongmatbac chieucaonhasobacGocnghiengthang _A B C")
(setq key (getkword "\nTuy chon < Sobac,kichthuocbac Chieucaonha,sobac,berongmatbac chieucaonha,sobac,Gocnghiengthang >: "))
(cond 
	((= key "A") 
		(if (and
				(setq pt (getpoint "\nChon diem chuan: "))
				(setq C (getreal "\nChieu cao bac: "))
				(setq R (getreal "\nChieu rong bac: "))
				(setq n (getint "\nSo bac: "))
			)
			(repeat n
				(command ".line" pt (polar pt (/ pi 2) C) (setq pt (polar (polar pt (/ pi 2) C) 0 R)) "")
			)
		)
	)
	((= key "B")
		(if (and
				(setq pt (getpoint "\nChon diem chuan: "))
				(setq h (getreal "\nChieu cao nha: "))
				(setq n (getint "\nSo bac: "))
				(setq R (getreal "\nChieu rong bac: "))
			)
			(progn
				(setq C (/ h n))
				(repeat n
				(command ".line" pt (polar pt (/ pi 2) C) (setq pt (polar (polar pt (/ pi 2) C) 0 R)) "")
				)
			)
		)
	)
	((= key "C")
		(if (and
				(setq pt (getpoint "\nChon diem chuan: "))
				(setq h (getreal "\nChieu cao nha: "))
				(setq n (getint "\nSo bac: "))
				(setq ang (getreal "\nGoc nghieng thang (deg): "))
			)
			(progn
				(setq C (/ h n)
					  R (* C (/ (cos (setq goc (/ (* ang pi) 180))) (sin goc)))
				)
				(repeat n
				(command ".line" pt (polar pt (/ pi 2) C) (setq pt (polar (polar pt (/ pi 2) C) 0 R)) "")
				)
			)
		)
	)
)
(mapcar 'setvar lst_va old)
(princ)
)

Của thằng Tây, bạn dùng nhé.

(defun C:A2T (/ eset1 blkcnt en enlist vl space)
  (setq eset1  (ssget (list (cons 0 "ATTDEF")))
blkcnt 0)
  (if eset1
    (while (<= blkcnt (- (sslength eset1) 1))
      (setq en    (ssname eset1 blkcnt)
   enlist (entget en)
   space  (cdr (assoc 67 enlist)))
      (setq vl (list
(cons 0 "TEXT")
(cons 100 "AcDbEntity")
(cons 100 "AcDbText")
(assoc 7 enlist)
(assoc 8 enlist)
(assoc...
>>

Của thằng Tây, bạn dùng nhé.

(defun C:A2T (/ eset1 blkcnt en enlist vl space)
  (setq eset1  (ssget (list (cons 0 "ATTDEF")))
blkcnt 0)
  (if eset1
    (while (<= blkcnt (- (sslength eset1) 1))
      (setq en    (ssname eset1 blkcnt)
   enlist (entget en)
   space  (cdr (assoc 67 enlist)))
      (setq vl (list
(cons 0 "TEXT")
(cons 100 "AcDbEntity")
(cons 100 "AcDbText")
(assoc 7 enlist)
(assoc 8 enlist)
(assoc 10 enlist)
(assoc 40 enlist)
(cond ((assoc 62 enlist))
      ((cons 62 256)))
(cons 1 (cdr (assoc 2 enlist)))
(if (= space nil)
  (cons 67 0)
  (cons 67 space))))
      (entdel en)
      (entmake vl)
      (setq blkcnt (1+ blkcnt)))))
 

Bổ sung thêm: tốc độ thì... khó nói lắm. Có lần tôi đã test 2 thằng, thấy vla nhanh hơn, nhưng quên mất ví dụ đó rồi.

Lại có lúc test khác, thấy entmake nhanh hơn, như ví dụ dưới đây. Nói chung, khi muốn đua tốc độ thì nên test thử rồi chọn là hay nhất.

Rất cám ơn bạn. mình có xem chủ trên và có dow 1lisp về chạy thử thì báo lỗi sau:

Command: ; error: malformed list on input

bạn kiểm tra giùm mình xem là lỗi gì ah?

đây là lsp :

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/3107-chuyen-so-lieu-text-tu-cad-sang-excell/
(defun c:CTE(/ ss ent sht dtich cthua gchu i L...
>>

Rất cám ơn bạn. mình có xem chủ trên và có dow 1lisp về chạy thử thì báo lỗi sau:

Command: ; error: malformed list on input

bạn kiểm tra giùm mình xem là lỗi gì ah?

đây là lsp :

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/3107-chuyen-so-lieu-text-tu-cad-sang-excell/
(defun c:CTE(/ ss ent sht dtich cthua gchu i L lst fname);copyright by Tue_NV(defun checkss (sset)    (if (null sset) 	(acet-list-to-ss (list (entmakex (list (cons 0 "TEXT") (cons 1 "") (cons 10 (list 0 0 0)) (cons 40 2) ) ) ))    ))(IF (ACET-UTIL-VER)(PROGN(iF (setq ss (ssget '((0 . "*POLYLINE") (70 . 1))))(pROGN (setq i -1 lst '())  (while (setq ent (ssname ss (setq i (1+ i))))    (setq L (acet-geom-vertex-list ent))    (if (null (setq sht (ssget "CP" L '((0 . "*TEXT") (8 . "Sothua") (1 . "~**")))) ) 	(setq sht (checkss sht)) )    (if (null (setq dtich (ssget "CP" L '((0 . "*TEXT") (8 . "Dientich") (1 . "*#.#*,*#,#*")))) )	(setq dtich (checkss dtich)) )    (if (null (setq cthua (ssget "CP" L '((0 . "*TEXT") (8 . "Text") (1 . "*@*")))) ) 	(setq cthua (checkss cthua)) )    (if (null (setq gchu (ssget "CP" L '((0 . "*TEXT") (8 . "Dientich") (1 . "@@@")))) )	(setq gchu (checkss gchu)) )       (setq lst (vl-sort 	           (append lst    		     (list		 	 (mapcar '(lambda(x) 			   		(acet-dxf 1 (entget x))				   )	    			(apply 'append			       		(mapcar 'acet-ss-to-list				       			(list sht sht cthua dtich gchu)			       		)				)    		   	)		     )	          );append		 '(lambda (x1 x2) (< (atoi (car x1)) (atoi (car x2))))		);vl-sort    	)  );while  ;;;;;;;;;;;;;;(if (setq fName (getfiled "Ten file xuat " (getvar "dwgprefix") "xls" 1))   (progn	(setq fName (open fName "w"))	(write-line "STT\tSO HIEU THUA\tCHU THUA\tDIEN TICH\tGHI CHU" fname)	(foreach pt lst	   (write-line (strcat (nth 0 pt) "\t" (nth 1 pt) "\t" (nth 2 pt) "\t"			       (nth 3 pt) "\t" (nth 4 pt)) fName)	)       (close fName)   ))  ))));PROGN_IF(setvar "modemacro" "Chuc ban lam viec hieu qua - tue_nvcc@yahoo.com") (princ))

Thanks!

Hình như là cái này:

;; free lisp from cadviet.com ;copyright by Tue_NV; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=3107
(defun C:CTE(/ ss ent sht dtich cthua gchu lst i fname)
 (if (acet-util-ver)
  (progn
   (if (setq ss (ssget '((0 . "*POLYLINE") (70 . 1))))
   (progn 
    (setq i -1 lst '())
    (while (setq ent (ssname ss (setq i (1+ i))))
     (setq L (acet-geom-vertex-list...
>>

Hình như là cái này:

;; free lisp from cadviet.com ;copyright by Tue_NV; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=3107
(defun C:CTE(/ ss ent sht dtich cthua gchu lst i fname)
 (if (acet-util-ver)
  (progn
   (if (setq ss (ssget '((0 . "*POLYLINE") (70 . 1))))
   (progn 
    (setq i -1 lst '())
    (while (setq ent (ssname ss (setq i (1+ i))))
     (setq L (acet-geom-vertex-list ent))
     (if
      (and
       (setq sht (ssget "CP" L '((0 . "*TEXT") (8 . "Sothua") (1 . "~**"))))   ;text lµ sè nguyªn
       (setq dtich (ssget "CP" L '((0 . "*TEXT") (8 . "Dientich") (1 . "*#.#*,*#,#*")))) ;text lµ sè thùc
       (setq cthua (ssget "CP" L '((0 . "*TEXT") (8 . "Chu SD") (1 . "*@*")))) ;text că chøa kư tù trèng ë ®Çu/gi÷a/cuèi
       (setq gchu (ssget "CP" L '((0 . "*TEXT") (8 . "Dientich") (1 . "@@@"))))) ;text chøa ®óng 3 kư tù ???
      (setq lst (vl-sort (append lst (list (mapcar '(lambda (x) (acet-dxf 1 (entget x)))
                       (apply 'append (mapcar 'acet-ss-to-list (list sht sht cthua dtich gchu))))))
'(lambda (x1 x2) (< (atoi (car x1)) (atoi (car x2))))))))
    (if (setq fName (getfiled "Ten file xuat " (getvar "dwgprefix") "xls" 1))
     (progn
      (setq fName (open fName "w"))
      (write-line "STT\tSO HIEU THUA\tCHU THUA\tDIEN TICH\tGHI CHU" fname)
      (foreach pt lst
       (write-line (strcat (nth 0 pt) "\t" (nth 1 pt) "\t" (nth 2 pt) "\t" (nth 3 pt) "\t" (nth 4 pt)) fName))
       (close fName)))))));PROGN_IF
 (setvar "modemacro" "Chuc ban lam viec hieu qua - tue_nvcc@yahoo.com")
 (princ))
 

;;;============================================== 
;;; Author: Charles Alan Butler 
;;; Version:  1.7 Nov. 24, 2007
;;; Purpose: To remove unnecessary vertex from a pline
;;; Supports arcs and varying widths
;;;=============================================================
;; This version will remove the first vertex if it is colinear
;; and first & last arcs that have the same center

;;  command line entry, user selection set pick
(defun c:PSimple ()...
>>

;;;============================================== 
;;; Author: Charles Alan Butler 
;;; Version:  1.7 Nov. 24, 2007
;;; Purpose: To remove unnecessary vertex from a pline
;;; Supports arcs and varying widths
;;;=============================================================
;; This version will remove the first vertex if it is colinear
;; and first & last arcs that have the same center

;;  command line entry, user selection set pick
(defun c:PSimple () (PSimpleUser nil)(princ))
(defun c:PSimpleV () ; Verbose version
  (mapcar '(lambda(x)(print (car x))(princ (cadr x))) (PSimpleUser nil))
  (princ)
)

;;  User interface Function
;;  flag = nil -> user selects a selection set
;;       = ENAME -> call the routine
;;       = OBJECT -> call the routine
;;       = True   -> User to select a single entity, repeats
(defun PSimpleUser (flag / ss ent)
  (cond
    ((null flag)    ; user selection set pick
     (prompt "\n Select polylines to remove extra vertex: ")
     (if (setq ss (ssget '((0 . "LWPOLYLINE"))))
       (PSimple ss)
     )
    )
    ;;  next two already have an object so pass to the main routine
    ((= (type flag) 'ENAME) (PSimple flag))
    ((= (type flag) 'VLA-object) (PSimple flag))
    (t  ; user single pick with repeat
       (while
         (setq ent (car (entsel "\n Select polyline to remove extra vertex: ")))
          (if (equal (assoc 0 (entget ent)) '(0 . "LWPOLYLINE"))
            (PSimple ent)
            (prompt "\nNot a LWPolyline, Try again.")
          )
       )
    )
  )
)





;;;============================================== 
;;; Author: Charles Alan Butler 
;;; Version:  1.7 Nov. 23, 2007
;;; Purpose: To remove unnecessary vertex from a pline
;;; Supports arcs and varying widths
;;;=============================================================
;; This version will remove the first vertex if it is colinear
;; and first & last arcs that have the same center
;; Open plines that have the same start & end point will be closed

;;  Argument: et
;;    may be an ename, Vla-Object, list of enames or
;;    a selection set
;;  Returns: a list, (ename message)
;;    Massage is number of vertex removed or error message string
;;    If a list or selection set a list of lists is returned
(defun PSimple (et / doc result Tan Replace BulgeCenter RemoveNlst ps1)
  (vl-load-com)

  (defun tan (a) (/ (sin a) (cos a)))

  (defun replace (lst i itm)
    (setq i (1+ i))
    (mapcar '(lambda (x) (if (zerop (setq i (1- i))) itm x)) lst)
  )

  
  ;;  CAB 11.16.07
  ;;  Remove based on pointer list
  (defun RemoveNlst (nlst lst)
    (setq i -1)
    (vl-remove-if  '(lambda (x) (not (null (vl-position (setq i (1+ i)) nlst)))) lst)
  )
  
  (defun BulgeCenter (bulge p1 p2 / delta chord radius center)
    (setq delta  (* (atan bulge) 4)
          chord  (distance p1 p2)
          radius (/ chord (sin (/ delta 2)) 2)
          center (polar p1 (+ (angle p1 p2) (/ (- pi delta) 2)) radius)
    )
  )

  ;;  Main function to remove vertex
  ;;  ent must be an ename of a LWPolyline
  (defun ps1 (ent /      aa     cpt    dir    doc    elst   hlst   Remove
                  idx    keep   len    newb   result vlst   x      closed
                  d10    d40    d41    d42    hlst   p1     p2     p3
                  plast  msg)
      ;;=====================================================
      (setq elst (entget ent)
            msg  "")
      (setq d10 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) elst)))
      (if (> (length d10) 2)
        (progn
          ;;  seperate vertex data
          (setq d40 (vl-remove-if-not '(lambda (x) (= (car x) 40)) elst))
          (setq d41 (vl-remove-if-not '(lambda (x) (= (car x) 41)) elst))
          (setq d42 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 42)) elst)))
          ;;  remove extra vertex from point list
          (setq plast (1- (length d10)))
          (setq p1 0  p2 1  p3 2)
          (if (and (not (setq closed (vlax-curve-isclosed ent)))
                   (equal (car d10) (last d10) 1e-6))
            (progn
              (setq Closed t ; close the pline
                    elst (subst (cons 70 (1+(cdr(assoc 70 elst))))(assoc 70 elst) elst)
                    msg  " Closed and")
              (if (and (not(zerop (nth plast d42)))(not(zerop (nth 0 d42))))
                (setq d10 (reverse(cdr(reverse d10)))
                      d40 (reverse(cdr(reverse d40)))
                      d41 (reverse(cdr(reverse d41)))
                      d42 (reverse(cdr(reverse d42)))
                      plast (1- plast)
                )
              )
            )
          )
          (setq idx -1)
          (while (<= (setq idx (1+ idx)) (if closed (+ plast 2) (- plast 2)))
            (cond
              ((and (or (equal (angle (nth p1 d10) (nth p2 d10))
                               (angle (nth p2 d10) (nth p3 d10)) 1e-6)
                        (equal (nth p1 d10) (nth p2 d10) 1e-6)
                        (equal (nth p2 d10) (nth p3 d10) 1e-6))
                    (zerop (nth p2 d42))
                    (or (= p1 plast)
                        (zerop (nth p1 d42)))
               )
               (setq remove (cons p2 remove)) ; build a pointer list
               (setq p2 (if (= p2 plast) 0 (1+ p2))
                     p3 (if (= p3 plast) 0 (1+ p3))
               )
              )
              ((and (not (zerop (nth p2 d42)))
                    (or closed (/= p1 plast))
                    (not (zerop (nth p1 d42))) ; got two arcs
                    (equal
                      (setq cpt (BulgeCenter (nth p1 d42) (nth p1 d10) (nth p2 d10)))
                      (BulgeCenter (nth p2 d42) (nth p2 d10) (nth p3 d10))
                      1e-4)
               )
               ;;  combine the arcs
               (setq aa   (+ (* 4 (atan (abs (nth p1 d42))))(* 4 (atan (abs (nth p2 d42)))))
                     newb (tan (/ aa 4.0))
               )
               (if (minusp (nth p1 d42))
                 (setq newb (- (abs newb)))
                 (setq newb (abs newb))
               )
               (setq remove (cons p2 remove)) ; build a pointer list
               (setq d42 (replace d42 p1 newb))
               (setq p2 (if (= p2 plast) 0 (1+ p2))
                     p3 (if (= p3 plast) 0 (1+ p3))
               )
              )
              (t
               (setq p1 p2
                     p2 (if (= p2 plast) 0 (1+ p2))
                     p3 (if (= p3 plast) 0 (1+ p3))
               )
              )
            )
          )
          (if remove
            (progn
              (setq count (length d10))
              ;; Rebuild the vertex data with pt, start & end width, bulge
              (setq d10 (RemoveNlst remove d10)
                    d40 (RemoveNlst remove d40)
                    d41 (RemoveNlst remove d41)
                    d42 (RemoveNlst remove d42)
              )
              (setq result (mapcar '(lambda(w x y z) (list(cons 10 w)
                                        x  y
                                        (cons 42 z))) d10 d40 d41 d42)
              )
              ;;  rebuild the entity data with new vertex data
              (setq hlst (vl-remove-if
                           '(lambda (x) (vl-position (car x) '(40 41 42 10))) elst)
              )
              (mapcar '(lambda (x) (setq hlst (append hlst x))) result)
              (setq hlst (subst (cons 90 (length result)) (assoc 90 hlst) hlst))
              (if (entmod hlst); return ename and number of vertex removed
                (list ent (strcat msg " Vertex removed " (itoa(- count (length d10)))))
                (list ent " Error, may be on locked layer.")
              )
            )
            (list ent "Nothing to remove - no colenier vertex.")
          )
        )
        (list ent "Nothing to do - Only two vertex.")
      )
    )
  

  ;;  ========  S T A R T   H E R E  ===========
  (setq doc (vla-get-activedocument (vlax-get-acad-object)))
  (cond
    ((or (=(type et) 'ENAME)
         (and (=(type et) 'VLA-object)
              (setq et (vlax-vla-object->ename et))))
      (vla-startundomark doc)
      (setq result (ps1 et))
      (vla-endundomark doc)
     )
    ((= (type et) 'PICKSET)
      (vla-startundomark doc)
      (setq result (mapcar '(lambda(x) (ps1 x))
              (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))))
      (vla-endundomark doc)
    )
    ((listp et)
      (vla-startundomark doc)
      (setq result (mapcar '(lambda(x) (ps1 x)) et))
      (vla-endundomark doc)
    )
    ((setq result "PSimple Error - Wrong Data Type."))
  )
  result
)
(prompt "\nPline Simplify loaded, PSimple to run.")
(princ)

Mình tìm thấy cái này làm đúng theo yêu cầu của bạn.

Tên lệnh: PSimple

Ví dụ thế này chăng?

 

(defun C:HA()
 (vl-load-com)
 (acad_colordlg (vlax-get (vlax-ename->vla-object (car (entsel))) 'Color)))
 

Hề hề hề,

Hay là cái ni nhể:

(defun c:getcol (/ col)

(setq col (cdr (assoc 62 (entget (car (entsel "\n chon doi tuong can xac...

Ví dụ thế này chăng?

 

(defun C:HA()
 (vl-load-com)
 (acad_colordlg (vlax-get (vlax-ename->vla-object (car (entsel))) 'Color)))
 

Hề hề hề,

Hay là cái ni nhể:

(defun c:getcol (/ col)

(setq col (cdr (assoc 62 (entget (car (entsel "\n chon doi tuong can xac dinh mau"))))))

(alert (strcat "\n Doi tuong co mau so: " (if col (rtos col 2 0) "256"))))

Lisp thêm tiền tố và/hoặc hậu tố cho DIMENSION, TEXT, MTEXT, ATTDEF.

Cái UCS đó dùng như thế nào vậy bác Tue? Em chưa biết cách.

Còn sau đây e gửi bác cách em thường đo Dim với cái file cad của em. Bác xem và giúp em với nhé

>>

Cái UCS đó dùng như thế nào vậy bác Tue? Em chưa biết cách.

Còn sau đây e gửi bác cách em thường đo Dim với cái file cad của em. Bác xem và giúp em với nhé

http://www.youtube.com/watch?v=PnAjmhsZM_U&feature=youtu.be

Do chưa hiểu file của bạn....

Code Lisp của bạn đây: 

(defun c:dop(/ Tue-dxf Tue-ent-Lpoint cur line dd)
(vl-load-com)
(defun Tue-dxf (dxf ename)(cdr(assoc dxf (entget ename))))
(defun Tue-ent-Lpoint(e / i Lpoint);Tue-dxf
(if (wcmatch (Tue-dxf 0 e) "*POLYLINE")
(progn
  (if (= (type e) 'VLA-OBJECT) (setq e (vlax-vla-object->ename e)))
  (setq i -1)
  (Repeat (if (wcmatch (Tue-dxf 0 e) "*POLYLINE") (fix (1+ (vlax-curve-getEndParam e))) 2)
    (setq Lpoint (append Lpoint (list (vlax-curve-getPointatParam e (setq i (1+ i))))))
  )
)
)
(if (wcmatch (Tue-dxf 0 e) "LINE")
  (setq Lpoint (append Lpoint (list (Tue-dxf 10 e) (Tue-dxf 11 e))))
)
Lpoint
)
  (command "ucs" "W")
(while (and
  (setq cur (car (entsel "\nChon Pline :")))
  (setq line (car (entsel "\nChon line1 :")))
  (setq dd (getpoint "\nChon diem dat :"))
  )
  (foreach x (Tue-ent-Lpoint cur)
  (command "._dimlinear"  x (vlax-curve-getClosestPointTo line x) x
             "._dimtedit" (entlast) (list (car x) (cadr dd) 0.0))
  )
)
)

Cám ơn bác Tuệ rất nhiều. Lisp bác viết rất đúng ý em rồi. Nhưng em dùng có điều này mong bác giúp là: 
+ Thêm sự lựa chọn hàng loạt Polyline một lúc.
+ Và thêm hàm có thể giúp Undo trở lại trước khi Dim. Em thử thêm mấy dòng này vào Lisp mà ko được : (command "undo" "be") (command "undo" "end")
Hoặc nếu...

>>

Cám ơn bác Tuệ rất nhiều. Lisp bác viết rất đúng ý em rồi. Nhưng em dùng có điều này mong bác giúp là: 
+ Thêm sự lựa chọn hàng loạt Polyline một lúc.
+ Và thêm hàm có thể giúp Undo trở lại trước khi Dim. Em thử thêm mấy dòng này vào Lisp mà ko được : (command "undo" "be") (command "undo" "end")
Hoặc nếu bác chỉ cho em cách sửa lisp thì tốt quá. Em gà về khoản này quá. Mong bác chỉ giúp. :)

Chỉnh code lại cho bạn đây: 

(defun c:dop(/ Tue-dxf Tue-ent-Lpoint cur line dd i sspline)
(vl-load-com)
(defun Tue-dxf (dxf ename)(cdr(assoc dxf (entget ename))))
(defun Tue-ent-Lpoint(e / i Lpoint);Tue-dxf
(if (wcmatch (Tue-dxf 0 e) "*POLYLINE")
(progn
  (if (= (type e) 'VLA-OBJECT) (setq e (vlax-vla-object->ename e)))
  (setq i -1)
  (Repeat (if (wcmatch (Tue-dxf 0 e) "*POLYLINE") (fix (1+ (vlax-curve-getEndParam e))) 2)
    (setq Lpoint (append Lpoint (list (vlax-curve-getPointatParam e (setq i (1+ i))))))
  )
)
)
(if (wcmatch (Tue-dxf 0 e) "LINE")
  (setq Lpoint (append Lpoint (list (Tue-dxf 10 e) (Tue-dxf 11 e))))
)
Lpoint
)
  (command "undo" "be")
  (command "ucs" "W")
  (setvar "cmdecho" 0)
(while (and
           (setq i -1) (princ "\n Select Polyline:")
          (setq sspline (ssget '((0 . "*LINE"))))
          (setq line (car (entsel "\nChon line1 :")))
          (setq dd (getpoint "\nChon diem dat :"))
    )
(Repeat (sslength sspline)
  (foreach x (Tue-ent-Lpoint (ssname sspline (setq i (1+ i))))
  (command "._dimlinear"  x (vlax-curve-getClosestPointTo line x) x
             "._dimtedit" (entlast) (list (car x) (cadr dd) 0.0))
  )
)
)
  (command "ucs" "p")
  (command "undo" "end")
)

Ý của mình giống như bạn phamthanhbinh nói.

Hề hề hề,

Đây là lisp mình làm thử theo giải pháp mình đã đề xuất bên trên. Tuy nhiên có khác chút chút ở bước kiểm tra giá trị bulge. do các cung có cùng...

Ý của mình giống như bạn phamthanhbinh nói.

Hề hề hề,

Đây là lisp mình làm thử theo giải pháp mình đã đề xuất bên trên. Tuy nhiên có khác chút chút ở bước kiểm tra giá trị bulge. do các cung có cùng bán kính và cùng tâm vẫn có các giá trị bulge khác nhau, Vì thế việc kiểm tra ở trong líp này chỉ đảm bảo là nếu có hai cung cong liên tiếp thì điểm nối sẽ bị loại trừ và thay cả hai cung này bằng một cung khác. Do đó khi sử dụng phải lưu ý điều này và phải kiểm tra trước xem các cung này có thực sự cùng tâm và bán kinh hay không. Nếu không thì việc thay thế như trên có hợp với yêu cầu hay không???

Vì mình chỉ căn cứ vào bản vẽ bạn đã gửi để viết lisp nên nếu như các hình khác của bạn không có các đặc tinh tương tự với bản vẽ bạn gửi thì không đảm bảo lisp sẽ chạy đúng yêu cầu. Tỷ như trường hợp  hình của bạn không phải là một lwpolyline kín hay là tổ hợp của các lines và các ảc rời rạc hoặc có nhiều cung bán kính khác nhau nối tiếp nhau .....

Mình đã chạy thử lisp với hình vẻ bạn gửi thì mọi thứ đều tốt.

Hãy dùng thử và cho ý kiến nếu thấy cần sửa chữa hay bổ sung.

http://www.cadviet.com/upfiles/3/5194_xoadinhpline.lsp

(defun c:xdpl (/ pl oldos plst plst1 plob elst bulst vtt1 vtt2 bul1 bul2 ang1 ang2 i k k1 b1 b2 sp m col)

(vl-load-com)

(setq oldos (getvar "osmode"))

(setvar "osmode" 0)

(command "undo" "be")

(setq pl (car (entsel "\n chon pline can xoa bot cac dinh"))

         plst (acet-geom-vertex-list pl)

         plob (vlax-ename->vla-object pl)

         elst (entget pl)

         bulst (list)

         plst1 plst

)

(if  (assoc 62 elst)

     (setq col (rtos (cdr (assoc 62 elst)) 2 0))

     (setq col "256")

)

(alert (strcat "\n Doi tuong co ma mau la : " col))

(setq m (getstring "\n Nhap ma mau khac voi ma mau hien tai cua doi tuong: "))

(if (= m "") (setq m "256"))

(command "cecolor" m)

(foreach a elst

        (if (= (car a) 42)

            (setq bulst (append bulst (list (cdr a))))

        )

)

(foreach vrt plst

       (setq i (vl-position vrt plst))

       (if (> i 0)

           (progn

                 (setq vtt1 (vlax-curve-getFirstDeriv plob (vlax-curve-getParamAtPoint plob (nth (1- i) plst))) ) 

                 (setq vtt2 (vlax-curve-getFirstDeriv plob (vlax-curve-getParamAtPoint plob vrt)) )

                 (setq bul1 (nth (1- i) bulst)

                           bul2 (nth i bulst)   )

                 (setq ang1 (angle '(0 0 0) vtt1)

                           ang2 (angle '(0 0 0) vtt2) )

                 (if (and (= bul1 0.0) (=  bul2 0.0) (equal ang1  ang2  0.0000001))

                     (setq plst1 (vl-remove vrt plst1))

                 )

                 (if (and (/= bul2 0.0) (/= bul1 0.0))

                      (setq plst1 (vl-remove vrt plst1) )

                 )

           )

        )

)

(setq plst1 (reverse (cdr (reverse plst1))))

(command "pline")

(foreach p plst1

    (setq k (vl-position p plst)

              b1 (nth k bulst) 

              k1 (vl-position p plst1) 

    )

    (if (> k1 0)

        (setq b2 (nth (vl-position (nth (1- k1) plst1) plst) bulst))

        (setq b2 0.0)

    )

    (if (= b1 0) 

        (if (= b2 0.0)

            (command p)

            (command p "l")

       )

        (progn

              (command p)

              (command "a" "s")

              (if (not (equal (nth (1+ k) plst) (nth (1+ k1) plst1) 0.0000001))

                  (setq sp  (nth (1+ k) plst)) 

                  (setq sp (getpoint "\n Chon diem thu hai thuoc cung tron"))

              )

              (command sp )  

          )

      )

)

(command "c")

(command "erase" pl "")

(command "undo" "e")

(setvar "osmode" oldos)

(princ)

)