Jump to content
InfoFile
Tác giả: hiepttr
Bài viết gốc: 272985
Tên lệnh: ib viet
[LI]Chương 6 : Bài Tập

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

<<

Filename: 272985_ib_viet.lsp
Tác giả: tien2005
Bài viết gốc: 273046
Tên lệnh: ttt
help lisp vẽ đường tròn chỉ 1 cái pick

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)

)


 


<<

Filename: 273046_ttt.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 273869
Tên lệnh: eln
[xin] Lisp tạo cao độ đường đồng mức san nền

Quick code:

(defun C:ELN ( / cd ss)
 (if
  (and
   (setq cd (getreal "\nNhap cao do moi: "))
   (princ "\nChon cac Pline...")
   (setq ss (ssget)))
  (foreach ent (acet-ss-to-list ss)
   (entmod (subst (cons 38 cd) (assoc 38 (entget ent)) (entget ent)))))
 (princ))

Filename: 273869_eln.lsp
Tác giả: dragontalon0802
Bài viết gốc: 274158
Tên lệnh: bang
Lấy dữ liệu từ file autocard vào file excel
discount cymbalta coupons Jodie Callahan, Jessica Hunt and Dezerah Silsby were indicted on five counts including forced labor, acquiring a controlled substance by deception and theft of government benefits related to allegations they forced the woman to use her public assistance money to buy groceries and cigarettes for them.
>>
discount cymbalta coupons Jodie Callahan, Jessica Hunt and Dezerah Silsby were indicted on five counts including forced labor, acquiring a controlled substance by deception and theft of government benefits related to allegations they forced the woman to use her public assistance money to buy groceries and cigarettes for them.
discount prozac no prescription Gross production, which includes production from wellsKodiak does not operate but has a stake in, has risen to "justshy" of 50,000 barrels of oil equivalent per day (boe/d), CEOLynn Peterson said on Wednesday.
isotretinoin pregnancy category Sergio George has been the driving force behind many of the biggest names in Latin music, so it’s no surprise the Grammy Award-winning producer would bring some of these giants together for a live album.

<<

Filename: 274158_bang.lsp
Tác giả: Skywings
Bài viết gốc: 274328
Tên lệnh: dmb
Nhờ viết list cho dân quy hoạch cấp thoát nước.

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

<<

Filename: 274328_dmb.lsp
Tác giả: hiepttr
Bài viết gốc: 275253
Tên lệnh: vct2
Chương 6 : Bài Tập

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

<<

Filename: 275253_vct2.lsp
Tác giả: hiepttr
Bài viết gốc: 274086
Tên lệnh: vct
[LI]Chương 6 : Bài Tập

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

<<

Filename: 274086_vct.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 275325
Tên lệnh: a2t
Chuyển text sẵn có thành ATT

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

<<

Filename: 275325_a2t.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 238890
Tên lệnh: ha1 ha2
Tập hợp một số hàm entmake object

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.

(defun C:HA1()
 (setq thisdrawing (vla-get-activedocument (vlax-get-acad-object)))
 (setq mspace (vla-get-modelspace...
>>

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.

(defun C:HA1()
 (setq thisdrawing (vla-get-activedocument (vlax-get-acad-object)))
 (setq mspace (vla-get-modelspace thisdrawing))
 (setq pt1 (vlax-3d-point (getpoint "\nCenter point: ")))
 (setq rad (getreal "\nRadius: "))
 (setq time (getvar "millisecs"))
 (repeat 100000
  (vla-AddCircle mspace pt1 rad))
 (- (getvar "millisecs") time))
(defun C:HA2()
 (setq pt1 (getpoint "\nCenter point: "))
 (setq rad (getreal "\nRadius: "))
 (setq time (getvar "millisecs"))
 (repeat 100000
  (Circle pt1 rad))
 (- (getvar "millisecs") time))
(defun Circle (cen rad) (entmake (list (cons 0 "CIRCLE") (cons 10 cen) (cons 40 rad))))
 


<<

Filename: 238890_ha1_ha2.lsp
Tác giả: kedensau88
Bài viết gốc: 210204
Tên lệnh: weld
Giao diện hộp thoại trong AutoLisp
Chào các anh,nhờ các anh xem giúp cho em đoạn lisp em viết ở đây sai chỗ nào mà nó ko hiển thị ảnh được :
File .DCL :

//WELD
weld :dialog {label = "Welding Detail";
:boxed_row {label = "Select Type"; height = 12;
:list_box {key = "type1"; width = 30;}
: image {key = "img"; width = 30; color = 0;}
}
spacer;
:row {
:button {label = "OK"; key =...
>>
Chào các anh,nhờ các anh xem giúp cho em đoạn lisp em viết ở đây sai chỗ nào mà nó ko hiển thị ảnh được :
File .DCL :

//WELD
weld :dialog {label = "Welding Detail";
:boxed_row {label = "Select Type"; height = 12;
:list_box {key = "type1"; width = 30;}
: image {key = "img"; width = 30; color = 0;}
}
spacer;
:row {
:button {label = "OK"; key = "ok"; width = 15; fixed_width = true;}
:button {label = "Cancel"; is_cancel = true; key = "cancel"; width = 15; fixed_width = true;}
}
}

http://direct1.anhso.net/original/16/168851/2682012102916346.jpg

File Lisp :

(defun saveVars()
(setq sStr1(get_tile "type1"))
(if(= sStr1 "")
(setq myItem1 "Nothing")
(setq myItem1 (nth (atoi sStr1) type1)))
)
;;;--------------------------------------------------------------
(defun weld_dialog( / i)
(setq type1(list "EXIT" "M-0" "M-1" "M-2"))
(setq i (load_dialog "weld\\weld.dcl"))
(if (not (new_dialog "weld" i)) (exit))
(start_list "type1" 3)
(mapcar 'add_list type1)
(end_list)
(action_tile "ok" "(setq ddiag 2)(saveVars)(done_dialog)")
(action_tile "cancel" "(setq ddiag 1)(done_dialog)")
(start_dialog) (unload_dialog i)
)
;;;--------------------------------------------------------
(start_image "img")
(fill_image 0 0 (dimx_tile "img") (dimy_tile "img") 0)
(slide_image 5 -10 (dimx_tile "img") (dimy_tile "img") "WELD")
(end_image)
;;;--------------------------------------------------------------
(defun C:weld()
(weld_dialog)
(if(= ddiag 1)
(princ "\n Weld cancelled!")
)
(if(= ddiag 2)
(progn
(command "-insert" myItem1 pause "" "" "")))
)
(princ)
;;;--------------------------------------------------------------



Em đã tạo được file WELD.slb đề cho nó hiện ảnh mà ko biết em làm sai chỗ nào nữa,các anh xem giúp em với.
Cảm ơn các anh nhiều.
<<

Filename: 210204_weld.lsp
Tác giả: whatcholingon
Bài viết gốc: 275600
Tên lệnh: cte
[ Yêu Cầu ] LISP xuất các text trong vùng kín

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!


<<

Filename: 275600_cte.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 275683
Tên lệnh: cte
[ Yêu Cầu ] LISP xuất các text trong vùng kín

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

<<

Filename: 275683_cte.lsp
Tác giả: conghoa
Bài viết gốc: 275951
Tên lệnh: psimple psimplev
Xóa bớt đỉnh
;;;============================================== 
;;; 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


<<

Filename: 275951_psimple_psimplev.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 275786
Tên lệnh: ha
Xin lisp lấy màu đối tượng

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

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

Filename: 275786_ha.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 275867
Tên lệnh: getcol
Xin lisp lấy màu đối tượng

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


<<

Filename: 275867_getcol.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 276072
Tên lệnh: aps
Hỏi về hàm trong lisp

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

;----- Add/Change Prefix and/or Suffix for DIMENSION, TEXT, MTEXT, ATTDEF. De tim hieu code >> nen mo trong Notepad++.
;----- Doan Van Ha - CadMagic - Ver.1: 15/9/2013
(vl-load-com)
(defun C:APS ( / dial flag lstobj lstkey lstvar fn Add_Prefix_Suffix SelectObj Ss->Lst Old_APS New_APS HA:SetVal Make_File_Dcl)
;----- Sub...
>>

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

;----- Add/Change Prefix and/or Suffix for DIMENSION, TEXT, MTEXT, ATTDEF. De tim hieu code >> nen mo trong Notepad++.
;----- Doan Van Ha - CadMagic - Ver.1: 15/9/2013
(vl-load-com)
(defun C:APS ( / dial flag lstobj lstkey lstvar fn Add_Prefix_Suffix SelectObj Ss->Lst Old_APS New_APS HA:SetVal Make_File_Dcl)
;----- Sub Functions
 (defun Add_Prefix_Suffix (lst pre suf add) ;Add Prefix vµ/hoÆc Suffix cho lstobj.
  (command "undo" "be")
  (if (and lst pre suf)
   (mapcar
   '(lambda (obj / typ txt pre1 suf1)
     (setq typ (cdr (assoc 0 (entget (vlax-vla-object->ename obj)))))
     (cond
      ((wcmatch typ "MTEXT,TEXT") (vla-put-TextString obj (strcat pre (vla-get-TextString obj) suf))) ;MultiLeader ???
      ((wcmatch typ "ATTDEF") (vla-put-TagString obj (strcat pre (vla-get-TagString obj) suf)))
      ((wcmatch typ "DIMENSION")
  (setq txt (cdr (assoc 1 (entget (vlax-vla-object->ename obj)))) pre1 (vla-get-TextPrefix obj) suf1 (vla-get-TextSuffix obj))
       (cond
        ((and (= txt "") (= add "0")) ; Nguyen thuy hoac da add pre/suf: Change
(vla-put-TextPrefix obj pre) (vla-put-TextSuffix obj suf))
((and (= txt "") (= add "1")) ; Nguyen thuy hoac da add pre/suf: Add
(vla-put-TextPrefix obj (strcat pre pre1)) (vla-put-TextSuffix obj (strcat suf1 suf)))
     (T ; Override: Add (not Change)
(vla-put-TextOverride obj (strcat pre txt suf))))))
     (vlax-release-object obj))
    lst))
  (command "undo" "e"))
 (defun SelectObj (lstvar lstkey / txt lst) ;Chän ®èi t­îng.
  (setq txt (apply 'strcat (mapcar '(lambda(var key) (if (= var "1") (strcat key ",") "")) (mapcar 'eval lstvar) lstkey)))
  (setq lst (Ss->Lst (ssget (list (cons 0 txt))) T)))
 (defun Ss->Lst (ss flag / lst) ;Convert selection set to list vla-object
  (and ss (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
   (if flag (setq lst (mapcar 'vlax-ename->vla-object lst))))
  lst)
 (defun Old_APS() ;®Æt chƠ ®é nh­ c̣.
  (setq text_old text mtext_old mtext attdef_old attdef dimension_old dimension pre_old pre suf_old suf add_old add change_old change))
 (defun New_APS() ;®Æt chƠ ®é míi nh­ c̣".
  (setq text text_old mtext mtext_old attdef attdef_old dimension dimension_old pre pre_old suf suf_old add add_old change change_ols))
 (defun HA:SetVal (lstkey lstvar lstval) ;Set value_default or set value_old for var + Set_tile for key. EX: (HA:SetVal '("key1" "key2" "key3") '(var1 var2 var3) '("0" "1" "a"))
  (mapcar '(lambda (var val) (if (not (eval var)) (set var val))) lstvar lstval)
  (mapcar '(lambda (key val) (set_tile key (set (read key) val))) lstkey (mapcar 'eval lstvar)))
 (defun Make_File_Dcl ( / fn ow dial) 
  (setq fn (vl-filename-mktemp "APS" nil ".dcl"))
  (setq ow (open fn "w"))
  (mapcar
  '(lambda (x) (write-line x ow))
   (list
"APS : dialog { label = \"CadMagic - Add prefix and suffix for objects\";"
" : boxed_column { label = \"Set variable\";"
"    : row {"
"      : boxed_column { label = \"Dimension\";"
"        : toggle { label = \"Dimension\"; key = \"dimension\"; }"
"        : radio_row {"
"          : radio_button { label = \"Add\";  key = \"add\"; }"
"          : radio_button { label = \"Change\";  key = \"change\"; }"
"        }"
"      }"
"      : boxed_row { label = \"Text/Mtext/Attdef\";"
"        : toggle { label = \"Text\"; key = \"text\"; }"
"        : toggle { label = \"Mtext\"; key = \"mtext\"; }"
"        : toggle { label = \"Attdef\"; key = \"attdef\"; }"
"      }"
"    }"
"    : column {"
"      : edit_box { label = \"Prefix:\"; key = \"pre\"; edit_width = 45; }"
"      : edit_box { label = \"Suffix:\"; key = \"suf\"; edit_width = 45; }"
"    }"
" : button { label = \"Select objects\"; key = \"chon\"; fixed_width = true; alignment = centered; }"
"  }"
"  ok_cancel;"
"}"))
  (close ow)
  fn)
;----- Main Function.
 (setq dial (load_dialog (setq fn (Make_File_Dcl))) flag 3)
 (while (> flag 1)
  (if (not (new_dialog "APS" dial)) (exit))
  (Old_APS)
  (HA:SetVal (setq lstkey '("text" "mtext" "attdef" "dimension" "pre" "suf" "add" "change"))
            (setq lstvar '(text mtext attdef dimension pre suf add change)) '("0" "0" "0" "0" "Prefix" "Suffix" "1" "0"))
  (action_tile "text" "(setq text $value)")
  (action_tile "mtext" "(setq mtext $value)")
  (action_tile "attdef" "(setq attdef $value)")
  (action_tile "dimension" "(setq dimension $value)")
  (action_tile "pre" "(setq pre $value)")
  (action_tile "suf" "(setq suf $value)")
  (action_tile "add" "(setq add $value change \"0\")")
  (action_tile "change" "(setq change $value add \"0\")")
  (action_tile "Cancel" "(done_dialog 0)")
  (action_tile "Accept" "(done_dialog 1)")
  (action_tile "chon" "(done_dialog 2)")
  (setq flag (start_dialog))
  (cond ((= 0 flag) (New_APS))
        ((= 2 flag) (setq lstobj (SelectObj lstvar lstkey)))
        ((= 1 flag) (Add_Prefix_Suffix lstobj pre suf add))))
 (unload_dialog dial) (vl-file-delete fn) (princ))
;--------------------------------------------------------------------------------------------------------------------------------------
 


<<

Filename: 276072_aps.lsp
Tác giả: Tue_NV
Bài viết gốc: 276062
Tên lệnh: dop
Nhờ Viết Lisp Dim hàng loạt theo phương đứng

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))
  )
)
)
(defun c:dop(/ Tue-dxf Tue-ent-Lpoint cur line dd)
(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))
  )
)
)

<<

Filename: 276062_dop.lsp
Tác giả: Tue_NV
Bài viết gốc: 276115
Tên lệnh: dop
Nhờ Viết Lisp Dim hàng loạt theo phương đứng

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

<<

Filename: 276115_dop.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 276123
Tên lệnh: xdpl
Xóa bớt đỉnh

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

)       

 


<<

Filename: 276123_xdpl.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 150458
Tên lệnh: udt
Viết lisp theo yêu cầu [phần 2]

Hề hề hề,
Xin lỗi vì chậm trả lời, Suốt tuần qua mình có việc gấp phải về quê nên không vào mạng được.
Bạn dùng thử cái này xem sao. Do làm vội và chưa test thử nên nhờ bạn test giùm. Nếu có trục trặc , hãy post lên để mình sửa lại nhé.

Filename: 150458_udt.lsp

Trang 149/312

149