Jump to content
InfoFile
Tác giả: leejang
Bài viết gốc: 141664
Tên lệnh: dc
lisp đổi màu tất cả các đường DIM ?

Do bạn dùng Dim override nên khi update dim, cad trả về nguyên thuỷ (gốc bạn để extendline có 2 unit, nên nhìn như bị chặt).

Thôi đành...

>>

Do bạn dùng Dim override nên khi update dim, cad trả về nguyên thuỷ (gốc bạn để extendline có 2 unit, nên nhìn như bị chặt).

Thôi đành không dùng Cadcommand nữa, ta dùng Vlisp cho nó sang ^^. Bạn thay lại thằng này :

(defun C:dc()
(vl-load-com)
(foreach ent (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "X" '((0 . "DIMENSION")))))))
(vla-put-Textcolor ent "2")
(if (vlax-property-available-p ent 'DimensionLinecolor)
(vla-put-DimensionLinecolor ent "30")
)
(if (vlax-property-available-p ent 'ExtensionLinecolor)
(vla-put-ExtensionLinecolor ent "30")
)
)
)

ok. Em cảm ơn bác nhé !!! hihihi


<<

Filename: 141664_dc.lsp
Tác giả: huytung89
Bài viết gốc: 334484
Tên lệnh: colorx colorxref colorxl colorxrefl
Đổi màu tất cả các đối tượng trên bản vẽ thành một màu duy nhất

Cái lisp này mình sưu tầm được trên mạng đã lâu. Nay thấy bạn có nhu cầu mình port lên bạn xem có vư ý không...

>>

Cái lisp này mình sưu tầm được trên mạng đã lâu. Nay thấy bạn có nhu cầu mình port lên bạn xem có vư ý không nhé.

;;; Posted Vladimir Azarko (VVA);;; ;;;;http://www.cadtutor.net/forum/showthread.p...=533&page=2(defun C:COLORX	(/ doc col)  (vl-load-com)  (setq doc (vla-get-activedocument (vlax-get-acad-object)))  (vla-startundomark doc)  (mip:layer-status-save)  (if (setq col (acad_colordlg 7 t))    (ChangeAllObjectsColor doc col) ;_ col — color number  ) ;_ end of if  (mip:layer-status-restore)  (vla-endundomark doc)  (princ)) ;_ end of defun(defun C:COLORXREF (/ doc col)  (vl-load-com)  (alert    "\This lisp change color xref\nONLY ON A CURRENT SESSION"  ) ;_ end of alert  (setq doc (vla-get-activedocument (vlax-get-acad-object)))  (vla-startundomark doc)  (mip:layer-status-save)  (if (setq col (acad_colordlg 7 t))    (ChangeXrefAllObjectsColor doc col) ;_ col — color number  ) ;_ end of if  (mip:layer-status-restore)  (vla-endundomark doc)  (princ)) ;_ end of defun(defun C:COLORXL (/ doc col)  (vl-load-com)  (setq doc (vla-get-activedocument (vlax-get-acad-object)))  (vla-startundomark doc)  (if (setq col (acad_colordlg 7 t))    (ChangeAllObjectsColor doc col) ;_ col — color number  ) ;_ end of if  (vla-endundomark doc)  (princ)) ;_ end of defun(defun C:COLORXREFL (/ doc col)  (vl-load-com)  (alert    "\This lisp change color xref\nONLY ON A CURRENT SESSION"  ) ;_ end of alert  (setq doc (vla-get-activedocument (vlax-get-acad-object)))  (vla-startundomark doc)  (if (setq col (acad_colordlg 7 t))    (ChangeXrefAllObjectsColor doc col) ;_ col — color number  ) ;_ end of if  (vla-endundomark doc)  (princ)) ;_ end of defun(defun mip:layer-status-restore	()  (foreach item	*MIP_LAYER_LST*    (if	(not (vlax-erased-p (car item)))      (vl-catch-all-apply	'(lambda ()	   (vla-put-lock (car item) (cdr (assoc "lock" (cdr item))))	   (vla-put-freeze	     (car item)	     (cdr (assoc "freeze" (cdr item)))	   ) ;_ end of vla-put-freeze	 ) ;_ end of lambda      ) ;_ end of vl-catch-all-apply    ) ;_ end of if  ) ;_ end of foreach  (setq *MIP_LAYER_LST* nil)) ;_ end of defun(defun mip:layer-status-save ()  (setq *MIP_LAYER_LST* nil)  (vlax-for item (vla-get-layers		   (vla-get-activedocument (vlax-get-acad-object))		 ) ;_ end of vla-get-layers    (setq *MIP_LAYER_LST*	   (cons (list item		       (cons "freeze" (vla-get-freeze item))		       (cons "lock" (vla-get-lock item))		 ) ;_ end of cons		 *MIP_LAYER_LST*	   ) ;_ end of cons    ) ;_ end of setq    (vla-put-lock item :vlax-false)    (if	(= (vla-get-freeze item) :vlax-true)      (vl-catch-all-apply	'(lambda () (vla-put-freeze item :vlax-false))      ) ;_ end of vl-catch-all-apply    ) ;_ end of if  ) ;_ end of vlax-for) ;_ end of defun(defun ChangeXrefAllObjectsColor (Doc Color / tmp txtstr)  (vlax-for Blk	(vla-get-Blocks Doc)    (cond      ((or (= (vla-get-IsXref Blk) :vlax-true)	   (and	(= (vla-get-IsXref Blk) :vlax-false)		(wcmatch (vla-get-name Blk) "*|*")	   ) ;_ end of and       ) ;_ end of or       (vlax-for Obj Blk	 (if (and (vlax-write-enabled-p Obj)		  (vlax-property-available-p Obj 'Color)	     ) ;_ end of and	   (vla-put-Color Obj Color)	 ) ;_ end of if	 (if (and (vlax-write-enabled-p Obj)		 (vlax-property-available-p Obj 'TextString)	    ) ;_ end of and	  (progn	    (setq txtstr		   (if (vlax-method-applicable-p Obj 'FieldCode)		       (vla-FieldCode Obj)		       (vlax-get-property Obj 'TextString))		  )	    (setq tmp 0)	     (while (setq tmp (VL-STRING-SEARCH "\\C" txtstr tmp))	      (setq txtstr	      (vl-string-subst		(strcat (substr txtstr (1+ tmp) 2)(itoa Color) ";")		(substr txtstr (1+ tmp) (- (1+ (VL-STRING-SEARCH ";" txtstr tmp)) tmp))		txtstr		tmp)		    )	      (setq tmp (+ tmp 3))	      )	    (vla-put-Textstring Obj txtstr)	    )	) ;_ end of if	 (if (and (vlax-write-enabled-p Obj)		  (= (vla-get-ObjectName obj) "AcDbBlockReference")		  (= (vla-get-HasAttributes obj) :vlax-true)	     ) ;_ end of and	   (foreach att	(vlax-safearray->list			  (vlax-variant-value (vla-GetAttributes obj))			) ;_ end of vlax-safearray->list	     (if (and (vlax-write-enabled-p att)		      (vlax-property-available-p att 'Color)		 ) ;_ end of and	       (vla-put-Color att Color)	     ) ;_ end of if	   ) ;_ end of foreach	 ) ;_ end of if	 (if (and (vlax-write-enabled-p Obj)		  (wcmatch (vla-get-Objectname Obj) "*Dimension*,AcDb*Leader")	     ) ;_ end of and	   (progn	     (vl-catch-all-apply 'vla-put-ExtensionLineColor (list Obj Color))	     (vl-catch-all-apply 'vla-put-TextColor (list Obj Color))	     (vl-catch-all-apply 'vla-put-DimensionLineColor (list Obj Color))	     (if (vlax-property-available-p Obj 'LeaderLineColor)	       (progn		 (setq tmp (vla-getinterfaceobject(vlax-get-acad-object)(strcat "AutoCAD.AcCmColor."		(substr (getvar "ACADVER") 1 2))))		 (vla-put-colorindex  tmp  Color)		 (vl-catch-all-apply 'vla-put-LeaderLineColor (list Obj tmp))		 )	       )	   ) ;_ end of progn	 ) ;_ end of if       ) ;_ end of vlax-for      )      ((= (vla-get-IsLayout Blk) :vlax-true)       (vlax-for Obj Blk	 (if	   (and	(vlax-write-enabled-p Obj)		(vlax-property-available-p Obj 'Color)		(vlax-property-available-p Obj 'Path)		(wcmatch (strcase (vla-get-ObjectName Obj)) "*BLOCK*")	   ) ;_ end of and	    (vla-put-Color Obj Color)	 ) ;_ end of if       ) ;_ end of vlax-for      )      (t nil)    ) ;_cond  ) ;_ end of vlax-for  (vl-cmdf "_redrawall")) ;_ end of defun(defun ChangeAllObjectsColor (Doc Color / txtstr tmp txt count)  (vlax-for Blk	(vla-get-Blocks Doc)    (if	(= (vla-get-IsXref Blk) :vlax-false)      (progn	(setq count 0 txt (strcat "Changed " (vla-get-name Blk)))	(grtext -1 txt)      (vlax-for	Obj Blk	(setq count (1+ count))	(if (zerop(rem count 10))(grtext -1 (strcat txt " : " (itoa count))))	(if (and (vlax-write-enabled-p Obj)		 (vlax-property-available-p Obj 'Color)	    ) ;_ end of and	  (vla-put-Color Obj Color)	) ;_ end of if	(if (and (vlax-write-enabled-p Obj)		 (vlax-property-available-p Obj 'TextString)	    ) ;_ end of and	  (progn	    (setq txtstr		   (if (vlax-method-applicable-p Obj 'FieldCode)		       (vla-FieldCode Obj)		       (vlax-get-property Obj 'TextString))		  )	    (setq tmp 0)	    (while (setq tmp (VL-STRING-SEARCH "\\C" txtstr tmp))	      (setq txtstr	      (vl-string-subst		(strcat (substr txtstr (1+ tmp) 2)(itoa Color) ";")		(substr txtstr (1+ tmp) (- (1+ (VL-STRING-SEARCH ";" txtstr tmp)) tmp))		txtstr		tmp)		    )	      (setq tmp (+ tmp 3))	      )	    (vla-put-Textstring Obj txtstr)	    )	) ;_ end of if	(if (and (vlax-write-enabled-p Obj)		 (= (vla-get-ObjectName obj) "AcDbBlockReference")		 (= (vla-get-HasAttributes obj) :vlax-true)	    ) ;_ end of and	  (foreach att (vlax-safearray->list			 (vlax-variant-value (vla-GetAttributes obj))		       ) ;_ end of vlax-safearray->list	    (if	(and (vlax-write-enabled-p att)		     (vlax-property-available-p att 'Color)		) ;_ end of and	      (vla-put-Color att Color)	    ) ;_ end of if	  ) ;_ end of foreach	) ;_ end of if        (if (and (vlax-write-enabled-p Obj)		  (wcmatch (vla-get-Objectname Obj)  "*Dimension*,AcDb*Leader")	     ) ;_ end of and	   (progn	     (vl-catch-all-apply 'vla-put-ExtensionLineColor (list Obj Color))	     (vl-catch-all-apply 'vla-put-TextColor (list Obj Color))	     (vl-catch-all-apply 'vla-put-DimensionLineColor (list Obj Color))	     (if (vlax-property-available-p Obj 'LeaderLineColor)	       (progn		 (setq tmp (vla-getinterfaceobject(vlax-get-acad-object)(strcat "AutoCAD.AcCmColor."		(substr (getvar "ACADVER") 1 2))))		 (vla-put-colorindex  tmp  Color)		 (vl-catch-all-apply 'vla-put-LeaderLineColor (list Obj tmp))		 )	       )	   ) ;_ end of progn	 ) ;_ end of if      ) ;_ end of vlax-for      )    ) ;_ end of if  ) ;_ end of vlax-for (vl-cmdf "_redrawall")) ;_ end of defun(princ  "\nType ColorX, COLORXREF, ColorXL, COLORXREFL  in command line") ;_ end of princ

Rồi là dùng sao ? Gõ lệnh gì bác ?


<<

Filename: 334484_colorx_colorxref_colorxl_colorxrefl.lsp
Tác giả: a12k39duchao
Bài viết gốc: 413463
Tên lệnh: ha
Lisp Tự Động Đo Và Ghi Kích Thước Nhiều Đối Tượng

 

Mình  sửa luôn trong lisp bác #Ha < bên dưới này > cho bạn. Bạn copy về...

>>

 

Mình  sửa luôn trong lisp bác #Ha < bên dưới này > cho bạn. Bạn copy về xem thế nào. Bạn nên cám ơn những người cống hiến vì diễn đàn nhiều như bác Kết vs bác Bee kia kìa. :) Mình đi học mót thôi, trình còn gà lắm.

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/55599-yeu-cau-lisp-lay-gia-tri-cua-dimenson-text-va-xuat-ra-file-text/


(defun C:HA( / lst fn fw index x y z txt)	;Doan Van Ha Cadviet.com

 (princ "\nChon cac Text/Mtext/Dimension can xuat ra file...")

 (setq lst (acet-ss-to-list (ssget '((0 . "*TEXT,DIMENSION"))))

       	fn (getfiled "Chon file de save" "" "csv" 1)

       	fw (open fn "w")

       	index 0 x 1 y 1 z 1)

 (repeat (length lst)

  (cond

   ((= (cdr (assoc 0 (entget (nth index lst)))) "TEXT") (setq txt (strcat (cdr (assoc 1 (entget (nth index lst)))) "," "text" (itoa x)) x (1+ x)))

   ((= (cdr (assoc 0 (entget (nth index lst)))) "MTEXT") (setq txt (strcat (cdr (assoc 1 (entget (nth index lst)))) "," "mtext" (itoa y)) y (1+ y)))

   ((= (cdr (assoc 0 (entget (nth index lst)))) "DIMENSION")

	(if (= (cdr (assoc 1 (entget (nth index lst)))) "")

 	(setq txt (strcat (rtos (cdr (assoc 42 (entget (nth index lst))))) "," "dim" (itoa z) "," (cdr (assoc 8 (entget (nth index lst))))) z (1+ z))

 	(setq txt (strcat (cdr (assoc 1 (entget (nth index lst)))) "," "dim" (itoa z)  "," (cdr (assoc 8 (entget (nth index lst))))) z (1+ z)))))

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

  (setq index (1+ index)))

 (close fw))



Vâng! Không chỉ có Anh #ket; Anh #Bee; Anh #Ha mà còn có cả Anh nữa. Nếu không có tất cả mọi người thì bọn em vẫn đang hì hục làm thủ công. Vừa chậm, vừa không chuyên nghiệp.

Anh #DANH CONG xem lại hộ em nhé. Lisp không chạy được.

Và em cũng có nhờ mọi người xem lại mấy lisp, anh cũng ngó qua coi dzum em.

1. Lisp lấy giá trị của dimension từ giá trị của anh #ket: Anh đang xem nhưng em test thì thấy nó chưa hoạt động.

2. Lisp của A #KET em muốn giữ nguyên các đường gióng.

3. Lisp đếm chiều dài đối tượng và xuất ra excel. Em không muốn nó tổng hợp nữa. Mà để nguyên các giá trị đó. Tương tự như câu hỏi ở bài #14 http://www.cadviet.com/forum/topic/64022-yeu-cau-lisp-thong-ke-doan-thang/

 

Cảm ơn Anh!


<<

Filename: 413463_ha.lsp
Tác giả: 3d.decor
Bài viết gốc: 151827
Tên lệnh: mblk
Đổi vị trí base point của block thế nào

Muốn thay đổi vị trí của tất cả các block trong bản vẽ mà

>>

Muốn thay đổi vị trí của tất cả các block trong bản vẽ mà ko làm thay đổi điểm chèn của block (yêu cầu quả là rắc rối :) ) Bạn có thể dùng thử lisp sau đây, có thể sửa để rotate block với một góc xác định mà ko động chạm thay đổi gì đến block cả.

(defun bocdt (ss1 c) (entget (ssname ss1 c)))
;;;======================================
(defun C:Mblk (/ ssld sstmp Pbase obj Goc Dis Ptmp1 Ptmp2)
 (setq osm (getvar "osmode"))
 (setvar "osmode" 0)
 (Princ "\nChon 2 diem dinh huong di chuyen...")
 (Setq Ptmp1 (getpoint "\nDiem thu nhat (diem goc) ..."))
 (Setq	Ptmp2 (getpoint
	Ptmp1
	"\nDiem thu 2 (chi huong va khoang cach di chuyen) ..."
      )
Goc   (angle Ptmp1 Ptmp2)
Dis   (distance Ptmp1 Ptmp2)
 )

 (princ "Chon cac doi tuong block can di chuyen")
 (setq	ssld  (ssget '((0 . "Insert")))
Count (sslength ssld)
i1    0
  )
 (while (<= i1 (1- Count))
   (setq obj	(bocdt ssld i1)
  i1	(1+ i1)
  Pbase	(cdr (assoc 10 obj))
  Pdes	(polar Pbase goc dis)
   )

   (command "move" (cdr (assoc -1 obj)) "" Pbase pdes)
 )
 (setvar "osmode" osm)
)

 

Cái này dùng với những trường hợp "điểm chèn phải đi liền với đối tượng" (hố ga chẳng hạn - toạ độ hố ga thường lấy bằng cách lọc toạ độ block, di chuyển đối tượng trong block mà giữ nguyên điểm chèn thì đến lúc thi công...cống đặt một nơi, hố ga một nẻo :)

Select objects: ; error: no function definition: BOCDT

bị lỗi rồi

bác nào rảnh xem hộ em

em dùng cad 2012


<<

Filename: 151827_mblk.lsp
Tác giả: Bee
Bài viết gốc: 423355
Tên lệnh: all2+nil
LISP CHUYỂN MÀU LAYER
2 phút trước, hoavienquang đã nói:

có cái lisp này nhưng em ko...

>>
2 phút trước, hoavienquang đã nói:

có cái lisp này nhưng em ko biết lệnh là gì

 

 

(defun mip:layer-status-restore () (foreach item *MIP_LAYER_LST* (if (not (vlax-erased-p (car item))) (vl-catch-all-apply '(lambda () (vla-put-lock (car item) (cdr (assoc "lock" (cdr item)))) (vla-put-freeze (car item) (cdr (assoc "freeze" (cdr item)))) ) ;_ end of lambda ) ;_ end of vl-catch-all-apply ) ;_ end of if ) ;_ end of foreach (setq *MIP_LAYER_LST* nil) ) ;_ end of defun (defun mip:layer-status-save () (setq *MIP_LAYER_LST* nil) (vlax-for item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) (setq *MIP_LAYER_LST* (cons (list item (cons "freeze" (vla-get-freeze item)) (cons "lock" (vla-get-lock item)) ) ;_ end of cons *MIP_LAYER_LST* ) ;_ end of cons ) ;_ end of setq (vla-put-lock item :vlax-false) (if (= (vla-get-freeze item) :vlax-true) (vl-catch-all-apply '(lambda () (vla-put-freeze item :vlax-false)))) ) ;_ end of vlax-for ) ;_ end of defun (defun ChangeAllObjectsColor (Doc Color ) (vlax-for Blk (vla-get-Blocks Doc) (if (= (vla-get-IsXref Blk) :vlax-false) (vlax-for Obj Blk (if (vlax-property-available-p Obj 'Color) (vla-put-Color Obj Color) ) ) ) ) ) (defun C:COLORX ( / doc col) (vl-load-com) (setq doc (vla-get-activedocument (vlax-get-acad-object))) (vla-startundomark doc) (mip:layer-status-save) (if (setq col (acad_colordlg 7 t)) (ChangeAllObjectsColor doc col);_ col — color number ) (mip:layer-status-restore) (vla-endundomark doc) (princ) ) (princ "\nType ColorX in command line")

COLORX đó thôi.

 

Thử cái này, chưa test hết các trường hợp.

;;;Code by Lee Mac, Copyright
;;;Modified by Bee
(defun c:All2 nil
    (vlax-for block (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))
        (vlax-for obj block
            (if (wcmatch (vla-get-objectname obj) "AcDb*Dimension,AcDbAttributeDefinition")
                (if (wcmatch (vla-get-objectname obj) "AcDbAttributeDefinition")
                  (progn
                    (vl-catch-all-apply 'vla-put-color (list obj 5))
                    (vl-cmdf "_.AttSync" "Name" (vla-get-name block))
                    )
                  (foreach prop '(Color DimensionLineColor ExtensionLineColor TextColor)
                    (vl-catch-all-apply 'vlax-put-property (list obj prop 5))
                    )
                  )
                (vl-catch-all-apply 'vla-put-color (list obj 5));
            )
        )
    )
    (princ)
)

 


<<

Filename: 423355_all2+nil.lsp
Tác giả: thienthantk103
Bài viết gốc: 267449
Tên lệnh: tl
Lisp ghi chiều dài đoạn thẳng theo Scale factor của Dimstyle hiện thời

 

Đây là đoạn Lisp của bác ssg, mình có chỉnh lại một chút cho phù hợp với yêu cầu thứ nhất của bạn.

Riêng yêu cầu 2...

>>

 

Đây là đoạn Lisp của bác ssg, mình có chỉnh lại một chút cho phù hợp với yêu cầu thứ nhất của bạn.

Riêng yêu cầu 2 trong bản vẽ bạn ghi : thực hiện lệnh, chọn đối tuong cần đo và nếu không

chọn text để gán kết quả thì Enter và pick 1 điểm trên màn hình để xuất kết quả bằng số theo style text hiện thời.

Kết quả bằng số là kết quả gì vậy bạn ? bạn hãy nói rõ.

;;;--------------------------------------------------------------------
(defun Length1(e) (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)))
;;;--------------------------------------------------------------------
(defun C:TL( / ss L e)
(setq
ss (ssget (list (cons 0 "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")))
L 0.0
)
(vl-load-com)
(while (setq e (ssname ss 0))
(setq L (+ L (length1 e)))
(ssdel e ss)
)


(setq te (entget(car(entsel"\n Chon Text de gan ket qua :")))
te (subst (cons 1 (rtos L 2 2)) (assoc 1 te) te))
(entmod te)
)
;;;--------------------------------------------------------------------

Cái lisp này có thể thêm phần đổi màu chữ của text được chọn không ạ.

Xin cảm ơn


<<

Filename: 267449_tl.lsp
Tác giả: manhlinh.eng
Bài viết gốc: 418138
Tên lệnh: test
Lisp bẻ và nối đối tượng

Break 2 đường tại vị trí giao nhau

(defun c:test ( / ss ent1 ent2 inter)

(setq ss (ssget))

(setq ent1...

>>

Break 2 đường tại vị trí giao nhau

(defun c:test ( / ss ent1 ent2 inter)

(setq ss (ssget))

(setq ent1  (ssname ss 0)

      ent2  (ssname ss 1))

(setq inter  (vla-intersectwith

      (vlax-ename->vla-object ent1)

      (vlax-ename->vla-object ent2) acExtendBoth)

      inter (safearray-value (variant-value inter)))

(command "break" ent1  inter inter)

(command "break" ent2 inter inter)

)

SAO LOAD RỒI BẤM LỆNH TEST HOK ĐƯỢC XIN CHỈ GIÁO


<<

Filename: 418138_test.lsp
Tác giả: nguyentuan_hagl
Bài viết gốc: 104795
Tên lệnh: kh
'Tạo khung bản đồ'
Hiện tại mình có lisp tạo khung bản đồ tự động rất hay. Nhưng mình vẫn chưa hài lòng lắm vì chỉ tạo được khung bản đồ ở khi hình chữ nhật ở dạng...
>>
Hiện tại mình có lisp tạo khung bản đồ tự động rất hay. Nhưng mình vẫn chưa hài lòng lắm vì chỉ tạo được khung bản đồ ở khi hình chữ nhật ở dạng đứng, nếu hình chữ nhật mà bị nghiêng thì không đúng theo ý muốn.

Mình post lên đây lisp đó, nếu ai cần thì download về dùng tạm.

 

;;; Tu dong ve khung ban do .

 

 (defun c:kh ()
;;; (princ "\n                      CHUONG TRINH VE KHUNG BAN DO .")
(command "osnap" "Endpoint,Intersection")
(setvar "blipmode" 1)
  (setq sp (getpoint "\n Chon goc khung thu 1 (Goc trai ben tren): "))
  (setq ep (getpoint sp "\n Chon goc khung thu 2 (Goc phai ben duoi): "))

;   (princ "\n Chon goc khung thu 1 (Goc trai ben tren): ")
;   (setq sp (getpoint))

;  (prompt "\n Chon goc khung thu 2 (Goc phai ben duoi): ")
;  (setq ep (getcorner (getpoint)) )
 (command "osnap" "off")

  (setq tyle (getint "\n Hay cho ty le ban do <500>: "))
  (if (= tyle nil) (setq tyle 500.0))
(setvar "blipmode" 0)
;;--- Dat bien chung cho chuong trinh -----
 (setq x1 (nth 0 sp)) (setq y1 (nth 1 sp))
 (setq x2 (nth 0 ep)) (setq y2 (nth 1 ep))
 (setq dayn (/ (* tyle 0.05) 500.0))
 (setq kctn (/ tyle 142.857))
 (setq ktmk (/ (* tyle 1.75) 500.0))
 (setq caoc (/ (* tyle 0.90) 500.0))
 (setq dich (/ (* tyle 0.33) 500.0))
;;;---- ve khung trong ------
  (command "LAYER" "M" "KHUNG" "")
  (Command "PLINE"
            (list x1 y1)
            (list x2 y1)
            (list x2 y2)
            (list x1 y2)
            "C"
  )
;;;;-------Ve khung ngoai ----------
  (command "LAYER" "M" "KHUNG" "")
  (Command "PLINE"
            (list (- x1 kctn) (+ y1 kctn)) "w" dayn dayn
            (list (+ x2 kctn) (+ y1 kctn))
            (list (+ x2 kctn) (- y2 kctn))
            (list (- x1 kctn) (- y2 kctn))
            "C"
  )
;;;------- Ve net ngang va doc -------
(setq nhay (/ tyle 10.0))
(setq tmpX1 (/ x1 nhay)) (setq tmpX2 (fix tmpX1)) (setq x (* tmpX2 nhay))
(setq tmpY1 (/ y2 nhay)) (setq tmpY2 (fix tmpY1)) (setq y (* tmpY2 nhay))
;-------------------------------------
(command "style" "STANDARD" "" caoc "" "" "" "" "" "")
(while (<= x x2)
      (if (>= x x1)
         (command "LINE" (list x y1) (list x (+ y1 kctn)) ""
                  "LINE" (list x y2) (list x (- y2 kctn)) ""
                  "TEXT" "C" (list x (+ y1 (/ kctn 2))) 0. (rtos x 2 0)
                  "TEXT" "TC" (list x (- y2 (/ kctn 2))) 0. (rtos x 2 0)
         )
      ) ;endif
 (setq x (+ x nhay))
)
(while (<= y y1)
  (setq tmp1 (rtos y 2 0))
  (setq len1 (strlen tmp1))
  (if ( <= len1 3)
     (progn (setq bef "000") (setq aff tmp1))
     (progn (setq bef (substr tmp1 1 (- len1 3)))
      (setq aff (substr tmp1 (- len1 2) 3))
     )
  ) ;;if
     (if (>= y y2)
          (command "LINE" (list x1 y) (list (- x1 kctn) y) ""
                   "LINE" (list x2 y) (list (+ x2 kctn) y) ""
                   "TEXT" "BC" (list (- x1 (/ kctn 2)) y) 0. bef
                   "TEXT" "TC" (list (- x1 (/ kctn 2)) (- y dich)) 0. aff

                   "TEXT" "BC" (list (+ x2 (/ kctn 2)) y) 0. bef
                   "TEXT" "TC" (list (+ x2 (/ kctn 2)) (- y dich)) 0. aff
          )
     ); endif
 (setq y (+ y nhay))
)
;--------- Ve chu thap --------------
(setq nhay (/ tyle 10.0)) (setq tmpX1 (/ x1 nhay)) (setq tmpX2 (fix tmpX1))
(setq x (* tmpX2 nhay))
(setq tmpY1 (/ y2 nhay)) (setq tmpY2 (fix tmpY1))
(while (< x x2)
 (setq y (* tmpY2 nhay))
    (while (< y y1)
       (if (and (>= x x1) (>= y y2))
          (command "LINE" (list (- x ktmk) y) (list (+ x ktmk) y) "")
       )
       (if (and (>= y y2) (>= x x1))
          (command "LINE" (list x (- y ktmk)) (list x (+ y ktmk)) "")
       )
      (setq y (+ y nhay))
    )
 (setq x (+ x nhay))
)
(command "REDRAW")
); End of program

Xin nhờ các pro có thể chỉnh sửa giúp lisp này được ko?

Với thuật toán như trên, mình muốn quét 1 lần tất cả các hình như nhật (kể cả các hình chữ nhật bị nghiêng) ta tạo được các mắt lưới dấu thập (các mắt lưới đều song song với trục X và trục Y) đồng thời trên khung ghi text các tọa độ của mắt lưới đó. Mình upload ví dụ lên đây. Kính mong các Pro giúp đỡ

Ví dụ : http://www.4shared.com/file/bMvNVwMM/khungtoado.html

Cảm ơn mọi người đã quan tâm.

Chương trình này mình đã dùng ở TEDIPORT nhưng đó là phần mềm tích hợp trong Cad phải cài đặt

Nó tên là EGS hay gì đó mà lâu rồi mình không nhớ nổi. Trên khung mình có thể ghi theo tọa độ X Y hay tọa độ địa lý B L đều được hết

Nếu ai có phần mềm đó có thể gửi cho mình được không?

Bạn có thể upload lên diễn đàn để mọi người cùng dùng hoặc gửi vào hòm thư: heaven2407@gmal.com

Chân thành cảm ơn


<<

Filename: 104795_kh.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 167979
Tên lệnh: ft
lisp đổi font của text style siêu nhanh !

Cả 2 cách trên đều không đúng thì phải, mình đã thử cách này thì ok .

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

Cả 2 cách trên đều không đúng thì phải, mình đã thử cách này thì ok .

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=53830&pid=167735&st=0entry167735
;free lisp by cadviet,cd2k44
;link bai viet http://www.cadviet.com/forum/index.php?showtopic=53830
(defun c:FT (/ ent tstyle )
(command "undo" "be")
(setq ent (entsel "\n Pick text :"))
(setq TSTYLE (cdr (assoc 7 (entget (car ent)))))
(command "STYLE" TSTYLE "vntimeh.shx,vns.shx" "0" "1" "0" "N" "N" "N")
(setvar "TEXTSTYLE" Tstyle)
(command "undo" "end")
)

bác nào biết thêm tùy chọn tìm và thay thế toàn bộ font trong 1 file cad thành font .vntimeh.shx thì tốt quá

Cảm ơn nhiều !

Hề hề hề,

Bạn thử làm thế này xem sao nhé:

1/- Vô hiệu hóa dòng code (setq ent (entsel "\n Pick text :")) bằng cách thêm một vài dấu ; phía trước nó.

2/- Thêm vào dưới dòng code này đoạn code như sau:

(setq sst (acet-ss-to-list (ssget "x" (cons 0 "TEXT,MTEXT"))))

(foreach ent sst

3/- Thêm một dấu ngoặc đóng hàm foreach vào dưới dòng code: (setvar "TEXTSTYLE" Tstyle)

 

Sau đó load lại lisp và chạy thử xem có được như ý bạn muốn không nhé.

Hề hề hề,.....

Chúc bạn vui.


<<

Filename: 167979_ft.lsp
Tác giả: DCL
Bài viết gốc: 4811
Tên lệnh: lokhoan
lisp vẽ lỗ khoan
* Lisp của bạn chạy tốt, thuật toán sai.

Vì thế chịu, phải viết lại thôi.

 

* Đây là bài toán hình học không hề đơn giản. Mấu chốt bài toán là...

>>
* Lisp của bạn chạy tốt, thuật toán sai.

Vì thế chịu, phải viết lại thôi.

 

* Đây là bài toán hình học không hề đơn giản. Mấu chốt bài toán là làm sao để vẽ được đường bao của nó. còn hai vòng tròn nhỏ bên trong thì chỉ là mắt muỗi thôi.

 

* tạm thời, đặt tên hình như sau:

vlkhoan.gif

 

* Ta phải xác định được các toạ độ p3, p4, p5, p6, p7, p8 từ các toạ độ p1, p2 và hai bán kính r1 và r2. Để từ đó lần lượt vẽ các đoạn thẳng p3-p4, p5-p6 và các cung tròn p3-p7-p5 và p4-p8-p6.

 

* Để xác định điểm các điểm này, ta sẽ xác định thông qua khoảng cách tương đối với các điểm gốc p1, p2 và các góc tương đối giữa vectơ tạo bởi chúng và hai điểm này với trục x. Tóm lại, chúng ta sẽ xác định toạ độ của chúng thông qua các hệ toạ độ cực với tâm toạ độ lần lượt là p1 và p2.

 

* Để xác định p3:

- cần xác định góc p1,p3.

- Để xác định góc p1,p3 ta thấy góc này bằng góc tuyệt đối giữa p1, p2 cộng thêm góc p2-p1-p3 (tạm đặt tên là g).

- g=arctan(b/a).

- a = r1-r2.

- b = căn bậc hai của bình phương cạnh huyền l trừ đi bình phương của a.

- l là khoảng cách giữa p1 và p2

 

* Tương tự như vậy với các đỉnh còn lại.

 

* Và như vậy, mã lệnh lisp sẽ là:

(defun c:lokhoan()  
 (setq p1 (getpoint "\nTam 1: ")
r1 (getdist p1 "\nBan kinh 1: ")
p2 (getpoint "\nTam 2: ")
r2 (getdist p2 "\nBan kinh 2: ")
l  (distance p1 p2)
a  (abs (- r1 r2))
b  (sqrt (- (* l l) (* a a)))
g  (atan b a)
p3 (polar p1 (+ (angle p1 p2) g) r1)
p4 (polar p2 (+ (angle p1 p2) g) r2)
p5 (polar p1 (- (angle p1 p2) g) r1)
p6 (polar p2 (- (angle p1 p2) g) r2)
p7 (polar p1 (+ (angle p1 p2) pi) r1)
p8 (polar p2 (+ (angle p2 p1) pi) r2)
 )
 (luuos)
 (setvar "osmode" 0)
 (command ".line" p3 p4 "")
 (command ".line" p5 p6 "")
 (command ".arc" p3 p7 p5)
 (command ".arc" p4 p8 p6)
 (traos)
 (princ "\nVao ban kinh duong tron thu nhat:")
 (command ".circle" p1 pause)
 (princ "\nVao ban kinh duong tron thu hai:")
 (command ".circle" p2 pause)
 (princ)
)
(defun luuos ()
 (setq
   HOANH_OSMODE   (getvar "OSMODE")
   HOANH_AUTOSNAP (getvar "AUTOSNAP")
 )
)
(defun traos ()
 (if HOANH_OSMODE
   (setvar "OSMODE" HOANH_OSMODE)
 )
 (if HOANH_AUTOSNAP
   (setvar "AUTOSNAP" HOANH_AUTOSNAP)
 )
)

 

 

Đây là bài toán nghiêng về tính toán hình học hơn là viết lisp. Bác Hoành ơi đoạn lisp của bác chỉ đúng với một nửa thôi. Có nghĩa là nếu cho đường kính vòng tròn bên trái nhỏ hơn thì sẽ ra hình khác : 2 cạnh bên lúc này không phải tiếp tuyến với đường tròn nữa. Có lẽ phải phân biệt vòng tròn nào lớn hơn đặt ở đâu mới có công thức tính thích hợp.


<<

Filename: 4811_lokhoan.lsp
Tác giả: eng-hiep
Bài viết gốc: 82170
Tên lệnh: cbl
Đếm block thuộc tính
Hề hề,

Chào bạn eng_hiep,

Cao thủ thì hơi hiếm, song thấp thủ thì có đây. Bạn xài thử cái củ lisp này xem có bị giắt răng tí nào không...

>>
Hề hề,

Chào bạn eng_hiep,

Cao thủ thì hơi hiếm, song thấp thủ thì có đây. Bạn xài thử cái củ lisp này xem có bị giắt răng tí nào không nhé.

(defun c:cbl (/ a b ss i n c)
(setq a (getstring "\n Nhap ky tu dau cua block: ")
     b (getstring "\n Nhap ky tu duoi cua block: ")
     ss (ssget "X" (list (cons 0 "INSERT") (cons 2 a) (cons 66 1)))
     i 0 
     n (sslength ss)
     c 0 )
(while (< i n)
(setq ent (ssname ss i)
     elst (entget (entnext ent)))
(if (= (cdr (assoc 1 elst)) b )
(setq c (1+ i))
)
(setq i (1+ i))
)
(alert (strcat " Có " (itoa c) " block " a b " tren ban ve."))
(princ "\n He he đúng chua???")
(princ)
)

Nếu thấy giắt răng chỗ nào, bạn cứ post lên sẽ có nha sĩ gỡ giùm bạn. Hề hề hề. Chúc bạn ngon miệng.

Cao thủ cứ chơi em út hoài ^^ Giắt quá trời lun bác ui :rolleyes: Đếm số lượng bị sai (cái nào cũng đếm ra kết quả là 1 cả :() , Dùng lsp của bác xong em phải dùng thèn Task manager để tắt acad :rolleyes: Ah mà lsp của bác thiếu dấu ngoặc ở cuối đấy :rolleyes:

 

Code lisp đã được chỉnh sửa lại bởi PhamThanhBinh để khắc phục lỗi do upload ngày 18-12-2009


<<

Filename: 82170_cbl.lsp
Tác giả: ro88
Bài viết gốc: 213914
Tên lệnh: %2Bc
Nhờ sửa lisp cộng tăng dần với số bất kỳ

Tạm thời làm thế này:

(defun c:+c (/ b p1 p2 cong value dimzin)
(defun *error* (msg) (and dimzin (setvar "dimzin"...
>>

Tạm thời làm thế này:

(defun c:+c (/ b p1 p2 cong value dimzin)
(defun *error* (msg) (and dimzin (setvar "dimzin" dimzin)) (setq *error* nil) (princ))
(while (null (setq b (ssget ":S" '((0 . "TEXT") (1 . "~**,~**")))))
 (princ "\nKhong phai so. Chon lai.")
);_ end while
(setq dimzin (getvar "dimzin"))
(setvar "dimzin" 0)
(setq b     (ssname b 0)
      value (cdr (assoc 1 (entget B)))
);_ end setq
(or *cong* (setq *cong* 1.0))
(or (setq cong (getreal (strcat "\nNhap so cong them: <" (rtos *cong* 2 2) ">")))
    (setq cong *cong*)
);_ end or
(setq *cong* cong)
(setq p1 (getpoint "\nDiem moc: "))
(while (setq p2 (getpoint p1 "\nDiem tiep theo: "))
 (command "copy" b "" p1 p2)
 (setq value (rtos (+ cong (atof value)) 2 2))
 (entmod (subst (cons 1 value) (assoc 1 (entget (entlast))) (entget (entlast))))
);_ end while
(setvar "dimzin" dimzin)
(setq *error* nil)
(princ)
);_ end defun

 

Bạn ơi có thể cho kết quả xuất ra đè lên text cũ được ko vậy?


<<

Filename: 213914_%2Bc.lsp
Tác giả: lon ton
Bài viết gốc: 47197
Tên lệnh: r2p
lisp chuyển region sang pline!!
Có cần dùng lisp không? Bạn dùng lệnh BO tự khắc có pline kín. Region gốc ban đầu nếu không cần nữa thì cho hide hoặc del chúng đi?

Nếu bạn vẫn thích dùng lisp thì...

>>
Có cần dùng lisp không? Bạn dùng lệnh BO tự khắc có pline kín. Region gốc ban đầu nếu không cần nữa thì cho hide hoặc del chúng đi?

Nếu bạn vẫn thích dùng lisp thì đây:

;;;-----------------------------------
(defun 1re2pl(e)
(command "explode" e "")
(command "pedit" (entlast) "y" "j" "all" "" "")
)
;;;-----------------------------------
(defun C:R2P( / ss e)
(setq ss (ssget '((0 . "REGION"))))
(while (setq e (ssname ss 0))
(1re2pl e)
(ssdel e ss)
)
(princ)
)
;;;-----------------------------------

Cảm ơn bác nhé, đúng thứ em đang cần!


<<

Filename: 47197_r2p.lsp
Tác giả: Danh Cong
Bài viết gốc: 423428
Tên lệnh: cong
Hỏi về hàm vlax-curve-getPointAtDist
17 giờ trước, doductiep đã nói:

Cho em hỏi về...

>>
17 giờ trước, doductiep đã nói:

Cho em hỏi về hàm vlax-curve-getPointAtDist  (tìm điểm trên Cuver khi biết khoảng cách):

 

Các bác hiểu như thế nào thế nhỉ ^^, em thì suy luận theo nội dung này của chủ thớt:

(defun c:CONG ( / DIS DISOBJ OBJECT PARAM PT1 PT2)
  (vl-load-com)
  (setq object (car (entsel "\nPick Polyline: "))
    pt1 (getpoint "\nPick point:")
    dis (getreal "\nNhap khoang cach: "))

  (setq param (vlax-curve-getparamatpoint object pt1))
  (if     (= param 0)
        (progn     (setq pt2 (vlax-curve-getpointatdist object dis))
      );end progn 1
        (progn    (setq disobj (vlax-curve-getDistAtParam object (vlax-curve-getEndParam object))
              pt2 (vlax-curve-getpointatdist object (- disobj dis)))
      );end progn 2
 )
  (command "point" "non" pt2)
  (princ))

( Mà các anh cho em hỏi, làm sao bài đăng của em nó có màu mè, dễ nhìn code như của các bác vậy ?, em đăng cả file .lsp mà nó có mỗi đường dẫn thôi. )

Cong.lsp


<<

Filename: 423428_cong.lsp
Tác giả: hieuhx68
Bài viết gốc: 297454
Tên lệnh: rdt dtd rt rtd
Lisp rải đối tượng theo đơờng dẩn.

Đã chỉnh lại lisp thêm chức năng rải text thay đổi giá trị.

-Tên lệnh: RT.

-Hỏi chọn đối tượng ko phải text thì hòi...

>>

Đã chỉnh lại lisp thêm chức năng rải text thay đổi giá trị.

-Tên lệnh: RT.

-Hỏi chọn đối tượng ko phải text thì hòi miết đến khi nào chọn đúng text thì hỏi tiếp điểm chuẩn, trong dòng hỏi điểm chuần có lồng giá trị thay đổi text mặc định là 1 (nghĩa là giá trị text thay đổi theo kiểu cộng 1 giá trị) nếu muốn thay đổi giá trị này thì đừng chọn điểm chuẩn vội mà gỏ d enter lisp hỏi giá trị cộng thêm bạn nhập vào (nhận cả giá trị âm nhé). Nhập xong lisp tiếp tục hỏi chọn điềm chuẩn.

-Hỏi chọn các đối tượng muốn rải theo các đối tượng này là bất cứ cái gì bạn muốn lisp sẽ rải nhóm đối tượng này và cái text bạn chọn ban đầu (giá trị cái text sẽ thay đổi còn các đối tượng chép theo giữ nguyên) nếu không chép theo cái gì thì enter.

-Các bước tiếp theo giống như cũ.

*Trong này có lệnh chính:

-RTD: rải từ điểm đã trình bày hôm trước.

-RDT: rải đồi tượng đã trình bày hôm trước.

-RT: rải text trình bày hôm nay.

*Và 1 lệnh khuyến mại:

-DTD: đo từ điểm, dùng đo độ dài đối tượng giữa 2 điểm trên đối tượng đó.

 

(Defun c:rdt (/ ss doituong dsl dc ddd chondd chieudaicuver diemdau diemcuoi krai chieudaidoan slc sl index d2 p2 d5 p5 d3 p3 dt l m)
(vl-load-com)
(command "undo" "be")
(command "ucs" "")
(chonnhomdoituong)
(choncuver)

(setq diemchuan (vlax-curve-getPointAtDist chondd 0))
(setq diemdinhhuong (vlax-curve-getPointAtDist chondd chieudaicuver))

(setq chieudaitinh chieudaicuver) 
(setq dautinh +) 

(setq thuchienrai raikieukhongtext)
(hoikieuraicd)
(command "ucs" "p")
(command "undo" "end")
(princ)
)
;;;;;;;;;;;;;;;;;
(Defun c:dtd (/ ss doituong dsl dc ddd chondd chieudaicuver diemdau diemcuoi krai chieudaidoan slc sl index d2 p2 d5 p5 d3 p3 dt l m daidendiem)
(vl-load-com)
(command "undo" "be")
(command "ucs" "")
(choncuver)
(cdxuatphatdo)
(cdketthucdo)
(Cond
((< daidendiemdo daidenhuongdo) (setq chieudaidoan (- daidenhuongdo daidendiemdo))) 
((> daidendiemdo daidenhuongdo) (setq chieudaidoan (- daidendiemdo daidenhuongdo)))
) 
(command "undo" "end")
(princ (strcat "\nChieu dai doan do la: " (rtos chieudaidoan 2 4))) 
(princ)
)
;;;;;;;;;;;;;;;;;
(Defun c:rt (/ ss doituong dsl dc ddd chondd chieudaicuver diemdau diemcuoi krai chieudaidoan slc sl index d2 p2 d5 p5 d3 p3 dt l m daidendiem)
(vl-load-com)
(command "undo" "be")
(command "ucs" "")
(chonnhomdoituongtext)

(princ "\nChon doi tuong rai kem theo text :")
(setq ss (ssget))
(cond 
((= ss nil) (setq thuchienrai raikieutextkokem))
((/= ss nil) (setq thuchienrai raikieutextcokem))) 

(choncuver)
(chondiemxuatphat)
;(setq thuchienrai raikieutext)
(hoikieuraicd)
(command "ucs" "p")
(command "undo" "end")
(princ)
)
;;;;;;;;;;;;;;;;;
(Defun c:rtd (/ ss doituong dsl dc ddd chondd chieudaicuver diemdau diemcuoi krai chieudaidoan slc sl index d2 p2 d5 p5 d3 p3 dt l m daidendiem)
(vl-load-com)
(command "undo" "be")
(command "ucs" "")
(chonnhomdoituong)
(choncuver)
(chondiemxuatphat)
(setq thuchienrai raikieukhongtext)
(hoikieuraicd)
(command "ucs" "p")
(command "undo" "end")
(princ)
)
;;;;;;;;;;;;;;;;;
(Defun chondiemchuandoituong ()
(setq dc (getpoint "\nChon diem goc: "))
(cond 
((= dc nil) (princ "\nChua chon duoc diem goc:") (chondiemchuandoituong))
((/= ss nil))) 
(princ)
)
;;;;;;;;;;;;;;;;;
(Defun chonnhomdoituongtext ()
(if (null congthem)(setq congthem "1"))
(setq ddd (entsel "\nChon text mau"))
(while
(or
(null ddd)
(/= "TEXT" (cdr (assoc 0 (entget (car ddd)))))
)
(princ "\nDoi tuong khong phai la text! Chon lai")
(setq ddd (entsel "\nChon text mau"))
)
(setq sst (car ddd))
(setq DTTT (entget sst))
(setq NDTTT (cdr (assoc 1 DTTT)))
(Setq temp T)
(While temp
(setq dc (strcat "\nDon vi cong them la(" congthem "): ")) 
(Initget "D")
(setq str (getpoint dc))
(Cond
((= str "D") (setq congthem (getstring (strcat"\nDon vi cong them la <" congthem "> :"))))
(Progn
(Setq dc str)
(setq temp nil)
)
)
)
(princ)
)

;;;;;;;;;;;;;;;;;
(Defun dotructiep ()
(cdxuatphatdo)
(cdketthucdo)
(Cond
((< daidendiemdo daidenhuongdo) (setq chieudaidoan (- daidenhuongdo daidendiemdo))) 
((> daidendiemdo daidenhuongdo) (setq chieudaidoan (- daidendiemdo daidenhuongdo)))
) 
(princ)
)
;;;;;;;;;;;;;;;;;
(Defun cdxuatphatdo ()
(setq luubatdiem (getvar "osmode"))
(setvar "osmode" 545)
(setq diemchuando (getpoint "\nTu diem :"))
(setvar "osmode" 0)
(setq daidendiemdo (vlax-curve-getDistAtPoint chondd diemchuando))
(setvar "osmode"luubatdiem)
(cond 
((= daidendiemdo nil) (princ "\nDiem vua chon khong nam tren duong dan, chon lai:") (cdxuatphatdo))
((/= daidendiemdo nil))) 
(princ)
)
;;;;;;;;;;;;;;;;;
(Defun cdketthucdo ()
(setq luubatdiem (getvar "osmode"))
(setvar "osmode" 545)
(setq diemdinhhuongdo (getpoint diemchuando"\nDen diem :"))
(setvar "osmode" 0)
(setq daidenhuongdo (vlax-curve-getDistAtPoint chondd diemdinhhuongdo))
(setvar "osmode"luubatdiem)
(cond 
((= daidenhuongdo nil) (princ "\nDiem vua chon khong nam tren duong dan, chon lai:") (cdketthucdo))
((/= daidenhuongdo nil))) 
(princ)
)
;;;;;;;;;;;;;;;;;
(Defun cdxuatphat ()
(setq luubatdiem (getvar "osmode"))
(setvar "osmode" 545)
(setq diemchuan (getpoint "\nDiem bat dau rai tren duong dan:"))
(setvar "osmode" 0)
(setq daidendiem (vlax-curve-getDistAtPoint chondd diemchuan))
(setvar "osmode"luubatdiem)
(cond 
((= daidendiem nil) (princ "\nDiem vua chon khong nam tren duong dan, chon lai:") (cdxuatphat))
((/= daidendiem nil))) 
(princ)
)
;;;;;;;;;;;;;;;;;
(Defun cdketthuc ()
(setq luubatdiem (getvar "osmode"))
(setvar "osmode" 545)
(setq diemdinhhuong (getpoint diemchuan"\nDiem ket thuc rai tren duong dan:"))
(setvar "osmode" 0)
(setq daidenhuong (vlax-curve-getDistAtPoint chondd diemdinhhuong))
(setvar "osmode"luubatdiem)
(cond 
((= daidenhuong nil) (princ "\nDiem vua chon khong nam tren duong dan, chon lai:") (cdketthuc))
((/= daidenhuong nil))) 
(princ)
)
;;;;;;;;;;;;;;;;;
(Defun thongbaoketqua ()
(princ (strcat "\nChieu dai doan la: " (rtos chieudaitinh 2 4) doanhienthinoidung)) 
(princ)
)
;;;;;;;;;;;;;;;;;
(Defun chondiemxuatphat ()
(cdxuatphat)
(cdketthuc)
(Cond
((< daidendiem daidenhuong) (setq chieudaitinh (- daidenhuong daidendiem)) (setq dautinh +)) 
((> daidendiem daidenhuong) (setq chieudaitinh (- daidendiem daidenhuong)) (setq dautinh -))
) 
(setq doanxuatphat daidendiem)
(princ)
)
;;;;;;;;;;;;;;;;;
(Defun hoikieuraicd ()
(setq kraicd (strcase (getstring "\nKieu rai theo: Tinh /So luong/")))

(Cond
((= kraicd "T") (raisoluongtinh))
((/= kraicd "T") 
(Cond
((= kraicd "S") (raisoluongcd))
((/= kraicd "S") (raikhoangcachcd))
) 
)
) 
(princ)
)
;;;;;;;;;;;;;;
(Defun raisoluongtinh ()
(setq slrai (getreal "\nRai them may lan khong tinh doi tuong tai diem bat dau rai:"))
(setq chieudaidoan (GETDIST "\nKhoang cach 1 lan rai: "))
(Cond
((= chieudaidoan 0) (dotructiep)))

(setq tongdoan (* slrai chieudaidoan))
(Cond
((> tongdoan chieudaitinh) 
(princ (strcat "\nChieu dai doan la: " (rtos chieudaitinh 2 4) ", Yeu cau la: " (rtos chieudaidoan 2 4) "x" (rtos slrai 2 0) "=" (rtos tongdoan 2 4))) 
(princ "\nVuot qua chieu dai cho phep, nhap lai:") 
(raisoluongtinh))
((< tongdoan chieudaitinh) 
(setq sl (fix (+ slrai 1)))
(setq sl (fix sl))
(setq doanhienthinoidung (strcat "\nDa thuc hien rai: " (rtos slrai 2 0) " lan voi khoang cach " (rtos chieudaidoan 2 4))) 
(thuchienrai)
)
) 
(princ)
)
;;;;;;;;;;;;;;
(Defun raikhoangcachcd ()
(setq chieudaidoan (GETDIST "\nKhoang cach 1 lan rai: "))
(Cond
((= chieudaidoan 0) (dotructiep)))
(Cond
((> chieudaidoan chieudaitinh) 
(princ (strcat "\nChieu dai doan la: " (rtos chieudaitinh 2 4) ", Yeu cau la: " (rtos chieudaidoan 2 4))) 
(princ "\nVuot qua chieu dai cho phep, nhap lai:") 
(raikhoangcachcd))
((< chieudaidoan chieudaitinh) 
(setq sol (+ (/ chieudaitinh chieudaidoan) 1))
(setq sl (fix sol))
(setq sl (fix sl))
(setq doanhienthinoidung (strcat "\nDa thuc hien rai: " (rtos sol 2 0) " lan voi khoang cach " (rtos chieudaidoan 2 4))) 
(thuchienrai)
)
) 
(princ)
)
;;;;;;;;;;;;;;
(Defun raisoluongcd ()
(setq slc (getreal "\nChia duong dan thanh may lan:"))
(setq chieudaidoan (/ chieudaitinh slc))
(setq sl (fix (+ 1 slc)))
(setq doanhienthinoidung (strcat "\nDa thuc hien rai: " (rtos slc 2 0) " lan voi khoang cach " (rtos chieudaidoan 2 4))) 
(thuchienrai)
(princ)
)
;;;;;;;;;;;;;;
(Defun chonnhomdoituong ()
(princ "\nChon doi tuong rai:")
(setq ss (ssget))

(cond 
((= ss nil) (princ "\nChua chon duoc doi tuong nao:") (chonnhomdoituong))
((/= ss nil) 
(setq dsl (sslength ss))
(cond 
((= dsl 1) 
(setq doituong (ssname SS 0))
(setq doituong (entget doituong))
(setq KIEUDOITUONG (cdr (assoc 0 doituong)))
(cond 
((= KIEUDOITUONG "INSERT") (setq dc (cdr (assoc 10 doituong))))
((/= KIEUDOITUONG "INSERT") (chondiemchuandoituong))
);ketthuccondxemblock
);kethucdsl1
((/= dsl 1) (chondiemchuandoituong))
);ketthuccondnho

);ketthucsetqdsl
);ketthuccondtong 
(princ)
)
;;;;;;;;;;;;;;;;;
(Defun chondiemchuandoituong ()
(setq dc (getpoint "\nChon diem goc: "))
(cond 
((= dc nil) (princ "\nChua chon duoc diem goc:") (chondiemchuandoituong))
((/= ss nil))) 
(princ)
)
;;;;;;;;;;;;;;;;;
(Defun choncuver ()

(setq ddd (entsel "\nChon duong dan:"))
(while
(or
(null ddd)
(or (= "TEXT" (cdr (assoc 0 (entget (car ddd))))) (= "MTEXT" (cdr (assoc 0 (entget (car ddd))))) (= "HATCH" (cdr (assoc 0 (entget (car ddd))))) (= "INSERT" (cdr (assoc 0 (entget (car ddd))))) (= "REGION" (cdr (assoc 0 (entget (car ddd))))) (= "DIMENSION" (cdr (assoc 0 (entget (car ddd)))))
)
)
(setq ddd (entsel "\nDoi tuong khong the lam duong dan! Chon lai"))
)

(setq chondd (car ddd))
(setq luubatdiem (getvar "osmode"))
(setvar "osmode" 0)
(setq chieudaicuver (vlax-curve-getDistAtParam chondd (vlax-curve-getEndParam chondd)))
(setq doanxuatphat 0)
(setvar "osmode"luubatdiem)
(princ)
)
;;;;;;;;;;;;;;
(Defun raikieukhongtext (/ quaykhong)

(setq quaykhong (strcase (getstring "\nCo quay doi tuong vuong goc voi duong dan khong: Khong/")))
(Cond
((= quaykhong "K") (setq copygiua copykoquay))
((/= quaykhong "K")(setq copygiua copyquay))
) 

(setq index -1)

(repeat sl
(setq index (1+ index))
(setq d2 (dautinh doanxuatphat (* chieudaidoan index)))
(setq luubatdiem (getvar "osmode"))
(setvar "osmode" 0)
(setq p2 (vlax-curve-getPointAtDist chondd d2))
(setvar "osmode"luubatdiem)
(copygiua)
)
(thongbaoketqua)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;
(defun copycuoiquay()
(setq luubatdiem (getvar "osmode"))
(setvar "osmode" 0)
(setq d5 (- (dautinh doanxuatphat (* chieudaidoan index)) 0.01))
(setq p5 (vlax-curve-getPointAtDist chondd d5))
(setq L 0)
(setq M (sslength ss))
(while (< L M)
(setq DT (ssname ss L))
(command ".copy" DT "" dc p2)
(command ".rotate" "last" "" p2 p5)
(command ".rotate" "last" "" p2 180)
(setq L (1+ L))
)
(setvar "osmode"luubatdiem)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;
(defun COPYQUAY(/ p3)
(setq luubatdiem (getvar "osmode"))
(setvar "osmode" 0)
(setq d3 (+ (dautinh doanxuatphat (* chieudaidoan index)) 0.001))
(setq p3 (vlax-curve-getPointAtDist chondd d3))
(setvar "osmode"luubatdiem)
(Cond
((= p3 nil) (copycuoiquay))
((/= p3 nil) 
(setq L 0)
(setq M (sslength ss))
(setq luubatdiem (getvar "osmode"))
(setvar "osmode" 0)
(while (< L M)
(setq DT (ssname ss L))
(command ".copy" DT "" dc p2)
(command ".rotate" "last" "" p2 p3)
(setq L (1+ L))
)
(setvar "osmode"luubatdiem)
)
) 


(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;
(Defun raikieutextcokem (/ quaykhong)

(setq quaykhong (strcase (getstring "\nCo quay doi tuong vuong goc voi duong dan khong: Khong/")))
(Cond
((= quaykhong "K") (setq copygiuatext copykoquaytext) (setq copygiua copykoquay))
((/= quaykhong "K")(setq copygiuatext copyquaytext) (setq copygiua copyquay))
) 

(setq index -1)

(repeat sl
(setq index (1+ index))
(setq d2 (dautinh doanxuatphat (* chieudaidoan index)))
(setq luubatdiem (getvar "osmode"))
(setvar "osmode" 0)
(setq p2 (vlax-curve-getPointAtDist chondd d2))
(setvar "osmode"luubatdiem)
(copygiuatext)
(copygiua)
)
(thongbaoketqua)
(princ)
)
;;;;;;;;;;;;;;
(Defun raikieutextkokem (/ quaykhong)

(setq quaykhong (strcase (getstring "\nCo quay doi tuong vuong goc voi duong dan khong: Khong/")))
(Cond
((= quaykhong "K") (setq copygiuatext copykoquaytext))
((/= quaykhong "K")(setq copygiuatext copyquaytext))
) 

(setq index -1)

(repeat sl
(setq index (1+ index))
(setq d2 (dautinh doanxuatphat (* chieudaidoan index)))
(setq luubatdiem (getvar "osmode"))
(setvar "osmode" 0)
(setq p2 (vlax-curve-getPointAtDist chondd d2))
(setvar "osmode"luubatdiem)
(copygiuatext)
)
(thongbaoketqua)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;
(defun copycuoiquaytext ()
(setq luubatdiem (getvar "osmode"))
(setvar "osmode" 0)
(setq d5 (- (dautinh doanxuatphat (* chieudaidoan index)) 0.01))
(setq p5 (vlax-curve-getPointAtDist chondd d5))
(command ".copy" sst "" dc p2)
(command ".rotate" "last" "" p2 p5)
(command ".rotate" "last" "" p2 180)
(setq congthems (atoi congthem)) 
(setq DTDM (entlast))

(if (and (>= (ascii NDTTT) 48) (<= (ascii NDTTT) 57))
(setq NDTTT (itoa (+ (atoi NDTTT) congthems)))
(setq NDTTT (chr (+ (ascii NDTTT) congthems)))
)

(setq Elist (entget DTDM)) 
(setq Oldlist (assoc 1 Elist)) 
(setq Oldtext (cdr Oldlist))
(setq Oldtext (strcase Oldtext nil))
(setq Newlist (cons '1 NDTTT))
(setq Elist (subst Newlist Oldlist Elist))
(entmod Elist)
(setvar "osmode"luubatdiem)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;
(defun COPYQUAYtext (/ p3)
(setq luubatdiem (getvar "osmode"))
(setvar "osmode" 0)
(setq d3 (+ (dautinh doanxuatphat (* chieudaidoan index)) 0.001))
(setq p3 (vlax-curve-getPointAtDist chondd d3))
(setvar "osmode"luubatdiem)
(Cond
((= p3 nil) (copycuoiquaytext))
((/= p3 nil) 
(setq luubatdiem (getvar "osmode"))
(setvar "osmode" 0)
(command ".copy" sst "" dc p2)
(command ".rotate" "last" "" p2 p3)


(setq congthems (atoi congthem)) 
(setq DTDM (entlast))

(if (and (>= (ascii NDTTT) 48) (<= (ascii NDTTT) 57))
(setq NDTTT (itoa (+ (atoi NDTTT) congthems)))
(setq NDTTT (chr (+ (ascii NDTTT) congthems)))
)

(setq Elist (entget DTDM)) 
(setq Oldlist (assoc 1 Elist)) 
(setq Oldtext (cdr Oldlist))
(setq Oldtext (strcase Oldtext nil))
(setq Newlist (cons '1 NDTTT))
(setq Elist (subst Newlist Oldlist Elist))
(entmod Elist)
(setvar "osmode"luubatdiem)
)
) 


(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;
(defun COPYKOQUAYtext ()
(setq luubatdiem (getvar "osmode"))
(setvar "osmode" 0)
(command ".copy" sst "" dc p2 "")
(setq congthems (atoi congthem)) 
(setq DTDM (entlast))

(if (and (>= (ascii NDTTT) 48) (<= (ascii NDTTT) 57))
(setq NDTTT (itoa (+ (atoi NDTTT) congthems)))
(setq NDTTT (chr (+ (ascii NDTTT) congthems)))
)

(setq Elist (entget DTDM)) 
(setq Oldlist (assoc 1 Elist)) 
(setq Oldtext (cdr Oldlist))
(setq Oldtext (strcase Oldtext nil))
(setq Newlist (cons '1 NDTTT))
(setq Elist (subst Newlist Oldlist Elist))
(entmod Elist)
(setvar "osmode"luubatdiem)
(princ)
)
;;;;;;;;;;;;;;

Bác ơi lips quá tuyệt vời ạ. Nhưng bác cho em thêm lựa chọn rải block nữa được ko. Em rải block ko được bác ạ. bác xem lại xem có phải không giúp em.


<<

Filename: 297454_rdt_dtd_rt_rtd.lsp
Tác giả: vndesperados
Bài viết gốc: 32580
Tên lệnh: mblk
Đổi vị trí base point của block thế nào
Muốn thay đổi vị trí của tất cả các block trong bản vẽ mà ko làm thay đổi...
>>
Muốn thay đổi vị trí của tất cả các block trong bản vẽ mà ko làm thay đổi điểm chèn của block (yêu cầu quả là rắc rối :) ) Bạn có thể dùng thử lisp sau đây, có thể sửa để rotate block với một góc xác định mà ko động chạm thay đổi gì đến block cả.

(defun bocdt (ss1 c) (entget (ssname ss1 c)))
;;;======================================
(defun C:Mblk (/ ssld sstmp Pbase obj Goc Dis Ptmp1 Ptmp2)
 (setq osm (getvar "osmode"))
 (setvar "osmode" 0)
 (Princ "\nChon 2 diem dinh huong di chuyen...")
 (Setq Ptmp1 (getpoint "\nDiem thu nhat (diem goc) ..."))
 (Setq	Ptmp2 (getpoint
	Ptmp1
	"\nDiem thu 2 (chi huong va khoang cach di chuyen) ..."
      )
Goc   (angle Ptmp1 Ptmp2)
Dis   (distance Ptmp1 Ptmp2)
 )

 (princ "Chon cac doi tuong block can di chuyen")
 (setq	ssld  (ssget '((0 . "Insert")))
Count (sslength ssld)
i1    0
  )
 (while (<= i1 (1- Count))
   (setq obj	(bocdt ssld i1)
  i1	(1+ i1)
  Pbase	(cdr (assoc 10 obj))
  Pdes	(polar Pbase goc dis)
   )

   (command "move" (cdr (assoc -1 obj)) "" Pbase pdes)
 )
 (setvar "osmode" osm)
)

 

Cái này dùng với những trường hợp "điểm chèn phải đi liền với đối tượng" (hố ga chẳng hạn - toạ độ hố ga thường lấy bằng cách lọc toạ độ block, di chuyển đối tượng trong block mà giữ nguyên điểm chèn thì đến lúc thi công...cống đặt một nơi, hố ga một nẻo :)

 

 

Có lẽ phải nói thế này thì đúng hơn - thay đổi tâm (điểm chèn) của block mà không làm thay đổi vị trí của block (vị trí tương đối của block) với các đối tượng khác.

Code của bạn chưa tính đến trường hợp block bị scale, đặc biệt là vừa scale, vừa rotate và scale với hệ số âm


<<

Filename: 32580_mblk.lsp
Tác giả: whatcholingon
Bài viết gốc: 265879
Tên lệnh: ed
- Tự động bật - tắt chế độ gõ tiếng việt trong CAD

Lisp này mình lấy về tự chế lại còn bị lỗi 1 số chổ chưa sữa được (đó là phải nhập lệnh ed) nhưng dùng cũng tạm...

>>

Lisp này mình lấy về tự chế lại còn bị lỗi 1 số chổ chưa sữa được (đó là phải nhập lệnh ed) nhưng dùng cũng tạm được. Mình dùng cad2008

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/66851-da-xong-tu-dong-bat-tat-che-do-go-tieng-viet-trong-cad/page-2
 
(vl-load-com)
;;; Dinh nghia lai lenh ED de lay ename doi tuong
(defun c:ed (/ textedit font ent n-textedit n-obj n-ent dk code l-obj obj lst)
(SETQ OLDERR *error*
*error* myerror)
(sendkeys "^+")
(and (or (and (setq textedit (ssget "I"))
           	(sssetfirst textedit)
           	(setq obj (ssname textedit 0)))
      	(setq textedit (entsel) obj (car textedit)))
(while obj
;(setq lst (Start-defun nil))
;(setq textedit (car (entsel)))
(setq ent (cdr (assoc 0 (entget obj))))
(cond ((wcmatch ent "*TEXT"); text
(progn
(setq font (cdr (assoc 7 (entget obj))))
;(setq font (vla-get-stylename (vlax-ename->vla-object textedit)))
(call font)
(command "ddedit" textedit "")
))
((= ent "DIMENSION") ;Dimension
(progn
          	(setq font (vla-get-textstyle (vlax-ename->vla-object obj)))
			;(setq font (vla-get-textstyle (vlax-ename->vla-object textedit)))
          	(call font)
			(command "ddedit" textedit "")
))
((= ent "HATCH") ;Hatch
(progn
          	(initdia)
			(call font)
			(command "hatchedit" textedit)
))
((= ent "INSERT") ;Block
          	(and (eq (type textedit) 'LIST)
               	(setq n-textedit (nentselp (cadr textedit)))
               	(setq n-obj (car n-textedit))
               	(setq n-ent (entget n-obj))
               	(setq n-obj (vlax-ename->vla-object n-obj))
               	(cond ((= (cdr (assoc 0 n-ent)) "ATTRIB") ; Attribute
                      	(setq code (check-font-code (cdr (assoc 7 n-ent))))
                      	(if (eq (vla-get-mtextattribute n-obj) :vlax-false)
                       	(progn
                        	;(setq dk nil dk (sendkeys "^+"))
                        	(cond ((= code "TCVN3") (sendkeys "^+{F2}"))
                              	((= code "UNICODE") (sendkeys "^+{F1}"))
                              	((= code "VNI") (sendkeys "^+{F3}")))))
						(vl-cmdf "eattedit" textedit)
                       	(if dk (sendkeys "^+")))
                     	((wcmatch (cdr (assoc 0 n-ent)) "TEXT,MTEXT") ; Text,Mtext in Block
                      	(if (or extract_clone (and (not extract_clone) (load "trexblk.lsp")))
                       	(progn
                        	(extract_clone n-textedit)
                        	(vla-put-visible n-obj :vlax-false)
                        	(entupd obj)
                        	(progn
							(setq l-obj (entlast) font (cdr (assoc 7 n-ent)))
							(call font)
							(vl-cmdf "DDedit" l-obj "")
							)
                        	(vla-put-textstring n-obj (cdr (assoc 1 (entget l-obj))))
                        	(vla-put-visible n-obj :vlax-true)
                        	(entdel l-obj)
                        	(entupd obj))
                       	(princ "Ban chua cai dat goi Express tool cho CAD\n"))))))
); cond	
;(Done-defun lst)		
(setq textedit (entsel) obj (car textedit))
);while
);and
(back)
(command "HIGHLIGHT" 1 "")
(SETQ *error* OLDERR)
(princ))
;;; Ham call dieu khien bo go tieng viet
(defun call (font / code Crfont)
(if font (setq Crfont font) (setq Crfont (getvar "textstyle")))
   (setq code (check-font-code Crfont))
   (cond ((= code "TCVN3") (sendkeys "^+{F2}"))
((= code "UNICODE") (sendkeys "^+{F1}"))
((= code "VNI") (sendkeys "^+{F3}"))
)
)
;;; Ham tra lai English
(defun back ()
(sendkeys "^+")
)
;;; Ham kiem tra bang ma cua textstyle (su dung true type font)
;;; style: String - ten cua textstlye kiem tra
(defun Check-Font-Code (style / ts font Bold Italic charSet PitchandFamily)
(setq ts (vlax-ename->vla-object (tblobjname "style" style)))
(vla-GetFont ts 'font 'Bold 'Italic 'charSet 'PitchandFamily)
(if (= font "") (setq font (vla-get-fontfile ts)))
(cond ((wcmatch (setq font (strcase font)) "ARIAL*,TAHOMA*,TIMES*,COURIER NEW,CAMBRIA,CONSOLAS") "UNICODE")
    ((wcmatch font ".VN*") "TCVN3")
    ((wcmatch font "VNI*") "VNI")))
;;; Ham senkeys
(defun SendKeys (keys / wscript)
(vlax-invoke-method (setq wscript (vlax-create-object "WScript.Shell")) 'sendkeys keys)
(vlax-release-object wscript))
;;;Ham bay loi
(defun myerror (s)
(if (= s "Function Cancelled") (sendkeys "^+"))
  (setq *error* OLDERR)
  (princ)
)
(defun Start-defun (lst-var)
(defun *error* (msg)
(redraw)
(vl-cmdf "undo" "end")
(vl-cmdf "undo" "")
(princ));end
(vl-cmdf "undo" "begin")
(mapcar '(lambda(x) (list x (getvar x))) lst-var));end
;;;
(defun Done-defun (lst-var / )
(mapcar '(lambda (x) (setvar (car x) (cadr x))) lst-var)
(vl-cmdf "undo" "end")
(princ));end

Bạn kiểm tra lại xem sau khi load lsp lên,khi chỉnh sửa text xong nó lại ko tự tắt unikey đi nhể!

Thanks!


<<

Filename: 265879_ed.lsp
Tác giả: dothuyth07
Bài viết gốc: 111442
Tên lệnh: chutoso
chuyển chữ thành số
Dạo này ít người yêu cầu viết lisp quá nên mình viết nghịch chơi cái lisp này.

Ngày xưa các bác chắc cũng từng thương thầm chộm nhớ một người nào...

>>
Dạo này ít người yêu cầu viết lisp quá nên mình viết nghịch chơi cái lisp này.

Ngày xưa các bác chắc cũng từng thương thầm chộm nhớ một người nào đấy. Muốn viết thư cho người ta mà lại e ngại không biết ý người ta thế nào.

Thế là các bác này nghĩ ra cái chò viết thư bằng số.

Ý nghĩa là nếu người ta có thích mình thì sẽ tìm cách mày mò để dịch (điều này kiểm tra luôn IQ của người đó). Nếu người đó không thích mình thì vèo một cái bay vào sọt rác.

Code đây (dành cho các bác nhát gan). Chú ý chữ để dịch phải không có dấu.

;; free lisp from cadviet.com
(defun c:chutoso()
(setq lis_chu '("A" "B" "C" "D" "E" "G" "H" "I" "K" "L" "M" "N" "O" "P" "Q" "R" "S" "T" "U" "V" "X" "Y" " "))
(setq lis_so '("4" "13" "6" "15" "3" "9" "76" "1" "16" "1" "111" "11" "0" "10" "2" "12" "5" "7" "22" "21" "96" "27"))
(setq name (car (entsel "\nChon chu la text hay mtext can chuyen sang so")))
(setq ent (entget name))
(setq loai (cdr (assoc 0 ent)))
(if (or (= loai "TEXT") (= loai "MTEXT"))
(progn
 (setq chu (strcase (cdr (assoc 1 ent))))
  (setq L (strlen chu) i L ma nil)
  (Repeat L
   (if (= (vl-position (substr chu i 1) lis_chu) 22)
(progn
   (setq kt " ")
   (setq ma (append (list kt) ma))
)
(progn    
   (setq kt (atoi (nth (vl-position (substr chu i 1) lis_chu) lis_so)))
    (setq ma (append (list (rtos kt 2 0)) ma))
)
)
(setq i (1- i))
)
(setq dct (getpoint "\nchon diem chen chu da dich")
chumoi (subst (cons 10 dct) (assoc 10 ent) ent)
chumoi (subst (cons 1 (apply 'strcat ma)) (assoc 1 chumoi) chumoi)
)
(entmake chumoi)
)
(alert (strcat "doi tuong ma cac bac chon la : " loai " khong phai la text hay mtext"))
)
)

 

cac bac cho em hoi su dung list nay the nao vay ?


<<

Filename: 111442_chutoso.lsp
Tác giả: truongvoky
Bài viết gốc: 118551
Tên lệnh: chutoso
chuyển chữ thành số
Dạo này ít người yêu cầu viết lisp quá nên mình viết nghịch chơi cái lisp này.

Ngày xưa các bác chắc cũng từng thương thầm chộm nhớ một người nào...

>>
Dạo này ít người yêu cầu viết lisp quá nên mình viết nghịch chơi cái lisp này.

Ngày xưa các bác chắc cũng từng thương thầm chộm nhớ một người nào đấy. Muốn viết thư cho người ta mà lại e ngại không biết ý người ta thế nào.

Thế là các bác này nghĩ ra cái chò viết thư bằng số.

Ý nghĩa là nếu người ta có thích mình thì sẽ tìm cách mày mò để dịch (điều này kiểm tra luôn IQ của người đó). Nếu người đó không thích mình thì vèo một cái bay vào sọt rác.

Code đây (dành cho các bác nhát gan). Chú ý chữ để dịch phải không có dấu.

;; free lisp from cadviet.com
(defun c:chutoso()
(setq lis_chu '("A" "B" "C" "D" "E" "G" "H" "I" "K" "L" "M" "N" "O" "P" "Q" "R" "S" "T" "U" "V" "X" "Y" " "))
(setq lis_so '("4" "13" "6" "15" "3" "9" "76" "1" "16" "1" "111" "11" "0" "10" "2" "12" "5" "7" "22" "21" "96" "27"))
(setq name (car (entsel "\nChon chu la text hay mtext can chuyen sang so")))
(setq ent (entget name))
(setq loai (cdr (assoc 0 ent)))
(if (or (= loai "TEXT") (= loai "MTEXT"))
(progn
 (setq chu (strcase (cdr (assoc 1 ent))))
  (setq L (strlen chu) i L ma nil)
  (Repeat L
   (if (= (vl-position (substr chu i 1) lis_chu) 22)
(progn
   (setq kt " ")
   (setq ma (append (list kt) ma))
)
(progn    
   (setq kt (atoi (nth (vl-position (substr chu i 1) lis_chu) lis_so)))
    (setq ma (append (list (rtos kt 2 0)) ma))
)
)
(setq i (1- i))
)
(setq dct (getpoint "\nchon diem chen chu da dich")
chumoi (subst (cons 10 dct) (assoc 10 ent) ent)
chumoi (subst (cons 1 (apply 'strcat ma)) (assoc 1 chumoi) chumoi)
)
(entmake chumoi)
)
(alert (strcat "doi tuong ma cac bac chon la : " loai " khong phai la text hay mtext"))
)
)

67640 1346 722!

14119 7764119 712311 151311 75411 776427 11510 6224 1346 76427 76427. 77622 21137 77622 6760 1192291 27322 641 67601.


<<

Filename: 118551_chutoso.lsp
Tác giả: ro88
Bài viết gốc: 224730
Tên lệnh: stt
Viết lisp đánh số thứ tự đỉnh,khoảng cách và diện tích

Thân bác phamthanhbinh,

Đúng là em có chút sơ suất khi đã không giải thích cụ thể. Lô đất của em ban đầu như...

>>

Thân bác phamthanhbinh,

Đúng là em có chút sơ suất khi đã không giải thích cụ thể. Lô đất của em ban đầu như thế này ạ!

3582aa41af1fd9ef3d9c337448014f65_52433831.1.700x0.jpg

Em đã có xem một vài lisp về thống kê đỉnh nhưng đều không đạt yêu cầu. Em thấy có mỗi 1 lisp đánh số thứ tự bằng tay như thế này thôi ạ.

(defun c:stt (/ oldPref oldSuf oldStart curStr newNum
           	actDoc actSp oldEcho oldSize *error*)
 (defun *error* (msg)
(setvar "CMDECHO" oldEcho)
(princ)
); end *error*

 (vl-load-com)
 (if(not num:Size)(setq num:Size(getvar "DIMTXT")))
 (if(not num:Pref)(setq num:Pref ""))
 (if(not num:Suf)(setq num:Suf ""))
 (if(not num:Num)(setq num:Num 1))
 (setq oldPref num:Pref
   	oldSuf num:Suf
   	oldStart num:Num
   	oldSize num:Size
   	actDoc(vla-get-ActiveDocument
           	(vlax-get-acad-object))
   	oldEcho(getvar "CMDECHO")
  ); end setq
 (setvar "CMDECHO" 0)
 (if(=(vla-get-ActiveSpace actDoc)1)
		(setq actSp(vla-get-ModelSpace actDoc))
		(setq actSp(vla-get-PaperSpace actDoc))
); end if
 (setq num:Size
(getreal
 	(strcat "\nText size <"(rtos num:Size)">: ")))
 (if(null num:Size)(setq num:Size oldSize))
 (setq num:Pref
(getstring T
 	(strcat "\nPrefix: <"num:Pref">: ")))
 (if(= "" num:Pref)(setq num:Pref oldPref))
 (if(= " " num:Pref)(setq num:Pref ""))
 (setq num:Suf
(getstring T
 	(strcat "\nSuffix: <"num:Suf">: ")))
 (if(= "" num:Suf)(setq num:Suf oldSuf))
 (if(= " " num:Suf)(setq num:Suf ""))
 (setq num:Num
(getint
 	(strcat "\nStarting number <"(itoa num:Num)">: ")))
 (if(null num:Num)(setq num:Num oldStart))
 (princ "\n<<< Insert numbers or press Esc to quit >>> ")
 	(while T
   	(setq curStr(strcat num:Pref(itoa num:Num)num:Suf)
         	newNum(vla-AddText actSp
         	curStr (vlax-3d-point '(0.0 0.0 0.0)) num:Size))
   	(vla-put-Alignment newNum acAlignmentMiddleCenter)
   	(command "_.copybase"(trans '(0.0 0.0 0.0)0 1)(entlast)"")
   	(command "_.erase" (entlast) "")
   	(command "_.pasteclip" pause)
   	(setq num:Num(1+ num:Num))
  	); end while
 (princ)
); end of c:stt
(princ "\n***Lenh STT.*** ")

Mong bác giúp em bổ sung thêm yêu cầu về chiều dài và diện tích ạ.

Em cảm ơn bác ạ!

 

 

bạn dùng thử cái này xem sao

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=63922&pid=213751&st=0entry213751
;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=63922&pid=199638&st=0entry199638
;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=13203&st=3100
;; free lisp from cadviet.com
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Chuong trinh danh so va lap bang toa do ho so thua dat dia chinh
;;;Bang toa do tao thanh block, duoc dat ten theo so thu tu 1, 2, 3...
;;;Chap nhan cac doi tuong la Region, Polyline, Line va Arc khep kin
;;;Written by - January 2009 - www.cadviet.com
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;PUBLIC FUNCTIONS
;;;-------------------------------------------------------------------------------
(Defun DTR (x) (/ (* x pi) 180))
;;;change degree to radian, return REAL
;;;-------------------------------------------------------------------------------
(defun lineP (p0 a r / p1)
;;;Line polar: point, degree angle, radius
 (setq p1 (polar p0 (dtr a) r))
 (command "line" p0 p1 "")
)
;;;-------------------------------------------------------------------------------
(defun linePX (p0 x) (lineP p0 0 x))
;;;Horizontal line: length x, from p0
;;;-------------------------------------------------------------------------------
(defun linePY (p0 y) (lineP p0 90 y))
;;;Vertical line: length y, from p0
;;;-------------------------------------------------------------------------------
(defun getVert (e / i L)
;;;Return list of all vertex from pline e
 (setq i 0
L nil
 )
 (vl-load-com)
 (repeat (fix (+ (vlax-curve-getEndParam e) 1))
(setq L (append L (list (vlax-curve-getPointAtParam e i))))
(setq i (1+ i))
 )
 L
)
;;; First point of List rearrangement
(defun relist(pt0 Lst / i rt)
 (setq i 0)
 (foreach pt Lst
(if (equal pt0 pt 0.001)
  (setq rt i))
(setq i (1+ i)))
 (append (append (member (nth rt Lst) Lst)
  (cdr (reverse (cdr (member (nth rt Lst) (reverse Lst))))))
  (list (nth rt Lst)))
)
;;;New Layer
(defun newlayer(a b c d)
(if (not (tblsearch "layer" a))
(command "-layer" "n" a "c" b a "l" c a "lw" d a ""))
)
;;;-------------------------------------------------------------------------------
(defun wtxtMC (txt p h k)
;;;Write text Middle Center, specify text, point, height
 (entmake (list (cons 0 "TEXT")
  (cons 7 (getvar "textstyle"))
  (cons 1 txt)
  (cons 10 p)
  (cons 11 p)
  (cons 40 h)
  (cons 72 1)
  (cons 73 2)
  (if k (cons 51 (DTR 18)) (cons 51 0))
)
 )
)
;;;-------------------------------------------------------------------------------
(defun Collect (e / e2 SS)
;;;Selection set from e to entlast
 (setq SS (ssadd))
 (ssadd e SS)
 (while (setq e2 (entnext e)) (ssadd e2 SS) (setq e e2))
 SS
)
;;;-------------------------------------------------------------------------------
(defun Collect1 (e / ss)
;;;Selection set after e to entlast. If e nil, select all from fist entity of drawing.
 (if (= e nil)
(setq ss (collect (entnext)))
(progn (setq ss (collect e)) (ssdel e ss))
 )
)
;;;-------------------------------------------------------------------------------
;;;PRIVATE FUNCTIONS
;;;-------------------------------------------------------------------------------
(defun txt1 (txtL / p1 p2 p3 p4 pL i)
;;;Write texts in 1 row
 (setq
p1 (list (+ (car p0) (* 2 h)) (- (cadr p0) (* 1.5 h)))
p2 (polar p1 0 (* 7 h))
p3 (polar p2 0 (* 10 h))
p4 (polar p3 0 (* 9 h))
pL (list p1 p2 p3 p4)
i  0
 )
 (repeat 4
(wtxtMC (nth i txtL) (nth i pL) h t)
(setq i (1+ i))
 )
)
;;;-------------------------------------------------------------------------------
(defun txt2 (txtL / p1 p2 p3 p4 pL i)
;;;Write texts in 1 row
 (setq
p1 (list (+ (car p0) (* 2 h)) (- (cadr p0) (* 1.5 h)))
p2 (polar p1 0 (* 7 h))
p3 (polar p2 0 (* 10 h))
p4 (polar p3 0 (* 9 h))
p4 (polar p4 (* 0.5 pi) h)
pL (list p1 p2 p3 p4)
i  0
 )
 (repeat 4
(wtxtMC (nth i txtL) (nth i pL) h t)
(setq i (1+ i))
 )
)
;;;-------------------------------------------------------------------------------
;;;MAIN PROGRAM
;;;-------------------------------------------------------------------------------
(defun C:TD (/ h p et p0 p00 p01 p02 pt pvL pvL1 n j pv num txtL ss bn ntp p11 p12 p13 p14)
 (setvar "cmdecho" 0)
;;;New layer check
 (newlayer "kichthuoc" 7 "continuous" "default")
 (newlayer "stt" 1 "continuous" "default")
 (newlayer "bangtd" 7 "continuous" "default")
;;;GET TEXT HEIGHT
 (if (not h0)  (setq h0 1))
 (setq h (getreal (strcat "\nChon chieu cao text <" (rtos h0) ">:")))
 (if (not h)  (setq h h0)  (setq h0 h))
;;;GET DECIMAL PRECISION
 (if (not ntp0)  (setq ntp0 2))
 (setq ntp (getint (strcat "\nSo chu so thap phan <" (itoa ntp0) ">:")))
 (if (not ntp)  (setq ntp ntp0)  (setq ntp0 ntp))
;;;GET CIRCLE RADIUS
 (if (not cr0)  (setq cr0 0.3))
 (setq cr (getreal (strcat "\nNhap ban kinh vong tron <" (rtos cr0) ">:")))
 (if cr (setq cr0 cr))
;;;PICK & BASE POINT
 (initget "Y")
 (setq save (getkword "\nBan co muon luu file? < Y / Enter for No >:"))
 (setq oldos (getvar "osmode")
pdau (getpoint "\nPick diem dau tien (so thu tu = M1): " )
 )
 ;(while pdau
(setq p (getpoint "\nPick 1 diem giua mien kin:")
      	pvL nil pvL1 nil)
(command "boundary" p "")
(setq et (entlast)
     	pvL1 (reverse (getvert et)))
(redraw et 3)
(setq p00 (getpoint "\nDiem dat Bang TDGR:"))
(initget "T t N n")
(setq chieu (getkword "\nLua chon chieu ghi toa do < T/N >"))
(command "erase" et "")
(setq  p0 p00
	p01  (polar p00 (* 1.5 pi) (* h 3))  
	pvL  (relist pdau pvL1)
	n (length pvL)
	p02 (polar p01 (* 1.5 pi) (+ (* h 3) (* (1- n) h 2)))
)
(setvar "osmode" 0)
;;;HEADER
 (setvar "CLAYER" "bangtd")
 (linepx p0 (* 32 h))
 (command "copy" "L" "" "m" p00 p01 "")
 (setq Lkqua nil)
 (command "style" "CadViet" ".VnArialH" "" "" "" "" "")
 (wtxtMC "B¶ng kª täa ®é vµ kho¶ng c¸ch"
  (polar (polar p0 0 (* 16 h)) (* 0.5 pi) (* 4 h))
  (* 1.2 h) nil)
 (wtxtMC "HÖ täa ®é VN - 2000"
  (polar (polar p0 0 (* 16 h)) (* 0.5 pi) (* 2 h))
  (* 1.2 h) nil)
 (txt1 (setq Lkq (list "TT" "Y (m)" "X (m)" "S (m)")))
 (setq Lkqua (append Lkqua (list Lkq)))
 (setq p0 (polar p0 (* 1.5 pi) (* 3 h)))
;;;MAKE RECORDS
 (if (or (= chieu "N") (= chieu "n")) (setq pvL (reverse pvL)) )
 (setq j  0
pt nil)
 (repeat n
(setq
  pv  (nth j pvL)
  num (itoa (1+ j))
num (strcat "M" num)
)
(if pt
  (setq S (rtos (distance pt pv) 2 ntp))
  (setq S "")
)
(setq
  txtL (list num (rtos (car pv) 2 ntp) (rtos (cadr pv) 2 ntp) S)
  Lkqua (append Lkqua (list txtL))
)
(txt2 txtL)
(setq p11 (polar p0 (* 1.5 pi) (* 2.5 h)))
(setq P12 (polar p11 0 (* 25 h)))
(setq P13 (polar p11 0 (* 31 h)))
(setq P14 (polar p11 0 (* 32 h)))
(command "LINE" p11 p12 "")
(command "LINE" p13 p14 "")
(setq p0 (polar p0 (* 1.5 pi) (* 2 h)))
(setq pt pv)
(setq j (1+ j))
(if (= j (- n 1))  (setq j 0))
 )
 (command "LINE" p11 p14 "")
 (linepy p00 (- (distance p00 (polar p0 (* 1.5 pi) (* 0.5 h)) )))
 (command "copy" "L" "" "m"  p0
(list (+ (car p0) (* 4 h)) (cadr p0))
(list (+ (car p0) (* 14 h)) (cadr p0))
(list (+ (car p0) (* 24 h)) (cadr p0))
(list (+ (car p0) (* 32 h)) (cadr p0))
"")
;;;WRITE POINT NAME
 (setvar "CLAYER" "stt")
 (setq j 0)
 (repeat (1- n)
(setq
  pv  (nth j pvL)
  num (itoa (1+ j))
num (strcat "M" num)
)
(wtxtMC num (polar pv 0 h) h t)
(command "circle" pv cr0)
(command "HATCH" "solid" "L" "")
(command "erase" vtron "")
(setq j (1+ j))
 )
;;;GHI CANH THUA
(setvar "CLAYER" "kichthuoc")
(ghicanh)
;;;FINISH
(savef)
(setvar "osmode" oldos)
;(setq pdau (getpoint "\nPick diem dau tien (so thu tu = 1) :"))
 ;;; )
 (setvar "cmdecho" 1)
 (princ)
)
;;;-------------------------------------------------------------------------------
(defun savef()
 (if save
(progn
  (setq file (open (setq tenfile (strcat (getvar "dwgprefix")
 (vl-filename-base (vl-string-right-trim "\\" (getvar "dwgname"))) ".txt")) "a"))
  (foreach line Lkqua
(setq line1 "")
(foreach it line
  (setq line1 (strcat line1 " " it)))
(write-line line1 file)
  )
  (close file)
  (princ (strcat "\nDa luu thanh file " tenfile))
)
 )
)
;;;PHAN BO SUNG
;;;------------------------------------------------------------------------------------
(defun Text_canh_TCA (S p a )
;;;Entmake text S at p with angle A - Top Center
 (if (/= p nil)
(entmake (list
	(cons 0 "TEXT")
	(cons 62 2)
	(cons 10 p)
	(cons 40 h)
	(cons 1 S)
	(cons 50 a )
	(cons 41 0.7)
	(cons 7 (getvar "textstyle"))
	(cons 72 1)
	(cons 11 p)
	(cons 73 3)
  )
)
 )
)
;;;------------------------------------------------------------------------------------
(defun Text_canh_BCA (S p a )
;;;Entmake text S at p with angle A - Bottom Center
 (if (/= p nil)
(entmake (list
	(cons 0 "TEXT")
	(cons 62 2)
	(cons 10 p)
	(cons 40 h)
	(cons 1 S)
	(cons 50 a )
	(cons 41 0.7)
	(cons 7 (getvar "textstyle"))
	(cons 72 1)
	(cons 11 p)
	(cons 73 1)
  )
)
 )
)
;;;-------------------------------------------------------------------------------
(defun Ghicanh (/ i k p1 p2 dist rad x_mp y_mp mp mp1)
 (setq
i 0 
k (1- (length pvL))
 )
 (repeat k
(setq
  p1   (nth i pvL)
  p2   (nth (+ i 1) pvL)
  dist (distance p1 p2)
  rad  (angle p1 p2)
  x_mp (* (+ (car p1) (car p2)) 0.5)
  y_mp (* (+ (cadr p1) (cadr p2)) 0.5)
  mp   (list x_mp y_mp)
)
(if (and (> rad (* 0.5 pi)) (<= rad (* 1.5 pi)))
  (setq mp (polar mp (+ rad (* 0.5 pi)) (* 0.3 h)))
)
(if (and (> rad (* 0.5 pi)) (<= rad (* 1.5 pi)))
  (progn
(setq rad (+ rad pi))
;(Text_canh_TCA (rtos dist 2 2) mp rad)
)
  ;(Text_canh_BCA (rtos dist 2 2) mp rad)
)
(setq mp1 (polar mp (angle p mp) (* 2 h)) )
(command "DIMALIGNED" p1 p2 mp1)
(setq i (1+ i))
 )
 ;; repeat k;
)
;;;--------------------------

 

 

cái này mình tìm trên diễn đàn và có nhờ Thiep sửa lại đôi chút bạn xem có được ko


<<

Filename: 224730_stt.lsp

Trang 244/303

244