Jump to content
InfoFile
Tác giả: Nguyen Hoanh
Bài viết gốc: 6193
Tên lệnh: mtp
Hỏi về LISP

Bạn xem ví dụ này:

Đây là đoạn mã có sử dụng hàm textbox, được viết theo yêu cầu của vbao tại: http://www.cadviet.com/forum/index.php?showtopic=1571

Filename: 6193_mtp.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 289845
Tên lệnh: ha
Lisp chọn polyline có elevation chẵn - lẻ

Đây bạn!

; Xoa cac Lwpolyline co cao do chan (VD: 2.0 4.0) hoac le (VD: 1.0 3.0).
(defun C:HA( / cl ss hei ent)
 (initget "C L")
 (setq cl (getkword "\nXoa cac Pline co cao do <L>: "))
 (princ "\nChon cac Pline...")
 (if (setq ss (ssget '((0 . "Lwpolyline"))))
  (repeat (setq i (sslength ss))
   (setq hei (cdr (assoc 38 (entget (setq ent (ssname ss (setq i (1-...
>>

Đây bạn!

; Xoa cac Lwpolyline co cao do chan (VD: 2.0 4.0) hoac le (VD: 1.0 3.0).
(defun C:HA( / cl ss hei ent)
 (initget "C L")
 (setq cl (getkword "\nXoa cac Pline co cao do <L>: "))
 (princ "\nChon cac Pline...")
 (if (setq ss (ssget '((0 . "Lwpolyline"))))
  (repeat (setq i (sslength ss))
   (setq hei (cdr (assoc 38 (entget (setq ent (ssname ss (setq i (1- i))))))))
   (cond
    ((and (= cl "C") (= (fix (/ hei 2)) (/ hei 2))) (entdel ent))
    ((and (or (not cl) (= cl "L")) (/= (fix (/ hei 2)) (/ hei 2))) (entdel ent))))))
 


<<

Filename: 289845_ha.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 289867
Tên lệnh: dmat
lisp chuyển màu các thuộc tính dynamic block

Hề hề hề,

Thử dùng cái này coi đã ưng ý chưa hè???

 

(defun c:dmat (/ ss tag col i a b )
(alert "\n Chon cac block chua thuoc tinh can doi mau")
(setq ss (ssget (list (cons 0 "insert") (cons 66 1))))
(setq tag (getstring "\n Nhap tag name cua thuoc tinh can doi mau : ")
          col (getint "\n Nhap so hieu...
>>

Hề hề hề,

Thử dùng cái này coi đã ưng ý chưa hè???

 

(defun c:dmat (/ ss tag col i a b )
(alert "\n Chon cac block chua thuoc tinh can doi mau")
(setq ss (ssget (list (cons 0 "insert") (cons 66 1))))
(setq tag (getstring "\n Nhap tag name cua thuoc tinh can doi mau : ")
          col (getint "\n Nhap so hieu mau muon doi thanh: ") 
          i 0)
(while (setq a (ssname ss i))
     (setq b (entnext a))
(while (and b (/= (cdr (assoc 0 (entget b))) "SEQEND"))
             (if (and (= (cdr (assoc 0 (entget b))) "ATTRIB") (= (cdr (assoc 2 (entget b))) tag))
                 (progn
                        (entmod (subst (cons 62 col) (assoc 62 (entget b)) (entget b)))
                        (entupd b)
                 )
             )
             (setq b (entnext b))
     )
     (setq i (1+ i))
)
)
(defun c:dmat (/ ss tag col i a b )
(alert "\n Chon cac block chua thuoc tinh can doi mau")
(setq ss (ssget (list (cons 0 "insert") (cons 66 1))))
(setq tag (getstring "\n Nhap tag name cua thuoc tinh can doi mau : ")
          col (getint "\n Nhap so hieu mau muon doi thanh: ") 
          i 0)
(while (setq a (ssname ss i))
     (setq b (entnext a))
     (while (and b (/= (cdr (assoc 0 (entget B))) "SEQEND"))
             (if (and (= (cdr (assoc 0 (entget B))) "ATTRIB") (= (cdr (assoc 2 (entget B))) tag))
                 (progn
                        (entmod (subst (cons 62 col) (assoc 62 (entget B)) (entget B)))
                        (entupd B)
                 )
             )
             (setq b (entnext B))
     )
     (setq i (1+ i))
)

Lisp rất hay, rất đúng ý mình, cám ơn bạn phamthanhbinh nhiều lắm nhưng có 3 điều nho nhỏ nữa phát sinh, bạn sửa giúp mình luôn nha

 

1. lúc ban đầu đưa ra lựa chọn dynamic block để đổi màu, nó lại hiện lên cái bảng, cứ phải ấn ok mới chọn được, bạn có thể bỏ các bảng đó đi, mình đưa ra lựa chọn dynamic block luôn được không

2. có thể liệt kê tên các attribute trong dynamic block để từ đó mình lựa chọn, như thế sẽ tiện hơn nhiều vì nhiều khi mình không nhớ tên attribute, cứ phải click đúp vào xem rồi mới gõ lệnh sửa mầu được

3. khi lựa chọn màu có thể hiện lên cả bảng màu để lựa chọn thì tốt, như thế sẽ trực quan dễ dàng hơn

 

Bạn giúp mình cái nha. chân thành cám ơn

Hề hề hề,

Sorry bạn vì chậm trả lời.

Đây là lisp mình đã bổ sung theo yêu cầu của bạn. hãy dùng thử và cho ý kiến.

 
(defun c:dmat (/ ss tag col i a b taglst tagname ssl tag0)
(prompt "\n Chon cac block chua thuoc tinh can doi mau")
(setq ss (ssget (list (cons 0 "insert") (cons 66 1))))
(setq ssl (acet-ss-to-list ss))
(setq taglst (list))
(foreach blk ssl
        (setq a (entnext blk))
        (while (and a (/= (cdr (assoc 0 (entget a))) "SEQEND"))
                (if (=  (cdr (assoc 0 (entget a))) "ATTRIB") 
                    (progn
                           (setq tag0 (cdr (assoc 2 (entget a))))
                           (if (not (member tag0 taglst))
                               (setq taglst (append taglst (list tag0)))
                           )
                     )
                  )
                  (setq a (entnext a))
         )
)
(setq tagname "")
(foreach tag taglst 
      (setq tagname (strcat tagname tag " , "))
)
(prompt (strcat "\n Cac thuoc tinh bao gom: " tagname))
(setq tag (getstring "\n Nhap tag name cua thuoc tinh can doi mau : ")
          col (acad_colordlg  1) 
          i 0)
(while (setq a (ssname ss i))
     (setq b (entnext a))
     (while (and b (/= (cdr (assoc 0 (entget b))) "SEQEND"))
             (if (and (= (cdr (assoc 0 (entget b))) "ATTRIB") (= (cdr (assoc 2 (entget b))) tag))
                 (progn
                        (entmod (subst (cons 62 col) (assoc 62 (entget b)) (entget b)))
                        (entupd b)
                 )
             )
             (setq b (entnext b))
     )
     (setq i (1+ i))
)
(princ)
)
 

<<

Filename: 289867_dmat.lsp
Tác giả: 0907398688
Bài viết gốc: 289931
Tên lệnh: aa
Ai sửa cho em cái lisp tính diện tích trong cad 2007 với

em bảo do em gà mà.bác thông cảm,thank bác nhiều.bác chỉnh lại hộ cái đó chuyển sang mày đỏ.em quên mất trong cad màu 2 là màu vàng.tại nghiện đế chế nên quan niệm mầu 2 là màu đỏ...sorry bác.có gì giúp em cho trót nhé...bác có thể thêm cho em phần khi dùng xong lẹnh aa mà em bị mất cái bắt điểm ko ạ.

;;=========================Tinh dien...
>>

em bảo do em gà mà.bác thông cảm,thank bác nhiều.bác chỉnh lại hộ cái đó chuyển sang mày đỏ.em quên mất trong cad màu 2 là màu vàng.tại nghiện đế chế nên quan niệm mầu 2 là màu đỏ...sorry bác.có gì giúp em cho trót nhé...bác có thể thêm cho em phần khi dùng xong lẹnh aa mà em bị mất cái bắt điểm ko ạ.

;;=========================Tinh dien tich==============================
(defun c:aa()
  (if (= tl nil) (progn
    (setq tl (getreal "\nDrawing scale<1/> : "))
    (setq ntl tl)
    (setq tl2 (* ntl ntl))
    )
  )
  (setq dtl 0)
  (setq ss (ssadd))
  (setq oslast (getvar "OSMODE"))
  (command "osnap" "")
  (print)
  (print)
  (setq pt1 (getpoint "\nChon mot diem trong vung dien tich can tinh: "))
  (while (/= pt1 nil)
    (command "-boundary" pt1 "")
    (setq et (entlast))
    (ssadd et ss)
    (command "area" "e" "last")
    (setq vsize ( /(getvar "VIEWSIZE") 3 ))
    (command "hatch" "ANSI31" vsize "0" "last" "")
    (setq et (entlast))
    (ssadd et ss)
    (setq dtcon (getvar "AREA"))
    (setq dtl (+ dtcon dtl))
    (print)
    (print)
    (setq pt1 (getpoint "\nChon mot diem trong vung dien tich tiep theo : "))
  )
  (command "setvar" "OSMODE" oslast)
  (command "erase" ss "")
  (setq ss nil)
  (command "redraw" )
  (setq dtl (* dtl tl2))
  (print dtl)
  (setq elst (entget (car (entsel "Thay cho so: "))))
  (setq elst (subst (cons 1 (rtos dtl 2 2)) (assoc 1 elst) elst))
(if (assoc 62 elst) (setq elst (subst (cons 62 1) (assoc 62 elst) elst)) (setq elst (cons (cons 62 1) elst)))
  (entmod elst)
  ;(print)
  (prompt (strcat "\nTong dien tich: " (rtos dtl 2 4)))
  (print)
;  (setq pt2 (getpoint "\nPoint to write: "))
;  (command "text" pt2 (/ vsize 6) "0" (rtos dtl 2 2))
);defun
;(setq caodo (atof (assoc 1 ((entget (car (entsel "Thay cho so: ")))))))

<<

Filename: 289931_aa.lsp
Tác giả: pdle
Bài viết gốc: 147043
Tên lệnh: lp
[Hỏi] Hàm polar
Em đã sửa lại như sau, giờ lisp đã chạy OK, nhưng có vẻ vẫn cần phải gọt giũa tiếp (em chưa làm phần kiểm tra 2 điểm pt1 và pt2 có trùng nhau hay không:D).

Filename: 147043_lp.lsp
Tác giả: ketxu
Bài viết gốc: 290345
Tên lệnh: loai1 loai2
giúp em làm cái lisp vẽ đoạn thẳng này với.

mifepristone misoprostol canada wtc Ninety-six percent of Lyme disease cases come from 13 states. Lyme disease — the most common tick-borne disease — was first identified by a researcher at Yale University in the mid-1970s among residents of Lyme and Old Lyme in Connecticut.
>>
mifepristone misoprostol canada wtc Ninety-six percent of Lyme disease cases come from 13 states. Lyme disease — the most common tick-borne disease — was first identified by a researcher at Yale University in the mid-1970s among residents of Lyme and Old Lyme in Connecticut.
lamictal rashes photos The defendants also told Kelly that "if she insisted on taking her dog home, that she would have to sign a form that it was against" their medical advice, "and that they were going to report her to the authorities for "animal cruelty," which is a crime," the lawsuit states.
cheap wellbutrin sr The country"s utilities are hit by plunging wholesale powerprices and a boom in solar and wind energy capacity, takingpriority when being fed into the grid and reducing the hoursconventional power plants can run.

<<

Filename: 290345_loai1_loai2.lsp
Tác giả: KangKung
Bài viết gốc: 290351
Tên lệnh: sd
Hỏi lệnh xem đối tượng màu số bao nhiêu?

Tặng bạn Lisp này. Xem được cả màu RGB và Color Index.

(defun C:SD(/ obj oColor)
  (setq obj(vlax-ename->vla-object(car(nentsel))))
  (setq oColor(vlax-get-property obj 'TrueColor))
  (princ "\nRGB = ")
  (princ (vla-get-red oColor))
  (princ ",")
  (princ (vla-get-green oColor))
  (princ ",")
  (princ (vla-get-blue oColor))
  (princ "\nIndexColor = ")
  (princ (vla-get-colorindex oColor))
  (princ)
  )

Filename: 290351_sd.lsp
Tác giả: ndtnv
Bài viết gốc: 290409
Tên lệnh: sc2
scale theo trục x và y

@ndtnv : Lưu cũng chẳng có ích gì vì sau khi explode, đối tượng sẽ mang tên (code -1) khác hoàn toàn, thậm chí sau khi scale chưa nổ nó cũng mang tên khác, chỉ có thể edit ngay khi nó còn trong block thôi.

 

@anpha3 : botay.com

Sau khi explode, thứ tự đối tượng sẽ không đổi.
Tôi sửa tạm như...

>>

@ndtnv : Lưu cũng chẳng có ích gì vì sau khi explode, đối tượng sẽ mang tên (code -1) khác hoàn toàn, thậm chí sau khi scale chưa nổ nó cũng mang tên khác, chỉ có thể edit ngay khi nó còn trong block thôi.

 

@anpha3 : botay.com

Sau khi explode, thứ tự đối tượng sẽ không đổi.
Tôi sửa tạm như sau:
( Chưa test nhiều để chắc chắn thứ tự trong (ssget "p") có thay đổi hay không.
An toàn hơn thì nên sort ss theo dxf 5 )

(defun C:sc2(/ ss p tlx tly btp tenbl data obj)
  (defun BlockText (v tlx tly  / blks name def i)
    (setq blks (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))
      name (vla-get-effectivename (vlax-ename->vla-object v)) i 0)
 
    (if (not (vl-catch-all-error-p (setq def (vl-catch-all-apply 'vla-item (list blks name)))))
      (vlax-for obj def
    (if (= "AcDbText" (vla-get-objectname obj))
        (setq data (cons  (list (vla-get-Height obj)(vla-get-ScaleFactor obj)(vla-get-ObliqueAngle obj) i )data)))
        (setq i (1+ i))
  )))
  ;;;
  (prompt "\nChon doi tuong de scale :")
  (setq ss  (ssget)
    p   (getpoint "\nDiem goc:")
      tlx (getreal "\nTy le scale phuong X:")
    tly (getreal "\nTy le scale phuong Y:"))
  (if (not btp) (setq btp -1))
  (while (tblsearch "block" (setq tenbl (strcat "btmp" (itoa (setq btp (1+ btp)))))))
    (command ".undo" "be")
  (command "-block" tenbl p ss "")
  (command "-insert" tenbl p tlx tly 0)
  (BlockText (entlast) tlx tly)
  (command "explode" (entlast))
    (setq ss (ssget "p"))
    (foreach e data
        (setq obj(vlax-ename->vla-object (ssname ss (last e))))
        (vla-put-Height obj (car e))
        (vla-put-ScaleFactor obj (cadr e))
        (vla-put-ObliqueAngle obj (caddr e))
    )
    (command ".undo" "e")
  (princ)
)

<<

Filename: 290409_sc2.lsp
Tác giả: Tot77
Bài viết gốc: 290419
Tên lệnh: test
scale theo trục x và y

Thứ tự trước và sau khi explode cũng khác nhau, dxf -1 và 5 đều khác, xem như cad đã xoá các vật thể trước trong kho dữ liệu và tạo ra vật thể hoàn toàn mới. Làm 1 "thí nghiệm" như sau, chọn khoảng 10 vật khác nhau tẽt pline,line, circle ... rồi chạy lisp sau:

 

(defun c:test()
  (setq ss (ssget)
i -1 data nil data1 nil data2 nil
p   (getpoint "\nDiem...
>>

Thứ tự trước và sau khi explode cũng khác nhau, dxf -1 và 5 đều khác, xem như cad đã xoá các vật thể trước trong kho dữ liệu và tạo ra vật thể hoàn toàn mới. Làm 1 "thí nghiệm" như sau, chọn khoảng 10 vật khác nhau tẽt pline,line, circle ... rồi chạy lisp sau:

 

(defun c:test()
  (setq ss (ssget)
i -1 data nil data1 nil data2 nil
p   (getpoint "\nDiem goc:"))
  
  (repeat (sslength ss)
    (setq obj (vlax-ename->vla-object (ssname ss (setq i (1+ i))))
 data (append data (list (list (vla-get-objectname obj) i )))))
  
  (if (not btp) (setq btp -1))
  (while (tblsearch "block" (setq tenbl (strcat "btmp" (itoa (setq btp (1+ btp)))))))
  
  (command ".undo" "be")
  (command "-block" tenbl p ss "")
  (command "-insert" tenbl p 1 1 0)
 
  (setq blks (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))
        name (vla-get-effectivename (vlax-ename->vla-object (entlast))) i 0)
 
    (if (not (vl-catch-all-error-p (setq def (vl-catch-all-apply 'vla-item (list blks name)))))
      (vlax-for obj def
        (setq data1 (append data1 (list (list (vla-get-objectname obj) i)))
     i (1+ i))))
 
  (command "explode" (entlast))
  (setq ss (ssget "p"))
  (foreach e data
        (setq obj (vlax-ename->vla-object (ssname ss (last e)))
     data2 (append data2 (list (list (vla-get-objectname obj) (last e)))))       
  )
  
  (princ data) (princ data1) (princ data2) (princ)
)

 

Tôi thấy nếu thay (setq ss (ssget "p")) bằng (setq ss (ssget)) và  thì 2 cái list trước và sau sẽ giống nhau, nhưng như vậy hơi phiền vì phải bắt 2 lần. Như vậy thì có vẻ hơi "lẩm cẩm"!!  :blink:  :blink:


<<

Filename: 290419_test.lsp
Tác giả: Tot77
Bài viết gốc: 290616
Tên lệnh: test
lisp sắp xếp các text thành 1 nhóm

Bạn dùng cái này, kết quả ra 1 list chứa tên theo thứ tự từ trên xuống.

(defun nhap(ss cao / L L1)
  (setq L (vl-sort (acet-ss-to-list ss) '(lambda(x y) (> (cadr (dxf 11 x)) (cadr (dxf 11 y))))))
  (while L
    (setq L1 (append L1 (list 
   (vl-remove-if '(lambda(x) (not (equal (cadr (dxf 11 (car L))) (cadr (dxf 11 x)) cao))) L)))
 L (vl-remove-if '(lambda(x) (equal (cadr (dxf 11 (car L)))...
>>

Bạn dùng cái này, kết quả ra 1 list chứa tên theo thứ tự từ trên xuống.

(defun nhap(ss cao / L L1)
  (setq L (vl-sort (acet-ss-to-list ss) '(lambda(x y) (> (cadr (dxf 11 x)) (cadr (dxf 11 y))))))
  (while L
    (setq L1 (append L1 (list 
   (vl-remove-if '(lambda(x) (not (equal (cadr (dxf 11 (car L))) (cadr (dxf 11 x)) cao))) L)))
 L (vl-remove-if '(lambda(x) (equal (cadr (dxf 11 (car L))) (cadr (dxf 11 x)) cao)) L)))
  L1
)
 
(defun dxf(id v) (cdr (assoc id (entget v))))
 
(defun c:test(/ ss)
  (nhap (setq ss (ssget '((0 . "TEXT")))) (* 0.5 (dxf 40 (ssname ss 0)))))


<<

Filename: 290616_test.lsp
Tác giả: nhatphong
Bài viết gốc: 290651
Tên lệnh: dtth
[Nhờ sửa]Lisp tính tổng hatch
t(defun c:dtth(/ cnt tot ss obj )
(if (> (atof (substr (getvar "ACADVER") 1 4)) 16.1)
(progn
(vl-load-com)
(setq cnt 0 tot 0 )
(princ "\nCh\U+1ECDn c\U+00E1c v\U+00F9ng hatch c\U+1EA7n t\U+00EDnh t\U+1ED5ng")
(if (setq ss (ssget '((0 . "HATCH"))))
(progn
(foreach e (mapcar 'vlax-ename->vla-Object (vl-remove-if 'listp (mapcar 'cadr (ssnamex 

ss))))
(if (vlax-property-available-p e 'Area)
(setq cnt (1+ cnt)
tot (+ tot (vla-get-Area e))
)
)
)
(princ (strcat...
>>
t(defun c:dtth(/ cnt tot ss obj )
(if (> (atof (substr (getvar "ACADVER") 1 4)) 16.1)
(progn
(vl-load-com)
(setq cnt 0 tot 0 )
(princ "\nCh\U+1ECDn c\U+00E1c v\U+00F9ng hatch c\U+1EA7n t\U+00EDnh t\U+1ED5ng")
(if (setq ss (ssget '((0 . "HATCH"))))
(progn
(foreach e (mapcar 'vlax-ename->vla-Object (vl-remove-if 'listp (mapcar 'cadr (ssnamex 

ss))))
(if (vlax-property-available-p e 'Area)
(setq cnt (1+ cnt)
tot (+ tot (vla-get-Area e))
)
)
)
(princ (strcat "\nT\U+1ED5ng di\U+1EC7n t\U+00EDch "(itoa cnt) " Hatch l\U+00E0: " 

(rtos tot) ) )
(setq obj (entsel "\nCh\U+1ECDn text \U+0111\U+1EC3 ghi k\U+1EBFt qu\U+1EA3 hoac k\U

+1EBFt th\U+00FAc \U+0111\U+1EC3 xem gi\U+00E1 tr\U+1ECB"))
(if (and
obj
(setq obj (vlax-ename->vla-object (car obj)))
(eq (vlax-get obj 'ObjectName) "AcDbText")
)
(vla-put-TextString obj (rtos tot))
)
(princ)
)
(princ "\nKB\U+1EA1n ch\U+01B0a ch\U+1ECDn \U+0111\U+1ED1i t\U+01B0\U+1EE3ng hatch n\U

+00E0o c\U+1EA3" )
)
)
(alert "\nPhi\U+00EAn b\U+1EA3n autocad c\U+1EE7a b\U+1EA1n kh\U+00F4ng h\U+1ED7 tr\U

+1EE3!")
)
) 

Mình tìm trên mạng được lisp này,cũng khá hay các bác có thể cho e thêm cái đơn vị tính ra "M2" ở cuối được không ạ... :unsure:

 

Không hiểu sao khi kết hợp với cái lisp này của bác Ketxu sao giá trị tổng lại kg bằng nhỉ : :D

http://www.cadviet.com/forum/topic/47301-da-xong-lisp-thong-ke-dien-tich-hatch-theo-layer/page-3

 

Nhờ các cao thủ ra tay dùm  :ph34r:


<<

Filename: 290651_dtth.lsp
Tác giả: vuminhchau
Bài viết gốc: 290633
Tên lệnh: kh
'Tạo khung bản đồ'

oh, hôm nay mới thấy lai cai upload lại, nên up nhờ các bác giúp em như hình vẽ dưới đây với!

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

oh, hôm nay mới thấy lai cai upload lại, nên up nhờ các bác giúp em như hình vẽ dưới đây với!

(defun c:kh ();;; (princ "\n                      CHUONG TRINH VE KHUNG BAN DO .")(command "osnap" "Endpoint,Intersection")(setvar "blipmode" 1)   (setq sp (getpoint "\n Chon goc khung thu 1 (Goc trai ben tren): "))   (setq ep (getpoint sp "\n Chon goc khung thu 2 (Goc phai ben duoi): "));   (princ "\n Chon goc khung thu 1 (Goc trai ben tren): ");   (setq sp (getpoint)) ;  (prompt "\n Chon goc khung thu 2 (Goc phai ben duoi): ") ;  (setq ep (getcorner (getpoint)) )  (command "osnap" "off")   (setq tyle (getint "\n Hay cho ty le ban do <500>: "))   (if (= tyle nil) (setq tyle 500.0))(setvar "blipmode" 0);;--- Dat bien chung cho chuong trinh -----  (setq x1 (nth 0 sp)) (setq y1 (nth 1 sp))  (setq x2 (nth 0 ep)) (setq y2 (nth 1 ep))  (setq dayn (/ (* tyle 0.05) 500.0))  (setq kctn (/ tyle 142.857))  (setq ktmk (/ (* tyle 1.75) 500.0))  (setq caoc (/ (* tyle 0.90) 500.0))  (setq dich (/ (* tyle 0.33) 500.0));;;---- ve khung trong ------   (command "LAYER" "M" "KHUNG" "")   (Command "PLINE"             (list x1 y1)             (list x2 y1)             (list x2 y2)             (list x1 y2)             "C"   );;;;-------Ve khung ngoai ----------   (command "LAYER" "M" "KHUNG" "")   (Command "PLINE"             (list (- x1 kctn) (+ y1 kctn)) "w" dayn dayn             (list (+ x2 kctn) (+ y1 kctn))             (list (+ x2 kctn) (- y2 kctn))             (list (- x1 kctn) (- y2 kctn))             "C"   );;;------- Ve net ngang va doc ------- (setq nhay (/ tyle 10.0)) (setq tmpX1 (/ x1 nhay)) (setq tmpX2 (fix tmpX1)) (setq x (* tmpX2 nhay)) (setq tmpY1 (/ y2 nhay)) (setq tmpY2 (fix tmpY1)) (setq y (* tmpY2 nhay));-------------------------------------(command "style" "STANDARD" "" caoc "" "" "" "" "" "")(while (<= x x2)       (if (>= x x1)          (command "LINE" (list x y1) (list x (+ y1 kctn)) ""                   "LINE" (list x y2) (list x (- y2 kctn)) ""                   "TEXT" "C" (list x (+ y1 (/ kctn 2))) 0. (rtos x 2 0)                   "TEXT" "TC" (list x (- y2 (/ kctn 2))) 0. (rtos x 2 0)          )       ) ;endif  (setq x (+ x nhay)))(while (<= y y1)   (setq tmp1 (rtos y 2 0))   (setq len1 (strlen tmp1))   (if ( <= len1 3)      (progn (setq bef "000") (setq aff tmp1))      (progn (setq bef (substr tmp1 1 (- len1 3)))       (setq aff (substr tmp1 (- len1 2) 3))      )   ) ;;if      (if (>= y y2)           (command "LINE" (list x1 y) (list (- x1 kctn) y) ""                    "LINE" (list x2 y) (list (+ x2 kctn) y) ""                    "TEXT" "BC" (list (- x1 (/ kctn 2)) y) 0. bef                    "TEXT" "TC" (list (- x1 (/ kctn 2)) (- y dich)) 0. aff                    "TEXT" "BC" (list (+ x2 (/ kctn 2)) y) 0. bef                    "TEXT" "TC" (list (+ x2 (/ kctn 2)) (- y dich)) 0. aff           )      ); endif  (setq y (+ y nhay)));--------- Ve chu thap --------------(setq nhay (/ tyle 10.0)) (setq tmpX1 (/ x1 nhay)) (setq tmpX2 (fix tmpX1))(setq x (* tmpX2 nhay))(setq tmpY1 (/ y2 nhay)) (setq tmpY2 (fix tmpY1))(while (< x x2)  (setq y (* tmpY2 nhay))     (while (< y y1)        (if (and (>= x x1) (>= y y2))           (command "LINE" (list (- x ktmk) y) (list (+ x ktmk) y) "")        )        (if (and (>= y y2) (>= x x1))           (command "LINE" (list x (- y ktmk)) (list x (+ y ktmk)) "")        )       (setq y (+ y nhay))     )  (setq x (+ x nhay)))(command "REDRAW")); End of program 

 

và cả muốn vẽ tỷ lệ 500 gõ số 5, tỷ lệ 1000 gõ số 1 và 2000 gõ số 2 và lưu lại giá trị cho những lần sau.

http://www.cadviet.com/upfiles/3/104547_drawing.rar

104547_untitled_2.jpg104547_untitled2.jpg


<<

Filename: 290633_kh.lsp
Tác giả: ketxu
Bài viết gốc: 290676
Tên lệnh: t1 t2
giúp em làm cái lisp vẽ đoạn thẳng này với.

@Hoằn : cảm ơn e vì món quà ^^  

@OP : cái này chắc chỉ ứng dụng cho mỗi bạn hén. Ket quick lại lần nữa đây, lần này lười lấy luôn mấy hàm Acet. Cứ chọn được 2 thằng thì bạn lại Cách 1 phát nhé - Chọn mãi.    

 

(defun *get*(/ s a b l dxf)	
	(and (setq s (ssget '((0 . "LINE"))))		
		(setq l (mapcar '(lambda(x)(list (acet-dxf 10 x)(acet-dxf 11 x)))(mapcar 'entget...
>>

@Hoằn : cảm ơn e vì món quà ^^  

@OP : cái này chắc chỉ ứng dụng cho mỗi bạn hén. Ket quick lại lần nữa đây, lần này lười lấy luôn mấy hàm Acet. Cứ chọn được 2 thằng thì bạn lại Cách 1 phát nhé - Chọn mãi.    

 

(defun *get*(/ s a b l dxf)	
	(and (setq s (ssget '((0 . "LINE"))))		
		(setq l (mapcar '(lambda(x)(list (acet-dxf 10 x)(acet-dxf 11 x)))(mapcar 'entget (acet-ss-to-list s))))
	) 
	l
)
(defun eL(a b)(entmake (list (cons 0 "LINE")(cons 10 a)(cons 11 b)(cons 8 "002-Leichtbau"))))
(defun c:t1(/ mid l)	
	(while (setq l(*get*)) (eL (apply 'acet-geom-midpoint  (car l)) (apply 'acet-geom-midpoint  (last l))))	
)
(defun c:t2(/ l rs)
	(defun rs(l)(cond ((<= (apply 'angle l) pi) l)((reverse l))))
	(while (setq l(*get*))(mapcar '(lambda(x y)(eL x y))  (car (setq l (mapcar 'rs l))) (last l)))		
)

 

@Tot77 : bạn đã entmake rồi thì đặt osnap chi ta ^^ Với lại k có nhu cầu bắt lại đối tượng thì dùng entmakex có phí quá k ? Thanked defun parallel :x


<<

Filename: 290676_t1_t2.lsp
Tác giả: Tot77
Bài viết gốc: 290621
Tên lệnh: t1 t2
giúp em làm cái lisp vẽ đoạn thẳng này với.

Bác Ketxu chắc bận rồi, thôi dùng tạm cái này, lệnh t1, t2.

(defun dxf (id v)  (cdr (assoc id (entget v))))
  
(defun c:t1(/ os kotieptuc ss)
  (defun kieu1(l) (entmakex (list '(0 . "LINE") (cons 10 (car l)) (cons 11 (last l)) (cons 8 "002-Leichtbau"))))
  (defun midp(d1 d2) (polar d1 (angle d1 d2) (* 0.5 (distance d1 d2))))
  
  (setq os (getvar 'osmode) kotieptuc nil)
 ...
>>

Bác Ketxu chắc bận rồi, thôi dùng tạm cái này, lệnh t1, t2.

(defun dxf (id v)  (cdr (assoc id (entget v))))
  
(defun c:t1(/ os kotieptuc ss)
  (defun kieu1(l) (entmakex (list '(0 . "LINE") (cons 10 (car l)) (cons 11 (last l)) (cons 8 "002-Leichtbau"))))
  (defun midp(d1 d2) (polar d1 (angle d1 d2) (* 0.5 (distance d1 d2))))
  
  (setq os (getvar 'osmode) kotieptuc nil)
  (setvar 'osmode 0)
  
  (while (not kotieptuc)
    (princ "\nChon 2 doan thang song song:")
    (setq ss (ssget '((0 . "LINE"))))
    (if (not ss)
      (setq kotieptuc t)
      (progn
 (setq kotieptuc nil)
    (kieu1 (mapcar '(lambda(x) (midp (dxf 10 x) (dxf 11 x))) (acet-ss-to-list ss))))
  ))
  (setvar 'osmode os) (princ)
)
  
(defun c:t2(/ os kotieptuc ss)
  (defun kieu2(l)    
     (entmakex (list '(0 . "LINE") (cons 10 (caar l)) (cons 11 (caadr l)) (cons 8 "002-Leichtbau")))
     (entmakex (list '(0 . "LINE") (cons 10 (cadar l)) (cons 11 (cadadr l)) (cons 8 "002-Leichtbau"))))
  
  (defun parallel(l)
    (if (equal (angle (caar l) (caadr l)) (angle (cadar l) (cadadr l)) 0.001)
      l (parallel (list (car l) (reverse (cadr l)))))
  )
  
  (setq os (getvar 'osmode) kotieptuc nil)
  (setvar 'osmode 0)
  
  (while (not kotieptuc)
    (princ "\nChon 2 doan thang song song:")
    (setq ss (ssget '((0 . "LINE"))))
    (if (not ss)
      (setq kotieptuc t)
      (progn
 (setq kotieptuc nil)
    (kieu2 (parallel (mapcar '(lambda(x) (list (dxf 10 x) (dxf 11 x))) (acet-ss-to-list ss)))))
  ))
  (setvar 'osmode os) (princ)
)
 


<<

Filename: 290621_t1_t2.lsp
Tác giả: Tot77
Bài viết gốc: 290675
Tên lệnh: mat
lisp chuyển màu các thuộc tính dynamic block

Cái này là 2 trong 1, bạn chọn 1 tag, chọn màu xong quét chọn toàn bộ , cái nào có tag giống cái kia thì đổi màu. Tên lệnh mat.

 

(defun C:mat()
  (defun dxf(id v) (cdr (assoc id (entget v))))
  (defun setColor(tag tval col v)
    (foreach item
      (vlax-safearray->list (vlax-variant-value
(vla-GetAttributes (vlax-ename->vla-object v))))
          (if...
>>

Cái này là 2 trong 1, bạn chọn 1 tag, chọn màu xong quét chọn toàn bộ , cái nào có tag giống cái kia thì đổi màu. Tên lệnh mat.

 

(defun C:mat()
  (defun dxf(id v) (cdr (assoc id (entget v))))
  (defun setColor(tag tval col v)
    (foreach item
      (vlax-safearray->list (vlax-variant-value
(vla-GetAttributes (vlax-ename->vla-object v))))
          (if (and (= tag (vla-get-TagString item)) (= tval (vla-get-TextString item)))
    (vla-put-Color item col)))
  )
  
  (setq a (car (nentsel "\nChon Attribute:"))
col (acad_colordlg (dxf 62 a))
        kt (dxf 1 a)
tag (dxf 2 a))
  
  (setColor tag kt col (dxf 330 a))
  (mapcar '(lambda(x) (setColor tag kt col x))
 (acet-ss-to-list (ssget (list  '(0 . "INSERT") '(2 . "att_ten dam") (cons 66 1)))))
  (princ)
)

 

Còn việc sửa lisp cùa Lee Mac, nhất là phần giao diện thì chắc hơi mệt, và tôi nghĩ làm vậy thì chỉ có tác dụng về mặt hình thức thôi, tôi nghĩ không cần thiết, cái mình cần là kết quả có ok không thôi.


<<

Filename: 290675_mat.lsp
Tác giả: Tot77
Bài viết gốc: 290702
Tên lệnh: mat1 mat2
[Xin] lisp chuyển màu các thuộc tính dynamic block

Cái danh cao thủ hay thấp thủ thì mình không dám nhận. Viết lisp cho vui thôi, nhân tiện có nhiều cái mới để học.

Bạn nói ngắn gọn thì tôi hiểu, nói càng dài thì tôi càng không hiểu.

Tóm lại ý bạn là có 2 cái lệnh:

1. Đổi màu những tiết diện giống nhau.

2. Đổi cả màu và text của tiết diện theo mẫu.

Thật ra 2 cái cũng gần giống nhau, bạn xài cái dưới đây,...

>>

Cái danh cao thủ hay thấp thủ thì mình không dám nhận. Viết lisp cho vui thôi, nhân tiện có nhiều cái mới để học.

Bạn nói ngắn gọn thì tôi hiểu, nói càng dài thì tôi càng không hiểu.

Tóm lại ý bạn là có 2 cái lệnh:

1. Đổi màu những tiết diện giống nhau.

2. Đổi cả màu và text của tiết diện theo mẫu.

Thật ra 2 cái cũng gần giống nhau, bạn xài cái dưới đây, lệnh mat1 và mat2.

 

(defun dxf(id v) (cdr (assoc id (entget v))))
(defun setColor(tag tval col v kieu)
    (foreach item
      (vlax-safearray->list (vlax-variant-value
(vla-GetAttributes (vlax-ename->vla-object v))))          
          (cond ((and (not kieu) (= tag (vla-get-TagString item)) (= tval (vla-get-TextString item)))
        (vla-put-Color item col))
((and kieu (= tag (vla-get-TagString item)))
        (vla-put-Color item col)
(vla-put-TextString item tval))
   ))
)
 
(defun C:mat1()  
  (setq a   (car (nentsel "\nChon Attribute:"))
col (acad_colordlg (dxf 62 a))
        kt  (dxf 1 a)
tag (dxf 2 a))  
  (setColor tag kt col (dxf 330 a) nil)
  (mapcar '(lambda(x) (setColor tag kt col x nil))
 (acet-ss-to-list (ssget (list  '(0 . "INSERT") '(2 . "att_ten dam") (cons 66 1)))))
  (princ)
)
 
(defun C:mat2()  
  (setq a   (car (nentsel "\nChon Attribute:"))
col (dxf 62 a)
        kt  (dxf 1 a)
tag (dxf 2 a))  
  (mapcar '(lambda(x) (setColor tag kt col x t))
    (acet-ss-to-list (ssget (list  '(0 . "INSERT") '(2 . "att_ten dam") (cons 66 1)))))
  (princ)
)
 


<<

Filename: 290702_mat1_mat2.lsp
Tác giả: ndtnv
Bài viết gốc: 66597
Tên lệnh: tuyen
Viết Lisp theo yêu cầu

Bạn thử lisp này, nếu có trường hợp nào chưa đúng yêu cầu thì
- Post bản vẽ các trường hợp đó
- Chú thích phần sai khác của lisp so với yêu cầu
- Dùng font unicode để chú thích hoặc post font của style TieuDe


Filename: 66597_tuyen.lsp
Tác giả: proconeng86
Bài viết gốc: 290705
Tên lệnh: mat1 mat2
lisp chuyển màu các thuộc tính dynamic block

Cái danh cao thủ hay thấp thủ thì mình không dám nhận. Viết lisp cho vui thôi, nhân tiện có nhiều cái mới để học.

Bạn nói ngắn gọn thì tôi hiểu, nói càng dài thì tôi càng không hiểu.

Tóm lại ý bạn là có 2 cái lệnh:

1. Đổi màu những tiết diện giống nhau.

2. Đổi cả màu và text của tiết diện theo mẫu.

Thật ra 2 cái cũng gần giống nhau, bạn xài cái dưới...

>>

Cái danh cao thủ hay thấp thủ thì mình không dám nhận. Viết lisp cho vui thôi, nhân tiện có nhiều cái mới để học.

Bạn nói ngắn gọn thì tôi hiểu, nói càng dài thì tôi càng không hiểu.

Tóm lại ý bạn là có 2 cái lệnh:

1. Đổi màu những tiết diện giống nhau.

2. Đổi cả màu và text của tiết diện theo mẫu.

Thật ra 2 cái cũng gần giống nhau, bạn xài cái dưới đây, lệnh mat1 và mat2.

 

(defun dxf(id v) (cdr (assoc id (entget v))))
(defun setColor(tag tval col v kieu)
    (foreach item
      (vlax-safearray->list (vlax-variant-value
(vla-GetAttributes (vlax-ename->vla-object v))))          
          (cond ((and (not kieu) (= tag (vla-get-TagString item)) (= tval (vla-get-TextString item)))
        (vla-put-Color item col))
((and kieu (= tag (vla-get-TagString item)))
        (vla-put-Color item col)
(vla-put-TextString item tval))
   ))
)
 
(defun C:mat1()  
  (setq a   (car (nentsel "\nChon Attribute:"))
col (acad_colordlg (dxf 62 a))
        kt  (dxf 1 a)
tag (dxf 2 a))  
  (setColor tag kt col (dxf 330 a) nil)
  (mapcar '(lambda(x) (setColor tag kt col x nil))
 (acet-ss-to-list (ssget (list  '(0 . "INSERT") '(2 . "att_ten dam") (cons 66 1)))))
  (princ)
)
 
(defun C:mat2()  
  (setq a   (car (nentsel "\nChon Attribute:"))
col (dxf 62 a)
        kt  (dxf 1 a)
tag (dxf 2 a))  
  (mapcar '(lambda(x) (setColor tag kt col x t))
    (acet-ss-to-list (ssget (list  '(0 . "INSERT") '(2 . "att_ten dam") (cons 66 1)))))
  (princ)
)
 

 

 

 

Bạn Tot77 xem lại cho mình lệnh mat1 được không, block của mình khi chuyển sang loại "leader" thì không chọn để đổi được nữa

Ngoài ra mình muốn áp dụng với các dynamic block khác nhưng không được. ví dụ mình có block ghi chú thép (file đính kèm) mình cũng muốn làm là đường kính giông nhau thì màu giống nhau, khoảng cách thép giống nhau thì mầu giống nhau nhưng lisp trên không dùng được.

bạn xem lại hộ mình cái nhé

http://www.cadviet.com/upfiles/3/9928_dynamic_block_3.dwg


<<

Filename: 290705_mat1_mat2.lsp
Tác giả: Trà Đá
Bài viết gốc: 271653
Tên lệnh: ttt
Lisp rải đối tượng theo đơờng dẩn.

Em có lisp sau rải chấm hatch tròn tại các điểm endpoint của đối tượng. Bây giờ em muốn cải tiến lisp trên 1 chút là cho phép chọn 1 text đi kèm và cũng rải tăng dần tại endpoint theo bước +1. Nhờ các bác giúp đỡ ạ:
 

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

Em có lisp sau rải chấm hatch tròn tại các điểm endpoint của đối tượng. Bây giờ em muốn cải tiến lisp trên 1 chút là cho phép chọn 1 text đi kèm và cũng rải tăng dần tại endpoint theo bước +1. Nhờ các bác giúp đỡ ạ:
 

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/73545-nho-cac-bac-sua-lisp-copy-doi-tuong-toi-nhieu-duong-polyline-cho-truoc/
(vl-load-com)
(defun GetVer (e / i L)

(setq i 0 L nil)

(repeat (fix (+ (vlax-curve-getEndParam e) 1))

(setq L (append L (list (vlax-curve-getPointAtParam e i))))

(setq i (1+ i))

)

L

)

(defun C:ttt(/ ss_rai pt_rai ss n e lstPt x)

(princ "\nChon doi tuong muon rai")

(setq ss_rai (ssget))

(setq pt_rai (getpoint "\nChon diem chen"))

(princ "\nChon doi tuong duong dan")

(setq ss (ssget (list (cons 0 "*POLYLINE"))))

(repeat (setq n (sslength ss))

(setq e (ssname ss (setq n (1- n))))

(setq lstPt (GetVer e))

(foreach x lstPt (command "copy" ss_rai "" pt_rai x))

)

(princ)

)


<<

Filename: 271653_ttt.lsp
Tác giả: hoanghaile86
Bài viết gốc: 291208
Tên lệnh: dt
lips tính diện tích

Em có 1 lips như sau:

(defun DXF (code elist)
  (cdr (assoc code elist))
);dxf

(defun c:dt(/ dtl dtcon pt1 pt2 ss et oslast vsize)
  (if (= tl nil) (progn
    (setq tl (getreal "\n Ti le ban ve (don vi ban ve la m thi nhap ti le la 1000): "))
;    (setq ntl (/ 1000 tl))
;    (setq tl2 (* ntl ntl))
    )
  )
  (setq dtl 0)
  (setq ss (ssadd))
  (setq oslast (getvar "OSMODE"))
  (command "osnap" "")
   (setq ntl (/ 1000 tl))
   (setq tl2 (* ntl...
>>

Em có 1 lips như sau:

(defun DXF (code elist)
  (cdr (assoc code elist))
);dxf

(defun c:dt(/ dtl dtcon pt1 pt2 ss et oslast vsize)
  (if (= tl nil) (progn
    (setq tl (getreal "\n Ti le ban ve (don vi ban ve la m thi nhap ti le la 1000): "))
;    (setq ntl (/ 1000 tl))
;    (setq tl2 (* ntl ntl))
    )
  )
  (setq dtl 0)
  (setq ss (ssadd))
  (setq oslast (getvar "OSMODE"))
  (command "osnap" "")
   (setq ntl (/ 1000 tl))
   (setq tl2 (* ntl ntl))

  (print)
  (print)
  (setq pt1 (getpoint "\nchon diem bat ki trong hinh: "))
  (while (/= pt1 nil)
    (command "-boundary" pt1 "")
    (setq et (entlast))
    (ssadd et ss)
    (command "area" "e" "last")
    (setq vsize ( /(getvar "VIEWSIZE") 5))
    (command "hatch" "ANSI31" vsize "0" "last" "")
    (setq et (entlast))
    (ssadd et ss)
    (setq dtcon (/ (getvar "AREA") tl2))
    (setq dtl (+ dtcon dtl))
    (prompt (strcat "\ntong dien tich hinh ban chon : " (rtos dtcon 2 2)))
    (print)
    (print)
    (setq pt1 (getpoint "\nChon tiep hinh nao nua khong?: "))
  )
  (command "setvar" "OSMODE" oslast)
  (command "erase" ss "")
  (setq ss nil)
  (command "redraw")
;  (setq dtl (/ (/ dtl tl2) 2)) 
;  (setq dtl (/ dtl 2)) 
  (print)
  (prompt (strcat "\ntong dien tich cac hinh ban da chon : " (rtos dtl 2 2)))
  (print)
  (setq pt2 (getpoint "\nDiem dat dien tich: "))
  (if (/= 0 (DXF 40 (tblsearch "STYLE" (getvar "TEXTSTYLE"))))
    (command "text" pt2  "0" (rtos dtl 2 2))
    (command "text" pt2 "0.4" "0" (rtos dtl 2 2))
  );if
  (princ)
);defun dt
;------------------------------------------------------------------------

kết quả đo diện tích chỉ có 2 số lẽ. E muốn kết quả là 3 số lẽ thì phải sữa lips như thế nào. em cảm ơn nhìu

http://www.cadviet.com/upfiles/3/130827_dien_tich.lsp


<<

Filename: 291208_dt.lsp

Trang 156/330

156