Jump to content
InfoFile
Tác giả: thanhduan2407
Bài viết gốc: 418313
Tên lệnh: convertfont+nil
Lisp Chuyển Đổi Mã Font Chữ Trong Autocad
(defun c:convertfont nil
  (setq
    UNI '((225) (224) (92 85 43 49 69 65 51) (92 85 43 48 48 69 51) (92 85 43 49 69 65 49)
	...
>>
(defun c:convertfont nil
  (setq
    UNI '((225) (224) (92 85 43 49 69 65 51) (92 85 43 48 48 69 51) (92 85 43 49 69 65 49)
	 (227) (92 85 43 49 69 65 70) (92 85 43 49 69 66 49) (92 85 43 49 69 66 51)
	 (92 85 43 49 69 66 53) (92 85 43 49 69 66 55) (226) (92 85 43 49 69 65 53)
	 (92 85 43 49 69 65 55) (92 85 43 49 69 65 57) (92 85 43 49 69 65 66)
	 (92 85 43 49 69 65 68) (233) (232) (92 85 43 49 69 66 66) (92 85 43 49 69 66 68)
	 (92 85 43 49 69 66 57) (234) (92 85 43 49 69 66 70) (92 85 43 49 69 67 49)
	 (92 85 43 49 69 67 51) (92 85 43 49 69 67 53) (92 85 43 49 69 67 55) (237)
	 (92 85 43 48 48 69 67) (92 85 43 49 69 67 57) (92 85 43 48 49 50 57)
	 (92 85 43 49 69 67 66) (243) (92 85 43 48 48 70 50) (92 85 43 49 69 67 70)
	 (92 85 43 48 48 70 53) (92 85 43 49 69 67 68) (244) (92 85 43 49 69 68 49)
	 (92 85 43 49 69 68 51) (92 85 43 49 69 68 53) (92 85 43 49 69 68 55)
	 (92 85 43 49 69 68 57) (245) (92 85 43 49 69 68 66) (92 85 43 49 69 68 68)
	 (92 85 43 49 69 68 70) (92 85 43 49 69 69 49) (92 85 43 49 69 69 51) (250)
	 (249) (92 85 43 49 69 69 55) (92 85 43 48 49 54 57) (92 85 43 49 69 69 53)
	 (253) (92 85 43 49 69 69 57) (92 85 43 49 69 69 66) (92 85 43 49 69 69 68)
	 (92 85 43 49 69 69 70) (92 85 43 49 69 70 49) (92 85 43 48 48 70 68)
	 (92 85 43 49 69 70 51) (92 85 43 49 69 70 55) (92 85 43 49 69 70 57)
	 (92 85 43 49 69 70 53) (240);
	 (193) (192) (92 85 43 49 69 65 50) (92 85 43 48 48 67 51) (92 85 43 49 69 65 48)
         (195) (92 85 43 49 69 65 69) (92 85 43 49 69 66 48) (92 85 43 49 69 66 50)
         (92 85 43 49 69 66 52) (92 85 43 49 69 66 54) (194) (92 85 43 49 69 65 52)
         (92 85 43 49 69 65 54) (92 85 43 49 69 65 56) (92 85 43 49 69 65 65)
         (92 85 43 49 69 65 67) (201) (200) (92 85 43 49 69 66 65) (92 85 43 49 69 66 67)
         (92 85 43 49 69 66 56) (202) (92 85 43 49 69 66 69) (92 85 43 49 69 67 48)
         (92 85 43 49 69 67 50) (92 85 43 49 69 67 52) (92 85 43 49 69 67 54) (205)
         (92 85 43 48 48 67 67) (92 85 43 49 69 67 56) (92 85 43 48 49 50 56)
         (92 85 43 49 69 67 65) (211) (92 85 43 48 48 68 50) (92 85 43 49 69 67 69)
         (92 85 43 48 48 68 53) (92 85 43 49 69 67 67) (212) (92 85 43 49 69 68 48)
         (92 85 43 49 69 68 50) (92 85 43 49 69 68 52) (92 85 43 49 69 68 54)
         (92 85 43 49 69 68 56) (213) (92 85 43 49 69 68 65) (92 85 43 49 69 68 67)
         (92 85 43 49 69 68 69) (92 85 43 49 69 69 48) (92 85 43 49 69 69 50) (218)
         (217) (92 85 43 49 69 69 54) (92 85 43 48 49 54 56) (92 85 43 49 69 69 52)
         (221) (92 85 43 49 69 69 56) (92 85 43 49 69 69 65) (92 85 43 49 69 69 67)
         (92 85 43 49 69 69 69) (92 85 43 49 69 70 48) (92 85 43 48 48 68 68)
         (92 85 43 49 69 70 50) (92 85 43 49 69 70 54) (92 85 43 49 69 70 56)
         (92 85 43 49 69 70 52) (208))
    TCVN '((184) (181) (182) (183) (185) (168) (190) (187) (188) (189) (198) (169) (202)
	 (199) (200) (201) (203) (92 85 43 48 48 68 48) (92 85 43 48 48 67 67) (206)
	 (207) (209) (170) (92 85 43 48 48 68 53) (92 85 43 48 48 68 50) (211) (212)
	 (214) (92 85 43 48 48 68 68) (215) (216) (220) (92 85 43 48 48 68 69)
	 (92 85 43 48 48 69 51) (223) (225) (226) (228) (171) (232) (229) (230) (231)
	 (233) (172) (237) (234) (235) (92 85 43 48 48 69 67) (238) (243) (239) (241)
	 (92 85 43 48 48 70 50) (244) (173) (248) (92 85 43 48 48 70 53) (246) (247)
	 (249) (92 85 43 48 48 70 68) (250) (251) (252) (92 85 43 48 48 70 69) (174);
	 (184) (181) (182) (183) (185) (161) (190) (187) (188) (189) (198) (162) (202)
         (199) (200) (201) (203) (92 85 43 48 48 68 48) (92 85 43 48 48 67 67) (206)
         (207) (209) (163) (92 85 43 48 48 68 53) (92 85 43 48 48 68 50) (211) (212)
         (214) (92 85 43 48 48 68 68) (215) (216) (220) (92 85 43 48 48 68 69)
         (92 85 43 48 48 69 51) (223) (225) (226) (228) (164) (232) (229) (230) (231)
         (233) (165) (237) (234) (235) (92 85 43 48 48 69 67) (238) (243) (239) (241)
         (92 85 43 48 48 70 50) (244) (166) (248) (92 85 43 48 48 70 53) (246) (247)
         (249) (92 85 43 48 48 70 68) (250) (251) (252) (92 85 43 48 48 70 69) (167))
    VNI '((97 249) (97 248) (97 251) (97 92 85 43 48 48 70 53) (97 239) (97 234)
         (97 233) (97 232) (97 250) (97 252) (97 235) (97 226) (97 225) (97 224)
         (97 229) (97 92 85 43 48 48 69 51) (97 228) (101 249) (101 248) (101 251)
         (101 92 85 43 48 48 70 53) (101 239) (101 226) (101 225) (101 224) (101 229)
         (101 92 85 43 48 48 69 51) (101 228) (237) (92 85 43 48 48 69 67) (230) (243)
         (92 85 43 48 48 70 50) (111 249) (111 248) (111 251) (111 92 85 43 48 48 70 53)
         (111 239) (111 226) (111 225) (111 224) (111 229) (111 92 85 43 48 48 69 51)
         (111 228) (244) (244 249) (244 248) (244 251) (244 92 85 43 48 48 70 53) (244 239)
         (117 249) (117 248) (117 251) (117 92 85 43 48 48 70 53) (117 239) (246) (246 249)
         (246 248) (246 251) (246 92 85 43 48 48 70 53) (246 239) (121 249) (121 248)
         (121 251) (121 92 85 43 48 48 70 53) (238) (241);
	 (65 217) (65 216) (65 219) (65 92 85 43 48 48 68 53)
         (65 207) (65 202) (65 201) (65 200) (65 218) (65 220)
         (65 203) (65 194) (65 193) (65 192) (65 197) (65 92 85 43 48 48 67 51)
         (65 196) (69 217) (69 216) (69 219) (69 92 85 43 48 48 68 53) (69 207)
         (69 194) (69 193) (69 192) (69 197) (69 92 85 43 48 48 67 51) (69 196)
         (205) (92 85 43 48 48 67 67) (198) (211) (92 85 43 48 48 68 50) (79 217)
         (79 216) (79 219) (79 92 85 43 48 48 68 53) (79 207) (79 194) (79 193)
         (79 192) (79 197) (79 92 85 43 48 48 67 51) (79 196) (212) (212 217) (212 216)
         (212 219) (212 92 85 43 48 48 68 53) (212 207) (85 217) (85 216) (85 219)
         (85 92 85 43 48 48 68 53) (85 207) (214) (214 217) (214 216) (214 219)
         (214 92 85 43 48 48 68 53) (214 207) (89 217) (89 216) (89 219)
         (89 92 85 43 48 48 68 53) (206) (209))
  )
  (mapcar '(lambda (a b c)
	     (eval (vl-list* 'defun (read (strcat "c:" a)) 'nil (list 'cf::convertfont b c) '((princ))))
	   )
	  '("t2u" "t2v" "u2t" "u2v" "v2t" "v2u")
	  '(tcvn tcvn uni uni vni vni)
	  '(uni vni tcvn vni tcvn uni)
  )
  (princ)
)
(defun cf::convertfont (c1 c2 / s i e el h l ol sl c n str mtx t0 t1 doc
			*error* _StartUndo _EndUndo)
  (defun *error* ( msg )
    (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
        (princ (strcat "\n** Error: " msg " **")))
    (princ)
  )  
  (defun _StartUndo ( doc ) (_EndUndo doc)
    (vla-StartUndoMark doc)
  )
  (defun _EndUndo ( doc )
    (if (= 8 (logand 8 (getvar 'UNDOCTL)))
      (vla-EndUndoMark doc)
    )
  )  
  (initget "Lower Upper Normal")
  (setq	#case (cond ((getkword (strcat "\nSpecify Case-Sensitiy option:  <"
				       (setq #case (cond (#case) ("Normal"))) ">: ")))
		    (#case)
	      )
        doc (vla-get-ActiveDocument (vlax-get-acad-object))
	sl 0
	ol 0
  )
  (cond	((= #case "Lower") (setq c2 (cf::sublist (/ (length c2) 2) c2) c 1))
	((= #case "Upper") (setq c2 (reverse (cf::sublist (/ (length c2) 2) (reverse c2))) c 2))
	((setq c 0))
  )
  (if (and (princ "\nSelect a TEXT: ") (setq s (ssget '((0 . "*TEXT")))))
    (progn
      (_StartUndo doc)
      (setq t0 (getvar "MilliSecs"))
      (repeat (setq i (sslength s))
	(setq e   (ssname s (setq i (1- i)))
	      el  (entget e)
	      h   (reverse (cdr (member (cond ((assoc 3 el)) ((assoc 1 el))) (reverse el))))
	      str (LM:UnFormat (cf::GetTextString el) (setq mtx (equal (cdr (assoc 0 el)) "MTEXT")))
	      sl  (+ (strlen str) sl)
	      ol  (1+ ol)
	      el  (cdr (member (assoc 1 el) el))
	)
	(setq str (apply (function append) (cf::ff0 str c1 c2 (length c2) c)))
	(if mtx
	  (progn
	    (setq str  (gbn str 250))
	    (repeat (1- (length str))
	      (setq l (cons (cons 3 (vl-list->string (car str))) l)
		    str (cdr str)))
	    (setq l (cons (cons 1 (vl-list->string (vl-remove nil (car str)))) l)
		  l (reverse l))
	  )
	  (setq l (cons (cons 1 (vl-list->string str)) l)) 
	)	
	(entmod (append h l el))
      )
      (setq t1 (getvar "MilliSecs"))
      (princ (strcat "\nTotal time to conver  with  is : "
		     (rtoc (- t1 t0) 0) " (ms)"))
      (_EndUndo doc)
    )
    (princ "\nNo Valid object selected!!!")
  )
  (princ)
)
(defun cf::ff0 (s c1 c2 n c / a p r)
  ; c = 1: lower
  ; c = 2: upper
  ; c = 0: normal
  (if (= (type s) 'str) (setq s (vl-string->list s)))
  (cond ((= 8 (apply (function max) (mapcar (function length) c1)))
	 (if (and (= (car s) 92) (setq p (vl-position (cf::f7 s) c1)))
	   (setq r (cons (nth (rem p n) c2) r)
		 s (cdddr (cddddr s))
	   )
	 )
	 (while s
	   (cond 
		 ((= (cadr s) 92)
		  (cond ((setq p (vl-position (cf::f8 s) c1))
			 (setq r (cons (nth (rem p n) c2) r) s (cddddr (cddddr s))))
			(t
			 (if (setq p (vl-position (list (car s)) c1))
			   (setq r (cons (nth (rem p n) c2) r) s (cdr s))
			   (cond ((= c 1)
				  (if (< 64 (car s) 91)
				    (setq r (cons (list (+ (car s) 32)) r) s (cdr s))
				    (setq r (cons (list (car s)) r) s (cdr s))))
				 ((= c 2)
				  (if (< 96 (car s) 123)
				    (setq r (cons (list (- (car s) 32)) r) s (cdr s))
				    (setq r (cons (list (car s)) r) s (cdr s))))
				 (t (setq r (cons (list (car s)) r) s (cdr s)))
			   )
			 )
			 (if (setq p (vl-position (cf::f7 s) c1))
			   (setq r (cons (nth (rem p n) c2) r) s (cdddr (cddddr s)))
			   (setq r (cons (list (car s)) r) s (cdr s))
			 )
			)
		  )
		 )
		 ((setq p (vl-position (cf::f2 s) c1))
		  (setq r (cons (nth (rem p n) c2) r) s (cddr s)))
		 ((setq p (vl-position (list (car s)) c1))
		  (setq r (cons (nth (rem p n) c2) r) s (cdr s)))
		 ((vl-position c '(0 1 2))
		  (cond ((= c 1)
			 (if (< 64 (car s) 91)
			   (setq r (cons (list (+ (car s) 32)) r) s (cdr s))
			   (setq r (cons (list (car s)) r) s (cdr s))))
			((= c 2)
			 (if (< 96 (car s) 123)
			   (setq r (cons (list (- (car s) 32)) r) s (cdr s))
			   (setq r (cons (list (car s)) r) s (cdr s))))
			(t (setq r (cons (list (car s)) r) s (cdr s)))
		  )
		 )
	   )
	 )
        )
	(t (while s
	     (cond ((= (car s) 92)
		    (if (setq p (vl-position (cf::f7 s) c1))
		      (setq r (cons (nth (rem p n) c2) r) s (cdddr (cddddr s)))
		      (setq r (cons (list (car s)) r) s (cdr s))
		    )
		   )		   
		   ((setq p (vl-position (setq a (list (car s))) c1))
		    (setq r (cons (nth (rem p n) c2) r) s (cdr s)))
		   ((vl-position c '(0 1 2))
		    (cond ((= c 1)
			   (if (< 64 (car s) 91)
			     (setq r (cons (list (+ (car s) 32)) r) s (cdr s))
			     (setq r (cons (list (car s)) r) s (cdr s))))
			  ((= c 2)
			   (if (< 96 (car s) 123)
			     (setq r (cons (list (- (car s) 32)) r) s (cdr s))
			     (setq r (cons (list (car s)) r) s (cdr s))))
			  (t (setq r (cons (list (car s)) r) s (cdr s)))
		    )
		   )
	     )
	   )
       )
  )
  (reverse r)
)
(defun cf::sublist ( n l ) (reverse (member (nth (1- n) l) (reverse l))))
(defun cf::f8 (l) (list (car l) (cadr l) (caddr l) (cadddr l) (car (setq l (cddddr l))) (cadr l) (caddr l) (cadddr l)))
(defun cf::f7 (l) (list (car l) (cadr l) (caddr l) (cadddr l) (car (setq l (cddddr l))) (cadr l) (caddr l)))
(defun cf::f2 (l) (list (car l) (cadr l)))
(defun cf::GetTextString (el / typ)
  (cond	((wcmatch (setq typ (cdr (assoc 0 el))) "TEXT,*DIMENSION") (cdr (assoc 1 (reverse el))))
	((wcmatch typ "ATTRIB,MTEXT")
	 (apply	(function strcat)
		(mapcar	(function cdr) (vl-remove-if-not (function (lambda (x) (vl-position (car x) '(1 3)))) el))
	 )
	)
  )
)
;;-------------------=={ UnFormat String }==------------------;;
;;                                                            ;;
;;  Returns a string with all MText formatting codes removed. ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  str - String to Process                                   ;;
;;  mtx - MText mtxag (T if string is for use in MText)        ;;
;;------------------------------------------------------------;;
;;  Returns:  String with formatting codes removed            ;;
;;------------------------------------------------------------;;

(defun LM:UnFormat ( str mtx / _replace rx )
    (defun _replace ( new old str )
        (vlax-put-property rx 'pattern old)
        (vlax-invoke rx 'replace str new)
    )
    (if (setq rx (vlax-get-or-create-object "VBScript.RegExp"))
        (progn
            (setq str
                (vl-catch-all-apply
                    (function
                        (lambda ( )
                            (vlax-put-property rx 'global     actrue)
                            (vlax-put-property rx 'multiline  actrue)
                            (vlax-put-property rx 'ignorecase acfalse) 
                            (foreach pair
                               '(
                                    ("\032"    . "\\\\\\\\")
                                    (" "       . "\\\\P|\\n|\\t")
                                    ("$1"      . "\\\\(\\\\)|\\\\*;|\\\
\")
                                    ("$1$2/$3" . "()\\\\S(*)(*);")
                                    ("$1$2"    . "\\\\(\\\\S)|(})|}")
                                    ("$1"      . "({)|{")
                                )
                                (setq str (_replace (car pair) (cdr pair) str))
                            )
                            (if mtx
                                (_replace "\\\\" "\032" (_replace "\\$1$2$3" "(\\\\)|({)|(})" str))
                                (_replace "\\"   "\032" str)
                            )
                        )
                    )
                )
            )
            (vlax-release-object rx)
            (if (null (vl-catch-all-error-p str))
                str
            )
        )
    )
)
(defun GBN (l n / b lst)
  ;; http://www.theswamp.org/index.php?topic=32428.msg380205#msg380205
  ;; by Elpanov Evgeniy
 (setq b (list '(reverse a)))
 (repeat (/ n 4)
  (setq b (cons '(setq
                  a
                  (cons (cadddr l) (cons (caddr l) (cons (cadr l) (cons (car l) a))))
                  l
                  (cddddr l)
                 ) ;_  setq
                b
          ) ;_  cons
  ) ;_  setq
 ) ;_  repeat
 (setq n (rem n 4))
 (repeat (/ n 3)
  (setq b (cons '(setq
                  a
                  (cons (caddr l) (cons (cadr l) (cons (car l) a)))
                  l
                  (cdddr l)
                 ) ;_  setq
                b
          ) ;_  cons
  ) ;_  setq
 ) ;_  repeat
 (setq n (rem n 3))
 (repeat (/ n 2)
  (setq b (cons '(setq
                  a
                  (cons (cadr l) (cons (car l) a))
                  l
                  (cddr l)
                 ) ;_  setq
                b
          ) ;_  cons
  ) ;_  setq
 ) ;_  repeat
 (setq n (rem n 2))
 (repeat (/ n 1)
  (setq b (cons '(setq
                  a
                  (cons (car l) a)
                  l
                  (cdr l)
                 ) ;_  setq
                b
          ) ;_  cons
  ) ;_  setq
 ) ;_  repeat
 (eval (cons 'defun (cons 'f1 (cons '(a) b))))
 (while l (setq lst (cons (f1 nil) lst)))
 (reverse lst)
)
(defun rtoc ( n p / foo d l )
    (defun foo ( l n )
        (if (or (not (cadr l)) (= 44 (cadr l)))
            l
            (if (zerop (rem n 3))
                (vl-list* (car l) 46 (foo (cdr l) (1+ n)))
                (cons (car l) (foo (cdr l) (1+ n)))
            )
        )
    )
    (setq d (getvar 'dimzin))
    (setvar 'dimzin 0)
    (setq l (subst 44 46 (vl-string->list (rtos (abs n) 2 p))))
    (setvar 'dimzin d)
    (vl-list->string
      (append (if (minusp n) '(45))
	      (foo l (- 3 (rem (fix (/ (log (abs n)) (log 10))) 3)))
      )
    )
)
(vl-load-com)
(c:convertfont)
(princ)

Bác có thể chỉ em cách dùng được không?

Em muốn chuyển từ Unicode sang TCVN3, gõ rất nhiều kiểu nhưng kiểu nào cũng ra dạng Unicode hiển thị trên Cad.

Các bác nào biết cách chỉ dùm em với.

 

@Nguyen Hoanh: Em dùng file VLX của anh thì OK nhưng khi download file về thì bị không thể chuyển được anh ạ. Mong anh giúp đỡ!

 

P/s: Edit lần 2:

Em khởi động lại Cad thì dùng của bác snowman.hms em dùng được rồi. Tuy nhiên em chưa biết cách sửa sao cho gọn, em muốn sửa theo:

Nếu là Font Unicode thì chuyển sang TCVN3, còn nếu là TCVN3 rồi thì không cần chuyển nữa.

Không biết yêu cầu này có cao quá không ạ?


<<

Filename: 418313_convertfont+nil.lsp
Tác giả: khaosat2009
Bài viết gốc: 56376
Tên lệnh: dvac
Xuất file *.txt cho chiều dài các cạnh
Xin phép bác Nguyen Hoanh cho mình viết cái lisp này giúp bạn 'thuong_mdc80' nhé.

(defun dxf( name n)
 (cdr (assoc n (entget name)))
)
(defun opw( tieude duoi)
(setq duongdanfile...
>>
Xin phép bác Nguyen Hoanh cho mình viết cái lisp này giúp bạn 'thuong_mdc80' nhé.

(defun dxf( name n)
 (cdr (assoc n (entget name)))
)
(defun opw( tieude duoi)
(setq duongdanfile (getfiled tieude duongdanfile duoi 7))
) 
(defun opr( tieude duoi)
(setq duongdanfile (getfiled tieude duongdanfile duoi 6))
) 

;ham thong ke so hieu diem va do dai canh
(defun C:DVAC( / ss name i j l p10 p11 d1 d2 s lis n1 f1 n old)
 (defun ltp( p)
(list (atof (rtos (car p) 2 2)) (atof (rtos (cadr p) 2 2)) 0)
 )
 (setq ss (ssget '((0 . "line"))))
 (if ss (progn
(setq n1 (opw "Ten file  : " "txt"))
(setq f (open n1 "w"))
(setq i 0 lis nil j 1 l (sslength ss))
(while (< i l)
  (setq name (ssname ss i))
  (setq p10 (dxf name 10) p11 (dxf name 11) s (distance p10 p11))
  (if (null lis) (setq d1 1 d2 2 lis (list (list (ltp p10) 1) (list (ltp p11) 2))) (progn
	(if (null (setq a (assoc (ltp p10) lis))) (setq lis (append lis (list (list (ltp p10) (+ 1 (length lis))))) d1 (length lis)) (setq d1 (cadr a))
	)
	(if (null (setq a (assoc (ltp p11) lis))) (setq lis (append lis (list (list (ltp p11) (+ 1 (length lis))))) d2 (length lis)) (setq d2 (cadr a))
   )
  ))
  (write-line (strcat (itoa d1) "\t" (itoa d2) "\t" (rtos s 2 2)) f)
  (setq i (1+ i))
)
 ))
 (close f)
 (setq old (getvar "osmode"))
 (setvar "osmode" 0)
 (if lis (foreach n lis (command "_.text" (car n) 2.0 0.0 (itoa (cadr n)))))
 (setvar "osmode" old)
)
(if (null duongdanfile) (setq duongdanfile ""))

lisp này mặc ðịnh ðộ dài cần 2 số lẽ và ðộ cao text =2. Nếu bạn không thích có thể chỉnh lại

Thýờng thì mình thấy ngýời ta có yêu cầu cả tọa ðộ nhýng bác chỉ cần cạnh. Bác xem thử có ðc 0 nhé

Bạn có thể viết giúp mình thêm thể hiện tọa độ x,y của các điểm đó và xuất ra bảng.

Rất cám ơn


<<

Filename: 56376_dvac.lsp
Tác giả: bach1212
Bài viết gốc: 191976
Tên lệnh: chial
chia đường tròn thành nhiều phân bằng nhau

Đoạn AB là Line :

(defun c:chial(/ e ename p1 p2 x1 y1 x2 y2 sk i )
(setq e (entget(setq ename (car(entsel "\n Chon Line can chia :...
>>

Đoạn AB là Line :

(defun c:chial(/ e ename p1 p2 x1 y1 x2 y2 sk i )
(setq e (entget(setq ename (car(entsel "\n Chon Line can chia : "))))	   
	x1 (car (setq p1 (getpoint "\n Diem 1")))
	y1 (cadr p1)
	x2 (car (setq p2 (getpoint p1 "\n Diem 2")))
	y2 (cadr p2)
	sk (getint "\n So khoang chia: ")
	i 0
)
(command "_Pline")
(command (cdr (assoc '10 e)))
(repeat (+ 1 sk)
(command (setq points
(list (+ x1 (* i (/ (- x2 x1) sk)))
  	(+ y1 (* i (/ (- y2 y1) sk)))
		0)))
	(setq i (1+ i))
	)
(command (cdr (assoc '11 e)) "")
(entdel ename)	   
)

bác ket ah, bác sửa thêm lisp này dùng được cho cả trường hợp nếu như đoạn AB là 1 đoạn của pline ABCD..... gì đó chẳng hạn đi ah.

Sau khi chia đoạn AB thành nhiều đoạn xong, thì pline ABCD.....vẫn sẽ là pline và tên mới là AA1A2A3......BCD.....


<<

Filename: 191976_chial.lsp
Tác giả: dnhqs
Bài viết gốc: 10660
Tên lệnh: test
xin giúp tôi file autolisp tính khối lượng san nền

Xin trả lời bạn về chương trình như sau:

1. Việc quét quanh trọng tâm để tìm 3 điểm tuy có tốt hơn nhưng lisp lại phức tạp hơn rất nhiều. Hơn nữa, mã lệnh...

>>
Xin trả lời bạn về chương trình như sau:

1. Việc quét quanh trọng tâm để tìm 3 điểm tuy có tốt hơn nhưng lisp lại phức tạp hơn rất nhiều. Hơn nữa, mã lệnh lisp trên tôi viết đã lâu, bây giờ đọc lại cũng chẳng còn nhớ nữa. Việc nâng cấp như vậy rất khó.

2. Giống 1.

3. Để kiểm tra lisp có làm sót hay không, trước khi bạn chạy lisp, hãy cho tất cả các giá trị về rỗng (như file mẫu của tôi). Nếu sót chỗ nào thì chỗ đó không hiện số (vì hiện giá trị cũ là rỗng).

 

Trả lời kiến thức lisp:

1. Để đọc được attribute bằng lisp, bạn cần lấy được entname của attribute đó thông qua entname của block (INSERT). muốn lấy entame của attribute thứ n (n=1,2,3,4...) từ ename của block, mã lệnh như sau:

(setq ent entbl)
(repeat n (setq ent (entnext ent)))

Trong đó, ent là ename của attribute, entbl là ename của block.

 

Ví dụ lệnh test sau đây sẽ highlight attribute đầu tiên của block được chọn:

(defun c:test()
 (setq entbl (car (entsel "\nHay chon block: ")))

 (setq ent entbl)
 (repeat 1 (setq ent (entnext ent)))

 (redraw ent 3)
 (princ)
)

 

2. Bạn dùng lệnh CAD, sau đó ghi lại thứ tự những gì mà bạn nhập vào.

Ví dụ những gì mà bạn gõ tại dòng lệnh:

 

Thì tương đương với:

(command "ucs" "3" "@1,1" "@1,2")

Cám ơn Nguyễn Hoanh!

Tôi vẫn con lơ mơ một tí, cái trên thì được rồi nhưng mà trường hợp thực hiện lệnh thì hắn ra hộp thoại ví dụ như lện layer, hatch ... tôi nhớ có ai đó đã chỉ rồi nhưng tìm hoài không thấy hình như có Pause rồi ghi lại - phiền pác chỉ giúp.

Tôi có một đoạn lisp về nội suy nhưng không biết làm sao chuyển để pác đọc để hiểu ý của tôi


<<

Filename: 10660_test.lsp
Tác giả: Tue_NV
Bài viết gốc: 74526
Tên lệnh: shbv
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)
Các bạn cho mình hỏi. Trong lisp muốn sử dụng dấu cách thì phải thể hiện như thế nào. Cảm ơn tất cả.

Cụ thể trong lisp dưới đây (lisp đánh số hiệu bản...

>>
Các bạn cho mình hỏi. Trong lisp muốn sử dụng dấu cách thì phải thể hiện như thế nào. Cảm ơn tất cả.

Cụ thể trong lisp dưới đây (lisp đánh số hiệu bản vẽ - VD: KT:01/1; CN:01/1)

Mình muốn giữa ký tự chữ và số có dấu cách (KT: 01/1; CN: 01/1)

Đây là lisp:

;; copyright by Tue_NV
(defun c:shbv(/ dau tong po po1 ent i pre cao)
(prompt "\n Danh so hieu ban ve dang n/m ")
(setvar "cmdecho" 0)

(command "style" "CADVIET" "Vhelven.TTF" "2" "1" "0" "n" "n")
(setq cao (getreal "\n Nhap chieu cao chu :"))
(setq pre (getstring 5"\n Nhap ky hieu ban ve : "))
(setq dau (getint "\n Danh so bat dau (n):"))
(setq tong (getint "\n Danh so tong (m):") i 1)

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

Chào HoangSon

 

Nếu (setq pre (getstring "\n Nhap ky hieu ban ve : ")) -> thì biến pre là biến chuỗi và không nhận dấu cách nào

Còn (setq pre (getstring 5"\n Nhap ky hieu ban ve : ")) -> thì biến pre là biến chuỗi và có nhận cả dấu cách rồi bạn à

:cheers:


<<

Filename: 74526_shbv.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 425200
Tên lệnh: tt
NHỜ BỔ SUNG NỘI DUNG TRONG LISP "GHI CAO DO DIEM TREN TRAC NGANG by Thaistreetz"

*** Chỉ cần thế này thôi (thằng gốc có 62 hay không, không quan trọng):

(entmod (append (entget ent) '((62 . 1))))

*** Mình sửa lại Lisp trên (Công thêm yêu cầu của Chien_LV):

 

(defun c:tt  (/ cd ed h0 pt pt0 x0 y y0 tmp v)
 (or #tyle# (setq #tyle# 1))
 (setq tmp t)
 (if (and (while (and tmp
                      (not (initget "S"))
                      (setq pt0 (getpoint
                       ...
>>

*** Chỉ cần thế này thôi (thằng gốc có 62 hay không, không quan trọng):

(entmod (append (entget ent) '((62 . 1))))

*** Mình sửa lại Lisp trên (Công thêm yêu cầu của Chien_LV):

 

(defun c:tt  (/ cd ed h0 pt pt0 x0 y y0 tmp v)
 (or #tyle# (setq #tyle# 1))
 (setq tmp t)
 (if (and (while (and tmp
                      (not (initget "S"))
                      (setq pt0 (getpoint
                                 (strcat "\n. Ty le: <" (rtos #tyle# 2 2) ">. Diem tim TN tu nhien!"))))
           (cond ((eq pt0 "S")
                  (setq #tyle# (cond ((getreal (strcat "\nTy le <" (rtos #tyle# 2 2) ">: ")))
                                     (#tyle#)))
                  (setq pt0 nil))
                 ((listp pt0) (setq tmp nil) t)
                 (t (setq tmp nil))))
          (setq ed (car (entsel "\nChon Text cao do tim: ")))
          (wcmatch (cdr (assoc 0 (entget ed))) "TEXT,MTEXT")
          (if (wcmatch (setq cd (cdr (assoc 1 (entget ed)))) "%%p*")
           (setq h0 (distof (substr cd 4)))
           (setq h0 (distof (cdr (assoc 1 (entget ed))))))
          (setq x0 (car pt0)
                y0 (cadr pt0)))
  (while (and (setq pt (getpoint "\nChon diem chuan : "))
              (setq ed (car (entsel "\nChon text de chinh sua: ")))
              (wcmatch (cdr (assoc 0 (setq ed (entget ed)))) "TEXT,MTEXT"))
   (setq y (- (cadr pt) y0 (- h0))
         v (cond ((> y 0) (strcat "+" (rtos (* y #tyle#) 2 2)))
                 ((< y 0) (rtos (* y #tyle#) 2 2))
                 (t "%%p0.00")))
   (entmod (append (subst (cons 1 v) (assoc 1 ed) ed) '((62 . 1))))))
 (princ))

 


<<

Filename: 425200_tt.lsp
Tác giả: tran.designer.int
Bài viết gốc: 267581
Tên lệnh: a3
Vẽ khung giấy

 

Khá rảnh nên ôn bài tí :D :D :D

Bạn thêm dòng này: 

(if (not (tblsearch "layer"...

>>

 

Khá rảnh nên ôn bài tí :D :D :D

Bạn thêm dòng này: 

(if (not (tblsearch "layer" "net_moi"))

(command "-layer" "m" "net_moi" "c" 11 "" "l" "continuous" "" "")

(setvar 'clayer "net_moi"))

vào trước dòng:

"RECTANG" "2500,1000" "@38500,27700"

để cái Rectang vẽ ra mang layer "net_moi"

(Defun c:A3 ()
(setq oldlayer (getvar 'clayer)) (setvar 'clayer "0")
(SETQ OLDERR *error*
      *error* myerror)
(setvar 'clayer "0")
(SETQ CMD (GETVAR "CMDECHO"))
(SETQ OSM (GETVAR "OSMODE"))
   (setvar "OSMODE" 0)
   (setq mv_sc 100)
   (setq x3  420)
   (setq y3  297)
   (setq x3 (* mv_sc x3) 
         y3 (* mv_sc y3))
   (command  
    "LIMITS" "0,0" (list x3 y3)
    "PLINE" "0,0" (list 0 y3) (list x3 y3) (list x3 0) "0,0" "_C")
(if (not (tblsearch "layer" "net_moi"))
(command "-layer" "m" "net_moi" "c" 11 "" "l" "continuous" "" "")
(setvar 'clayer "net_moi"))
    (command "RECTANG" "2500,1000" "@38500,27700"
    "ZOOM" "_a"  )
   (setvar "OSMODE" 4263)
(SETVAR "OSMODE" OSM)
(SETVAR "CMDECHO" CMD)
(setvar 'clayer oldlayer)
(princ))

Cám ơn bạn nhiều nhiều! 

Edu level: li5

<<

Filename: 267581_a3.lsp
Tác giả: nataca
Bài viết gốc: 88806
Tên lệnh: bat tat
đặt phím tắt cho lệnh Ortho

Nếu bạn muốn sử dụng Lisp thì đây :

Tên lệnh là Bat -> Bật ORTHO

Tên lệnh là Tat -> Tắt ORTHO

(defun c:Bat()
(command "ORTHO" "ON")...
>>
Nếu bạn muốn sử dụng Lisp thì đây :

Tên lệnh là Bat -> Bật ORTHO

Tên lệnh là Tat -> Tắt ORTHO

(defun c:Bat()
(command "ORTHO" "ON") (princ)
)
(defun c:Tat()
(command "ORTHO" "OFF") (princ)
)

Dùng lệnh có một cái dở là trong khi đang vẽ dở đối tượng mới nhớ ra là cần bật Ortho. Có thể dùng Ctrl+L để chuyển chế độ Ortho, hoặc vào Quickcui để sửa lại phím tắt cho tiện hơn (Ctrl+D chẳng hạn)


<<

Filename: 88806_bat_tat.lsp
Tác giả: phongtran86
Bài viết gốc: 400006
Tên lệnh: tacht
Lisp Tính Số Lượng Đai Và Ghi Ra Thành Text
(defun C:tacht (/ ss tong text point giatri)
(vl-load-com)
(defun ss2ent (ss / sodt index lstent)  
(setq sodt (if ss...
>>
(defun C:tacht (/ ss tong text point giatri)
(vl-load-com)
(defun ss2ent (ss / sodt index lstent)  
(setq sodt (if ss (sslength ss) 0)    
index 0  )  
(repeat sodt 
(setq ent (ssname ss index)
index (1+ index)
lstent (cons ent lstent))
)  
(reverse lstent))
(prompt "\nChon doi tuong Text.")
(setq ss (ssget '((0 . "TEXT")))
lst (ss2ent ss)
lst (vl-sort lst '(lambda (e1 e2) (< (cadr (assoc 10 (entget e1))) (cadr (assoc 10 (entget e2))))))) 
(setq tong 0)
(setq chuoi "")
(foreach enxt lst
(setq giatri (cdr (assoc 1 (entget enxt))))
(setq text (substr giatri 1 (- (vl-string-search "C" giatri) 2)))
(setq chuoi (strcat chuoi "+" text))
(setq tong (+ (atof text) tong))
)
(setq chuoi (substr chuoi 2 (- (strlen chuoi) 1)))
(setq point (getpoint "\n Chon diem ghi dien tich: "))
(setq dientext (strcat chuoi " = " (rtos tong 2 0)))
(command "TEXT" point 80 0 dientext)
(princ) 
)

cảm ơn bác. lisp tacht trên vẫn còn mà. em xin lisp http://www.cadviet.c...6960_lamthu.lsp mà. bị die rồi. 

Tiện bác sửa giúp em theo ý:

Nhờ các bác giúp với, vẫn với lisp trên nhưng mà khác chút xíu: k phải như "lisp sẽ hỏi đường kính cốt đai là bao nhiêu, mình gõ 6, sau đó"

mà là lisp hiển thị gợi ý trong dòng lệnh chính: (pick điểm ghi text hoặc (Duongkinhdai<6>  :). Nếu gõ D: gõ đường kính---> trở lại pick text. Nếu k thì pick vị trí text bình thường.

Tổng quát hơn: (pick điểm ghi text hoặc chỉnh (Duongkinhdai<6>/ Kcdai <150>  :) Nếu gõ D: gõ đường kính . Vẫn hiển thị gợi ý:

(pick điểm ghi text hoặc chỉnh (Duongkinhdai<6>/ Kcdai <150>  :)  gõ K nếu muốn thay đổi khoảng cách. k thì pick điểm ghi text bình thường.

Tổng cả lisp cho vào vòng lặp, để khi gõ lệnh nếu D với K không đổi ta chi cần chọn đoạn dim (hoặc nhập bề rộng đoạn rải cốt đai) pick điểm ghi, rồi lại chọn đoạn dim- pick điểm ghi  :) Giá trị K,D lưu lại từ lần gần nhất thay đổi.  :)

Cảm ơn bác nhiều


<<

Filename: 400006_tacht.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 425214
Tên lệnh: tt
NHỜ BỔ SUNG NỘI DUNG TRONG LISP "GHI CAO DO DIEM TREN TRAC NGANG by Thaistreetz"

Có phải thế này không???

(defun c:tt  (/ cd ed h0 pt pt0 x0 y y0 tmp v k)
 (or (and #tyle# (member (type #tyle#) '(REAL INT))) (setq #tyle# 1))
 (setq tmp t)
 (if (and (while (and tmp
                      (not (initget "S"))
                      (setq pt0 (getpoint
                                 (strcat "\n. Ty le: <" (rtos #tyle# 2 2) ">. Diem tim TN tu nhien!"))))
           (cond ((eq pt0 "S")
                  (setq #tyle# (cond ((getreal...
>>

Có phải thế này không???

(defun c:tt  (/ cd ed h0 pt pt0 x0 y y0 tmp v k)
 (or (and #tyle# (member (type #tyle#) '(REAL INT))) (setq #tyle# 1))
 (setq tmp t)
 (if (and (while (and tmp
                      (not (initget "S"))
                      (setq pt0 (getpoint
                                 (strcat "\n. Ty le: <" (rtos #tyle# 2 2) ">. Diem tim TN tu nhien!"))))
           (cond ((eq pt0 "S")
                  (setq #tyle# (cond ((getreal (strcat "\nTy le <" (rtos #tyle# 2 2) ">: ")))
                                     (#tyle#)))
                  (setq pt0 nil))
                 ((listp pt0) (setq tmp nil) t)
                 (t (setq tmp nil))))
          (setq ed (car (entsel "\nChon Text cao do tim: ")))
          (wcmatch (cdr (assoc 0 (entget ed))) "TEXT,MTEXT")
          (if (wcmatch (setq cd (cdr (assoc 1 (entget ed)))) "%%p*")
           (setq h0 (distof (substr cd 4)))
           (setq h0 (distof (cdr (assoc 1 (entget ed))))))
          (setq x0 (car pt0)
                y0 (cadr pt0)))
  (while (and (setq pt (getpoint "\nChon diem chuan : "))
              (setq ed (car (entsel "\nChon text de chinh sua: ")))
              (wcmatch (cdr (assoc 0 (setq ed (entget ed)))) "TEXT,MTEXT"))
   (setq y (+ (* (- (cadr pt) y0) #tyle#) h0)
         k (rtos y 2 2)
         v (cond ((> y 0) (strcat "+" k))
                 ((< y 0) k)
                 (t "%%p0.00")))
   (entmod (append (subst (cons 1 v) (assoc 1 ed) ed) '((62 . 1))))))
 (princ))

 


<<

Filename: 425214_tt.lsp
Tác giả: Snowman
Bài viết gốc: 24658
Tên lệnh: ao
Hướng dẫn lập trình Lisp
Lệnh AO -> lisp sẽ chạy "một mạch". Còn việc có đúng ý user hay không thì người lập trình không chịu trách nhiệm!

(defun C:AO( / ss e);;;AutoOffset!
(setq
ss...
>>
Lệnh AO -> lisp sẽ chạy "một mạch". Còn việc có đúng ý user hay không thì người lập trình không chịu trách nhiệm!

(defun C:AO( / ss e);;;AutoOffset!
(setq
ss (ssget "X" '((0 . "LINE")))
e (ssname ss 0)
)
(command "offset" 10 e (list 0 0 0) "")
)

Bác SSg làm thế này là hại người ta rồi còn gì nữa :rolleyes: :gun:

Người ta chưa hiểu biết nhiều mà bác cho người ta một công cụ "chạy một mạch mà không cần động tay động chân" (chắc hắn cũng không hiểu công cụ đó chạy một mạch như thế nào :lol: ) vừa làm cho họ ...lười lao động, vừa làm cho họ ...lười suy nghĩ.

@ tulipden87:

Không có một lisp nào chạy một mạch mà không cần động chân động tay đâu. Chí ít ra là bạn cũng phải ...động não xem nó sẽ làm gì, làm như thế nào chứ

Lisp thực ra cũng chỉ làm thay cho bạn những động tác mà bạn phải click, type, di chuột, ... còn thuật toán của lisp chính là suy nghĩ, tính toán của bạn để giải quyết 1 vấn đề. Nếu bạn lười động tay động chân (ví dụ vậy :gun: ) thì lisp của bạn viết ra cũng không thể làm việc "chăm chỉ" thay bạn được.

Ý mình là nếu bạn "động tay động chân, động não" nhiều, bạn sẽ có được nhiều kinh nghiệm, nhiều cách tư duy mới, sáng tạo và từ đó mới có được những thuật toán lisp "chạy một mạch" không cần động tay động chân được :gun:


<<

Filename: 24658_ao.lsp
Tác giả: proconeng86
Bài viết gốc: 307144
Tên lệnh: cvp
lisp chia viewport trong layout

 

Bạn thử cái này. Chọn viewport trong layout, nhấp chọn điểm a, kéo ngang thì chia làm 2 vp theo phương ngang, kéo đứng thì chia 2 vp theo...

>>

 

Bạn thử cái này. Chọn viewport trong layout, nhấp chọn điểm a, kéo ngang thì chia làm 2 vp theo phương ngang, kéo đứng thì chia 2 vp theo phương đứng, còn enter thì chia thành 4 viewport tại a.

 

(defun c:cvp(/ os vp tt10 tt12 tt40 tt41 tyle p1 p2 b c)
  (defun dxf (id v) (cdr (assoc id (entget v))))
  (defun dtim (pt) (polar tt12 (angle tt10 pt) (* tyle (distance tt10 pt))))
  (defun make (a b)
    (command "mview" a b)
    (vla-put-CustomScale (vlax-ename->vla-object (entlast)) (/ 1.0 tyle))    
    (command "MSPACE")
    (command "zoom" (dtim a) (dtim b))
    (command "PSPACE")
  )
  
  (command "undo" "be")
  (setq os (getvar 'osmode))
  (mapcar 'setvar (list 'orthomode 'tilemode 'cmdecho 'osmode) (list 1 0 0 0))
  (setq vp  (car (entsel "\nChon viewport: "))
tt10 (dxf 10 vp)
tt12 (dxf 12 vp)
tt40 (dxf 40 vp)
tt41 (dxf 41 vp)
tyle (/ (dxf 45 vp) tt41 1.0)
p1 (polar (polar tt10 pi (* 0.5 tt40)) (* -0.5 pi) (* 0.5 tt41))
p2 (polar (polar tt10 0 (* 0.5 tt40)) (* 0.5 pi) (* 0.5 tt41))
b (getpoint "\Diem chia: ")
c (getpoint b "\nTheo huong <Enter neu chia 4>: "))
 
  (cond ((eq (car b) (car c))
           (make p1 (list (car b) (cadr p2)))
  (make (list (car b) (cadr p1)) p2))
 
((eq (cadr b) (cadr c)) 
           (make p1 (list (car p2) (cadr b)))
  (make (list (car p1) (cadr b)) p2))
 
        (t (make p1 b) (make b p2)
  (make b (list (car p1) (cadr p2)))
  (make b (list (car p2) (cadr p1))))
  )
  (entdel vp)
  (command "undo" "e")
  (mapcar 'setvar (list 'orthomode 'tilemode 'cmdecho 'osmode) (list 0 0 1 os))  
)

 

Cám ơn bạn Tot77 nhé. Tiện đây bạn xem giúp mình ko hiểu sao khi chia viewport thì thi thoảng CAD không hiện được hình trong viewport mặc dù in ra vẫn có, điều này làm xếp bản vẽ khó hơn, không hiểu là lỗi lisp hay lỗi file

Mình có kèm file bên dưới, có 3 viewport không hiện được, bạn xem hộ mình lỗi tại sao nhé

Mình cám ơn nhiều

http://www.mediafire.com/download/8qsbwbw09ems5c0/HT_ct_be_phot,_be_nuoc_mai.dwg


<<

Filename: 307144_cvp.lsp
Tác giả: proconeng86
Bài viết gốc: 307581
Tên lệnh: cvp
lisp chia viewport trong layout

 

Bạn dùng cái này.

 

(defun c:cvp(/ os vp tt10 tt12 tt40 tt41 tyle p1 p2 b c layer)
  (defun dxf (id v) (cdr...
>>

 

Bạn dùng cái này.

 

(defun c:cvp(/ os vp tt10 tt12 tt40 tt41 tyle p1 p2 b c layer)
  (defun dxf (id v) (cdr (assoc id (entget v))))
  (defun dtim (pt) (polar tt12 (angle tt10 pt) (* tyle (distance tt10 pt))))
  (defun make (a b / obj)
    (command "mview" a b)
    (vla-put-CustomScale (setq obj (vlax-ename->vla-object (entlast))) (/ 1.0 tyle))
    (vla-put-Layer obj layer)    
    (command "MSPACE")
    (command "zoom" (dtim a) (dtim b))
    (command "PSPACE")
    (vla-put-DisplayLocked obj :vlax-true)
  )
  
  (command "undo" "be")
  (setq os (getvar 'osmode))
  (mapcar 'setvar (list 'orthomode 'tilemode 'cmdecho 'osmode) (list 1 0 0 0))
  (setq vp  (car (entsel "\nChon viewport: "))
tt10 (dxf 10 vp)
tt12 (dxf 12 vp)
tt40 (dxf 40 vp)
tt41 (dxf 41 vp)
layer (dxf 8 vp)
tyle (/ (dxf 45 vp) tt41 1.0)
p1 (polar (polar tt10 pi (* 0.5 tt40)) (* -0.5 pi) (* 0.5 tt41))
p2 (polar (polar tt10 0 (* 0.5 tt40)) (* 0.5 pi) (* 0.5 tt41))
b (getpoint "\Diem chia: ")
c (getpoint b "\nTheo huong <Enter neu chia 4>: "))
 
  (cond ((eq (car b) (car c))
           (make p1 (list (car b) (cadr p2)))
  (make (list (car b) (cadr p1)) p2))
 
((eq (cadr b) (cadr c)) 
           (make p1 (list (car p2) (cadr b)))
  (make (list (car p1) (cadr b)) p2))
 
        (t (make p1 b) (make b p2)
  (make b (list (car p1) (cadr p2)))
  (make b (list (car p2) (cadr p1))))
  )
  (entdel vp)
  (command "undo" "e")
  (mapcar 'setvar (list 'orthomode 'tilemode 'cmdecho 'osmode) (list 0 0 1 os))  
)

 

Bạn Tot77 sửa lại lisp trên giúp mình là chuyển layer vp thành defpoint được không. Lisp trên mình cho thêm dòng (setvar 'clayer "defpoints") vào nhưng không được

Mình cám ơn nhiều


<<

Filename: 307581_cvp.lsp
Tác giả: hoangkimanh1607
Bài viết gốc: 211172
Tên lệnh: cvt3d
Xin lisp nội suy cao độ ?

Đã chỉnh sửa lisp trên theo yêu cầu của bạn. Bạn down lại nhé

Nếu muốn chọn text mà cao độ text lại bằng "0" thì lấy...

>>

Đã chỉnh sửa lisp trên theo yêu cầu của bạn. Bạn down lại nhé

Nếu muốn chọn text mà cao độ text lại bằng "0" thì lấy nội dung text làm cao độ. Vậy thì dùng lisp Convert Text 3D để tạo text có cao độ. Mình lười nên dùng cái có sẵn. Ngại viết.

(defun ST:Text-Base (ent)
 (setq Ma10  (cdr (assoc 10 (entget ent))))
 (setq Ma11  (cdr (assoc 11 (entget ent))))
 (setq X11 (car Ma11))
 (setq Ma71  (cdr (assoc 71 (entget ent))))
 (setq Ma72  (cdr (assoc 72 (entget ent))))
 (if (or (and (= Ma71 0) (= Ma72 0) (= X11 0))
  (and (= Ma71 0) (= Ma72 3) )
  (and (= Ma71 0) (= Ma72 5) )
 	)
Ma10
Ma11
  )
)
(defun C:CVT3D (/ ss Z_value temp koord)
 (command "undo" "be")
 (command "osnap" "off")
  (setq ss (ssget (list (cons 0  "TEXT"))))
 	(setq s1 ((lambda (sec) (+ (* 86400 (- sec (fix sec))) 60)) (getvar "DATE")))
 (progn
 	(setq ss (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex ss))))
 	(foreach item ss
(setq temp  (entget item))
(setq   Tdo (ST:Text-Base item ))
(setq  Caodo (cdr (assoc 1 temp))
		h (cdr (assoc 40 temp))
     	Pnt   (list (car Tdo)
  	(cadr Tdo)
  	(atof caodo)
   	)
 	)
(entdel item)
(entmake (list (cons 0 "TEXT") (cons 10 Pnt) (cons 40  h) (cons 1  Caodo)))
 	)
)
 	(setq s2 ((lambda (sec) (+ (* 86400 (- sec (fix sec))) 60)) (getvar "DATE")))
 	(setq stop (getvar "date"))
(command "undo" "end")
(princ "\n")
(alert (strcat   "Th\U+1EDDi gian th\U+1EF1c hi\U+1EC7n ch\U+01B0\U+01A1ng tr\U+00ECnh l\U+00E0: " (rtos (- s2 s1) 2 3) " gi\U+00E2y"))
(princ)
)

nhờ bạn thanhduan2407 dưa thêm đọan mã của lisp cvt3d.lsp vao listp nội suy cao độ chm_chd_cdlt.lsp để lisp hoàn thiện hơn nhé thanks


<<

Filename: 211172_cvt3d.lsp
Tác giả: proconeng86
Bài viết gốc: 307518
Tên lệnh: cvp
lisp chia viewport trong layout

 

Bạn thử cái này. Chọn viewport trong layout, nhấp chọn điểm a, kéo ngang thì chia làm 2 vp theo phương ngang, kéo đứng thì chia 2 vp theo...

>>

 

Bạn thử cái này. Chọn viewport trong layout, nhấp chọn điểm a, kéo ngang thì chia làm 2 vp theo phương ngang, kéo đứng thì chia 2 vp theo phương đứng, còn enter thì chia thành 4 viewport tại a.

 

(defun c:cvp(/ os vp tt10 tt12 tt40 tt41 tyle p1 p2 b c)
  (defun dxf (id v) (cdr (assoc id (entget v))))
  (defun dtim (pt) (polar tt12 (angle tt10 pt) (* tyle (distance tt10 pt))))
  (defun make (a b)
    (command "mview" a b)
    (vla-put-CustomScale (vlax-ename->vla-object (entlast)) (/ 1.0 tyle))    
    (command "MSPACE")
    (command "zoom" (dtim a) (dtim b))
    (command "PSPACE")
  )
  
  (command "undo" "be")
  (setq os (getvar 'osmode))
  (mapcar 'setvar (list 'orthomode 'tilemode 'cmdecho 'osmode) (list 1 0 0 0))
  (setq vp  (car (entsel "\nChon viewport: "))
tt10 (dxf 10 vp)
tt12 (dxf 12 vp)
tt40 (dxf 40 vp)
tt41 (dxf 41 vp)
tyle (/ (dxf 45 vp) tt41 1.0)
p1 (polar (polar tt10 pi (* 0.5 tt40)) (* -0.5 pi) (* 0.5 tt41))
p2 (polar (polar tt10 0 (* 0.5 tt40)) (* 0.5 pi) (* 0.5 tt41))
b (getpoint "\Diem chia: ")
c (getpoint b "\nTheo huong <Enter neu chia 4>: "))
 
  (cond ((eq (car b) (car c))
           (make p1 (list (car b) (cadr p2)))
  (make (list (car b) (cadr p1)) p2))
 
((eq (cadr b) (cadr c)) 
           (make p1 (list (car p2) (cadr b)))
  (make (list (car p1) (cadr b)) p2))
 
        (t (make p1 b) (make b p2)
  (make b (list (car p1) (cadr p2)))
  (make b (list (car p2) (cadr p1))))
  )
  (entdel vp)
  (command "undo" "e")
  (mapcar 'setvar (list 'orthomode 'tilemode 'cmdecho 'osmode) (list 0 0 1 os))  
)

 

Lisp này rất tốt nhưng có 1 điều là nó đang tự động đổi layer của viewport theo layer hiện hành. Viewport toàn ở layer defpoint, ko để ý khi chia viewport mà layer hiện hành không phải là defpoint là nó đổi ngay theo layer hiện hành. khi in ra thấy ngay viewport. Bạn sửa lại giúp mình là khi chia viewport thì nó tự đổi layer của viewport là layer defpoint nhé

Mình cám ơn nhiều


<<

Filename: 307518_cvp.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 425283
Tên lệnh: dtt
NHỜ SỬA LISP ĐÁNH SỐ THỨ TỰ THÊM CHỨC NĂNG GIẢM DẦN CHO BLOCK ATT

Thử xem nhé!

(defun c:dtt  (/ ans ins lst blkName tagName ent ss str) ;Block Order
 ;; By : Gia_Bach, www.CadViet.com ;;
 (vl-load-com)
 (while (not (and (setq ent (car (nentsel "\nChon thuoc tinh can danh so: ")))
                  (if ent
                   (eq (cdr (assoc 0 (entget ent))) "ATTRIB"))))
  (princ "\n Ban chon nham roi! "))
 (setq blkName (cdr (assoc 2 (entget (cdr (assoc 330 (entget ent))))))
       tagName (cdr (assoc 2 (entget ent))))
 (or...
>>

Thử xem nhé!

(defun c:dtt  (/ ans ins lst blkName tagName ent ss str) ;Block Order
 ;; By : Gia_Bach, www.CadViet.com ;;
 (vl-load-com)
 (while (not (and (setq ent (car (nentsel "\nChon thuoc tinh can danh so: ")))
                  (if ent
                   (eq (cdr (assoc 0 (entget ent))) "ATTRIB"))))
  (princ "\n Ban chon nham roi! "))
 (setq blkName (cdr (assoc 2 (entget (cdr (assoc 330 (entget ent))))))
       tagName (cdr (assoc 2 (entget ent))))
 (or gtmtxt (setq gtmtxt "1"))
;;;  (initget 6)
 (setq ans (getstring (strcat "\nNhap so bat dau <" gtmtxt "> :")))
 (if (/= ans "")
  (setq gtmtxt ans))
 (setq str (strcase gtmtxt))
;;; Nhap so gia
 (or (and #sogia# (eq (type #sogia#) 'INT)) (setq #sogia# 1))
 (setq #sogia# (cond ((getint (strcat "\nNhap so gia <" (itoa #sogia#) ">: ")))
                     (#sogia#)))
 (princ "\nChon Khung ten can danh so thu tu :")
 (if (setq ss (ssget (list (cons 0 "INSERT") (cons 66 1) (cons 2 blkName))))
  (progn (vlax-for e  (vla-get-ActiveSelectionSet (vla-get-ActiveDocument (vlax-get-Acad-Object)))
          (setq ins (vlax-safearray->list (variant-value (vla-get-InsertionPoint e)))
                lst (cons (list e ins) lst)))
         (setq lst (vl-sort lst
                            '(lambda (x y)
                              (or (< (car (cadr x)) (car (cadr y)))
                                  (and (> (cadr (cadr x)) (cadr (cadr y))) (= (car (cadr x)) (car (cadr y))))))))
         (foreach e  (append (mapcar 'car lst))
          (foreach Att  (vlax-invoke e 'GetAttributes)
           (if (= (vla-get-TagString att) tagName)
            (vla-put-TextString att str)))
          (setq gtmtxt (tang1 gtmtxt))
          (setq str gtmtxt))))
 (princ))
(defun tang1  (te / chuoite1 sosaucung)
 (setq chuoite1  (vl-string-right-trim "- 0 1 2 3 4 5 6 7 8 9" te)
       sosaucung (vl-string-subst "" chuoite1 te))
 (if (/= chuoite1 "")
  (setq te (strcase (incC1 te)))
  (setq te (itoa (+ (atoi te) #sogia#)))))
(defun incC1  (c / i c1 c2)
;;;Increase character c
 (if (= sosaucung "")
  (setq i  (strlen c)
        c1 (substr c 1 (- i 1))
        c2 (chr (+ (ascii (substr c i 1)) #sogia#)))
  (setq c1 chuoite1
        c2 (itoa (+ (atoi sosaucung) #sogia#))))
 (if (or (= c2 "{") (= c2 "["))
  (progn (entdel (entlast)) (alert "Over character!") (exit))
  (strcat c1 c2)))

 


<<

Filename: 425283_dtt.lsp
Tác giả: thanhlong.hygt
Bài viết gốc: 253919
Tên lệnh: ha
Lisp xóa điểm trùng và sắp xếp lại đỉnh của LWPolyline

Nếu nhằm mục đích xóa tất cả các điểm trùng nhau của 1 Lwpolyline bất kỳ, không phân biệt có arc hay không, thì dùng lisp này...

>>

Nếu nhằm mục đích xóa tất cả các điểm trùng nhau của 1 Lwpolyline bất kỳ, không phân biệt có arc hay không, thì dùng lisp này (còn nếu có thêm điều kiện là chỉ xóa các điểm liên tiếp mà trùng nhau thì phải sửa lisp tí):

(defun C:HA( / ent)
(vl-load-com)
(if
  (and
   (setq ent (car (entsel "\nChon Lwpolyline: ")))
   (= "LWPOLYLINE" (cdr (assoc 0 (entget ent)))))
  (entmod (LM:HA:UniqueFuzz (entget ent) 1E-8)))
(princ))
(defun LM:HA:UniqueFuzz (lst fz)
(if lst
  (cons (car lst) (LM:HA:UniqueFuzz (vl-remove-if '(lambda (x) (if (= 10 (car x)) (equal x (car lst) fz))) (cdr lst)) fz))))

Bạn có thể giúp mình bổ sung thêm chức năng nhập khoảng cách min bỏ đỉnh không. Nếu khoảng cách nhỏ hơn khoảng cách min thì bỏ đỉnh nếu khoảng cách lớn hơn thì  giữ nguyên lại đỉnh. thank bạn


<<

Filename: 253919_ha.lsp
Tác giả: chippy
Bài viết gốc: 269767
Tên lệnh: 2csv
nhờ giúp list tính diện tích trong cad và tự động nhập trong excel

 

Bạn chạy thử Lisp xuất ra file CSV

sau đó dùng Excel mở file này, save as qua file *.xls

 

Cách sử dụng : tên lệnh...

>>

 

Bạn chạy thử Lisp xuất ra file CSV

sau đó dùng Excel mở file này, save as qua file *.xls

 

Cách sử dụng : tên lệnh 2CSV

lần luơt chọn :

- Text để lấy số lô

- đối tuơng để lấy Diện tích

- đối tuơng để lấy Khoảng lùi

 

lặp lại các buớc trên, nhấn Enter để kết thúc quá trình chọn.

- Chỉ ra ten file -> kết thúc.

 

(defun c:2Csv (/ chdai dtich ent1 ent2 ent3 lst solo tmp)  (vl-load-com)    (while (and	   (setq ent1 (car (entsel "\nchon Text de lay So lo :")))	   (= (cdr (assoc 0 (entget ent1))) "TEXT")	   (setq solo (vlax-get(vlax-Ename->Vla-Object ent1)'TextString))	   	   (setq ent2 (car (entsel "\nchon doi tuong de lay Dien tich :"))		 ent2 (vlax-Ename->Vla-Object ent2))	   (and (vlax-property-available-p ent2 'area)	     (setq dtich (vlax-get ent2 'Area) )  )	   	   (setq ent3 (car (entsel "\nchon doi tuong de lay Khoang lui :"))		 ent3 (vlax-Ename->Vla-Object ent3))	   (and (vlax-property-available-p ent3 'Length)	     (setq chdai (vlax-get ent3 'Length) )  )  )    (princ "\n")       (princ (setq tmp (strcat solo "," (rtos dtich) "," (rtos chdai))))    (setq lst (append lst (list tmp)))  )    (if (setq tmp (getfiled "Ten file " (getvar "dwgprefix") "csv" 1))    (progn      (setq tmp (open tmp "a"))      (write-line "So lo,Dien tich,Khoang lui" tmp)            (foreach txt lst	(write-line txt tmp)   )      (close tmp)))  (princ))

Kính chào các anh trong ban quản trị diễn đàn cadviệt.com em mới tham gia diễn đàn và đọc các bài viết mọi người em thấy rất hay và bỗ ích. hiện nay trong công việc em đang làm gặp rất nhiều khó khăn và tốn thời gian xin các anh viết giúp em một cái lisp tự động tính diện tích các hình trong cad sau đó xuất sang excell. nói thì rất khó nên em đã diễn tả trong file đính kèm. trân thành cảm ơn các anh trong ban quản trị và mọi người trong dien đàn.http://www.cadviet.com/upfiles/3/126616_file_dinh_kem.rar


<<

Filename: 269767_2csv.lsp
Tác giả: trinhvqh
Bài viết gốc: 86045
Tên lệnh: 2csv
nhờ giúp list tính diện tích trong cad và tự động nhập trong excel
Hôm nay bác trinhvqh vui tính quá ! :undecided:

BTW, thanks you very nhiều :undecided:

 

Click vào đối tuợng Text để lấy Số lô

Click vào...

>>
Hôm nay bác trinhvqh vui tính quá ! :undecided:

BTW, thanks you very nhiều :undecided:

 

Click vào đối tuợng Text để lấy Số lô

Click vào đối tuợng lô đất để lấy diện tích.

Click vào đối tuợng Text để lấy Khoảng lùi.

 

Ngay từ đầu, nếu bạn đưa file CAD lên thì mọi chuyện đơn giản hơn không ?

(defun c:2Csv (/ chdai dtich ent1 ent2 ent3 lst solo tmp)
 (vl-load-com)  
 (while (and
   (setq ent1 (car (entsel "\nchon Text de lay So lo :")))
   (= (cdr (assoc 0 (entget ent1))) "TEXT")
   (setq solo (vlax-get(vlax-Ename->Vla-Object ent1)'TextString))	   
   (setq ent2 (car (entsel "\nchon doi tuong (lo dat) de lay Dien tich :"))
	 ent2 (vlax-Ename->Vla-Object ent2))
   (and (vlax-property-available-p ent2 'area)
     (setq dtich (vlax-get ent2 'Area) )  )	   
   (setq ent3 (car (entsel "\nchon Text de lay Khoang lui :")))
   (= (cdr (assoc 0 (entget ent1))) "TEXT")
   (setq chdai (vlax-get(vlax-Ename->Vla-Object ent3)'TextString) )  )
   (princ "\n")   
   (princ (setq tmp (strcat solo "," (rtos dtich) "," (rtos chdai))))
   (setq lst (append lst (list tmp)))  )  
 (if (setq tmp (getfiled "Ten file " (getvar "dwgprefix") "csv" 1))
   (progn
     (setq tmp (open tmp "a"))
     (write-line "So lo,Dien tich,Khoang lui" tmp)      
     (foreach txt lst
(write-line txt tmp)   )
     (close tmp)))
 (princ))

 

Có lẽ vẫn chưa đúng yêu cầu "em nó" rồi

Khoảng lùi: Click vào Dimension (nhìn hình đoán thế)


<<

Filename: 86045_2csv.lsp
Tác giả: sgcq
Bài viết gốc: 287500
Tên lệnh: test
Lisp nối Line thành Pline ?

Nhân đề nghị của anh 2 lúa cad nông dân bên trên tôi làm thêm 1 bước nữa, chỉ cần đánh lệnh test nó sẽ tự động nối line,arc.

Nhưng...

>>

Nhân đề nghị của anh 2 lúa cad nông dân bên trên tôi làm thêm 1 bước nữa, chỉ cần đánh lệnh test nó sẽ tự động nối line,arc.

Nhưng tôi chưa có file line arc số lượng lớn để test, bạn nào có file lớn đưa lên để test thử. File lisp như sau:

 

 

(defun c:test(/ kc L1 L2 tieptuc tm1 tm2 tm ng obj)
  (defun noithem(d v kc tr / tm tm1)
    (if (setq tm (car (vl-remove nil
(mapcar '(lambda(x) (if (and (/= v (cadar x))
    (or (<= (distance d (car x)) kc) (<= (distance d (last x)) kc))) x nil)) L1))))
    (if (or (and tr (<= (distance d (car tm)) kc)) 
            (and (not tr) (<= (distance d (last tm)) kc)))
    (setq ng t tm1 (reverse tm))
    (setq ng nil tm1 tm)))
  )
  
  (defun ssfrom (sl / ss0) (setq ss0 (ssadd)) (foreach v sl (ssadd v ss0)) ss0)
  ;;;
  (setq kc (getreal "\nNhap khoang ho cho phep de noi:")
L1 (mapcar '(lambda(x) (list (vlax-curve-getStartPoint (setq obj (vlax-ename->vla-object x))) x
(vlax-curve-getEndPoint obj))) (acet-ss-to-list (ssget "X" '((0 . "LINE,ARC")))))
L2 (list (car L1))
L1 (cdr L1))
  (setvar "cmdecho" 0)
  (while L1
    (setq tieptuc t)
    (while tieptuc      
      (if (setq tm1 (noithem (caar L2) (cadar L2) kc t))
        (setq L2 (cons tm1 L2) L1 (vl-remove (if ng (reverse tm1) tm1) L1)))
      (if (setq tm2 (noithem (last (last L2)) (cadr (last L2)) kc nil))
        (setq L2 (append L2 (list tm2)) L1 (vl-remove (if ng (reverse tm2) tm2) L1)))
      (if (and (not tm1)(not tm2))
(setq tieptuc nil
     tm (COMMAND ".PEDIT" "M" (ssfrom (mapcar 'cadr L2)) ""  "Y" "J" kc "")
     L2 (list (car L1))
     L1 (cdr L1)))
    )
  )
  (setvar "cmdecho" 1)
)
 

:D :D :D

Đây là file ví dụ:

http://www.cadviet.com/upfiles/3/110802_hoankiempart1.rar

http://www.cadviet.com/upfiles/3/110802_hoankiempart2.rar

2 lúa chỉ cần gõ lệnh, chọn option thì sẽ tự động nối. 

Việc line, arc nào là lề đường, line arc nào là thửa tất nhiên 2 lúa sẽ tự lo;

 

2 lúa đề xuất cái này như 1 dạng option, không phải là 1 lisp riêng. 

Vì nhiều bạn vẫn cần lisp có thể pick được từng line rồi nối lại.

Riêng 2 lúa lại cần tổng thể hơn một chút.

 

Với lisp đã có sẵn, 2 lúa thấy nó chạy rất ổn.

Nhưng với file như trên, 2 lúa phải tốn thêm khoảng 30 ngày mới có thể pick hết các line. :D

:D :D :D


<<

Filename: 287500_test.lsp

Trang 261/330

261