Jump to content
InfoFile
Tác giả: Tue_NV
Bài viết gốc: 241390
Tên lệnh: cpk
Lisp move đối tượng theo giá trị cố định?

Ý bạn chủ topic chắc như thế này :

(defun c:cpk(/ p pdich ss kcach )
(defun Tue-ss-drag-move (ss p / el lp)
;;;copyright by Tue_NV
(setq el (entlast))
(if (and ss p (vl-cmdf "copy" ss "" "non"  p pause) (null (equal (getvar "lastpoint") p)))
   (setq lp (getvar "lastpoint")) (setq lp nil)
)
            (while (setq el (entnext el)) (entdel el))
lp)
 
  (or *kc* (setq *kc* 100.0))
  (setq ss (ssget))
 
  (setq p...
>>

Ý bạn chủ topic chắc như thế này :

(defun c:cpk(/ p pdich ss kcach )
(defun Tue-ss-drag-move (ss p / el lp)
;;;copyright by Tue_NV
(setq el (entlast))
(if (and ss p (vl-cmdf "copy" ss "" "non"  p pause) (null (equal (getvar "lastpoint") p)))
   (setq lp (getvar "lastpoint")) (setq lp nil)
)
            (while (setq el (entnext el)) (entdel el))
lp)
 
  (or *kc* (setq *kc* 100.0))
  (setq ss (ssget))
 
  (setq p (getpoint "\n  Enter nhap khoang cach moi \\ Diem goc : "))
  (if (= p nil) (progn
    (setq kcach (getreal (strcat "\n Nhap khoang cach <" (rtos *kc* 2 2) ">:" )))
    (if kcach (setq *kc* kcach) (setq kcach *kc*))
    (setq p (getpoint "\n Diem goc : "))
  ))
(if (setq pdich (Tue-ss-drag-move ss p   )                   )
    (command "move" ss "" "non" p "non" (polar p (angle p pdich) kcach))
)
  (princ)
  )
(defun c:cpk(/ p pdich )
(defun Tue-ss-drag-move (ss p / el lp)
;;;copyright by Tue_NV
(setq el (entlast))
(if (and ss p (vl-cmdf "copy" ss "" "non"  p pause) (null (equal (getvar "lastpoint") p)))
   (setq lp (getvar "lastpoint")) (setq lp nil)
)
(while (setq el (entnext el)) (entdel el))
lp)
 
  (or *kc* (setq *kc* 100.0))
  (setq ss (ssget))
  
  (setq p (getpoint "\n  Enter nhap khoang cach moi \\ Diem goc : "))
  (if (= p nil) (progn
    (setq kcach (getreal (strcat "\n Nhap khoang cach <" (rtos *kc* 2 2) ">:" )))
    (if kcach (setq *kc* kcach) (setq kcach *kc*))
    (setq p (getpoint "\n Diem goc : ")) 
  ))
(if (setq pdich (Tue-ss-drag-move ss p   ) )
    (command "move" ss "" "non" p "non" (polar p (angle p pdich) kcach)) 
)
;;;  (princ)
  )

<<

Filename: 241390_cpk.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 241397
Tên lệnh: ha
Chia Polyline kín thành các Polyline kín

Lisp chia đôi nhiều lần 1 Pline kín không chứa Arc. Vòng lặp cho đến khi Enter thì ngừng chia.

;; Chia Pline kin khong chua Arc thanh 2 Pline kin. Vong lap den khi Enter thi dung.
;; Doan Van Ha - CadViet.com - 16/7/2013
(defun C:HA( / #List:Subtract1 #List:SubList LM:Collinear-p1 #List:InsertNth LWPoly ent p1 p2 lst i lst1 n1 n2)
 (defun #List:Subtract1(lst1 lst2)
  (foreach n (reverse (cdr (reverse (cdr lst2))))
 ...
>>

Lisp chia đôi nhiều lần 1 Pline kín không chứa Arc. Vòng lặp cho đến khi Enter thì ngừng chia.

;; Chia Pline kin khong chua Arc thanh 2 Pline kin. Vong lap den khi Enter thi dung.
;; Doan Van Ha - CadViet.com - 16/7/2013
(defun C:HA( / #List:Subtract1 #List:SubList LM:Collinear-p1 #List:InsertNth LWPoly ent p1 p2 lst i lst1 n1 n2)
 (defun #List:Subtract1(lst1 lst2)
  (foreach n (reverse (cdr (reverse (cdr lst2))))
   (setq lst1 (vl-remove n lst1))))
 (defun #List:SubList(lst start len / i tmp)
  (setq len (if len (min len (- (length lst) start)) (- (length lst) start)) i (+ start len))
  (repeat len
   (setq tmp (cons (nth (setq i (1- i)) lst) tmp))))
 (defun #List:InsertNth(x n lst)
  ((lambda(i) (apply 'append (mapcar '(lambda(a) (if (= n (setq i (1+ i))) (list x a) (list a))) lst))) -1))
 (defun LWPoly (lst cls)
  (entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 (length lst)) (cons 70 cls)) (mapcar (function (lambda (p) (cons 10 p))) lst))))
 (defun LM:Collinear-p1 (p1 pg p2)
  (equal (+ (distance p1 pg) (distance p2 pg)) (distance p1 p2) 1E-8))
;; main function
 (command "undo" "be")
 (while
  (and
   (setq ent (car (entsel "\nChon Pline kin: ")))
   (setq p1 (getpoint "\nPick diem thu 1 tren Pline: "))
   (setq p2 (getpoint p1 "\nPick diem thu 2 tren Pline: ")))
  (setq lst (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget ent))))
  (setq i -1 lst1 lst)
  (repeat (1- (length lst1))
   (if (LM:Collinear-p1 (nth (setq i (1+ i)) lst1) p1 (nth (1+ i) lst1))
    (setq lst (#List:InsertNth p1 (1+ i) lst1))))
  (setq i -1 lst1 lst)
  (repeat (1- (length lst1))
   (if (LM:Collinear-p1 (nth (setq i (1+ i)) lst1) p2 (nth (1+ i) lst1))
    (setq lst (#List:InsertNth p2 (1+ i) lst1))))
  (setq n1 (min (vl-position p1 lst) (vl-position p2 lst)))
  (setq n2 (max (vl-position p1 lst) (vl-position p2 lst)))
  (LWPoly (setq lst1 (#List:SubList lst n1 (- n2 n1 -1))) 1)
  (LWPoly (#List:Subtract1 lst lst1) 1)
  (entdel ent))
 (command "undo" "e"))
 

<<

Filename: 241397_ha.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 241470
Tên lệnh: ha
Lisp đổi đầu arrow của leader

Lisp thay đổi Arrowhead của Leader và Dimension. Tưởng bạn đã quên ai ngờ vẫn nhớ.

;; Thay doi Arrowhead cua cac Leader va Dimension duoc chon.
;; Doan Van Ha - CadViet.com - ngay 16/7/2013
(vl-load-com)
(defun C:HA( / lst ss txt i ent L->Ptr #String:Replace)
 (defun L->Ptr(lst)
  (vl-string-trim "()" (vl-princ-to-string...
>>

Lisp thay đổi Arrowhead của Leader và Dimension. Tưởng bạn đã quên ai ngờ vẫn nhớ.

;; Thay doi Arrowhead cua cac Leader va Dimension duoc chon.
;; Doan Van Ha - CadViet.com - ngay 16/7/2013
(vl-load-com)
(defun C:HA( / lst ss txt i ent L->Ptr #String:Replace)
 (defun L->Ptr(lst)
  (vl-string-trim "()" (vl-princ-to-string lst)))
 (defun #String:Replace(new old str / inc len)
  (setq len (strlen new) inc 0)
  (while (setq inc (vl-string-search old str inc))
   (setq str (vl-string-subst new old str inc) inc (+ inc len)))
  str)
 (setq lst
 '(("01.ClosedFilled" acArrowDefault)
   ("02.Dot" acArrowDot)
   ("03.DotSmall" acArrowDotSmall)
   ("04.DotBlank" acArrowDotBlank)
   ("05.OriginIndicator" acArrowOrigin)
   ("06.OriginIndicator2" acArrowOrigin2)
   ("07.Open" acArrowOpen)
   ("08.RightAangle" acArrowOpen90)
   ("09.Open30" acArrowOpen30)
   ("10.Closed" acArrowClosed)
   ("11.DotSmallBlank" acArrowSmall)
   ("12.None" acArrowNone)
   ("13.Oblique" acArrowOblique)
   ("14.BoxFilled" acArrowBoxFilled)
   ("15.Box" acArrowBoxBlank)
   ("16.ClosedBlank" acArrowClosedBlank)
   ("17.DatumTriangleFilled" acArrowDatumFilled)
   ("18.DatumTriangle" acArrowDatumBlank)
   ("19.Integral" acArrowIntegral)
   ("20.ArchitecturalTick" acArrowArchTick)))
 (setq lst (list (mapcar 'car lst) (mapcar 'cadr lst)))
 (if
  (and 
   (princ "\nChon cac Leader can thay doi Arrowhead...")
   (setq ss (ssget '((0 . "LEADER,DIMENSION"))))
   (not (initget (strcat (L->Ptr (car lst)) " _" (L->Ptr (cadr lst)))))
   (setq txt (getkword (strcat "\nNhap 1 tuy chon tu 01 den 20 : "))))
  (repeat (setq i (sslength ss))
   (if (eq (cdr (assoc 0 (entget (setq ent (ssname ss (setq i (1- i))))))) "LEADER")
    (vla-put-ArrowheadType (vlax-ename->vla-object ent) (eval (read txt)))
(progn
     (vla-put-Arrowhead1Type (vlax-ename->vla-object ent) (eval (read txt)))
     (vla-put-Arrowhead2Type (vlax-ename->vla-object ent) (eval (read txt)))))))
 (princ))
 

<<

Filename: 241470_ha.lsp
Tác giả: ndtnv
Bài viết gốc: 241563
Tên lệnh: xtd
lisp xuat tọa độ có điều kiện

Vì không có thời gian nên không xử lý lỗi nếu chọn sai đối tượng.
Khi chọn pline, pick vào gần điểm bắt đầu

(vl-load-com)
(defun Dxf(n e) (cdr (assoc n e)))
(defun C:XTD ( / d en es f fz g i k l lh lk ls ob p st v) ; xuat toa do
    (setq es (entsel "\nChon duong polyline ") ob (vlax-ename->vla-object (car es)) p (cadr es))
    (setq st (vlax-curve-getStartPoint ob) en (vlax-curve-getEndPoint...
>>

Vì không có thời gian nên không xử lý lỗi nếu chọn sai đối tượng.
Khi chọn pline, pick vào gần điểm bắt đầu

(vl-load-com)
(defun Dxf(n e) (cdr (assoc n e)))
(defun C:XTD ( / d en es f fz g i k l lh lk ls ob p st v) ; xuat toa do
    (setq es (entsel "\nChon duong polyline ") ob (vlax-ename->vla-object (car es)) p (cadr es))
    (setq st (vlax-curve-getStartPoint ob) en (vlax-curve-getEndPoint ob))
    (setq l (vlax-curve-getDistAtParam ob (vlax-curve-getEndParam ob)) d 0)
    (setq fz 0.001) ; sai so lam tron k/c
    (if (< (distance p st) (distance p en))
        (setq d 0 k 1)
        (setq d l k -1)
    )
    (princ "\nChon text :")
    (setq ls (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "TEXT") ))))))
    (foreach e ls
        (setq g (entget e) v (list (car (Dxf 10 g)) (Dxf 1 g)))
        (if (= 0 (Dxf 50 g))
            (setq lk (cons v lk))
            (setq lh (cons v lh))
        ))
    (setq    lk (vl-sort lk (function (lambda (e1 e2) (< (car e1) (car e2))))))
    (setq    lh (vl-sort lh (function (lambda (e1 e2) (< (car e1) (car e2))))))
    (setq f (open (strcat (getvar "DWGPREFIX") "Toado.txt") "w") i 0)
    (write-line "X\tY\t\H" f)
    (while (and (nth i lh) (< d (+ l fz)) (>= d (- fz)))
        (if (equal d 0 fz) (setq p st)
            (if (equal d l fz) (setq p en)
                (setq p (vlax-curve-getPointAtDist ob d))))
        (write-line (strcat (rtos (cadr p) 2 3) "\t"(rtos (car p) 2 3) "\t" (cadr(nth i lh))) f)
        (setq d (+ d (* k (atof (cadr(nth i lk))))) i (1+ i))
    )
    (close f)
)

<<

Filename: 241563_xtd.lsp
Tác giả: lyky
Bài viết gốc: 241622
Tên lệnh: c2t
lisp xuất bảng trong cad 2007 ra file exell
Bạn Explode Table để được Text (hoặc MText) trước đã, sau đó sử dụng LISP sau, Mở file lyky.txt được xuất ra tại "C:\\lyky.txt" bằng Excel.
(defun C:C2T ( / e f lst ss y z)
  (setq ss  (acet-ss-to-list (ssget '((0 . "TEXT,MTEXT,RTEXT"))))
        lst (mapcar '(lambda (e) (cons(Dxf 10 (entget e)) (Dxf 1 (entget e)))) ss)
        z   (* (Dxf 40 (entget (car ss))) 0.5)
        lst (vl-sort lst...
>>
Bạn Explode Table để được Text (hoặc MText) trước đã, sau đó sử dụng LISP sau, Mở file lyky.txt được xuất ra tại "C:\\lyky.txt" bằng Excel.
(defun C:C2T ( / e f lst ss y z)
  (setq ss  (acet-ss-to-list (ssget '((0 . "TEXT,MTEXT,RTEXT"))))
        lst (mapcar '(lambda (e) (cons(Dxf 10 (entget e)) (Dxf 1 (entget e)))) ss)
        z   (* (Dxf 40 (entget (car ss))) 0.5)
        lst (vl-sort lst (function (lambda (e1 e2) (Compare2D (car e1) (car e2) z))))
        f   (open "C:\\lyky.txt" "w"))
(foreach e lst
(princ (if (equal y (cadr (car e)) z) "\t" "\n") f)
(princ (cdr e) f) (setq y (cadr (car e)))) (close f)
(prompt "Ket qua xuat ra tai C:/lyky.txt"))
(defun Compare2D (p q f / ) (if (equal (cadr p) (cadr q) f) (< (car p) (car q)) (> (cadr p) (cadr q))))
(defun Dxf(n e) (cdr (assoc n e)))

<<

Filename: 241622_c2t.lsp
Tác giả: ndtnv
Bài viết gốc: 241689
Tên lệnh: xtd
lisp xuat tọa độ có điều kiện

Chọn lần lượt polyline, text. Khi nào chọn xong thì enter.
Trong code có ghi chú để bạn sửa cho phù hợp

(vl-load-com)
(defun Dxf(n e) (cdr (assoc n e)))

(defun C:XTD ( / d en es f fz g i n k l lh lk ls ob p st v) ; xuat toa do
    (setq f (open (strcat (getvar "DWGPREFIX") "Toado.txt") "w") n 0)
    (setq fz 0.001) ; sai so lam tron k/c
    (while (setq es (entsel "\nChon duong polyline "))
        (setq...
>>

Chọn lần lượt polyline, text. Khi nào chọn xong thì enter.
Trong code có ghi chú để bạn sửa cho phù hợp

(vl-load-com)
(defun Dxf(n e) (cdr (assoc n e)))

(defun C:XTD ( / d en es f fz g i n k l lh lk ls ob p st v) ; xuat toa do
    (setq f (open (strcat (getvar "DWGPREFIX") "Toado.txt") "w") n 0)
    (setq fz 0.001) ; sai so lam tron k/c
    (while (setq es (entsel "\nChon duong polyline "))
        (setq ob (vlax-ename->vla-object (car es)) p (cadr es))
        (setq st (vlax-curve-getStartPoint ob) en (vlax-curve-getEndPoint ob))
        (setq l (vlax-curve-getDistAtParam ob (vlax-curve-getEndParam ob)) d 0)
        (setq     i 0 lh '() lk '() n (1+ n))
        (if (< (distance p st) (distance p en))
            (setq d 0 k 1)
            (setq d l k -1)
        )
        (princ "\nChon text :")
        (setq ls (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "TEXT") ))))))
        (foreach e ls
            (setq g (entget e) v (list (car (Dxf 10 g)) (Dxf 1 g)))
            (if (= 0 (Dxf 50 g))
                (setq lk (cons v lk))
                (setq lh (cons v lh))
            ))
        (setq    lk (vl-sort lk (function (lambda (e1 e2) (< (car e1) (car e2))))))
        (setq    lh (vl-sort lh (function (lambda (e1 e2) (< (car e1) (car e2))))))
        (write-line (strcat "Duong thu " (itoa n)) f) ; Neu khong can thi xoa dong nay
        (write-line "X\tY\t\H" f); Neu xoa dong tren thi dua dong nay len sau dong (setq f ...)
        (while (and (nth i lh) (< d (+ l fz)) (>= d (- fz)))
            (if (equal d 0 fz) (setq p st)
                (if (equal d l fz) (setq p en)
                    (setq p (vlax-curve-getPointAtDist ob d))))
            (write-line (strcat (rtos (cadr p) 2 3) "\t"(rtos (car p) 2 3) "\t" (cadr(nth i lh))) f)
            (setq d (+ d (if (nth i lk) (* k (atof (cadr(nth i lk)))) 0)) i (1+ i))
        )
    )
    (close f)
)

 
<<

Filename: 241689_xtd.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 241705
Tên lệnh: ha
[YÊU CẦU] Xin lisp chuyển layer của các đối tượng trong block về cùng layer của block

Xét cả block lồng nhiều tầng.

;; Convert Layer cua cac doi tuong ben trong block (co the long nhau) ve cung Layer cua Block chinh.
;; Doan Van Ha - CadViet.com - ngay 18/7/2013
(defun C:HA ( / ent1 obj1 )
 (if (setq ent1 (car (entsel "\nChon Block: ")))
  (foreach obj (Get_lst_Obj (vla-get-Name (setq obj1 (vlax-ename->vla-object ent1))))
   (vla-put-Layer obj (vla-get-Layer obj1))))
 (vla-update obj1))
(defun Get_lst_Obj...
>>

Xét cả block lồng nhiều tầng.

;; Convert Layer cua cac doi tuong ben trong block (co the long nhau) ve cung Layer cua Block chinh.
;; Doan Van Ha - CadViet.com - ngay 18/7/2013
(defun C:HA ( / ent1 obj1 )
 (if (setq ent1 (car (entsel "\nChon Block: ")))
  (foreach obj (Get_lst_Obj (vla-get-Name (setq obj1 (vlax-ename->vla-object ent1))))
   (vla-put-Layer obj (vla-get-Layer obj1))))
 (vla-update obj1))
(defun Get_lst_Obj (blkname / lst)
 (vlax-for each (vla-Item (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) blkname)
  (if (/= (vla-get-ObjectName each) "AcDbBlockReference")
   (setq lst (cons each lst))
   (setq lst (append (Get_lst_Obj (vla-get-Name each)) lst))))
 lst)

<<

Filename: 241705_ha.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 241604
Tên lệnh: xtt
lỗi CAD khi load lisp

Lisp liên tù tì thường là do lỗi diễn đàn chứ bình thường nó ngắt quảng lấy hơi đàng hoàng.

Sửa lại cho bạn, cũng liên tù tì, nhưng không lỗi.

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/205-viet-lisp-theo-yeu-cau/page-123#entry67734
(defun C:XTT(/ ss ss1 fuzzo fuzz n ent p ndung ent1 ndung1)(prompt "\n Chon Text,MTEXT : ")   (setq ss...
>>

Lisp liên tù tì thường là do lỗi diễn đàn chứ bình thường nó ngắt quảng lấy hơi đàng hoàng.

Sửa lại cho bạn, cũng liên tù tì, nhưng không lỗi.

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/205-viet-lisp-theo-yeu-cau/page-123#entry67734
(defun C:XTT(/ ss ss1 fuzzo fuzz n ent p ndung ent1 ndung1)(prompt "\n Chon Text,MTEXT : ")   (setq ss (ssget '((0 . "text,mtext"))) n (sslength ss))(if (null fuzzo) (setq fuzzo 20))(setq fuzz (getreal (strcat "\n Enter Numeric fuzz < " (rtos fuzzo 2 2) "> : ")))(if (null fuzz) (setq fuzz fuzzo) (setq fuzzo fuzz))    (setq ss1 (ssadd))    (while (> n 0)      (setq ent (ssname ss 0))      (setq p (cdr(assoc 10 (entget ent)))) (setq ndung (cdr(assoc 1 (entget ent))) i 1) (while (< i n)(setq ent1 (ssname ss i))      (setq p1 (cdr(assoc 10 (entget ent1)))) (setq ndung1 (cdr(assoc 1 (entget ent1))))(if (and (equal p p1 fuzz) (eq ndung ndung1))(progn(setq ss1 (ssadd ent1 ss1))))(setq i (1+ i)))(setq ss (ssdel ent ss))(setq n (sslength ss)))(if (> (sslength ss1) 0) (command "_.erase" ss1 ""))(princ))
 

<<

Filename: 241604_xtt.lsp
Tác giả: duy782006
Bài viết gốc: 241659
Tên lệnh: dlb
Xin lisp chuyển layer của các đối tượng trong block về cùng layer của block

Chi bằng ta đổi tất cả các đối tượng trong block thành layer 0 màu bylayer như vậy nó sẽ tự thành như ý nhỉ.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;sua ma dxf block
;;;Cu phap su dung (duy:block_s_dxf block mdxf thanh)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun block_s_dxf (blk mdxf thanh /  e el name ob lname name mdxf...
>>

Chi bằng ta đổi tất cả các đối tượng trong block thành layer 0 màu bylayer như vậy nó sẽ tự thành như ý nhỉ.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;sua ma dxf block
;;;Cu phap su dung (duy:block_s_dxf block mdxf thanh)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun block_s_dxf (blk mdxf thanh /  e el name ob lname name mdxf thanh)
(setq name (cdr (assoc 2 (entget blk))))
(if (not (member name lname))
(progn
(setq lname (append lname (list name)))
(setq e (cdr (assoc -2 (tblsearch "BLOCK" name))))
(while e
(setq el (entget e))

(cond 
((wcmatch (cdr (assoc 0 el)) "INSERT") (block_s_dxf e mdxf thanh) )
)

(setq Ent (subst (cons mdxf thanh) (assoc mdxf el) el))
(entmod ent)
(setq e (entnext e))  
);while
);progn
);if
(command ".move" (ssget "x" (list (cons 0 "INSERT")(cons 2 name))) "" (list 0 0 0) (list 0 0 0))
)

(DEFUN C:dlb ()
(setq dttd (car(entsel "Chon BLOCK!")))
(block_s_dxf dttd 8 "0")
(block_s_dxf dttd 62 256)
)

<<

Filename: 241659_dlb.lsp
Tác giả: gia_bach
Bài viết gốc: 241792
Tên lệnh: sv
Nhờ viết lisp chia màn hình (VPort)

Bạn Ketxu và Thaistreetz bận rồi ah, hic

Có cao thủ nào giúp mình cái

Chắc các cao thủ bận thi đại học, ý nhầm: các cao thủ bận chấm thi và tuyển sinh rồi,

 

Sửa lại lisp của Thaistreetz cho bạn nè :

>>

Bạn Ketxu và Thaistreetz bận rồi ah, hic

Có cao thủ nào giúp mình cái

Chắc các cao thủ bận thi đại học, ý nhầm: các cao thủ bận chấm thi và tuyển sinh rồi,

 

Sửa lại lisp của Thaistreetz cho bạn nè :

;;; Copyright 2011 Thaistreetz from cadviet.com
;;; Edit by Gia_Bach - Ngay 19/7/2013
(defun C:sv (/ dxf10 dxf11 phuong pt pt1 pt2 tl);Split View
  (vl-load-com)
  (defun get-coordinate-screen (coner / Y1 X1)
    (cond ((= (strcase coner) "TL")
	   (polar(polar(getvar "viewctr")(* 0.5 pi) (setq Y1 (* 0.5 (getvar"viewsize")))) pi (/(* Y1 (car(setq X1 (getvar"screensize"))))(cadr X1))))
	  ((= (strcase coner) "BR")
	   (polar(polar(getvar "viewctr")(* -0.5 pi)(setq Y1 (* 0.5 (getvar"viewsize")))) 0 (/(* Y1 (car(setq X1 (getvar"screensize"))))(cadr X1))))))
  (defun TS:zoom (pt1 pt2) (vlax-invoke (vlax-get-acad-object) 'zoomwindow pt1 pt2))
  ;(command "propertiesclose")  
  (if (= (length (vports)) 1)
    (progn
      (setq pt (getpoint "\nChon diem chia :"))
      (setq PT1 (get-coordinate-screen "TL") PT2 (get-coordinate-screen "BR"))
      (initget 1 "Ngang Doc")
      (setq phuong (getkword "\nChia theo phuong ? (Ngang/Doc) "))
      (if (= phuong "Doc")
	(setq tl (/ (- (car pt) (car pt1)) (- (car pt2)(car pt1)))
	      dxf11 (cons 11 (list  tl 1.0))
	      dxf10 (cons 10 (list  tl 0.0 0.0)) )
	(setq tl (/ (- (cadr pt) (cadr pt2)) (- (cadr pt1)(cadr pt2)))
	      dxf11 (cons 11 (list 1.0 tl))
	      dxf10 (cons 10 (list 0.0 tl 0.0)) ) )
      (if (not(tblsearch "vport" "ThaistreetzView"))
	(progn
	  (entmakex (append '((0 . "VPORT")(100 . "AcDbSymbolTableRecord")(100 . "AcDbViewportTableRecord")(2 . "ThaistreetzView")(70 . 0)(10 0.0 0.0) )
			    (list dxf11)))
	  (entmakex (append '((0 . "VPORT")(100 . "AcDbSymbolTableRecord")(100 . "AcDbViewportTableRecord")(2 . "ThaistreetzView")(70 . 0)(11 1.0 1.0 0.0) )
			    (list dxf10) ))))
      (vl-cmdf "vports" "r" "ThaistreetzView")
      (ts:zoom pt1 pt2)
      (setvar "cvport" 3)
      (ts:zoom pt1 pt2))
    (progn
      (vl-cmdf "vports" "si")
      (if (tblsearch "vport" "ThaistreetzView") (vl-cmdf "vports" "d" "ThaistreetzView"))
      (vlax-invoke (vlax-get-acad-object) 'zoomall) ) )
  (princ))

<<

Filename: 241792_sv.lsp
Tác giả: Namvanvo
Bài viết gốc: 241241
Tên lệnh: baitap2-1 baitap2-2
Chữa bài tập chương 2

Mình nộp bài tập bài 2 Ketxu ơi.


Filename: 241241_baitap2-1_baitap2-2.lsp
Tác giả: Namvanvo
Bài viết gốc: 241241
Tên lệnh: dtvk dttg dtmctt kltt klthhv1 klthhv2
Chữa bài tập chương 2

Mình nộp bài tập bài 2 Ketxu ơi.


Filename: 241241_dtvk_dttg_dtmctt_kltt_klthhv1_klthhv2.lsp
Tác giả: vuminhchau
Bài viết gốc: 241969
Tên lệnh: tcir
Nhờ các anh coi giúp lisp vẽ đường tròn bao quanh chữ bị lỗi gì với!

Các anh ơi coi giúp em cái lisp này nó báo lỗi : ; error: no function definition: CONS0 là do thiếu định nghĩa chứa năng cons0 phải không ạ, nhờ các anh bổ sung giúp em với!

 

(defun C:TCir()
    (setq txtSet(ssget(list(cons0"text"))))
    (setq setlen(sslength txtSet))
    (setq ctr 0)
    (repeat setlen
        (setq ent(ssname txtSet ctr))
        (setq...
>>

Các anh ơi coi giúp em cái lisp này nó báo lỗi : ; error: no function definition: CONS0 là do thiếu định nghĩa chứa năng cons0 phải không ạ, nhờ các anh bổ sung giúp em với!

 

(defun C:TCir()
    (setq txtSet(ssget(list(cons0"text"))))
    (setq setlen(sslength txtSet))
    (setq ctr 0)
    (repeat setlen
        (setq ent(ssname txtSet ctr))
        (setq entl(entget ent))
        (setq otex(textbox entl))
        (setq po1(cdr(assoc10 entl)))
        (setq ang1(cdr(assoc50 entl)))
        (setq sinrot(sin ang1))
        (setq cosrot(cos ang1))
        (setq t1(car otex))
        (setq t2(cadr otex))
        (setq p1o(list(+(car po1) (-(*(car t1) cosrot) (*(cadr t1) sinrot))) (+(cadr po1)(+(*(car t1) sinrot) (*(cadr t1) cosrot)))))
        (setq p2o(list (+ (car po1) (-(*(car t2) cosrot) (*(cadr t2) sinrot))) (+(cadr po1) (+(*(car t2) sinrot) (* (cadr t2) cosrot)))))        
        (command"._Circle" (midp p1o p2o) (*0.6(distance p1o p2o)))
        (setq ctr(1+ ctr))
    )
    (princ)
)

; Function to find the mid point of two points.
(defun MidP(midp_fpo midp_spo)
    (setq midp_mpo(list(/ (+(car midp_fpo) (car midp_spo))2) (/ (+(cadr midp_fpo) (cadr midp_spo))2)))
)

(princ "\nType \"TCir\" for Circling selected Texts.")  (princ)

<<

Filename: 241969_tcir.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 241975
Tên lệnh: ha
Xin lisp chuyển layer của các đối tượng trong block về cùng layer của block

Chưa hạn chế được hết tất cả các khiếm khuyết, nhưng cái này có "khá" hơn.

;; Convert Layer cua cac doi tuong ben trong block (co the long nhau) ve cung Layer cua Block chinh. De Undo tat ca: dung lenh "U" + "Regen"
;; Doan Van Ha - CadViet.com - ngay 21/7/2013
(defun C:HA ( / doc blkname lay)
 (princ "\nChon cac Blocks...")
 (if (ssget '((0 . "INSERT")))
  (progn
   (vlax-for obj (vla-get-ActiveSelectionSet...
>>

Chưa hạn chế được hết tất cả các khiếm khuyết, nhưng cái này có "khá" hơn.

;; Convert Layer cua cac doi tuong ben trong block (co the long nhau) ve cung Layer cua Block chinh. De Undo tat ca: dung lenh "U" + "Regen"
;; Doan Van Ha - CadViet.com - ngay 21/7/2013
(defun C:HA ( / doc blkname lay)
 (princ "\nChon cac Blocks...")
 (if (ssget '((0 . "INSERT")))
  (progn
   (vlax-for obj (vla-get-ActiveSelectionSet (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))))
    (setq blkname (vla-get-Name obj)
          lay (vla-get-Layer obj))
    (mapcar '(lambda(o) (vla-put-Layer o lay)) (Get_lst_Obj doc blkname)))
   (vla-Regen doc acActiveViewport))))
(defun Get_lst_Obj (doc blkname / lst)
 (vlax-for blk (vla-Item (vla-get-Blocks doc) blkname)
  (if (/= (vla-get-ObjectName blk) "AcDbBlockReference")
   (if (not (vl-position blk lst))
    (setq lst (cons blk lst)))
   (setq lst (append (Get_lst_Obj doc (vla-get-Name blk)) lst)))))
 

<<

Filename: 241975_ha.lsp
Tác giả: TaiNguyen79
Bài viết gốc: 242044
Tên lệnh: laytd ghitd
Lisp thống kê tọa độ địa chính

Tôi cũng đang có nhu cầu sử dụng một lisp như thế. Thấy bạn có nhắc đến một lisp xuất được bảng tọa độ đơn giản như hình rất hay. Nếu bạn có lisp như thế thì có thể chia sẻ cho tôi được không. Cảm ơn bạn nhé. Chứ hiện tại khi muốn sử dụng bảng tọa độ như hình trên tôi thường phải chuyển sang...

>>

Tôi cũng đang có nhu cầu sử dụng một lisp như thế. Thấy bạn có nhắc đến một lisp xuất được bảng tọa độ đơn giản như hình rất hay. Nếu bạn có lisp như thế thì có thể chia sẻ cho tôi được không. Cảm ơn bạn nhé. Chứ hiện tại khi muốn sử dụng bảng tọa độ như hình trên tôi thường phải chuyển sang MicroStation và dùng Famis để xuất. Làm như thế tôi rất mất thời gian. Hy vọng sẽ được các anh em trên diễn đàn giúp đỡ dùm cho tôi cái lisp xuất bảng tọa độ ra như hình trên. (Thao tác chỉ cần chọn lần lượt từ điểm 1- có thể theo chiều kim đồng hồ hoặc ngược lại - cho đến điểm thứ n và quay về điểm 1, sau đó click một vị trí nào đó trên màn hình sẽ hiện bảng tọa độ như hình trên) . Rất chân thành cảm ơn các anh em.
P/S: Nếu được các anh em diễn đàn chia sẽ lisp hãy gửi giúp tôi vào địa chỉ mail: hihass76@gmail.com. Chân thành cảm ơn anh em diễn đàn CadViet. Chúc diễn đàn ngày càng lớn mạnh.

Mình đang dùng lsp này. Bạn nào đang làm địa chính vẽ 1/500 in 2=1 thì dùng rất phù hợp.  Còn in tỷ lệ khac thì chỉnh lại code lsp là đc
Lệnh như sau :
ghitd (Xuất bảng tọa độ góc ranh theo cách pick điểm tuần tự do ng dùng chỉ định)
laytd (Xuất bảng tọa độ theo cách ng dùng pick chọn 1 điểm trong vùng muốn xuất tọa độ. kết quả xuất ra bảng tọa độ theo nguyên tắc lấy điểm thứ 1 là điểm cao nhất và chạy tọa độ cùng chiều kim đồng hồ )

;Ndaitfunc 2013
;Viet boi : Ndait Nguyen
;;-------------------------------------------------------
;Ghi toa do tu dong theo chieu kim dong ho
(defun c:laytd (/ p bound k lstpt lstx lsty newlst i bien t1 p1 diem x y ymax kmax n c new name ltext diemve pt p1
p2 p3 p4 p5 p6 pt1 pt2 pt3 pt4 pt5 pt6 pt7 pt8 pt9 pt10 pt11 pt12 pt13 pt14 pt15 pt16 pt17)
(luuBHT)
(setq p (getpoint "\nPick point :"))
(setvar "osmode" 0)
(taolop '("vunglaytd" "diemtd" "texttd"))
(setvar "clayer" "vunglaytd")
(command "style" "APTIMA" "vaptimn.ttf" 0 1 0 "" "" "")
(if (/= p nil) (command "-Boundary" p "" ));end if
(setq bound (entget (entlast)))
(setq k (cdr (assoc 90 bound)))
(setq lstpt '() lstx '() lsty '() newlst '())
(setq i 1)
(while (<= i k)
(progn
(setq bien (assoc 10 bound))
(setq t1 (member bien bound))
(setq p1 (car t1))
(setq bound (cdr t1))
(setq diem (cdr p1))
(setq x (car diem) y (cadr diem))
(setq lstx (append lstx (list x)) lsty (append lsty (list y)))
(setq lstpt (append lstpt (list diem)))
(setq i (+ 1 i))));while
(setq ymax (maximum lsty))
(setq kmax (vl-position ymax (reverse lsty)))
(setq lstpt (reverse lstpt))
(setq newlst (member (nth kmax lstpt) lstpt))
(setq n 0)
(repeat kmax (setq newlst (append newlst (list (nth n lstpt)))) (setq n (+ 1 n)))
(setq c 0 new '())
(foreach name newlst (setq new (append new (list (append (list (setq c (1+ c))) name)))))
(setq c 1 new (append new (list (nth 0 new))))
(setq ltext '())
(setq ltext (append ltext (list (nth 0 new))))
(setq newlst (append newlst (list (nth 0 newlst))))
(repeat (- (length new) 1)
(setq ltext (append ltext (list (append (nth c new)
(list (distance (append (nth (- c 1) newlst) '(0.0)) (append (nth c newlst) '(0.0))))))))
(setq c (1+ c)));repeat
(setq n 0)
(setvar "clayer" "diemtd")
(repeat (- (length new) 1)
(ndait_addtext (itoa (car (nth n new))) "texttd" 256 (cdr (nth n new)) 1.0 0.0 "aptima" "BL")
(command "CIRCLE" (cdr (nth n new)) "0.25" "")
(setq n (1+ n)));repeat
(setq diemve (getpoint "\nChon vi tri ve bang toa do : "))
(if (null diemve)
(prompt "\nKhong ve bang ! ")
(progn
(setvar "osmode" 0)
(setvar "orthomode" 0)
(taolop '("Text_Bang" "Line_Bang"))
(setq pt diemve)
(taochu "BAÛNG LIEÄT KEÂ TOÏA ÑOÄ GOÙC RANH" "Text_Bang" 256 (polar (polar pt 0.0 2.5) (* 0.5 Pi) 0.75) 1.0 "Aptima")
(command "layer" "s" "Line_Bang" "")
(setq pt1 pt pt (polar pt (* 1.5 pi) 0.25))
(setq p (polar (polar pt 0.0 0.5) (* 1.5 pi) 2.0))
(setq p1 p
p2 (polar (polar p1 0.0 11.8) (* 0.5 pi) 0.25)
p3 (polar (polar p1 0.0 0.5) (* 1.5 Pi) 2.25)
P4 (polar p3 0.0 7.0)
p5 (polar p4 0.0 9.0)
p6 (polar (polar p5 0.0 7.5) (* 0.5 Pi) 1.5))
(setq pt2 (polar pt1 0.0 5.5)
pt3 (polar pt2 0.0 18.0)
pt4 (polar pt3 0.0 5.5)
pt5 (polar pt2 (* 1.5 Pi) 2.5)
pt6 (polar pt5 0.0 9.0)
pt7 (polar pt6 0.0 9.0)
pt8 (polar pt1 (* 1.5 Pi) 5.0)
pt9 (polar pt8 0.0 5.5)
pt10 (polar pt9 0.0 9.0)
pt11 (polar pt10 0.0 9.0)
pt12 (polar pt11 0.0 5.5))
(taochu "Soá hieäu" "Text_Bang" 256 p1 1.0 "Aptima")
(taochu "Toïa ñoä" "Text_Bang" 256 p2 1.0 "Aptima")
(taochu "ñieåm" "Text_Bang" 256 p3 1.0 "Aptima")
(taochu "X( m )" "Text_Bang" 256 p4 1.0 "aptima")
(taochu "Y( m )" "Text_Bang" 256 p5 1.0 "aptima")
(taochu "Caïnh" "Text_Bang" 256 p6 1.0 "aptima")
(command "layer" "s" "Line_Bang" "")
(command "line" pt1 pt2 pt5 pt6 pt7 pt3 pt4 pt12 pt11 pt10 pt9 pt8 pt1 "")
(command "line" pt2 pt3 "")
(command "line" pt5 pt9 "")
(command "line" pt6 pt10 "")
(command "line" pt7 pt11 "")
(setq pt (polar pt (* 1.5 pi) 6.9))
(setq i 0)
(repeat (length ltext) (ghihang pt (nth i ltext)) (setq i (1+ i)) (setq pt (polar pt (* 1.5 pi) 2.0)))
(setq pt13 (polar pt8 (* 1.5 Pi) (+ (* 2.0 (length ltext)) 0.25)))
(setq pt14 (polar pt13 0.0 5.5)
pt15 (polar pt14 0.0 9.0)
pt16 (polar pt15 0.0 9.0)
pt17 (polar pt16 0.0 5.5))
(command "layer" "s" "Line_Bang" "")
(command "line" pt8 pt13 pt14 pt9 "")
(command "line" pt14 pt15 pt10 "")
(command "line" pt15 pt16 pt11 "")
(command "line" pt16 pt17 pt12 "")
));if
(traBHT)
(princ))
;;----------------------------------------------------------------
;;;Xuat so lieu toa do diem ra file va danh so thu tu
(defun c:ghitd (/ SBD DIEMDAU pt pt0 canh diem text text0 dspt ltext DIEMCUOI Tongdiem diemve i f fl)
(luuBHT)
(setq TL (getvar "userr1"))
(if (<= TL 0.0) (tyle))
(setvar "cmdecho" 0) (setvar "cecolor" "256")
(setq dspt '() ltext '() pt0 nil canh nil)
(Setq SBD (getint "\n Nhap so hieu diem bat dau ghi toa do : <Enter=1> "))
(if (null SBD) (setq SBD 1) (setq SBD SBD))
(command "style" "APTIMA" "vaptimn.ttf" 0 1 0 "" "" "")
(taolop '("MiaP" "MiaT"))
(SETQ DIEMDAU SBD)
(while (setq pt (getpoint (strcat "\n Chon diem toa do : <Mia so " (itoa SBD) "> (Enter de ket thuc)")))
(if (not (null pt0)) (setq canh (distance pt0 pt)))
(setq pt0 pt)
(setq diem (strcat (itoa SBD) " " (trtos (car pt) 3) " " (trtos (cadr pt) 3)))
(setq text (list SBD (car pt) (cadr pt) canh))
(command "layer" "s" "MiaP" "")
(command "point" pt "")
(command "CIRCLE" pt "0.25" "")
(taochu (itoa SBD) "MiaT" 256 pt 1.0 "Aptima")
(setq SBD (1+ SBD))
(setq dspt (append dspt (list diem)))
(setq ltext (append ltext (list text)))
);end while
(setq text0 (nth 0 ltext))
(setq canh (distance (list (nth 1 text0) (nth 2 text0) 0) pt0))
(Setq text (list (nth 0 text0) (nth 1 text0) (nth 2 text0) canh))
(setq ltext (append ltext (list text)))
(setq Tongdiem (itoa (- SBD diemdau)))
(SETQ DIEMCUOI (- SBD 1))
(setq diemve (getpoint "\nChon vi tri ve bang toa do : "))
(if (null diemve)
(prompt "\nKhong ve bang ! ")
(progn
(setvar "osmode" 0)
(setvar "orthomode" 0)
(taolop '("Text_Bang" "Line_Bang"))
(setq pt diemve)
(taochu "BAÛNG LIEÄT KEÂ TOÏA ÑOÄ GOÙC RANH"
"Text_Bang" 256 (polar (polar pt 0.0 2.5) (* 0.5 Pi) 0.75) 1.0 "Aptima")
(command "layer" "s" "Line_Bang" "")
(setq pt1 pt pt (polar pt (* 1.5 pi) 0.25))
(setq p (polar (polar pt 0.0 0.5) (* 1.5 pi) 2.0))
(setq p1 p
p2 (polar (polar p1 0.0 11.8) (* 0.5 pi) 0.25)
p3 (polar (polar p1 0.0 0.5) (* 1.5 Pi) 2.25)
P4 (polar p3 0.0 7.0)
p5 (polar p4 0.0 9.0)
p6 (polar (polar p5 0.0 7.5) (* 0.5 Pi) 1.5)) ;_ end of setq
(setq pt2 (polar pt1 0.0 5.5)
pt3 (polar pt2 0.0 18.0)
pt4 (polar pt3 0.0 5.5)
pt5 (polar pt2 (* 1.5 Pi) 2.5)
pt6 (polar pt5 0.0 9.0)
pt7 (polar pt6 0.0 9.0)
pt8 (polar pt1 (* 1.5 Pi) 5.0)
pt9 (polar pt8 0.0 5.5)
pt10 (polar pt9 0.0 9.0)
pt11 (polar pt10 0.0 9.0)
pt12 (polar pt11 0.0 5.5)) ;_ end of setq
(taochu "Soá hieäu" "Text_Bang" 256 p1 1.0 "Aptima")
(taochu "Toïa ñoä" "Text_Bang" 256 p2 1.0 "Aptima")
(taochu "ñieåm" "Text_Bang" 256 p3 1.0 "Aptima")
(taochu "X( m )" "Text_Bang" 256 p4 1.0 "aptima")
(taochu "Y( m )" "Text_Bang" 256 p5 1.0 "aptima")
(taochu "Caïnh" "Text_Bang" 256 p6 1.0 "aptima")
(command "layer" "s" "Line_Bang" "")
(command "line" pt1 pt2 pt5 pt6 pt7 pt3 pt4 pt12 pt11 pt10 pt9 pt8 pt1 "") ;_ end of command
(command "line" pt2 pt3 "")
(command "line" pt5 pt9 "")
(command "line" pt6 pt10 "")
(command "line" pt7 pt11 "")
(setq pt (polar pt (* 1.5 pi) 6.9))
(setq i 0)
(repeat (length ltext) (ghihang pt (nth i ltext)) (setq i (1+ i)) (setq pt (polar pt (* 1.5 pi) 2.0)))
(setq pt13 (polar pt8 (* 1.5 Pi) (+ (* 2.0 (length ltext)) 0.25))
pt14 (polar pt13 0.0 5.5)
pt15 (polar pt14 0.0 9.0)
pt16 (polar pt15 0.0 9.0)
pt17 (polar pt16 0.0 5.5))
(command "layer" "s" "Line_Bang" "")
(command "line" pt8 pt13 pt14 pt9 "")
(command "line" pt14 pt15 pt10 "")
(command "line" pt15 pt16 pt11 "")
(command "line" pt16 pt17 pt12 "")))
(if (/= (setq f (getstring "\n<Ten FILE> luu toa do diem , Go <ENTER> neu khong luu : ")) "")
(progn
(if (findfile f) (setq fl (open f "a")) (setq fl (open f "w")))
(write-line "DANH SACH TOA DO DIEM " fl)
(write-line (strcat "File name : " (getvar "dwgprefix") (getvar "dwgname")) fl)
(write-line (strcat "TONG SO DIEM : " Tongdiem) fl)
(write-line (strcat "DIEM DAU : " (itoa DIEMDAU) " DIEM CUOI : " (itoa DIEMCUOI)) fl)
(setq i 0)
(repeat (length dspt) (write-line (nth i dspt) fl) (setq i (1+ i)))))
(if fl (close fl))
(traBHT)
(princ))
;;Dung cho ham ghitd
(defun ghihang (point hang / p p1 p2 p3 pt pt2 pt3 pt4 pt5 t1 t2 t3 t4)
(setq pt point
p (polar (polar pt 0.0 2.0) (/ pi 2.0) 0.25)
t1 (rtos (car hang) 2 0)
t2 (trtos (cadr hang) 3)
t3 (trtos (cadr (cdr hang)) 3))
(if (not (null (nth 3 hang))) (setq t4 (trtos (nth 3 hang) 2)))
(setq p1 p
p2 (polar p1 0.0 12.0)
p3 (polar p2 0.0 8.5)
p4 (polar (polar p3 0.0 5.5) (* 0.5 Pi) 1.0))
(taochu t1 "Text_Bang" 256 p1 0.9 "aptima")
(Ndait_addtext t3 "Text_Bang" 256 p2 0.9 nil "aptima" "R")
(Ndait_addText t2 "Text_Bang" 256 p3 0.9 nil "aptima" "R")
(if (not (null t4)) (Ndait_addText t4 "Text_Bang" 256 p4 0.9 nil "aptima" "R")));end of defun
;-----------------------------------
;Cac ham dung chung
;;Luu va tra bien he thong
(defun luuBHT ()
(setq
auts (getvar "autosnap")
blip (getvar "blipmode")
ceco (getvar "cecolor")
clay (getvar "clayer")
cmec (getvar "cmdecho")
fdia (getvar "filedia")
osmo (getvar "osmode")
orth (getvar "orthomode")
plwi (getvar "plinewid")
pola (getvar "polarmode")
tsty (getvar "textstyle")) ;_ end of setq
) ;_ end of defun
(defun traBHT ()
(setvar "autosnap" auts)
(setvar "blipmode" blip)
(setvar "cecolor" ceco)
(setvar "clayer" clay)
(setvar "cmdecho" cmec)
(setvar "filedia" fdia)
(setvar "osmode" osmo)
(setvar "orthomode" orth)
(setvar "plinewid" plwi)
(setvar "polarmode" pola)
(setvar "textstyle" tsty)
) ;_ end of defun
;---
;;Tao lop theo danh sach di kem
(defun taolop (dslop)
(mapcar '(lambda (a) (if (null (tblsearch "layer" a)) (command "layer" "N" a ""))) dslop)
)
;-----
;Ham tao text
(defun taochu (noidung lop mau diem caochu kieu / x y)
(setq x (car diem) y (cadr diem))
(entmod (entmake (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 8 lop) (cons 62 mau)
(cons 100 "AcDbText") (list 10 x y 0.0) (cons 40 caochu)
(cons 1 noidung) (cons 7 kieu))))
) ;defun
(defun Ndait_addtext (noidung lop mau diem caochu goc kieu canhchu / x y va ha)
(cond
((= canhchu "L") (setq va 0 ha 0));Left
((= canhchu "C") (setq va 0 ha 1));Center
((= canhchu "R") (setq va 0 ha 2));Right
;((= canhchu "A") (setq va 0 ha 3));Aligned
((= canhchu "M") (setq va 0 ha 4));Middle
;((= canhchu "F") (setq va 0 ha 5));Fit
((= canhchu "TL") (setq va 3 ha 0));Top Left
((= canhchu "TC") (setq va 3 ha 1));Top Center
((= canhchu "TR") (setq va 3 ha 2));Top Right
((= canhchu "ML") (setq va 2 ha 0));Middle Left
((= canhchu "MC") (setq va 2 ha 1));Middle Center
((= canhchu "MR") (setq va 2 ha 2));Middle Right
((= canhchu "BL") (setq va 1 ha 0));Bottom Left
((= canhchu "BC") (setq va 1 ha 1));Bottom Center
((= canhchu "BR") (setq va 1 ha 2));Bottom Right
(T (setq va 0 ha 0));canhchu false -> Left
);cond
(if (null (tblsearch "style" kieu)) (setq kieu (getvar "textstyle")))
(if (null goc) (setq goc 0.0))
(if (null caochu) (setq caochu 1.0))
(if (null diem) (progn (initget 1) (setq diem (getpoint "\npick point :"))))
(if (null mau) (setq mau 256))
(if (null lop) (setq lop (getvar "clayer")))
(setq x (car diem) y (cadr diem))
(entmod (entmake (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 8 lop)
(cons 62 mau) (cons 100 "AcDbText") (list 10 x y 0.0)
(cons 40 caochu) (cons 50 goc)(cons 1 noidung) (cons 7 kieu)
(cons 72 ha) (list 11 x y 0.0) (cons 100 "AcDbText") (cons 73 va))))
);defun
;Tra ve so lon nhat trong danh sach a
(defun maximum (a)
(setq i 0 maxa (max (nth 0 a) (nth 1 a)))
(repeat (length a) (setq maxa (max (nth i a) maxa)) (setq i (1+ i)))
maxa)
;;Doi so thuc sang chuoi (giong rtos)
;;VD (trtos 1.05 3) -> "1.050"
(defun trtos (Num dec / HSLT N0 N1 N2 N3 them0 them1 CHU)
(setq HSLT dec N0 (+ Num 0.000000001) N1 (- N0 (fix N0)) N2 (rtos N1 2 HSLT)
N3 (- (strlen N2) 2) them0 "." them1 "")
(if (>= N3 HSLT)
(setq CHU (rtos N0 2 HSLT))
(if (= N3 -1)
(setq CHU (strcat (rtos N0 2 HSLT)
(if (= HSLT 0)
(setq them0 "") (repeat HSLT (setq them0 (strcat them0 "0"))))))
(setq CHU (strcat (rtos N0 2 HSLT)
(repeat (- HSLT N3) (setq them1 (strcat them1 "0")))))
);if
);if
CHU)
;the end


ps: trên máy người dùng nhất định phải có font Aptima (vaptimn.ttf) nếu không lsp sẽ bị lỗi.
<<

Filename: 242044_laytd_ghitd.lsp
Tác giả: thiep
Bài viết gốc: 105325
Tên lệnh: sch
Xem giúp đoạn lisp của mình vẽ pline có nhập chiều dài và góc

Chào bác Duy, thiep xin sửa giúp bác 1 chút cái lisp trên, đúng là đối tượng hatch không nên dùng hàm "entmod"

Filename: 105325_sch.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 242156
Tên lệnh: ha
tìm lisp đo diện tích trong diễn đàn

Quick code cho bạn.

(defun C:HA( / ent1 ent2 elist)
 (vl-load-com)
 (while
  (and
   (setq ent1 (car (entsel "\nChon hinh kin: ")))
   (setq ent2 (car (entsel "\nChon Text de ghi: "))))
  (setq elist (entget ent2))
  (entmod (subst (cons 1 (rtos (vla-get-Area (vlax-ename->vla-object ent1)) 2 2)) (assoc 1 elist) elist)))
 (princ))
 

Filename: 242156_ha.lsp
Tác giả: TaiNguyen79
Bài viết gốc: 242078
Tên lệnh: t id
Lisp thống kê tọa độ địa chính

bác xem xem phải không nhé em tríc tọa độ 2 điểm này,với cả em muốn chỉnh cái cỡ chữ số hiệu điểm thì chỉnh ở đâu bác, bác đang để 1.0 giờ em muốn cho nó nhỏ hơn chút
đây là file ảnh http://www.upanh.com/view/?s=upload&id=8vp5bvcl5oz

Tọa...
>>

bác xem xem phải không nhé em tríc tọa độ 2 điểm này,với cả em muốn chỉnh cái cỡ chữ số hiệu điểm thì chỉnh ở đâu bác, bác đang để 1.0 giờ em muốn cho nó nhỏ hơn chút
đây là file ảnh http://www.upanh.com/view/?s=upload&id=8vp5bvcl5oz

Tọa độ địa chính thì như mình đã nói, không có gì phải bàn cả.
Nếu muốn sửa độ lớn của chữ thì bạn tìm dòng như vầy :
(taochu "Soá hieäu" "Text_Bang" 256 p1 1.0 "Aptima")
sửa giá trị 1.0 đi là đc.
PS: Nếu bạn muốn Trục XY như cũ thì hoặc là sửa code hoặc là move cột X thành Y thôi
À mà mình thấy có lẽ bạn cần cái này để lấy tọa độ diểm phải không ?

(defun c:T_id ()
(luuBHT) (setvar "cmdecho" 0)
(initget 1) (setq point01 (getpoint "\nChon diem 1 : \n"))
(setq x1 (rtos (car point01) 2 3) y1 (rtos (cadr point01) 2 3))
(setvar "osmode" 0)
(initget 1) (setq point02 (getpoint point01 "\nChon diem 2 :\n :"))
(setq Angle12 (angle Point01 Point02) dis12 (distance point01 point02))
(if (and (> Angle12 (/ pi 2)) (< Angle12 (* pi 1.5)))
(progn (setq Angle0 pi) (setq Jus "BR"))
(progn (setq Angle0 0.0) (setq Jus "BL")));end if
(setq Point03 (polar (polar Point01 Angle12 dis12) (/ pi 2) 0.275))
(taolop '("Hientrang")) (command "layer" "s" "Hientrang" "")
(command "style" "APTIMA" "vaptimn.ttf" 0 1 0 "" "" "")
(command "pline" point01 "w" 0.0 0.4 (polar Point01 Angle12 1) "w" 0.0 0.0
(polar Point01 Angle12 dis12)
(polar (polar Point01 Angle12 dis12) Angle0 10.5) "")
(command ".text" Jus Point03 1.0 0.0 (strcat "X = " x1) "")
(command ".text" Jus (polar Point03 (* pi 1.5) 2.5) 1.0 0.0 (strcat "Y = " y1) "")
(traBHT) (princ))

(Không có vòng tròn như bạn vì công việc của mình không cần vòng tròn đó )
<<

Filename: 242078_t_id.lsp
Tác giả: lyky
Bài viết gốc: 241831
Tên lệnh: cd bd
Nhờ chỉnh sửa LISP CUTDIM.

Sau khi sửa theo bác NĐT xong, bạn có thể tổng hợp 2 phần riêng lẻ thành một code chung, phần bẫy lỗi bạn tự bổ xung nhé (bởi vì: theo ý mình phần bẫy lỗi - thiết định và phục hồi giá trị các biến hệ thống được thực hiện bằng các hàm riêng (như là một Public function))

(defun CBD (p / dem ds gocx gocy kdl...
>>

Sau khi sửa theo bác NĐT xong, bạn có thể tổng hợp 2 phần riêng lẻ thành một code chung, phần bẫy lỗi bạn tự bổ xung nhé (bởi vì: theo ý mình phần bẫy lỗi - thiết định và phục hồi giá trị các biến hệ thống được thực hiện bằng các hàm riêng (như là một Public function))

(defun CBD (p / dem ds gocx gocy kdl lth n10 n11 n13 n14 n70 o10 o11 o13 o14 pt pt10 pt10i pt10n pt11 pt11n pt13 pt13i pt13n pt14 pt14i pt14n pti ss)
(princ "\nVui long chon vung dimmensions can thao tac:\n") (setq ss (ssget))
(setq pt (getpoint "\nPick diem moc:\n")) (setq pt (trans pt 1 0))
(setq lth (sslength ss)) (setq dem 0) (while (< dem lth) (progn
(setq ds (entget (ssname ss dem)) kdl (cdr (assoc 0 ds)))
(if (and (= "DIMENSION" kdl) (> 2 (setq n70 (rem (cdr (assoc 70 ds)) 32))))
  (progn
(setq pt10 (cdr (assoc 10 ds)) pt11 (cdr (assoc 11 ds))
      pt13 (cdr (assoc 13 ds)) pt14 (cdr (assoc 14 ds)))
(setq gocx (if (= n70 1) (angle pt13 pt14) (cdr (assoc 50 ds))))
(setq gocy (- gocx (/ pi 2)))
(setq pti   (polar pt   gocx 2)  pt13i (polar pt13 gocy 2)
      pt14i (polar pt14 gocy 2)  pt10i (polar pt10 gocy 2))
(setq pt13n (inters pt pti pt13 pt13i nil) pt14n (inters pt pti pt14 pt14i nil)
      pt10n (inters pt pti pt10 pt10i nil)
      pt11n (polar pt11 (angle pt10 pt10n) (distance pt10 pt10n)))
(setq o13 (assoc 13 ds   ) o14 (assoc 14 ds   ) o10 (assoc 10 ds   ) o11 (assoc 11 ds   )
      n13 (cons  13 pt13n) n14 (cons  14 pt14n) n10 (cons  10 pt10n) n11 (cons 11 pt11n))
(if p (progn (setq ds (subst n13 o13 ds) ds (subst n14 o14 ds)))
      (progn (setq ds (subst n10 o10 ds) ds (subst n11 o11 ds))))
      (entmod ds))) (setq dem (+ dem 1)))))
;;;======================================================================
(defun C:CD () (CBD T  ))	       ; Cat moc DIM theo diem giong ;;<>
(defun C:BD () (CBD NIL))	       ; Doi moc DIM theo diem giong ;;<>

P/S: Vote Bác NĐT, Cám ơn Bác đã hướng dẫn em sửa lại code nhé!


<<

Filename: 241831_cd_bd.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 242149
Tên lệnh: ha
[Yêu cầu] Lisp cộng - trừ - nhân - chia 2 hàng số cho ra hàng thứ 3

cho mình xin lisp mà cộng, trừ nhân chia cả 1 hàng hay cột với 1 số cố định ( nhập bằng tay ). Kết quả xuất ra có thể là hàng hay cột mới hoặc chính là hàng hay cột ban đầu có dc k??? xin các bác giúp mình với

Lisp + - * / vào 1 nhóm (hàng/cột) và trả kết quả ngay tại nhóm (hàng/cột)...

>>

cho mình xin lisp mà cộng, trừ nhân chia cả 1 hàng hay cột với 1 số cố định ( nhập bằng tay ). Kết quả xuất ra có thể là hàng hay cột mới hoặc chính là hàng hay cột ban đầu có dc k??? xin các bác giúp mình với

Lisp + - * / vào 1 nhóm (hàng/cột) và trả kết quả ngay tại nhóm (hàng/cột) đó.

;; Cong/Tru/Nhan/Chia 1 nhom (hang hoac cot) cho 1 so. Tra ve ket qua ngay tai vi tri cua chung.
;; CadViet.com - ngay 23/7/2013
(defun C:HA( / #SS->List toan so ss elist)
 (defun #SS->List (ss / i lst)
  (repeat (setq i (sslength ss))
   (setq lst (cons (ssname ss (setq i (1- i))) lst))))
 (if
  (and
   (not (initget "C T N H"))
   (setq toan (getkword "\nPhep toan [Cong/Tru/Nhan/cHia: "))
   (not (initget 3))
   (setq so (getreal "\nNhap so: "))
   (setq ss (ssget '((0 . "*Text")))))
  (progn
   (setq toan
    (cond
     ((= toan "C") +)
     ((= toan "T") -)
     ((= toan "N") *)
     ((= toan "H") /)))
   (foreach ent (#SS->List ss)
    (setq elist (entget ent))
    (entmod (subst (cons 1 (rtos (toan (atof (cdr (assoc 1 elist))) so) 2 2)) (assoc 1 elist) elist)))))
 (princ))
 

<<

Filename: 242149_ha.lsp

Trang 136/330

136