Jump to content
InfoFile
Tác giả: aabbccdd
Bài viết gốc: 359900
Tên lệnh: stan
Lisp đánh lý trình center line

Lisp đánh lý trình trên center line/polyline cho trước (kiểu 0+000)

Filename: 359900_stan.lsp
Tác giả: duy782006
Bài viết gốc: 359988
Tên lệnh: ttt
Lisp thay thế một phần nội dung text
Ví dụ : Có một đoạn text "1aaa", "1bbb", "1ccc",..., "1zzz"
Bản vẽ thứ 2 sửa thành :"2aaa", "2bbb", "2ccc",..., "2zzz"
Bản vẽ thứ 9 sửa thành :"9aaa", "9bbb", "9ccc",..., "9zzz"

Filename: 359988_ttt.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 360611
Tên lệnh: apo
Lisp chèn nhanh các đối tượng Point vào enpoint của đối tượng

Chọn đối tượng
Đầu vào các loại đối tượng vẽ (line, arc, circle, ellipse, polyline, ray)
Kết quả là các point được add thêm vào tại các vị trí end_point của các đối tượng đầu vào

Filename: 360611_apo.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 361783
Tên lệnh: pl1
Lisp vẽ, chỉnh sửa đường 3D Polyline theo độ dốc

Dùng lệnh, nhập cao độ tại điểm đầu pick chuột
Nhập độ dốc tính toán, pick chuột vào điểm tiếp theo khi đó sẽ tạo được đường 3D polyline với 2 cao độ 2 đỉnh có độ dốc mình vừa nhập. tiếp tục hỏi độ dốc và vẽ các đỉnh tiếp theo của đường Polyline.
Khi muốn chỉnh độ dốc của đường Polyline thì mình kick vào đoạn cần chỉnh (giả sử đoạn này tạo bởi 2 đỉnh...
>>
Dùng lệnh, nhập cao độ tại điểm đầu pick chuột
Nhập độ dốc tính toán, pick chuột vào điểm tiếp theo khi đó sẽ tạo được đường 3D polyline với 2 cao độ 2 đỉnh có độ dốc mình vừa nhập. tiếp tục hỏi độ dốc và vẽ các đỉnh tiếp theo của đường Polyline.
Khi muốn chỉnh độ dốc của đường Polyline thì mình kick vào đoạn cần chỉnh (giả sử đoạn này tạo bởi 2 đỉnh số 1 và 2) nhập độ dốc mới và lisp sẽ tính toán cao độ đỉnh Polyline đỉnh số 2 theo cao độ đỉnh số 1 và độ dốc nhập vào. Các đỉnh tiếp theo của đường Polyline sẽ tự động được tính lại dựa vào độ dốc vốn có của nó.
<<

Filename: 361783_pl1.lsp
Tác giả: Oohlala
Bài viết gốc: 361854
Tên lệnh: mtll
Lisp tạo viewport từ khung chọn bên model
(defun Makepline (listpoint closed Layer Linetype LTScale xdata / Lst)
	(setq Lst (list '(0 . "LWPOLYLINE")'(100 . "AcDbEntity")
	(cons 8 (if Layer Layer (getvar "Clayer")))
	(cons 6 (if Linetype Linetype "bylayer"))
	(cons 48 (if LTScale LTScale 1))
	'(100 . "AcDbPolyline")
	(cons 90 (length listpoint))
	(cons 70 (if closed 1 0))))
	(foreach PP listpoint	(setq Lst (append Lst (list (cons 10 PP)))))
	(if xdata (setq Lst (append lst (list (cons -3 (list...
>>
(defun Makepline (listpoint closed Layer Linetype LTScale xdata / Lst)
	(setq Lst (list '(0 . "LWPOLYLINE")'(100 . "AcDbEntity")
	(cons 8 (if Layer Layer (getvar "Clayer")))
	(cons 6 (if Linetype Linetype "bylayer"))
	(cons 48 (if LTScale LTScale 1))
	'(100 . "AcDbPolyline")
	(cons 90 (length listpoint))
	(cons 70 (if closed 1 0))))
	(foreach PP listpoint	(setq Lst (append Lst (list (cons 10 PP)))))
	(if xdata (setq Lst (append lst (list (cons -3 (list xdata))))))
	(entmakex Lst))
;end;=================================
;;;;;;;;;;
(defun _layer2 ( name colour )
    (if (null (tblsearch "LAYER" name))
        (entmake
            (list
               '(0 . "LAYER")
               '(100 . "AcDbSymbolTableRecord")
               '(100 . "AcDbLayerTableRecord")
               '(70 . 0)
                (cons 2 name)
                (cons 62 colour)
            )
        )
    )
)
; ham luu gia tri
(defun getvalue ( a giatri dongnhac / astr) 
(or a (setq a giatri))
(cond
	((= (type a) 'INT) (setq a (cond ((getint (strcat "\n" dongnhac "(" (itoa a) ") :")))(a))))
	((= (type a) 'REAL) (setq a (cond ((getreal (strcat "\n" dongnhac "(" (rtos a 2 0) ") :")))(a))))
	((= (type a) 'STR) (setq a (cond ((= "" (setq astr (getstring 1 (strcat "\n" dongnhac " (" a "): ")))) a) (astr))))
))
;;;;
;============================================================
;========LISP TAO VIEWPORT TREN LAYOUT BANG CACH CHON O MODEL========
;=========================REV4ii=====================================
(defun C:mtll( / os lst khung X_min Y_min X_max Y_max X index taphop pt1)
(vl-load-com)
(if (null (tblsearch "LAYER" "khung")) (_layer2 "Khung" 3))
  (command "UNDO" "BE")
  (setq os(getvar "OSMODE"))
  (setvar "OSMODE" 0)
  (while (/= (setq taphop (ssget "+.:E:S" '((0 . "LWPOLYLINE")))) nil)
  (progn
   (setq tyleVT (getvalue tyleVT 1000.0 "Nhap ty le ban do: "))
  (command "LAYOUT" "S" "Layout1")
  (setq pt1 (getpoint "\nchon diem dat khung"))
  (command "ZOOM" "E")
    (setq khung (ssname taphop 0))
    (setq lst (cdr (acet-geom-vertex-list khung)))
    (setq X_min 1000000000
      Y_min 1000000000
      X_max -1000000000
      Y_max -1000000000)
    (foreach a lst
      (if (< (car a) X_min) (setq X_min (car a)))
      (if (< (cadr a) Y_min) (setq Y_min (cadr a)))
      (if (> (car a) X_max) (setq X_max (car a)))
      (if (> (cadr a) Y_max) (setq Y_max (cadr a)))
      )
    (command "LAYOUT" "S" "Layout1")
    (command "ZOOM" "W" (list X_min Y_min) (list X_max Y_max))
    (makepline lst 1 "Khung" nil nil nil)
    (command "MOVE" (entlast) "" (list X_min Y_min) (list (car pt1) 0))
    (command "ZOOM" "W" (list 0 0) (list (+ (car pt1) 100) 0))
    (command "SCALE" (entlast) "" (list (car pt1) 0) (/ 1000 tyleVT))
    (command "MVIEW" "O" (entlast))
    (command "MSPACE")
    (command "ZOOM" (list X_min Y_min) (list X_max Y_max))
    (command "PSPACE")
	(command "MVIEW" "L" "on" (entlast) "")
    (command "ZOOM" "W" (list 0 0) (list (+ (car pt1) 100) 0))
    (command "MODEL")
    ) ;ene progn while
	) ; end while
  (command "MODEL")
  (command "UNDO" "END")
  (setvar "OSMODE" os)
  (princ)
  )
;======================================================= 

Mình tìm được 1 lsp về tạo viewport từ khung chọn bên model trong topic này http://www.cadviet.com/forum/topic/68723-yeu-cau-lisp-tao-viewport-tu-khung-chon-ben-model/page-6

 

lsp #109 của nhoclangbat rất gần với nhu cầu làm việc của mình, mình muốn nhờ bạn nào biết về lsp sửa giúp cho phù hợp với mình.

 

Mình muốn sửa cách thức nhập tỷ lệ cho viewport khi lsp yêu cầu nhập tỷ lệ ở dòng command ( vd tỷ lệ 1/50 thì nhập là 1/50, tỷ lệ 2/1 thì nhập là 2/1 )

Thứ 2 là tỷ lệ của viewport, ( mình dùng lsp này thấy có vẻ như tác giả scale khung viewport lên n lần theo cái tỷ lệ nhập vào khi lsp yêu cầu ) giờ mình muốn sửa lại là cái viewport đc tạo ra bên layout y nguyên cái khung bên model.

Nhân tiện có cách nào để chỉnh linetype của khung viewport thành nét đứt đc không ?

 

 


<<

Filename: 361854_mtll.lsp
Tác giả: snowman.hms
Bài viết gốc: 362233
Tên lệnh: m2v
Lisp tạo viewport từ khung chọn bên model
(defun c:m2v (/ #app #doc *error* c cmd lay lst o sc vp)

  (defun *error* (msg)
    (and cmd (setvar 'cmdecho cmd))
    (and #doc (vla-endundomark #doc))
    (if	(and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*,")))
      (princ (strcat "\nError: " msg))
    )
  )
  
  (setq #app (vlax-get-acad-object)
	#doc (vla-get-activedocument #app)
	cmd (getvar 'cmdecho))
  
  (if (= 0 (vla-get-activespace #doc)) (vla-put-activespace #doc 1))
  
  (if (and...
>>
(defun c:m2v (/ #app #doc *error* c cmd lay lst o sc vp)

  (defun *error* (msg)
    (and cmd (setvar 'cmdecho cmd))
    (and #doc (vla-endundomark #doc))
    (if	(and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*,")))
      (princ (strcat "\nError: " msg))
    )
  )
  
  (setq #app (vlax-get-acad-object)
	#doc (vla-get-activedocument #app)
	cmd (getvar 'cmdecho))
  
  (if (= 0 (vla-get-activespace #doc)) (vla-put-activespace #doc 1))
  
  (if (and (princ    "\nSelect a Closed LwPolyline:  ")
	   (setq o   (ssget "_+.:E:S" '((0 . "LWPOLYLINE") (70 . 1))))
	   (setq o   (ssname o 0))
	   (setq c   (pline-centroid o))
	   (setq o   (vlax-ename->vla-object o))
	   (setq sc  (distof (getstring "\nEnter Scale for new Viewport: ")))
	   (setq sc  (/ 1.0 sc))
      )
    (progn
      (vlax-for	lay (vla-get-layouts #doc)
	(if (/= "MODEL" (strcase (vla-get-name lay)))
	  (setq lst (cons (cons (vla-get-name lay) lay) lst))
	)
      )
      (if (setq	lst
		 (mapcar
		   '(lambda (x) (cdr (assoc x lst)))
		   (LM:Listbox
		     "Choose Layout[s] to create ViewPort"
		     (mapcar 'car
			     (vl-sort lst
				      '(lambda (a b)
					 (< (vla-get-taborder (cdr a))
					    (vla-get-taborder (cdr b))
					 )
				       )
			     )
		     )
		     t
		   )
		 )
	  )
	(progn
	  (vla-startundomark #doc)
	  (LM:loadlinetypes '("hidden") nil)
	  (setvar 'cmdecho 0)
	  (foreach lay lst
	    (vla-put-activelayout #doc lay)
	    (setq vp (vlax-vla-object->ename
		       (car (vlax-invoke
			      #doc
			      'copyobjects
			      (list o)
			      (vla-get-block lay)
			    )
		       )
		     )
	    )
	    (vla-put-linetype (vlax-ename->vla-object vp) "hidden")
            (vla-ZoomExtents #app)
	    (vl-cmdf "_.mview" "_object" vp)
	    (setq vp (vlax-ename->vla-object (entlast)))
	    (vla-put-linetype vp "hidden")
	    (vla-display vp :vlax-true)
	    (vla-put-mspace #doc :vlax-true)
	    (vla-put-ActivePViewport #doc vp)
	    (vla-zoomCenter #app (vlax-3d-point c) 1.0)
	    (vla-put-mspace #doc :vlax-false)
	    (vla-put-customscale vp sc)
	    (VLA-ZoomObject vp)
	  )
	)
      )
    )
  )
  (*error* nil)
  (princ)
)

;;==================================================================;;
;;======================== SUB FUNCTION ============================;;
;;==================================================================;;


;;=================== POLYLINE CENTROID BY GILE=====================;;
;; ALGEB-AREA
;; Returns tha algebraic area of the triangle defined by 3  2d points
;; the area is negative if points are clockwise

(defun algeb-area (p1 p2 p3)
  (/ (-	(* (- (car p2) (car p1))
	   (- (cadr p3) (cadr p1))
	)
	(* (- (car p3) (car p1))
	   (- (cadr p2) (cadr p1))
	)
     )
     2.0
  )
)

;; TRIANGLE-CENTROID
;; Returns the centroid of a triangle defined by 3 points

(defun triangle-centroid (p1 p2 p3)
  (mapcar '(lambda (x1 x2 x3)
	     (/ (+ x1 x2 x3) 3.0)
	   )
	  p1
	  p2
	  p3
  )
)

;; POLYARC-CENTROID
;; Returns a list which first item is the centroid of a 'polyarc'
;; and the second its algeraic area
;;
;; Arguments
;; bu : polyarc bulge
;; p1 : start point
;; p2 : end point

(defun polyarc-centroid	(bu p1 p2 / ang rad cen area dist cg)
  (setq	ang  (* 2 (atan bu))
	rad  (/	(distance p1 p2)
		(* 2 (sin ang))
	     )
	cen  (polar p1
		    (+ (angle p1 p2) (- (/ pi 2) ang))
		    rad
	     )
	area (/ (* rad rad (- (* 2 ang) (sin (* 2 ang)))) 2.0)
	dist (/ (expt (distance p1 p2) 3) (* 12 area))
	cg   (polar cen
		    (- (angle p1 p2) (/ pi 2))
		    dist
	     )
  )
  (list cg area)
)

;; PLINE-CENTROID
;; Returns the WCS coordinates of a lwpolyline centroid
;;
;; Argument
;; pl : the lwpolyline ename

(defun pline-centroid (pl / elst lst tot cen p0 area cen)
  (setq elst (entget pl))
  (while (setq elst (member (assoc 10 elst) elst))
    (setq lst  (cons (cons (cdar elst) (cdr (assoc 42 elst))) lst)
	  elst (cdr elst)
    )
  )
  (setq	lst (reverse lst)
	tot 0.0
	cen '(0.0 0.0)
	p0  (caar lst)
  )
  (if (/= 0 (cdar lst))
    (setq p-c (polyarc-centroid (cdar lst) p0 (caadr lst))
	  cen (mapcar '(lambda (x) (* x (cadr p-c))) (car p-c))
	  tot (cadr p-c)
    )
  )
  (setq lst (cdr lst))
  (if (equal (car (last lst)) p0 1e-9)
    (setq lst (reverse (cdr (reverse lst))))
  )
  (while (cadr lst)
    (setq area (algeb-area p0 (caar lst) (caadr lst))
	  cen  (mapcar '(lambda (x1 x2) (+ x1 (* x2 area)))
		       cen
		       (triangle-centroid p0 (caar lst) (caadr lst))
	       )
	  tot  (+ area tot)
    )
    (if	(/= 0 (cdar lst))
      (setq p-c	(polyarc-centroid (cdar lst) (caar lst) (caadr lst))
	    cen	(mapcar	'(lambda (x1 x2) (+ x1 (* x2 (cadr p-c))))
			cen
			(car p-c)
		)
	    tot	(+ tot (cadr p-c))
      )
    )
    (setq lst (cdr lst))
  )
  (if (/= 0 (cdar lst))
    (setq p-c (polyarc-centroid (cdar lst) (caar lst) p0)
	  cen (mapcar '(lambda (x1 x2) (+ x1 (* x2 (cadr p-c))))
		      cen
		      (car p-c)
	      )
	  tot (+ tot (cadr p-c))
    )
  )
  (trans (list (/ (car cen) tot)
	       (/ (cadr cen) tot)
	       (cdr (assoc 38 (entget pl)))
	 )
	 pl
	 0
  )
)

;;-----------------------=={ List Box }==---------------------;;
;;                                                            ;;
;;  Displays a List Box allowing the user to make a selection ;;
;;  from the supplied data.                                   ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2012 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  title    - List Box Dialog title                          ;;
;;  lst      - List of Strings to display in the List Box     ;;
;;  multiple - Boolean flag to determine whether the user     ;;
;;             may select multiple items (T=Allow Multiple)   ;;
;;------------------------------------------------------------;;
;;  Returns:  List of selected items, else nil.               ;;
;;------------------------------------------------------------;;
 
(defun LM:ListBox ( title lst multiple / dch des tmp res )
    (cond
        (   (not
                (and
                    (setq tmp (vl-filename-mktemp nil nil ".dcl"))
                    (setq des (open tmp "w"))
                    (write-line
                        (strcat
                            "listbox : dialog { label = \""
                            title
                            "\"; spacer; : list_box { key = \"list\"; multiple_select = "
                            (if multiple "true" "false")
                            "; } spacer; ok_cancel; }"
                        )
                        des
                    )
                    (not (close des))
                    (< 0 (setq dch (load_dialog tmp)))
                    (new_dialog "listbox" dch)
                )
            )
            (prompt "\nError Loading List Box Dialog.")
        )
        (   t     
            (start_list "list")
            (foreach item lst (add_list item))
            (end_list)
            (setq res (set_tile "list" "0"))
            (action_tile "list" "(setq res $value)")
            (setq res
                (if (= 1 (start_dialog))
                    (mapcar '(lambda ( x ) (nth x lst)) (read (strcat "(" res ")")))
                )
            )
        )
    )
    (if (< 0 dch)
        (unload_dialog dch)
    )
    (if (and tmp (setq tmp (findfile tmp)))
        (vl-file-delete tmp)
    )
    res
)

;; Load Linetypes  -  Lee Mac
;; Attempts to load a list of linetypes from any .lin files found in the support path.
;; Excludes known metric & imperial definition files based on the value of MEASUREMENT
;; lts - [lst] List of linetypes to load
;; rdf - [bol] If T, linetypes will be redefined from file if already loaded
;; Returns: [bol] T if all linetypes are loaded successfully, else nil
 
(defun LM:loadlinetypes ( lts rdf / lst ltc rtn val var )
    (if (zerop (getvar 'measurement))
        (setq lst (mapcar 'strcase '("acadiso.lin" "iso.lin")))  ;; Known metric .lin files
        (setq lst (mapcar 'strcase '("acad.lin" "default.lin"))) ;; Known imperial .lin files
    )
    (setq ltc  (vla-get-linetypes (vla-get-activedocument (vlax-get-acad-object)))
          var '(cmdecho expert)
          val  (mapcar 'getvar var)
          lst  (vl-remove-if '(lambda ( x ) (member (strcase x) lst))
                   (apply 'append
                       (mapcar '(lambda ( dir ) (vl-directory-files dir "*.lin" 1))
                           (vl-remove "" (LM:str->lst (getenv "ACAD") ";"))
                       )
                   )
               )
    )
    (mapcar 'setvar var '(0 5))
    (setq rtn
        (apply 'and
            (mapcar
               '(lambda ( typ )
                    (cond
                        (   (not (tblsearch "ltype" typ))
                            (vl-some
                               '(lambda ( lin )
                                    (vl-catch-all-apply 'vla-load (list ltc typ lin))
                                    (tblsearch "ltype" typ)
                                )
                                lst
                            )
                        )
                        (   rdf
                            (vl-some
                               '(lambda ( lin )
                                    (and (LM:ltdefined-p typ lin)
                                         (vl-cmdf "_.-linetype" "_L" typ lin "")
                                         (tblsearch "ltype" typ)
                                    )
                                )
                                lst
                            )
                        )
                        (   t   )
                    )
                )
                lts
            )
        )
    )
    (mapcar 'setvar var val)
    rtn
)
 
;; Linetype Defined-p  -  Lee Mac
;; Returns T if the linetype is defined in the specified .lin file
;; ltp - [str] Linetype name
;; lin - [str] Filename of linetype definition file (.lin)
 
(defun LM:ltdefined-p ( ltp lin / str rtn )
    (if
        (and
            (setq lin (findfile lin))
            (setq lin (open lin "r"))
        )
        (progn
            (setq ltp (strcat "`*" (strcase ltp) "`,*"))
            (while
                (and (setq str (read-line lin))
                     (not (setq rtn (wcmatch (strcase str) ltp)))
                )
            )
            (close lin)
            rtn
        )
    )
)
 
;; String to List  -  Lee Mac
;; Separates a string using a given delimiter
;; str - [str] String to process
;; del - [str] Delimiter by which to separate the string
;; Returns: [lst] List of strings
 
(defun LM:str->lst ( str del / pos )
    (if (setq pos (vl-string-search del str))
        (cons (substr str 1 pos) (LM:str->lst (substr str (+ pos 1 (strlen del))) del))
        (list str)
    )
)

(defun VLA-ZoomObject (obj / minPt maxPt)
  (vla-GetBoundingBox obj 'minPt 'maxpt)
  (vla-ZoomWindow (vlax-get-acad-object) minPt maxpt)
)

(vl-load-com)
;|«Visual LISP© Format Options»
(70 2 1 2 nil "_eof " 100 9 0 0 1 T T T T)
;*** DO NOT add text below the comment! ***|;


<<

Filename: 362233_m2v.lsp
Tác giả: lamngoctien0810
Bài viết gốc: 337466
Tên lệnh: cl
Lisp đo tổng chiều dài đối tượng trên CAD 2015, 2016

Em thay đoạn mã vào nhưng khi load lips vẫn báo lỗi.

Command: CL
; error: quit / exit abort
;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/763-routine-tinh-tong-chieu-dai-cac-doi-tuong/
;Form chuong trinh va cac thao tac
(DEFUN CALLINE(/ DCL_ID_CALLINE cd_temp ID_ha ss)  
  (setq DCL_ID_CALLINE (load_dialog "CALLINE.DCL"))
  (if...
>>

Em thay đoạn mã vào nhưng khi load lips vẫn báo lỗi.

Command: CL
; error: quit / exit abort
;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/763-routine-tinh-tong-chieu-dai-cac-doi-tuong/
;Form chuong trinh va cac thao tac
(DEFUN CALLINE(/ DCL_ID_CALLINE cd_temp ID_ha ss)  
  (setq DCL_ID_CALLINE (load_dialog "CALLINE.DCL"))
  (if (not(new_dialog "CALLINE" DCL_ID_CALLINE)) (exit))  
  (start_list "La_CL")  
  (mapcar 'add_list LiLa)
  (end_list)  
  (Setvalue_CL)
  (action_tile "Sele_CL" "(Getvalue_CL) (done_dialog 2)")
  (action_tile "Info" "(ABOUT)")
  (action_tile "ChkLa_CL" "(IsChkLa_CL)")
  (setq RES (start_dialog))  
  (if (= RES 2)
	(progn	  
	  (prompt "Chon doi tuong:")
	  (setq la_name (LANAME LiLa (atoi la_CL)))	 
	  (if (= chk_CL "1")	
	(setq ss (ssget (List (cons 8 la_name))))
	(setq ss (ssget))
	  )
	  (if (/= ss Nil)
	(progn
	  (setq n (sslength ss))
		  (setq i 0)
		  (While (< i n)
			(setq dt (ssname ss i))
		(if (OR (= (TENDOITUONG dt) "LINE")
				(= (TENDOITUONG dt) "LWPOLYLINE")
								(= (TENDOITUONG dt) "POLYLINE")
				(= (TENDOITUONG dt) "SPLINE")
				(= (TENDOITUONG dt) "ARC")
				(= (TENDOITUONG dt) "CIRCLE"))
		  (progn	  
			(setq ID_ha (ID_HANDLE dt))
			(if (IsNotExist ID_ha)
			  (progn		
				(setq List_obj (Append List_obj (List ID_ha)))
				(setq cd_temp (CDAIOBJ dt))
				(setq chieudai_CL (+ chieudai_CL cd_temp))
			  )
			  (alert "Doi tuong nay da duoc chon")
			)	  
		  )
		)  
			(setq i (+ 1 i))					   
		  )
	)  
	(alert "Khong co doi tuong nao duoc chon!")
	  )
	  (CALLINE)
	)
  )  
  (unload_dialog DCL_ID_CALLINE) 
)
;Khoi dong
(DEFUN CALINIT()
  (CREALILA)
  (if (Null La_CL)
	(setq la_CL "0")
  )  
  (setq chieudai_CL 0)
  (if (Null chk_CL)
	(setq chk_CL "0")
  )
  (setq List_obj Nil)
)
;Cai dat cac gia tri
(DEFUN Setvalue_CL()
  (set_tile "L_CL" (rtos chieudai_CL 2 2))
  (set_tile "La_CL" la_CL)
  (set_tile "ChkLa_CL" chk_CL)
  (IsChkLa_CL)
)
;Nhan gia tri
(DEFUN Getvalue_CL()
  (setq chk_CL (get_tile "ChkLa_CL"))
  (setq chieudai (atof (get_tile "L_CL")))
  (setq la_CL (get_tile "La_CL"))
)
;Nhan handle
(DEFUN ID_HANDLE (obj / idha)
  (setq idha (CDR (ASSOC 5 (ENTGET obj))))  
  idha
)
;Thay doi trang thai
(DEFUN IsChkLa_CL ()
  (if (= (get_tile "ChkLa_CL") "1")
	(mode_tile "La_CL" 0)
	(mode_tile "La_CL" 1)
  )
)
;Kiem tra ton tai
(DEFUN IsNotExist (id / l in IsOK id_temp)
  (setq IsOK T)
  (setq l (length List_obj))
  (If (= l 0)
	(setq IsOK T)
	(progn
	  (setq in 0)
	  (while (< in l)
	(setq id_temp (nth in List_obj))
	(If (= id id_temp)
	  (setq IsOK Nil)
	)
	(setq in (1+ in))
	  )
	)
  )
  IsOK
)
;Ham thong tin
(DEFUN ABOUT(/ DCL_ID_ABOUT)
  (setq DCL_ID_ABOUT (load_dialog "CALLINE.DCL"))
  (if (not(new_dialog "ABOUT" DCL_ID_ABOUT))(exit))  
  (start_list "aboutme")
  (add_list " ")  
  (add_list "  VO KIEN CUONG - Bachelor of IT")
  (add_list "  =====================================================")
  (add_list "  Email : vkcuong_23@yahoo.com")
  (add_list "  Mobile: 0983616182 - 0977352125")
  (add_list "  CAD developer (LISP, DCL, VBA for AutoCad, ObjectARX...)")  
  (add_list "  ")
  (end_list)
  (start_dialog)
  (unload_dialog DCL_ID_ABOUT)
)
;Ham thuc thi chuong trinh
(DEFUN C:CL()
  (setvar "CMDECHO" 0)
  (CALINIT)  
  (CALLINE)
  (setvar "CMDECHO" 1)
)
;Ham lai chieu dai
(DEFUN CDAIOBJ(obj / cdai)
  (command-s "LENGTHEN" obj "" "" "")
  (setq cdai (getvar "PERIMETER"))
  cdai
)
;ham lay ten doi tuong
(DEFUN TENDOITUONG (obj / name)
  (setq name (CDR (ASSOC 0 (ENTGET obj))))  
  name  
)
;Ham tao danh sach layer
(DEFUN CREALILA (/ NL)
  (setq LiLa (List))
  (setq NL (tblnext "LAYER" T))  
  (while NL	
	(setq LiLa (append LiLa (list (cdr (assoc 2 NL)))))
	(setq NL (tblnext "LAYER"))
  )
  (setq LiLa (Acad_strlsort LiLa))
)
;Ham lay layer
(DEFUN LANAME(LiLa index / la)
  (setq la (nth index LiLa))
  la
)

Bác xem có cách nào không ah.

PS: Em dùng trên AutoCAD 2016.

Thank bác!


<<

Filename: 337466_cl.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 362488
Tên lệnh: path
Lisp hiển thị đường dẫn của file Lisp vừa mới Load
Ví dụ: đường dẩn file lisp như thế này E:\BV\DUY\DUONGAN.LSP
sau khi load lên thì thu được biến tenđuongan là E:\BV\DUY\

Filename: 362488_path.lsp
Tác giả: ssg
Bài viết gốc: 23047
Tên lệnh: ilp ipp ilp ipp
Những câu hỏi về vẽ 3D trên AutoCAD

Các bạn dùng thử lisp này:
1- Lệnh ILP (Intersection between Line and Plane), chọn line và chỉ định 3 điểm thuộc mặt phẳng. Kết quả: 1 point giao điểm
2- Lệnh IPP (Intersection between Plane and Plane), chỉ định 6 điểm xác định 2 mặt phẳng. Kết quả: 1 line giao tuyến.


Filename: 23047_ilp_ipp_ilp_ipp.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 363127
Tên lệnh: trale
[Yêu Cầu] Lisp Thay Text Theo Từ Điển Có Sẵn

File gửi kèm đây bác nhé.

 

Up file lên CADVIET chạy một tẹo lại dừng hình, em up tạm lên Google Drive nhé.

 

Hề hề hề,

Có một vấn đề là trên file bản vẽ bạn sử dụng font của text là fonts Arial. 

Khi chuyển text tiếng Việt từ file excel sang bản vẽ thì bị hiển thị sai. Do đó trong file từ điển của bạn phải nhập sẵn các text tiếng Việt theo mà Unicode thì khi chuyển sang CAD mới đúng được bạn ạ.

Đây là lisp mình viết, bạn hãy dùng thử nó với file data.csv mà mình chuyển một phần của file data.xlsx của bạn sang các mả unicode mà mình biết nhé.

(defun c:trale ()
(setq  fn (getfiled "Select Data File" "" "csv" 0)
            f (open fn "r")
            txl nil
)
(while  (/= (setq str (read-line f)) nil) 
(setq tls (separate str ","))
(setq txl (append txl (list tls)))
)
(setq sst (acet-ss-to-list (ssget (list (cons 0 "text")))))
(foreach txt sst
   (foreach tl txl
       (if (= (cdr (assoc 1 (entget txt))) (car tl))
           (entmod (subst (cons 1 (cadr tl)) (assoc 1 (entget txt)) (entget txt)))
       )
   )
)
)
 
;;;;;;;;;;;;;;;;;;;;;
(defun Separate (S sym / i L ch)
(setq i 0 L nil)
(while (< i (strlen S))
      (setq i (1+ i) ch (substr S i 1))
      (if (= ch sym) (progn
(setq
     L (append L (list (substr S 1 (- i 1))))
     S (substr S (1+ i) (- (strlen S) i))
     i 0
)
      )) 
)
(append L (list S))
)
 

<<

Filename: 363127_trale.lsp
Tác giả: thanhduan2407
Bài viết gốc: 363156
Tên lệnh: vtl vtl2 dctl
[Nhờ Chỉnh Sửa] Lisp Dải Taluy

Của bạn đây! Mình đang ở vùng biên giới nên ko có mạng internet.

(vl-load-com)
(defun C:VTL( /  ObjPline LtsTaluy LtsLDai LtsLNgan e1 e2 e3 e4 ang1 ang2 ang3 ang4 Pnt10N Pnt10D Pnt11N Pnt11D Chon)
(defun *error* ( msg )
(if Olmode (setvar 'osmode Olmode))
(if (not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
    (princ (strcat "\nError: " msg))
)
(princ)
)
(setq Olmode (getvar "OSMODE"))

(or *CDTLN* (setq *CDTLN* 1))
(setq CDTLN...
>>

Của bạn đây! Mình đang ở vùng biên giới nên ko có mạng internet.

(vl-load-com)
(defun C:VTL( /  ObjPline LtsTaluy LtsLDai LtsLNgan e1 e2 e3 e4 ang1 ang2 ang3 ang4 Pnt10N Pnt10D Pnt11N Pnt11D Chon)
(defun *error* ( msg )
(if Olmode (setvar 'osmode Olmode))
(if (not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
    (princ (strcat "\nError: " msg))
)
(princ)
)
(setq Olmode (getvar "OSMODE"))

(or *CDTLN* (setq *CDTLN* 1))
(setq CDTLN (getreal (strcat "\nChi\U+1EC1u d\U+00E0i c\U+1EE7a v\U+1EA1ch nh\U+1ECF < "
			  (rtos *CDTLN* 2 2)
			 " > :"
		    )
	 )
)
(if (not CDTLN) (setq CDTLN *CDTLN*) (setq *CDTLN* CDTLN))

(or *CDTLD* (setq *CDTLD* 2))
(setq CDTLD (getreal (strcat "\nChi\U+1EC1u d\U+00E0i c\U+1EE7a v\U+1EA1ch d\U+00E0i < "
			  (rtos *CDTLD* 2 2)
			 " > :"
		    )
	 )
)
(if (not CDTLD) (setq CDTLD *CDTLD*) (setq *CDTLD* CDTLD))

  
(or *Sovachngan* (setq *Sovachngan* 2))
(setq Sovachngan (getint (strcat "\nS\U+1ED1 v\U+1EA1ch nh\U+1ECF gi\U+1EEFa 2 v\U+1EA1ch l\U+1EDBn: < "
			  (rtos *Sovachngan* 2 0)
			 " > :"
		  )
	 )
)
(if (not Sovachngan) (setq Sovachngan *Sovachngan*) (setq *Sovachngan* Sovachngan))

(while (setq ObjPline (car (entsel "\nCh\U+1ECDn Pline: ")))
  	(setq VlaObjPL (vlax-ename->vla-object ObjPline))
        (setq LtsTaluy (VTLL CDTLN CDTLD Sovachngan ObjPline))
	(setq LtsLDai (car LtsTaluy))
	(setq LtsLNgan (cadr LtsTaluy))
  	 (setq Chon (strcase (getstring "\n(Ghi ch\U+00FA: U - L\U+00E0m l\U+1EA1i, C - \U+0110\U+1ED5i chi\U+1EC1u v\U+1EA1ch, G\U+00F5 b\U+1EA5t k\U+1EF3 \U+0111\U+1EC3 ti\U+1EBFp t\U+1EE5c) ")))
         (cond
           ((= Chon  "U")
	     (progn
	        (foreach e1 LtsLDai
			(entdel e1)
		)
	        (foreach e2 LtsLNgan
			(entdel e2)
		)
	     )
	    )
	   ((= Chon  "C")
	     (progn
	        (foreach e3 LtsLDai
		  	(progn
				(setq Pnt10D (cdr (assoc 10 (entget e3))))
			  	(setq ang3 (angle '(0 0) (Vlax-curve-getfirstderiv VlaObjPL (vlax-curve-getParamAtPoint VlaObjPL Pnt10D))))
			  	(setq Pnt11D (polar Pnt10D (- ang3 (/ pi 2) )  CDTLD))
		  		(entmod (subst (cons 11 Pnt11D) (assoc 11 (entget e3)) (entget e3) ))
			)
		)
	        (foreach e4 LtsLNgan
		  	(progn
				(setq Pnt10N (cdr (assoc 10 (entget e4))))
			  	(setq ang4 (angle '(0 0) (Vlax-curve-getfirstderiv VlaObjPL (vlax-curve-getParamAtPoint VlaObjPL Pnt10N))))
			  	(setq Pnt11N (polar Pnt10N (- ang4 (/ pi 2) ) CDTLN))
		  		(entmod (subst (cons 11 Pnt11N) (assoc 11 (entget e4)) (entget e4) ))
			)
		)
	     )
	    )
	   ((or (/= Chon  "U") (/= Chon  "C"))
	     (setq Chon nil)
	    )
	 )
   )
(setvar "OSMODE" Olmode)
(princ)
)

(defun VTLL (CDTLN CDTLD Sovachngan ObjPline / CDTLD CDDoan n d1 d2 CDaiPLine ang2 Ptd Lts1 Lts2 LtsPntNgan Pnt1  EnameLD )
(MakeLayer_ "TALUY" 7)
(setq CDDoan (* (+ Sovachngan 1) CDTLN ))
(setq VlaObjPline (vlax-ename->vla-object ObjPline))
(setq CDaiPLine (vla-get-length VlaObjPline))
(setq n (fix (/ CDaiPLine CDDoan)))
(setq d1 0)
(setq Lts1 (list))
(setq LtsEnameLD (list))
(setq LtsEnameLN (list))
(while (< d1 CDaiPLine)
	(progn
		(setq Ptd (vlax-curve-getPointAtDist VlaObjPline d1))
		(setq d1 (+ d1 CDDoan))
	  	(setq ang2 (angle '(0 0) (Vlax-curve-getfirstderiv VlaObjPline (vlax-curve-getParamAtPoint VlaObjPline Ptd))))
	  	(entmake (list (cons 0 "LINE") (cons 8 "TALUY") (cons 10  Ptd) (cons 11 (polar Ptd (+ ang2 (/ pi 2) ) CDTLD))))
	  	(setq EnameLD (entlast))
	  	(setq LtsEnameLD (append LtsEnameLD (list EnameLD)))
	  	(setq Lts1 (append Lts1 (list Ptd)))
	)
)
(setq d2 0)
(setq Lts2 (list))
(setq m (fix (/ CDaiPLine CDTLN)))
(while (< d2 CDaiPLine)
	(progn
		(setq Ptn (vlax-curve-getPointAtDist VlaObjPline d2))
		(setq d2 (+ d2 CDTLN))
	  	(setq Lts2 (append Lts2 (list Ptn)))
	)
)
(setq LtsPntNgan (LM:ListDifference Lts2 Lts1))
(foreach Pnt1 LtsPntNgan
  	(setq ang3 (angle '(0 0) (Vlax-curve-getfirstderiv VlaObjPline (vlax-curve-getParamAtPoint VlaObjPline Pnt1))))
  	(entmake (list (cons 0 "LINE") (cons 10  Pnt1) (cons 8 "TALUY") (cons 11 (polar Pnt1 (+ ang3 (/ pi 2) ) CDTLN))))
  	(setq EnameLN (entlast))
  	(setq LtsEnameLN (append LtsEnameLN (list EnameLN)))
)
(setq DsTaluy (list LtsEnameLD LtsEnameLN))
DsTaluy
)


(defun MakeLayer_ ( name colour /)
    (if (null (tblsearch "LAYER" name))
        (entmake
            (list
               '(0 . "LAYER")
               '(100 . "AcDbSymbolTableRecord")
               '(100 . "AcDbLayerTableRecord")
               '(70 . 0)
                (cons 2 name)
                (cons 62 colour)
            )
        )
    )
)

(defun C:VTL2 (  / Olmode Sovachngan  *Sovachngan* CDVN *CDVN*  CDDoan ObjPline1 ObjPL2 ObjPline2 VlaObjPline1 CDaiPLine1 VlaObjPline2
		   n d1 d2 LtsEnameLD LtsEnameLN Lts1 Lts2 LtsPntNgan   PntInObjPline2 PntInObjPline3 ang_1 ang_2 P3
	       )
(MakeLayer_ "TALUYN" 1)
(MakeLayer_ "TALUYD" 7)
;;;;;;;;;LUU OSNAP KHI BREAK, CANCEL, EXIT
(defun *error* ( msg )
(if Olmode (setvar 'osmode Olmode))
(if (not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
    (princ (strcat "\nError: " msg))
)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq Olmode (getvar "OSMODE"))
;;;(setq Sovachngan 1)

(or *Sovachngan* (setq *Sovachngan* 1))
(setq Sovachngan (getint (strcat "\nNhap so vach ngan giua 2 vach dai: < "
			  (rtos *Sovachngan* 2 0)
			 " > :"
		    )
	 )
)
(if (not Sovachngan) (setq Sovachngan *Sovachngan*) (setq *Sovachngan* Sovachngan))
  
(or *CDVN* (setq *CDVN* 2.5))
(setq CDVN (getreal (strcat "\nNh\U+1EADp kho\U+1EA3ng c\U+00E1ch gi\U+1EEFa c\U+00E1c v\U+1EA1ch: < "
			  (rtos *CDVN* 2 2)
			 " > :"
		    )
	 )
)
(if (not CDVN) (setq CDVN *CDVN*) (setq *CDVN* CDVN))
(setq CDDoan (* (+ Sovachngan 1) CDVN ))


  
(setq ObjPline1 (car (entsel "\nChon duong thu nhat: ")))
(setq ObjPL2  (entsel "\nChon duong thu hai: "))
(setq ObjPline2 (car ObjPL2))
;;;(setq PickPoint (cdr ObjPL2))

(setq VlaObjPline1 (vlax-ename->vla-object ObjPline1))
(setq CDaiPLine1 (vla-get-length VlaObjPline1))


(setq VlaObjPline2 (vlax-ename->vla-object ObjPline2))
  
(setq n (fix (/ CDaiPLine1 CDDoan)))
(setq d1 0)
(setq Lts1 (list))
(setq LtsEnameLD (list))
(setq LtsEnameLN (list))
(while (< d1 CDaiPLine1)
	(progn
		(setq Ptd (vlax-curve-getPointAtDist VlaObjPline1 d1))
		(setq d1 (+ d1 CDDoan))
	  	(setq ang_1 (angle '(0 0) (Vlax-curve-getfirstderiv VlaObjPline1 (vlax-curve-getParamAtPoint VlaObjPline1 Ptd))))
	  	(if (setq PntInObjPline2 (TDKDGN Ptd ObjPline2 (polar Ptd (+ ang_1 (/ pi 2) ) CDVN)))
		    (progn
	  	    	(entmake (list (cons 0 "LINE") (cons 8 "TALUYD") (cons 10  Ptd) (cons 11 PntInObjPline2)))
	  	    	(setq EnameLD (entlast))
	  		(setq LtsEnameLD (append LtsEnameLD (list EnameLD)))
	  		(setq Lts1 (append Lts1 (list Ptd)))
		    )
		)
	)
)
(setq d2 0)
(setq Lts2 (list))
(setq m (fix (/ CDaiPLine1 CDVN)))
(while (< d2 CDaiPLine1)
	(progn
		(setq Ptn_N (vlax-curve-getPointAtDist VlaObjPline1 d2))
		(setq d2 (+ d2 CDVN))
	  	(setq Lts2 (append Lts2 (list Ptn_N)))
	)
)
(setq LtsPntNgan (LM:ListDifference Lts2 Lts1))
(foreach Pnt1 LtsPntNgan
  	(setq ang_2 (angle '(0 0) (Vlax-curve-getfirstderiv VlaObjPline1 (vlax-curve-getParamAtPoint VlaObjPline1 Pnt1))))
  	(if (setq PntInObjPline3 (TDKDGN Pnt1 ObjPline2 (polar Pnt1 (+ ang_2 (/ pi 2) ) CDVN)))
	    (progn
	  	(setq P3 (list (/ (+ (car Pnt1) (car PntInObjPline3)) 2) (/ (+ (cadr Pnt1) (cadr PntInObjPline3)) 2)))
	  	(entmake (list (cons 0 "LINE") (cons 10  Pnt1) (cons 8 "TALUYN") (cons 11 P3)))
	    )
	)
)
(princ)
)





;;;HAM LAY RA CAC PHAN TU KHAC NHAU TRONG DANH SACH 1 SO VOI DANH SACH 2 (TO - CON) (LEN L1 > LEN L2)
;;;(LM:ListDifference '(1 2 3 4 5) '(2 4 6)  )
(defun LM:ListDifference ( l1 l2 )
  (if l1
    (if (member (car l1) l2)
      (LM:ListDifference (cdr l1) l2)
      (cons (car l1) (LM:ListDifference (cdr l1) l2))
    )
  )
)


;;;;;;;;;;;;;;;acextendnone	Do not extend either object
;;;;;;;;;;;;;;;acextendthisentity	Extend obj1 to meet obj2
;;;;;;;;;;;;;;;acextendotherentity	Extend obj2 to meet obj1
;;;;;;;;;;;;;;;acextendboth	Extend both objects

(defun LM:Intersections ( obj1 obj2 mode / l r )
    (setq l (vlax-invoke obj1 'intersectwith obj2 mode))
    (repeat (/ (length l) 3)
        (setq r (cons (list (car l) (cadr l) (caddr l)) r)
              l (cdddr l)
        )
    )
    (reverse r)
)

(defun MakeXline (pt vec)
  (entmakex (list (cons 0 "XLINE")
                  (cons 100 "AcDbEntity")
                  (cons 100 "AcDbXline")
                  (cons 10 pt)
                  (cons 11 vec)
	    )
  )
)

(defun TDKDGN (P1 ObjPline1 Pnt / Vla:ObjPline1   EnameXline Vla:Xline LtsPnt ) ;;;TIM DIEM KEO DAI GAN NHAT
(setq Vla:ObjPline1 (vlax-ename->vla-object ObjPline1))
(setq P2 (mapcar '- Pnt P1))
(MakeXline P1 P2)
(setq EnameXline (entlast))
(setq Vla:Xline (vlax-ename->vla-object EnameXline))
(setq LtsPnt (LM:Intersections Vla:ObjPline1  Vla:Xline acextendboth))
(entdel EnameXline)
(setq PntNear (car (vl-sort LtsPnt '(lambda(x y) (< (distance x P1) (distance y P1))))))
PntNear
)


(defun C:DCTL( / ss LtsEnameLine P1 P2  PVG1 PVG2 CDLine);;;DAO CHIEU TALUY
(setq VLA:ObjPline (vlax-ename->vla-object (car (entsel "\nChon Polyline can dao chieu Taluy:"))))
(Alert "\nQuet chon Line")
(setq ss (ssget (list (cons 0 "LINE"))))
(setq LtsEnameLine (acet-ss-to-list ss))
(setq i 0)
(foreach EnameL LtsEnameLine
	(setq P1 (acet-dxf 10 (entget EnameL)))
	(setq P2 (acet-dxf 11 (entget EnameL)))
	(if (and (setq Pgiao (last (LM:Intersections (vlax-ename->vla-object EnameL) VLA:ObjPline acextendnone ))) (equal (LineVGtPline VLA:ObjPline EnameL) 1 0.0000000001))
	    (progn
	    	(setq CDLine (vla-get-length (vlax-ename->vla-object EnameL)))
	    	(cond ((equal P1 Pgiao 0.00000001)
		      	      (progn
			    	(setq angL10 (angle '(0 0) (Vlax-curve-getfirstderiv VLA:ObjPline (vlax-curve-getParamAtPoint VLA:ObjPline Pgiao))))
				(setq P2A (polar Pgiao (+ angL10 (* -1.0 (PointLeftRightPline VLA:ObjPline P2)  (/ pi 2))) CDLine))
			      	(entmod (subst (cons 11 P2A) (assoc 11 (entget EnameL)) (entget EnameL) ))
			      )
		      )
		      ((equal P2 Pgiao 0.00000001)
		      	      (progn
			    	(setq angL11 (angle '(0 0) (Vlax-curve-getfirstderiv VLA:ObjPline (vlax-curve-getParamAtPoint VLA:ObjPline Pgiao))))
				(setq P1A (polar Pgiao (+ angL11 (* -1.0 (PointLeftRightPline VLA:ObjPline P1)  (/ pi 2))) CDLine))
			      	(entmod (subst (cons 10 P1A) (assoc 10 (entget EnameL)) (entget EnameL) ))
			      )
		      )
		    )
		 )
	)
)
(princ)
)


  
(defun LineVGtPline (VLA:ObjPline ObjLine / PVG Pd1 Pd2 GocP1P2  VLA:ObjPline VLA:ObjLine PntGiao );;;;XET LINE VUONG GOC VOI POLYLINE HAY KHONG?
	(setq P1 (acet-dxf 10 (entget ObjLine)))
	(setq P2 (acet-dxf 11 (entget ObjLine)))
  	(setq GocP1P2 (angle P1 P2))
  	(setq GocP2P1 (angle P2 P1))
  	(setq VLA:ObjLine (vlax-ename->vla-object ObjLine))
        (setq PntGiao (last (LM:Intersections VLA:ObjLine VLA:ObjPline acextendnone)))
  	(setq Goctaidiemgiao (angle '(0 0) (Vlax-curve-getfirstderiv VLA:ObjPline (vlax-curve-getParamAtPoint VLA:ObjPline PntGiao))))
  	(setq KQVG nil)
	(if (or (equal (+ Goctaidiemgiao (/ pi 2)) GocP1P2 0.00000000001) (equal (- Goctaidiemgiao (/ pi 2)) GocP1P2 0.00000000001)
	        (equal (+ Goctaidiemgiao (/ pi 2)) GocP2P1 0.00000000001) (equal (- Goctaidiemgiao (/ pi 2)) GocP2P1 0.00000000001))
	    (setq KQVG 1)
	    (setq KQVG 0)
        )
  KQVG
)


(defun PointLeftRightPline (ObjPline Pnt / PVG Pd1 Pd2);;;;XET DIEM NAM TRAI HAY PHAI PLINE
    (setq PVG (vlax-curve-getClosestPointTo ObjPline Pnt)
          Pd1 (vlax-curve-getpointAtParam ObjPline (fix (vlax-curve-getparamatPoint ObjPline PVG)))
          Pd2 (vlax-curve-getpointAtParam ObjPline (1+ (fix (vlax-curve-getparamatPoint ObjPline PVG))))
    )
    (setq Kqua nil)
    (if (or (equal (cos (+ (/ pi 2) (angle Pd1 Pd2))) (cos (angle Pnt PVG)) 0.00000001)
   	    (equal (sin (+ (/ pi 2) (angle Pd1 Pd2))) (sin (angle Pnt Pd1)) 0.00000001)
	)
        (setq Kqua -1)
        (setq Kqua 1)
    )
    Kqua
)





<<

Filename: 363156_vtl_vtl2_dctl.lsp
Tác giả: khiem10ck
Bài viết gốc: 363171
Tên lệnh: ok
Lisp Offset
offset liên tục các đối tượng với khoảng cách tuỳ ý, và các đối tượng sau khi offset tự động chuyển sang kiểu đường nét khác.

Filename: 363171_ok.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 363796
Tên lệnh: vtb
Lisp vẽ cầu thang bộ
Lisp vẽ cầu thang bộ nhanh chóng

Filename: 363796_vtb.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 364093
Tên lệnh: test
Lisp Đánh Dấu Rectange, Thống Kê Độ Dài Rectange Và Xuất Ra Excell.
Tự động đánh dấu thứ tự ống nước (ống nước em sẽ vẽ là một rectange) là d1, d2, d3.
_ Thống kê chiều dài của ống nước (sẽ là độ dài cạnh dài hơn của rectange).
==> Xuất ra file excell với các cột là tên ống, layer, độ dài.

Filename: 364093_test.lsp
Tác giả: dckonhi1987
Bài viết gốc: 342123
Tên lệnh: cot00 cotxx dc dcx
Lisp đánh cốt tầng

  Chào mọi người, mình hay sử dụng 1 lisp để tích cao độ cho tiện. Lisp này của bác Nguyen Hoanh (post trong http://www.cadviet.com/forum/topic/152-danh-cot-tu-dong-bang-lisp-dc), có được thêm thắt 1 ít.

  Quan trọng là hồi trước dùng cad 2015 trở xuống thì vẫn bình thường. Nhưng hqua mò mẫn dùng autocad 2016...

>>

  Chào mọi người, mình hay sử dụng 1 lisp để tích cao độ cho tiện. Lisp này của bác Nguyen Hoanh (post trong http://www.cadviet.com/forum/topic/152-danh-cot-tu-dong-bang-lisp-dc), có được thêm thắt 1 ít.

  Quan trọng là hồi trước dùng cad 2015 trở xuống thì vẫn bình thường. Nhưng hqua mò mẫn dùng autocad 2016 thì không chạy được.

  Menu command báo lỗi như sau:

Command: DC
Vao diem can danh cot: .insert Enter block name or [?] <CTr>: CTr
Units: Unitless   Conversion:         1
Specify insertion point or [Basepoint/Scale/X/Y/Z/Rotate]:
Enter X scale factor, specify opposite corner, or [Corner/XYZ] <1>: 1 Enter Y scale factor <use X scale factor>: 1
Specify rotation angle <0>: 0.000000000000000 *Invalid*
; error: Function cancelled

  Còn đây là lisp:

;Tao cac STYLE chu
 (if (not (tblsearch "STYLE" ".Text-thuong"))
   (command "-style" ".Text-thuong" "Vntime.shx" "0.15"  "0.85" "0" "N" "N" )
 )
 (if (not (tblsearch "STYLE" ".Text-INTO"))
   (command "-style" ".Text-INTO" ".VnArialH" "0.3"  "0.85" "0" "N" "N" "N")
 )
 (if (not (tblsearch "STYLE" ".Text-INnho"))
   (command "-style" ".Text-INnho" "VntimeH.shx" "0.15"  "0.85" "0" "N" "N" "N")
 )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Tao cao do mat cat
;Tao hinh dang block "CTr"

(defun CTr_def ()
  
  ;BLOCK Header definition:
  (entmake '((0 . "BLOCK")(2 . "CTr")(70 . 2)(10 0.0 0.0 0.0)))
  
  ;LINE definition:
  (entmake
    '((0 . "LINE")(8 . "7")(10 -0.15 0.0 0.0)(11 0.15 0.0 0.0)(210 0.0 0.0 1.0))
  )
  (entmake
    '((0 . "LINE")(8 . "6")(10 0.0 0.0 0.0)(11 0.1 0.15 0.0)(210 0.0 0.0 1.0))
  ) 
(entmake
    '((0 . "LINE")(8 . "6")(10 0.0 0.0 0.0)(11 -0.1 0.15 0.0)(210 0.0 0.0 1.0))
  )  
(entmake
    '((0 . "LINE")(8 . "6")(10 0.1 0.15 0.0)(11 -0.1 0.15 0.0)(210 0.0 0.0 1.0))
  )
(entmake
    '((0 . "SOLID")(8 . "7")(10 0.1 0.15 0.0)(11 0 0.15 0.0)(12 0.0 0.0 0.0)(13 0.0 0.0 0.0))
  )
;Text ATTRIBUTE definition:
  ;Note that it is an invisible attribute (code 70=1)
  
  (entmake 
    '((0 . "ATTDEF")(7 . ".Text-INnho")(8 . "7")(10 -0.35 0.25 0.0)(1 . "#")(2 . "AMDUONG")
    (3 . "#")(40 . 0.15)(41 . 0.85)(50 . 0.0)(70 . 0)(71 . 0)(72 . 0)(73 . 0))
  )
   (entmake 
    '((0 . "ATTDEF")(7 . ".Text-INnho")(8 . "7")(10 -0.20 0.255 0.0)(1 . "#")(2 . "GIATRI")
    (3 . "#")(40 . 0.15)(41 . 0.85)(50 . 0.0)(70 . 0)(71 . 0)(72 . 0)(73 . 0))
  ) 
 ;BLOCK's ending definition:
  
  (entmake '((0 . "ENDBLK")))
  
)
  (if (null (tblsearch "BLOCK" "CTr"))(CTr_def))


;; Chuong trinh danh cot
; Danh cot goc toa do 00
(defun c:cot00 ()
  (setq Cot00 (cadr (getpoint "\nDiem co cot 0.00: ")))
  (princ)
)

; Danh cot goc o cao do bat ky
(defun c:cotxx ()
  (setq Cotxx (getreal "\nNhap cot can dinh nghia: ")
      Cot00 (- (cadr (getpoint (strcat "\nDiem co cot " (rtos cotxx 2 2) ": ")))
 (* Cotxx 1))
    )
  (princ))

(defun c:dc (/ diem caodo dau giatri dodaichuoi)
  (if (not cot00)
(progn
 (alert "chua co cot 0.00")
 (c:cot00)
)
  )
  (grdraw (list (+ (car (getvar "VIEWCTR")) (* -1.0 (getvar "VIEWSIZE")))
cot00
 )
 (list (+ (car (getvar "VIEWCTR")) (* 1.0 (getvar "VIEWSIZE")))
cot00
 )
 1
 1
  )
  (setq
diem   (getpoint "\nVao diem can danh cot: ")
caodo  (- (cadr diem) cot00)
dau    (cond
((equal caodo 0.0 0.01) "%%p")
((> caodo 0.0) "+")
(t "-")
  )
giatri (rtos (* caodo 100) 2 0)
  )
  (if (= "-" (substr giatri 1 1))
(setq giatri (substr giatri 2))
  )
  (while (< (strlen giatri) 4)
(setq giatri (strcat "0" giatri))
  )
  (setq dodaichuoi (strlen giatri)
giatri    (strcat (substr giatri 1 (- dodaichuoi 2))
  "."
  (substr giatri (- dodaichuoi 1))
  )
  )
  (command ".insert" "CTr" diem 1 1 0.0 dau giatri)
  (redraw)
)


; Danh cot tu nhap bat ky
(defun c:dcx (/ caodo diem dau giatri)
  (setq
caodo (getreal "\nNhap cot can dung: ")
nghieng (getreal "\nNhap cot can dung: ")
diem   (getpoint "\nVao diem can danh cot: ")
dau    (cond
((equal caodo 0.0 0.01) "%%p")
((> caodo 0.0) "+")
(t "-")
      )
giatri (rtos (* caodo 100) 2 0)
  )
  (if (= "-" (substr giatri 1 1))
(setq giatri (substr giatri 2))
  )
  (while (< (strlen giatri) 4)
(setq giatri (strcat "0" giatri))
  )
  (setq dodaichuoi (strlen giatri)
giatri    (strcat (substr giatri 1 (- dodaichuoi 2))
  "."
  (substr giatri (- dodaichuoi 1))
  )
  )
  (command ".insert" "CTr" diem 1 1 0.0 dau giatri)
)

 Mong được sự giúp đỡ!


<<

Filename: 342123_cot00_cotxx_dc_dcx.lsp
Tác giả: pawuta
Bài viết gốc: 365471
Tên lệnh: block01
Lisp Insert Block

Lisp gọi block từ thư viện tạo sẵn, nhưng khi chèn thì vẫn giữ các tính chất của block (block att, block động...)

Filename: 365471_block01.lsp
Tác giả: bach1212
Bài viết gốc: 365850
Tên lệnh: edt vld
Lisp đổi màu text kết quả của tính diện tích
text kết quả sau khi ed vào text có sẵn thì text đổi màu thành màu hồng

Filename: 365850_edt_vld.lsp
Tác giả: thanhduan2407
Bài viết gốc: 365876
Tên lệnh: ttt
Sửa Lisp tự động extend và trim các đường pline
Lisp sẽ yêu cầu chọn các đường Pline cho trước màu xanh, sau đó quét hết các các đường trên bản vẽ, các đường Pline màu đỏ sẽ tự động extend và trim với đường Pline màu xanh gần nó nhất.

Filename: 365876_ttt.lsp
Tác giả: thanhduan2407
Bài viết gốc: 366314
Tên lệnh: tgzpl
nhờ viết lisp gán cao độ cho đường đồng mức và ghi ra text

Gửi tặng bạn!

(vl-load-com)
;;;(Prompt (strcat "\nCh\U+01B0\U+01A1ng tr\U+00ECnh n\U+00E2ng h\U+1EA1 cao \U+0111\U+1ED9 \U+0111\U+01B0\U+1EDDng 3D Polyline"
;;;		"\nL\U+1EC7nh: TGZPL"
;;;		"\nNg\U+01B0\U+1EDDi vi\U+1EBFt: Nguy\U+1EC5n Th\U+00E0nh Du\U+00E2n"
;;;		"\nEmail: heaven2407@gmail.com"
;;;		"\nMobile: 0972.0168.25"
;;;	)
;;;)
;;;(Alert (strcat "\nCh\U+01B0\U+01A1ng tr\U+00ECnh n\U+00E2ng h\U+1EA1 cao \U+0111\U+1ED9...
>>

Gửi tặng bạn!

(vl-load-com)
;;;(Prompt (strcat "\nCh\U+01B0\U+01A1ng tr\U+00ECnh n\U+00E2ng h\U+1EA1 cao \U+0111\U+1ED9 \U+0111\U+01B0\U+1EDDng 3D Polyline"
;;;		"\nL\U+1EC7nh: TGZPL"
;;;		"\nNg\U+01B0\U+1EDDi vi\U+1EBFt: Nguy\U+1EC5n Th\U+00E0nh Du\U+00E2n"
;;;		"\nEmail: heaven2407@gmail.com"
;;;		"\nMobile: 0972.0168.25"
;;;	)
;;;)
;;;(Alert (strcat "\nCh\U+01B0\U+01A1ng tr\U+00ECnh n\U+00E2ng h\U+1EA1 cao \U+0111\U+1ED9 \U+0111\U+01B0\U+1EDDng 3D Polyline"
;;;		"\nL\U+1EC7nh: TGZPL"
;;;		"\nNg\U+01B0\U+1EDDi vi\U+1EBFt: Nguy\U+1EC5n Th\U+00E0nh Du\U+00E2n"
;;;		"\nEmail: heaven2407@gmail.com"
;;;		"\nMobile: 0972.0168.25"
;;;	)
;;;)
(defun C:TGZPL (/ a e1  ObjPL  elistPl     );;;TANG GIAM Z PLINE
(setvar "CMDECHO" 0)
(setq a (getreal "\nNh\U+1EADp gi\U+00E1 tr\U+1ECB Delta c\U+1EA7n thay \U+0111\U+1ED5i cao \U+0111\U+1ED9:  "))
(Alert "Qu\U+00E9t ch\U+1ECDn Polyline")
(setq LtsObjPl (LM:ss->ent (ssget (list (cons 0 "POLYLINE,LWPOLYLINE")))))
(setq Lts2DPLine (vl-remove nil (mapcar '(lambda(x) (if (= (cdr (assoc 100 (reverse (entget x)))) "AcDbPolyline") x nil)) LtsObjPl)))
(setq Lts3DPLine (vl-remove nil (mapcar '(lambda(x) (if (= (cdr (assoc 100 (reverse (entget x)))) "AcDb3dPolyline") x nil)) LtsObjPl)))
(mapcar '(lambda(e2) (NH1PL2D e2 a)) Lts2DPLine)
(mapcar '(lambda(e1) (NH1PL3D e1 a)) Lts3DPLine)
(princ)
)



(defun NH1PL3D (ent a /  edata pt)
  (if (= (cdr (assoc 100 (reverse (entget ent)))) "AcDb3dPolyline")
    (while
      (and
        (setq ent (entnext ent))
        (= (cdr (assoc 0 (entget ent))) "VERTEX")
        (setq edata (entget ent))
	 (setq   pt (cdr (assoc 10 edata)))
      )
      (entmod
        (subst
          (list 10 (car pt) (cadr pt) (+ (caddr pt) a))
          (assoc 10 edata)
          edata
        )
      )
    )
  )
)

(defun NH1PL2D (ent a / elitObj )
(if (= (cdr (assoc 100 (reverse (entget ent)))) "AcDbPolyline")
	(progn
		(setq elitObj (entget ent))
	  	(entmod (subst (cons 38 (+ (cdr (assoc 38 elitObj)) a )) (assoc 38 elitObj) elitObj ))
	)
)
)
(defun LM:ss->ent ( ss / i l )
    (if ss
        (repeat (setq i (sslength ss))
            (setq l (cons (ssname ss (setq i (1- i))) l))
        )
    )
)

<<

Filename: 366314_tgzpl.lsp
Tác giả: pawuta
Bài viết gốc: 366266
Tên lệnh: mat
Lisp Matchprop Text Attribute
Copy thuộc tính của các Text Attribute

Filename: 366266_mat.lsp

Trang 194/304

194