Jump to content
InfoFile
Tác giả: Doan Van Ha
Bài viết gốc: 406122
Tên lệnh: mul sum
Nhờ Chỉnh Sửa Lisp Cộng Giá Trị Text Của Vật Tư Ngành Nước

Sửa giùm cho bạn nè!

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/165286-nho-chinh-sua-lisp-cong-gia-tri-text-cua-vat-tu-nganh-nuoc/
 (defun CheckObj(e MyType) (equal (cdr (assoc 0 (entget e))) MyType))
;;;-----------------------------------------
(defun FilObj (ss1 MyType / ss2 i e)
(setq ss2 (ssadd)
i 0
)
(repeat (sslength ss1)
(setq e (ssname ss1 i)
i (1+ i)
)
(if...
>>

Sửa giùm cho bạn nè!

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/165286-nho-chinh-sua-lisp-cong-gia-tri-text-cua-vat-tu-nganh-nuoc/
 (defun CheckObj(e MyType) (equal (cdr (assoc 0 (entget e))) MyType))
;;;-----------------------------------------
(defun FilObj (ss1 MyType / ss2 i e)
(setq ss2 (ssadd)
i 0
)
(repeat (sslength ss1)
(setq e (ssname ss1 i)
i (1+ i)
)
(if (CheckObj e MyType)
(ssadd e ss2)
)
)
(eval ss2)
)
;;;-----------------------------------------
(defun SelData (/ OK)
(setq OK nil)
(while (not OK)
(prompt "\tChon cac text can tinh:")
(setq ss (FilObj (ssget) "TEXT"))
(if (> (sslength ss) 0)
(setq OK T)
(princ "\nDoi tuong chon khong phai text")
)
)
)
;;;-----------------------------------------
(defun WriteRes (kq / OK e data)
(setq OK nil)
(while (not OK)
(setq e (car (entsel "\tChon text ghi ket qua:")))
(if (CheckObj e "TEXT")
(setq OK T)
(princ "\nDoi tuong chon khong phai text")
)
)
(entmod (subst (cons 1 kq) (assoc 1 (setq data (entget e)))  data))
(princ)
)
 
(defun getchar(s)
(vl-list->string (vl-remove-if '(lambda(x) (<= 48 x 57)) (vl-string->list s)))
)
;;;-----------------------------------------
(defun C:MUL (/ i m e ss vt chu dv)
(SelData)
(setq i 0
m 1.0
)
(repeat (sslength ss)
(setq e (ssname ss i)
i (1+ i))
(if (setq vt (vl-string-search "- L" (strcae (setq chu (cdr (assoc 1 (entget e)))))))
(setq m (* m (atof (substr chu (+ 4 vt)))))
)
(setq dv (getchar (substr chu (+ 4 vt))))
)
(WriteRes (strcat (rtos m) dv))
)
;;;-----------------------------------------
(defun C:SUM (/ i s e ss chu vt dv)
(SelData)
(setq i 0
s 0.0
)
(repeat (sslength ss)
(setq e (ssname ss i)
i (1+ i))
(if (setq vt (vl-string-search "- L" (strcase (setq chu (cdr (assoc 1 (entget e)))))))
(setq s (+ s (atof (substr chu (+ 4 vt)))))
)
(setq dv (getchar (substr chu (+ 4 vt))))
)
(WriteRes (strcat (rtos s) dv))
)

<<

Filename: 406122_mul_sum.lsp
Tác giả: united
Bài viết gốc: 373739
Tên lệnh: n1 n2
Sửa Lisp Lock Layer Cho Cad 2015.

 

Dạ đã ngon ạ! Bác nhiệt tình quá ạ.

Có lẽ hơi tham nhưng bác cho em nhờ luôn ạ: Nhờ bác gộp cho em 2 lisp nối line, pline... sau đây thành 1 với ạ.

Cụ thể là như này: khi có đối tượng là line, arc thì CONVERT rồi JOIN, còn khi chỉ toàn polyline thì JOIN luôn ạ. Tại CAD...

>>

 

Dạ đã ngon ạ! Bác nhiệt tình quá ạ.

Có lẽ hơi tham nhưng bác cho em nhờ luôn ạ: Nhờ bác gộp cho em 2 lisp nối line, pline... sau đây thành 1 với ạ.

Cụ thể là như này: khi có đối tượng là line, arc thì CONVERT rồi JOIN, còn khi chỉ toàn polyline thì JOIN luôn ạ. Tại CAD đời thấp thì chỉ cần dùng thằng "N1" cho cả line, polyline... nhưng CAD2015 thì nối 2 polyline lại phải dùng lisp N2.Rất là bất tiện khi dùng cùng lúc 2 loại CAD.

(defun c:N1(/ ss)
 (vl-load-com)
 (if (setq ss (ssget '((0 . "*line,arc"))))
 (vl-cmdf ".pedit" "m" ss "" "y" "j" "0" ""))
 (princ))

(defun c:N2(/ ss)
(vl-load-com)
(if (setq ss (ssget '((0 . "*line,arc"))))
(vl-cmdf ".pedit" "m" ss "" "j" "0" ""))
(princ))

<<

Filename: 373739_n1_n2.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 407322
Tên lệnh: tt
lisp xoay text theo pline
Viết lại cho bạn:
(defun c:tt (/ FixTextAngle a ang els ent h mid p pte pts spt txt)
(defun FixTextAngle (ang)
(if (and (> ang (* 0.5 pi)) (<= ang (* 1.5 pi)))
(+ ang pi)
ang))
(while (and (setq txt (car (entsel "\nPick Text")))
(wcmatch (cdr (assoc 0 (entget txt))) "TEXT")
(setq ent (entsel "\nPick LINE, PLINE: "))
(setq els (entget (car ent)))
(wcmatch (cdr (assoc 0 els)) "*LINE"))
(setq spt (osnap (cadr ent) "NEA")
mid (osnap (cadr ent)...
>>
Viết lại cho bạn:
(defun c:tt (/ FixTextAngle a ang els ent h mid p pte pts spt txt)
(defun FixTextAngle (ang)
(if (and (> ang (* 0.5 pi)) (<= ang (* 1.5 pi)))
(+ ang pi)
ang))
(while (and (setq txt (car (entsel "\nPick Text")))
(wcmatch (cdr (assoc 0 (entget txt))) "TEXT")
(setq ent (entsel "\nPick LINE, PLINE: "))
(setq els (entget (car ent)))
(wcmatch (cdr (assoc 0 els)) "*LINE"))
(setq spt (osnap (cadr ent) "NEA")
mid (osnap (cadr ent) "MID"))
(if (< (car mid) (car spt))
(setq pts mid
pte spt)
(setq pts spt
pte mid))
(setq ang (FixTextAngle (angle pts pte))
els (entget txt))
(setq h (cdr (assoc 40 els))
p (cons 10 (polar spt (+ ang (* 0.5 pi)) (* 0.5 h)))
a (cons 50 ang))
(setq els (subst a (assoc 50 els) els))
(entmod (subst p (assoc 10 els) els)))
(princ))
P/s: Chọn Text trước, Line or Pline sau:
<<

Filename: 407322_tt.lsp
Tác giả: bienda
Bài viết gốc: 407173
Tên lệnh: blockinfo
Lisp Lấy Tọa Độ X,y Của Block (Xref)

Các bác sửa hộ em code này theo yêu cầu bên trên của em với ạ

(defun c:blockinfo ( / e f i s )
    (if 
        (and
            (setq s (ssget "_X" '((0 . "INSERT") (410 . "Model"))))
            (setq f (getfiled "Create CSV File" "" "csv" 1))
            (setq f (open f "w"))
        )
 ...
>>

Các bác sửa hộ em code này theo yêu cầu bên trên của em với ạ

(defun c:blockinfo ( / e f i s )
    (if 
        (and
            (setq s (ssget "_X" '((0 . "INSERT") (410 . "Model"))))
            (setq f (getfiled "Create CSV File" "" "csv" 1))
            (setq f (open f "w"))
        )
        (progn
            (repeat (setq i (sslength s))
                (setq e (entget (ssname s (setq i (1- i)))))
                (write-line
                    (apply 'strcat
                        (cons (LM:name->effectivename (cdr (assoc 2 e)))
                            (mapcar '(lambda ( x ) (strcat "," (rtos x)))
                                (cdr (assoc 10 e))
                            )
                        )
                    )
                    f
                )
            )
            (close f)
        )
    )
    (princ)
)




(defun LM:name->effectivename ( blk / rep )
    (if
        (and (wcmatch blk "`**")
            (setq rep
                (cdadr
                    (assoc -3
                        (entget
                            (cdr (assoc 330 (entget (tblobjname "block" blk))))
                           '("AcDbBlockRepBTag")
                        )
                    )
                )
            )
            (setq rep (handent (cdr (assoc 1005 rep))))
        )
        (cdr (assoc 2 (entget rep)))
        blk
    )
)


(princ)

<<

Filename: 407173_blockinfo.lsp
Tác giả: hainguyen2014
Bài viết gốc: 407421
Tên lệnh: dcc
Nhờ Viết Lisp Copy Text

Code cho bạn. Hy vong là đúng yêu cầu. he he

 

(defun c:dcc (/ sl s1 s2)
(setvar "cmdecho" 0)
(setq s1 (entget (car (entsel "\nChon text goc:"))))
(princ "\nChon cac Text can thay doi.")
(setq s2 (ssget '((0 . "TEXT,MTEXT"))))
(setq sl (sslength s2))
(setq dem 0)
(while (< dem sl)
(setq nds2 (entget (ssname s2 dem)))
(setq text (cdr (assoc 1 s1)))
(setq thaythe (subst (cons 1 text) (assoc 1 nds2) nds2))
(entmod...

>>

Code cho bạn. Hy vong là đúng yêu cầu. he he

 

(defun c:dcc (/ sl s1 s2)
(setvar "cmdecho" 0)
(setq s1 (entget (car (entsel "\nChon text goc:"))))
(princ "\nChon cac Text can thay doi.")
(setq s2 (ssget '((0 . "TEXT,MTEXT"))))
(setq sl (sslength s2))
(setq dem 0)
(while (< dem sl)
(setq nds2 (entget (ssname s2 dem)))
(setq text (cdr (assoc 1 s1)))
(setq thaythe (subst (cons 1 text) (assoc 1 nds2) nds2))
(entmod thaythe)
(setq dem (1+ dem))
)
)


<<

Filename: 407421_dcc.lsp
Tác giả: Han Tinh
Bài viết gốc: 407189
Tên lệnh: mtl
Lisp tạo viewport từ khung chọn bên model.
Với vấn đề này mình nhờ bạn KangKung chỉnh giúp mình sao cho:
khung tên bên layout luôn ở tỉ lệ 1:1(dùng khung tên xref), còn khung bên model thì có các tỉ lệ khác nhau như:
1:10, 1:15, 1:20, ... Khi ta dùng lệnh lsp thì tất cả các khung bản vẽ bên model sẽ nằm gọn...
>>
Với vấn đề này mình nhờ bạn KangKung chỉnh giúp mình sao cho:
khung tên bên layout luôn ở tỉ lệ 1:1(dùng khung tên xref), còn khung bên model thì có các tỉ lệ khác nhau như:
1:10, 1:15, 1:20, ... Khi ta dùng lệnh lsp thì tất cả các khung bản vẽ bên model sẽ nằm gọn trong khung tên layout đúng tỉ lệ 1:1
(hiện tại khi xuất qua layout thì có rất nhiều tỉ lệ
Chọn khung view bên model trước thì nó xuất qua bên layout trước
Mong bạn sửa giúp
========LISP TAO VIEWPORT TREN LAYOUT BANG CACH CHON O MODEL========
;============================REV5====================================
;=========THEM LUA CHON XOAY HCN NGHIENG VA XREF KHUNG TEN===========
(defun C:mtl( / os lst khung pt0 pt1 pt2 pt3 Y index taphop xrefFile xref)
  (command "UNDO" "BE")
  (setq os(getvar "OSMODE"))
  (setvar "OSMODE" 0) 
  (setq taphop(ssget (LIST (CONS 0 "POLYLINE,LWPOLYLINE"))))
  (if (= Tyle nil)
    (setq Tyle1 1)
    (setq Tyle1 Tyle))
  (setq Tyle (getreal (strcat "\n Ty le: <" (rtos Tyle1 2 0) "> ")))
  (if (= Tyle nil)
    (setq Tyle Tyle1))
  (setq xref(getstring "\n Ban co muon chen file khung ten hay khong? <Y/N>:"))
  (if (= (strcase xref) "Y")
    (progn
      (if (not Path)
	(setq Path(getvar "dwgprefix")))
      (setq xrefFile(getfiled "Chon File khung ten" Path "dwg" 2))
      (setq Path xrefFile)))
  (setq soluong (sslength taphop))
  (setq index 0)
  (command "LAYOUT" "N" "Layout1")
  (command "LAYOUT" "S" "Layout1")
  (command "ERASE" "ALL" "")
  (command "ZOOM" "E")
  (command "MODEL")
  (setq Y 0)
  (command "ZOOM" "E")
  (while (< index soluong)
    (setq khung(ssname taphop index))
    (setq lst(acet-geom-vertex-list khung))
    (setq lst (vl-sort lst '(lambda (e1 e2) (if (/= (car e1) (car e2)) (< (car e1) (car e2)) (< (cadr e1) (cadr e2))))))
    (setq pt0(nth 0 lst) pt3(nth 3 lst))
    (if (> (cadr (nth 1 lst)) (cadr (nth 2 lst)))
      (setq pt1(nth 1 lst) pt2(nth 2 lst))
      (setq pt1(nth 2 lst) pt2(nth 1 lst))
      )
    (command "LAYOUT" "S" "Layout1")
    (if (> (distance pt2 pt0) (distance pt1 pt0))
      (command "RECTANG" (list 0 Y) (list (distance pt2 pt0) (+ Y (distance pt1 pt0))))
      (command "RECTANG" (list 0 Y) (list (distance pt1 pt0) (+ y (distance pt2 pt0))))
      )
    (command "SCALE" (entlast) "" (list 0 Y) (/ 1 tyle))
    (command "MVIEW" "O" (entlast))
    (if (= (strcase xref) "Y")
      (command "xref" "A" xrefFile (list 0 Y) "" "" ""))
    (command "MSPACE")
    (if (> (distance pt2 pt0) (distance pt1 pt0))
      (command "DVIEW" khung "" "TW" (- 90 (* (/ (angle pt0 pt1) pi) 180)) "")
      (command "DVIEW" khung "" "TW" (- 0 (* (/ (angle pt0 pt1) pi) 180)) "")
      )
    (command "ZOOM" "W" pt0 pt3)
    (command "PSPACE")
    (command "TEXT" "J" "MR" (list -50 (+ Y (/ (distance pt1 pt0) (* 2 tyle)))) (* 25 tyle) "0" (strcat "VP " (rtos (1+ index) 2 0)) "")
    (if (> (distance pt2 pt0) (distance pt1 pt0))
      (setq Y(- Y 50 (/ (distance pt1 pt0) tyle)))
      (setq Y(- Y 50 (/ (distance pt2 pt0) tyle)))
      )
    (command "ZOOM" "W" (list -100 (+ Y (distance pt3 pt0))) (list (distance pt3 pt0) (- Y 50 (distance pt3 pt0))))
    (setq index (+ index 1))
    )
  (command "ZOOM" "E")
  (command "MODEL")
  (command "UNDO" "END")
  (setvar "OSMODE" os)
  (princ)
  )

<<

Filename: 407189_mtl.lsp
Tác giả: hainguyen2014
Bài viết gốc: 407430
Tên lệnh: gg
Xin Trợ Giúp Về Lisp Ghi Độ Dài Đường Thẳng Ra Block Att

Tôi mạn phép sửa code của bác Trịnh Công Sơn cho bạn vuonghung108 nhé! 

 

;;;------------------------------

;;;-----by MENZI ENGINEERING ----

(defun SetAtt (obj lst / attval)

(mapcar '(lambda (att)

(if (setq attval (cdr (assoc (vla-get-TagString att) lst)))

(vla-put-TextString att attval)

)

)

(vlax-invoke obj 'GetAttributes)

)

(vla-update...

>>

Tôi mạn phép sửa code của bác Trịnh Công Sơn cho bạn vuonghung108 nhé! 

 

;;;------------------------------

;;;-----by MENZI ENGINEERING ----

(defun SetAtt (obj lst / attval)

(mapcar '(lambda (att)

(if (setq attval (cdr (assoc (vla-get-TagString att) lst)))

(vla-put-TextString att attval)

)

)

(vlax-invoke obj 'GetAttributes)

)

(vla-update obj)

)

;;;------------------------------

(defun TS:select (/ ent)

(while

(progn

(setvar 'errno 0)

(setq ent (entsel "\nCh\U+1ECDn Line,Pline,SPline \U+0111\U+1EC3 l\U+1EA5y chi\U+1EC1u d\U+00E0i :"))

(cond

((= 7 (getvar 'errno))

(princ "\nCh\U+1ECDn l\U+1ED7i.Vui l\U+00F2ng l\U+1EA1i.")

)

((= 'ename (type (car ent)))

(if (wcmatch (cdr (assoc 0 (entget (car ent))))

"*LINE"

)

(progn (setq ent (car ent))

nil

)

(princ

"\n\U+0110\U+1ED1i t\U+01B0\U+1EE3ng ch\U+1ECDn kh\U+00F4ng ph\U+1EA3i LINE,PLINE,SPLINE."

)

)

)

)

)

)

ent

)

;;;-------------------------------

(defun GetLen (ent / len)

(setq len (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent)))

)

;;;-------------------------------

(defun GetDxf (n elist) (cdr (assoc n elist)))

;;;-------------------------------

(defun c:GG (/ *error* blkatt ent len)

(vl-load-com)

(setvar "Modemacro" "@ Tr\U+1EA7n C\U+00F4ng S\U+01A1n _ XDDD & CN")

(defun *error* (msg)

(if ent

(redraw ent 4)

)

(if (not (wcmatch (strcase msg) "*BREAK,*EXIT*,*CANCEL*"))

(princ (strcat "\n** Error: " msg " **"))

)

(princ)

)

(while (setq ent (TS:select))

(redraw ent 3)

(setq Len (rtos (GetLen ent) 2 2))

(if (and (setq BlkATT (car (entsel "\nChon Block ATT:")))

(wcmatch (GetDxf 0 (entget BlkATT)) "INSERT")

(= (GetDxf 66 (entget BlkATT)) 1)

)

(SetAtt (vlax-ename->Vla-Object BlkATT) (list (cons "CHIEUDAI" Len)))

(alert

"\n\U+0110\U+1ED1i t\U+01B0\U+1EE3ng ch\U+1ECDn kh\U+00F4ng ph\U+1EA3i Block ATTribute."

)

)

(redraw ent 4)

)

(princ)

)

 

Tôi mặc định 2 số thập phân. Bạn có thể thay đổi tùy ý trong hàm (rtos (GetLen ent) 2 2) ở trên.

VD: Muốn kết quả la 3 sô thập phân thì sửa nó lại thành (rtos (GetLen ent) 2 3)


<<

Filename: 407430_gg.lsp
Tác giả: dntpi92
Bài viết gốc: 407582
Tên lệnh: c1
Nhờ Cao Thủ Giúp Em Chỉnh Sửa Lisp Vẽ Đường Tâm Hình Tròn.

(defun c:c1 ( / _line ss e c r l1 l2 )
(if
(and
(setq ss
(ssget
(list '(0 . "CIRCLE") '(-4 . " )
)
(vlr-object-reactor (mapcar 'vlax-ename->vla-object (list l1 l2)) (list cl:app h)
(list
(cons :vlr-modified 'cl:line:callback)
)
)
)
)
)
(princ)
)

;;------------------------------------------------------------;;
")>


Filename: 407582_c1.lsp
Tác giả: duy782006
Bài viết gốc: 407628
Tên lệnh: mtd
Nhờ Viết Lisp Vẽ Tên Chỉ Hướng Đường

Thử xem!

(defun duy:taobk_mtdcv ()
  (entmake '((0 . "BLOCK") (100 . "AcDbEntity") (67 . 0) (8 . "0") (100 . "AcDbBlockReference") (2 . "duy_tv_muitenduongcv") (10 0.0 0.0 0.0) (70 . 0)))
  (entmake '((0 . "LWPOLYLINE") (100 . "AcDbEntity") (67 . 0) (8 . "0") (100 . "AcDbPolyline") (90 . 4) (70 . 1) (43 . 0.0) (38 . 0.0) (39 . 0.0) (10 0.0 0.0) (40 . 0.0) (41 . 0.0) (42 . 0.0) (10 0.0 0.079048750845185) (40 . 0.0) (41 . 0.0) (42 . 0.0) (10 1.0...
>>

Thử xem!

(defun duy:taobk_mtdcv ()
  (entmake '((0 . "BLOCK") (100 . "AcDbEntity") (67 . 0) (8 . "0") (100 . "AcDbBlockReference") (2 . "duy_tv_muitenduongcv") (10 0.0 0.0 0.0) (70 . 0)))
  (entmake '((0 . "LWPOLYLINE") (100 . "AcDbEntity") (67 . 0) (8 . "0") (100 . "AcDbPolyline") (90 . 4) (70 . 1) (43 . 0.0) (38 . 0.0) (39 . 0.0) (10 0.0 0.0) (40 . 0.0) (41 . 0.0) (42 . 0.0) (10 0.0 0.079048750845185) (40 . 0.0) (41 . 0.0) (42 . 0.0) (10 1.0 0.079048750845185) (40 . 0.0) (41 . 0.0) (42 . 0.0) (10 1.0 0.0) (40 . 0.0) (41 . 0.0) (42 . 0.0)))
  (entmake '((0 . "LWPOLYLINE") (100 . "AcDbEntity") (67 . 0) (8 . "0") (100 . "AcDbPolyline") (90 . 4) (70 . 1) (43 . 0.0) (38 . 0.0) (39 . 0.0) (10 0.0 0.144923408667705) (40 . 0.0) (41 . 0.0) (42 . 0.0) (10 0.0 0.223972159512890) (40 . 0.0) (41 . 0.0) (42 . 0.0) (10 1.0 0.223972159512890) (40 . 0.0) (41 . 0.0) (42 . 0.0) (10 1.0 0.144923408667705) (40 . 0.0) (41 . 0.0) (42 . 0.0)))
  (entmake '((0 . "HATCH") (100 . "AcDbEntity") (8 . "0") (100 . "AcDbHatch") (10 0.0 0.0 0.0) (210 0.0 0.0 1.0) (2 . "SOLID") (70 . 1) (71 . 0) (91 . 1) (92 . 1) (93 . 7) (72 . 1) (10 1.0 0.474294301946547 0.0) (11 1.0 0.312761773046283 0.0) (72 . 1) (10 1.0 0.312761773046283 0.0) (11 0.0 0.312761773046283 0.0) (72 . 1) (10 0.0 0.312761773046283 0.0) (11 0.0 0.474294301946547 0.0) (72 . 1) (10 0.0 0.474294301946547 0.0) (11 -0.309210583527104 0.474294301946547 0.0) (72 . 1) (10 -0.309210583527104 0.474294301946547 0.0) (11 0.500000000000000 0.907304787768128 0.0) (72 . 1) (10 0.500000000000000 0.907304787768126 0.0) (11 1.309210583527104 0.474294301946545 0.0) (72 . 1) (10 1.309210583527104 0.474294301946547 0.0) (11 1.0 0.474294301946547 0.0) (97 . 0) (75 . 0) (76 . 1) (98 . 1) (10 21.99031319514620 -88.48062166520982 0.0) (450 . 0) (451 . 0) (460 . 0.0) (461 . 0.0) (452 . 1) (462 . 1.0) (453 . 2) (463 . 0.0) (63 . 5) (421 . 255) (463 . 1.0) (63 . 7) (421 . 16777215) (470 . "LINEAR")))
  (entmake '((0 . "LWPOLYLINE") (100 . "AcDbEntity") (67 . 0) (8 . "0") (100 . "AcDbPolyline") (90 . 8) (70 . 1) (43 . 0.0) (38 . 0.0) (39 . 0.0) (10 1.0 0.474294301946547) (40 . 0.0) (41 . 0.0) (42 . 0.0) (10 1.0 0.312761773046283) (40 . 0.0) (41 . 0.0) (42 . 0.0) (10 0.0 0.312761773046283) (40 . 0.0) (41 . 0.0) (42 . 0.0) (10 0.0 0.474294301946547) (40 . 0.0) (41 . 0.0) (42 . 0.0) (10 -0.309210583527104 0.474294301946547) (40 . 0.0) (41 . 0.0) (42 . 0.0) (10 0.500000000000000 0.907304787768126) (40 . 0.0) (41 . 0.0) (42 . 0.0) (10 0.500000000000000 0.907304787768126) (40 . 0.0) (41 . 0.0) (42 . 0.0) (10 1.309210583527104 0.474294301946547) (40 . 0.0) (41 . 0.0) (42 . 0.0)))
  (entmake '((0 . "ENDBLK") (100 . "AcDbBlockEnd") (8 . "0")))
  (princ)
) 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun duy:xd_diem<traiphai (diemchuan diemchuanm diemxd / diemchuan diemchuanm diemxd)
(cond
((> (* (- (car diemchuanm) (car diemchuan)) (- (cadr diemxd) (cadr diemchuan))) (* (- (cadr diemchuanm) (cadr diemchuan)) (- (car diemxd) (car diemchuan))) ) (setq kqtp "trai") )
((< (* (- (car diemchuanm) (car diemchuan)) (- (cadr diemxd) (cadr diemchuan))) (* (- (cadr diemchuanm) (cadr diemchuan)) (- (car diemxd) (car diemchuan))) ) (setq kqtp "phai") )
((= (* (- (car diemchuanm) (car diemchuan)) (- (cadr diemxd) (cadr diemchuan))) (* (- (cadr diemchuanm) (cadr diemchuan)) (- (car diemxd) (car diemchuan))) ) (setq kqtp "trung") )
)
kqtp)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:mtd ()
(command "undo" "be") 
(cond
((= nill (tblsearch "block" "duy_tv_muitenduongcv")) (duy:taobk_mtdcv) )
((/= nill (tblsearch "block" "duy_tv_muitenduongcv")) )
)

 (while  (setq diemchenmtdm (getpoint "\nDiem thu nhat. Hoac ENTER de ket thuc !"))
(setq diemchenmtdh (getpoint diemchenmtdm "\nDiem thu hai"))
 (command ".insert" "duy_tv_muitenduongcv" "_non" diemchenmtdm  (distance diemchenmtdm diemchenmtdh)  (distance diemchenmtdm diemchenmtdh) diemchenmtdh)

(setq diemchuanh (getpoint diemchenmtdm "\nHuong mui ten"))
(setq huongmtd (duy:xd_diem<traiphai diemchuanh diemchenmtdm  diemchenmtdh))
(cond
((= huongmtd "trai")   )
((= huongmtd "phai")   (command ".mirror" (entlast) "" "_non" diemchenmtdm "_non" diemchenmtdh "y"))
((= huongmtd "trung")   (command ".mirror" (entlast) "" "_non"diemchenmtdm "_non" diemchenmtdh "") (princ "\nDiem dinh huong trung voi duong thang nen ve hai huong luon nhe !") )
)

)
(command "undo" "end")
(princ)
)

<<

Filename: 407628_mtd.lsp
Tác giả: nguyentuyen6
Bài viết gốc: 113344
Tên lệnh: tt
Sửa hộ em code tính tổng lỗi này
thì vẫn cái líp lúc nãy bạn hỏi, chỉ sửa 1 tý.


Filename: 113344_tt.lsp
Tác giả: Bee
Bài viết gốc: 407730
Tên lệnh: test
Tạo 1 ứng dụng AutoCAD .NET với MS Visual C#
using Autodesk.AutoCAD.Geometry;
using Autodesk.AutoCAD.ApplicationServices;
using Autodesk.AutoCAD.DatabaseServices;
using Autodesk.AutoCAD.EditorInput;
using Autodesk.AutoCAD.Runtime;

namespace Gia_Bach
{
public class Cad_command
{
[CommandMethod("CadViet1")]
public static void...
>>
using Autodesk.AutoCAD.Geometry;
using Autodesk.AutoCAD.ApplicationServices;
using Autodesk.AutoCAD.DatabaseServices;
using Autodesk.AutoCAD.EditorInput;
using Autodesk.AutoCAD.Runtime;

namespace Gia_Bach
{
public class Cad_command
{
[CommandMethod("CadViet1")]
public static void ex1()
{
Autodesk.AutoCAD.ApplicationServices.Application.ShowAlertDialog("Chào mừng bạn đến với ứng dụng AutoCAD .NET API!");
}

[CommandMethod("CadViet2")]
public static void ex2()
{
Document doc = Autodesk.AutoCAD.ApplicationServices.Application.DocumentManager.MdiActiveDocume
nt;
Editor ed = doc.Editor;
Database db = doc.Database;

PromptPointResult Pr = ed.GetPoint("\nChọn điểm đặt Text : ");
Point3d pt = Pr.Value;

if (Pr.Status != PromptStatus.OK) return;

// Start a transaction
using (Transaction acTrans = db.TransactionManager.StartTransaction())
{
// Open the Block table for read
BlockTable acBlkTbl = acTrans.GetObject(db.BlockTableId, OpenMode.ForRead) as BlockTable;

// Open the Block table record Model space for write
BlockTableRecord acBlkTblRec
= acTrans.GetObject(acBlkTbl[BlockTableRecord.ModelSpace], OpenMode.ForWrite) as BlockTableRecord;

// Create a single-line text object
DBText acText = new DBText();
acText.SetDatabaseDefaults();
acText.Position = pt;
acText.Height = 0.5;
acText.TextString = "Chào mừng bạn đến với ứng dụng AutoCAD .NET API!";

acBlkTblRec.AppendEntity(acText);
acTrans.AddNewlyCreatedDBObject(acText, true);
// Save the changes and dispose of the transaction
acTrans.Commit();
}
}
}
}

Chào anh gia bach và mọi người.

Anh (hoặc bạn nào)có thể chuyển ngữ đoạn lisp này sang C# để em hiểu cách thức làm việc từ lisp sang C#. Xin cám ơn.

(defun c:test (/ ss n pt str h att old_os num)
  (setq old_os (getvar 'osmode))
  ;ssget and repeat
  (if (setq ss (ssget '((0 . "*TEXT"))))
    (progn
      (setq n 0)
      (repeat (sslength ss)

	(setvar 'osmode 0)
	
	(setq num (getreal "\Chon so: "));number
	
	(setq pt (cdr (assoc 10 (entget (ssname ss n)))))
	(setq str (cdr (assoc 1 (entget (ssname ss n)))))
	(setq h (cdr (assoc 40 (entget (ssname ss n)))))
	(mapcar 'print (list pt str h)); print
	
	;change value text
	(entmod (subst (cons 1 (rtos num 2 2)) (assoc 1 (entget (ssname ss n))) (entget (ssname ss n))))
	
	(setq n (1+ n))
	);repeat
      )
    (princ "\nBan da khong chon doi tuong")
    );if
  
  ;;;While and nentsel
  (while (setq att (car (nentsel "\nChon att: ")))
    (progn
      (change_w att)
      )    
    )
  (setvar "osmode" old_os)
  (princ)
  )

(defun change_w (att / w_att w)
  (setq w_att (vla-get-ScaleFactor (vlax-ename->vla-object att)))
  (if (setq w (getreal (strcat "\nChon withfactor <" (rtos w_att 2 2) ">: ")))
    (vla-put-ScaleFactor (vlax-ename->vla-object att) w)
    )
  )  

(princ "\nCommand: test")
  

<<

Filename: 407730_test.lsp
Tác giả: duy782006
Bài viết gốc: 407756
Tên lệnh: vdt
Lisp Vẽ Polyline Kín +Hatch Khi Biết Trước Diện Tích Và Nhập Số Điểm

Nói chung là đoán mò. Vẽ pline bằng cách pick điểm. Scale cho cái pline đó có diện tích như mong muốn. Nếu đúng thì viết như này:

(defun c:vdt ()

(command "pline")
(princ "\nSpecify start point:")
(while (< 0 (getvar "CMDACTIVE"))
(command pause)
(princ "\nSpecify next point or [Arc/Close/Halfwidth/Length/Undo/Width]:")
) 

(command "area" "object" "last")
(setq dtt (getvar "area"))
(setq cheot (* dtt 2))...
>>

Nói chung là đoán mò. Vẽ pline bằng cách pick điểm. Scale cho cái pline đó có diện tích như mong muốn. Nếu đúng thì viết như này:

(defun c:vdt ()

(command "pline")
(princ "\nSpecify start point:")
(while (< 0 (getvar "CMDACTIVE"))
(command pause)
(princ "\nSpecify next point or [Arc/Close/Halfwidth/Length/Undo/Width]:")
) 

(command "area" "object" "last")
(setq dtt (getvar "area"))
(setq cheot (* dtt 2)) 
(setq cheotr (sqrt cheot)) 
(setq dts (getreal "\nDien tich mong muon : "))
(setq cheos (* dts 2)) 
(setq cheosr (sqrt cheos)) 
(setq tilenhan (/ cheosr cheotr))
(setq dc (getpoint "\nChon diem goc: "))
(command "scale" "last" "" "_non" dc tilenhan)
(princ))

Phần hatch thì cần đề cho tên. tỉ lệ của hatch thì mới viết không mất công sửa mệt.


<<

Filename: 407756_vdt.lsp
Tác giả: gia_bach
Bài viết gốc: 407933
Tên lệnh: at2t
Lisp Ghép Text Cần Giúp Đỡ

E đang dùng lisp này của bác gia_bach. chạy rất ok, nhưng chỉ có hơi bất tiện ở chỗ: mỗi đợt nối 2 text (mỗi đợt nối text thì có mỗi yêu cầu khác nhau), cần thêm 1 cụm từ gì vào gữa 2 text cần nối thì e phải vào sửa code trong lisp. lúc thì nối không có khoảng trống, lúc thì nối cần...

>>

E đang dùng lisp này của bác gia_bach. chạy rất ok, nhưng chỉ có hơi bất tiện ở chỗ: mỗi đợt nối 2 text (mỗi đợt nối text thì có mỗi yêu cầu khác nhau), cần thêm 1 cụm từ gì vào gữa 2 text cần nối thì e phải vào sửa code trong lisp. lúc thì nối không có khoảng trống, lúc thì nối cần có khoảng trống, lúc thì cần thêm cụm "-D" hoặc "-L=",... thì hơi mất công tý, mà e thì ko biết về lisp nên ko sửa cho trọn vẹn được ạ. nay e nhờ bác sửa cái lisp trên giúp e :

gõ n2t;

lisp sẽ nhắc: "thêm ký hiệu giữa 2 text" có thể là chữ, dấu, số,... nếu cần thêm gì thì gõ vào, ko cần thì thôi, ấn enter hoặc space (mặc định của lisp là nối text ko cần khoảng trắng. còn nếu cần nối text có khỏang trắng thì e sử dụng lại lisp ở trên.

chọn text theo thứ tự nối, ấn space, text được nối. chọn tiếp các text, ấn space, text được nối. ấn speace 2 lần để kết thúc lệnh (hoặc ấn esc để thoát lệnh mà cad ko bị lỗi :) ). mong bác gia_bach và mọi người giúp e ạ. e cảm ơn

Update theo yêu cầu:

 (defun c:at2t (/ center ent i sel ss str ans obj tobj dyn);All Text to Text
  (vl-load-com)
  (defun centerSS (ss / lst_max lst_min maxpt minpt ll ur)
    (foreach ent (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
      (vla-GetBoundingBox ent 'minpt 'maxpt)
      (setq lst_min (cons (vlax-safearray->list minpt) lst_min)
	    lst_max (cons (vlax-safearray->list maxpt) lst_max)  )   )
    (setq ll (list (car (vl-sort (mapcar 'car lst_min) '<))
		   (car (vl-sort (mapcar 'cadr lst_min) '<))  )
	  ur (list (last (vl-sort (mapcar 'car lst_max) '<))
		   (last (vl-sort (mapcar 'cadr lst_max) '<)) ) )
    (mapcar '/ (mapcar '+ ll ur) '(2.0 2.0 2.0))	) 
;main
  (setq ss (ssadd))
  (while (setq sel (entsel "\nChon cac Text can noi voi nhau: "))
    (setq ent (car sel))
    (if (= (cdr (assoc 0 (entget ent))) "TEXT")
      (ssadd ent ss)) )
  (if (> (sslength ss) 1)
    (progn
      (setq dyn (getvar "DYNMODE"))
      (setvar "DYNMODE" 0)
      (setq *connect (getstring t "\nKi hieu giua 2 text:"))
      (setvar "DYNMODE"  dyn)
      (setq i 0	    
	    center (centerSS ss)
	    obj (vlax-ename->vla-object (ssname ss 0))
	    str (vlax-get obj 'TextString) )
      (while (setq ent (ssname ss (setq i (1+ i))))
	(setq str (strcat str *connect (vlax-get (vlax-ename->vla-object ent) 'TextString)) )
	(entdel ent)	)
      (vla-put-alignment
	(setq tObj (vla-addText
		     (vla-get-modelspace (vla-get-activedocument(vlax-get-acad-object)))
		     str
		     (vlax-3d-point '(0 0 0)) 1)) acAlignmentMiddleCenter)
      (vla-put-TextAlignmentPoint tObj (vlax-3d-point center))
      (foreach pro (list "Height" "Layer" "Linetype" "Rotation" "Color")
	(vlax-put tObj pro (vlax-get obj pro)))
      (vla-erase obj)      )
    (princ "\nKhong chon duoc Text !"))
  (princ))

<<

Filename: 407933_at2t.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 108213
Tên lệnh: velp
Viết lisp theo yêu cầu [phần 2]

Hề hề hề,
Biếu bác Tài xài chơi coi có ưng ý không hè???? Có gì chưa ưng bác lại hỏi nữa nghen.


PS: có cái ni bữa mô đi off Đè nẽng bác ôm đi mấy cái làm xuồng câu mực bác hỉ?????

Filename: 108213_velp.lsp
Tác giả: phamhuy1
Bài viết gốc: 408123
Tên lệnh: sci
xin lisp scale TẠI TÂM cho nhiều đối tượng

chào anh và các cao thủ trên diễn đàn

anh có thể giúp mình sửa thành lisp có chức năng scale tất cả các block được chọn, tại điểm đặt (pick point) của từng block đó không.

xin cảm ơn rất nhiều ạ

Bạn thử dùng xem sao nếu tốt thì Like nhé :

>>

chào anh và các cao thủ trên diễn đàn

anh có thể giúp mình sửa thành lisp có chức năng scale tất cả các block được chọn, tại điểm đặt (pick point) của từng block đó không.

xin cảm ơn rất nhiều ạ

Bạn thử dùng xem sao nếu tốt thì Like nhé :

(defun c:sci (/ ss tile i en obj ins) (vl-load-com)
(princ "\nChon cac Block :") 
(setq ss (ssget '((0 . "INSERT"))) 
tile (getreal "\nChon tile Scale:")) 
(setq i 0) 
(while (< i (sslength ss)) (setq en (ssname ss i) 
obj (vlax-ename->vla-object en)
ins (vla-get-InsertionPoint obj)) 
(vla-ScaleEntity obj ins tile) (setq i (1+ i)) ) 
(princ)
)


<<

Filename: 408123_sci.lsp
Tác giả: thanhduan2407
Bài viết gốc: 408245
Tên lệnh: 99
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

Chào các bác!

Em có viết một lisp để tạo nhiều Viewport hiển thị nội dung bên Model. Với số lượng Viewport ít thì OK không sao nhưng khi  số lượng Viewport lớn (50 chẳng hạn) thì các Viewport đầu bị mất và chỉ còn mấy Viewport cuối. Em không...

>>

Chào các bác!

Em có viết một lisp để tạo nhiều Viewport hiển thị nội dung bên Model. Với số lượng Viewport ít thì OK không sao nhưng khi  số lượng Viewport lớn (50 chẳng hạn) thì các Viewport đầu bị mất và chỉ còn mấy Viewport cuối. Em không biết nguyên nhân tại sao nữa. Mong các bác giải thích và cho phương thức với ạ!

Cảm ơn các bác rất nhiều!

(defun C:99 (/	       CHCAO	 CHNGANG   I	     N
	     PNTDONGNAM		 PNTTAYBAC PNT_CHEN  PNT_I
	     PNT_I+1
	    )
  (vl-load-com)
  (setq Olmode (getvar "OSMODE"))
  (setvar "OSMODE" 0)
  (setvar 'TILEMODE 0)
  (setq	Pnt_Chen
	 (getpoint
	   "\nCh\U+1ECDn \U+0111i\U+1EC3m ch\U+00E8n khung: "
	 )
  )
  (setq n (getint "\nNhap so Viewport: "))
  (setq ChCao 400.0)
  (setq ChNgang 350.0)
  (setq i 0)
  (vl-cmdf "Zoom" "E")
  (while (< i n)
    (setq Pnt_i (polar Pnt_Chen 0 (* i 800.0)))
    (setq Pnt_i+1 (polar Pnt_Chen 0 (* (+ i 1) 400.0)))
    (setq PntTayBac (polar Pnt_i (/ pi 2) 400.0))
    (setq PntDongNam (polar Pnt_i 0 350.0))
    (vl-cmdf "Zoom" "W" PntTayBac PntDongNam)
    (vl-cmdf "Mview" PntTayBac PntDongNam)
    (vl-cmdf "MSpace")
    (vl-cmdf "Zoom" "E")
    (vl-cmdf "PSpace")
    (vl-cmdf "PAN" Pnt_i Pnt_i+1)
    (setq i (1+ i))
  )
  (vl-cmdf "Zoom" "E")
  (setvar "OSMODE" Olmode)
  (Princ)
)

<<

Filename: 408245_99.lsp
Tác giả: Bee
Bài viết gốc: 408255
Tên lệnh: test
Xin Lisp Chỉnh Tâm Của Text Trùng Tâm Đường Tròn

chào mọi người, nhờ các bác giúp mình lisp khi chọn text với đường tròn cho ra kết quả bán kính của đường tròn bằng chiều cao của text , tâm của đườn tròn trùng tâm của  text (dạng middle center ).thank

Thử cái này xem: ^_^ viết nhanh chỉ dùng cho 1 text với 1 đường tròn . Chọn...

>>

chào mọi người, nhờ các bác giúp mình lisp khi chọn text với đường tròn cho ra kết quả bán kính của đường tròn bằng chiều cao của text , tâm của đườn tròn trùng tâm của  text (dạng middle center ).thank

Thử cái này xem: ^_^ viết nhanh chỉ dùng cho 1 text với 1 đường tròn . Chọn đối tượng lần đầu có thể chọn hết các đường tròn. 

Chúc ngon miệng. ^_^

(defun c:test (/ ss n ename center radius pt1 pt2 ss1)
  (setvar "CMDECHO" 0)
  (princ "\nChon duong tron: ")
  (if (setq ss (ssget '((0 . "CIRCLE"))))
    (progn
      (command "zoom" "ob" ss "")
      (setq n 0)
      (repeat (sslength ss)
	(setq ename (ssname ss n))
	(setq center (cdr (assoc 10 (entget ename))))
	(setq radius (cdr (assoc 40 (entget ename))))
	(setq pt1 (polar center (/ (* pi 3) 4) (/ (* 3 radius) 4)))
	(setq pt2 (polar pt1 (angle pt1 center) (/ (* 3 radius) 2)))
	(setq ss1 (ssget "C" pt1 pt2 '((0 . "TEXT"))))
	(if ss1
	  (progn
	    (command "_justifytext" ss1 "" "MC"
		     "move" (ssname ss1 0) "" "_none" (cdr (assoc 11 (entget (ssname ss1 0)))) "_none" center)
	    (entmod (subst (assoc 40 (entget (ssname ss1 0)))
			   (assoc 40 (entget ename))
			   (entget ename))
		    )
	    )
	  )
	
	(setq n (1+ n))
	);repeat
      );progn
    );if
  (command "zoom" "P")
  (princ)
  )

<<

Filename: 408255_test.lsp
Tác giả: Tue_NV
Bài viết gốc: 304019
Tên lệnh: vbatoolbarmenu
Gọi Tool Bar trong CUI vừa Add

Dạ nó như này anh ạ.

36665_55_2.png

 

Em tham khảo 2 đoạn code này, anh copy nhặt được trên mạng, vì quá bận nên chưa nghiên cứu nhiều ^ _ ^

 

(vl-load-com)
(defun c:test()
    (setq acadObj (vlax-get-acad-object))
    (setq currMenuGroup (vla-Item (vla-get-MenuGroups acadObj) "ACAD"))
 
    ;; Create the new...
>>

Dạ nó như này anh ạ.

36665_55_2.png

 

Em tham khảo 2 đoạn code này, anh copy nhặt được trên mạng, vì quá bận nên chưa nghiên cứu nhiều ^ _ ^

 

(vl-load-com)
(defun c:test()
    (setq acadObj (vlax-get-acad-object))
    (setq currMenuGroup (vla-Item (vla-get-MenuGroups acadObj) "ACAD"))
 
    ;; Create the new toolbar
    (setq newToolBar (vla-Add (vla-get-Toolbars currMenuGroup) "HA1"))
 
    ;; Assign the macro string the VB equivalent of "ESC ESC _open "
    (setq openMacro (strcat (Chr 3) (Chr 3) (Chr 95) "open" (Chr 32)))
    (setq newButton1 (vla-AddToolbarButton newToolBar "" "NewButton1" "Open a file." openMacro))
 
    ;; Display the toolbar
    (vla-put-Visible newToolBar :vlax-true)
 
    (vla-put-CommandDisplayName newButton1 "Open a File")
 
    ;; Read the current value of the Help string
    (alert (strcat "The current CommandDisplayName for the toolbar button is: " (vla-get-CommandDisplayName newButton1)))
 
    ;; Change the value of the CommandDisplayName
    (vla-put-CommandDisplayName newButton1 "Open File")
 
    ;; Read the new value of the CommandDisplayName
    (alert (strcat "The new CommandDisplayName for the toolbar button is: " (vla-get-CommandDisplayName newButton1)))
)

(defun C:VBATOOLBARMENU (/ fn acadobj thisdoc menus flag currMenuGroup
newToolbar newToolbarButton openMacro
SmallBitmapName LargeBitmapName)
 
(vl-load-com)
 
;;; CreateToolbar is called if the Toolbar in question doesn't exist
  (defun createToolbar ()
    (setq newToolbar (vla-add (vla-get-toolbars currMenuGroup) "VBA Menu"))
    ;;------------------------------------------------------------------
    ;; create the first Toolbar Button, VbaLoad
    (setq openMacro (strcat (chr 3) (chr 3) (chr 95) "vbaload" (chr 32)))
    (setq newToolbarButton (vla-addToolbarButton
             newToolbar
             (1+ (vla-get-count newToolbar))
             "VBA Load" "VBA Load" openMacro
           )
    )
    (setq SmallBitmapName "VbaLoad.bmp")
    (setq LargeBitmapName "VbaLoad.bmp")   
    (vla-setBitmaps newToolbarButton SmallBitmapName LargeBitmapName)
 
    (vla-put-helpString newToolbarButton "Load a VBA Application")
    ;;------------------------------------------------------------------
    ;; create the second Toolbar Button, Vbaide
    (setq openMacro (strcat (chr 3) (chr 3) (chr 95) "vbaide" (chr 32)))
    (setq newToolbarButton (vla-addToolbarButton
             newToolbar
             (1+ (vla-get-count newToolbar))
             "VBA Editor" "VBA Editor" openMacro
           )
    )
    (setq SmallBitmapName "Vbaide.bmp")
    (setq LargeBitmapName "Vbaide.bmp")   
    (vla-setBitmaps newToolbarButton SmallBitmapName LargeBitmapName)
 
    (vla-put-helpString newToolbarButton "Switch to the VBA Editor")
    ;;------------------------------------------------------------------
    ;; create the third Toolbar Button, Vbarun
    (setq openMacro (strcat (chr 3) (chr 3) (chr 95) "vbarun" (chr 32)))
    (setq newToolbarButton (vla-addToolbarButton
             newToolbar
             (1+ (vla-get-count newToolbar))
             "VBA Macro" "VBA Macro" openMacro
           )
    )
    (setq SmallBitmapName "Vbamacro.bmp")
    (setq LargeBitmapName "Vbamacro.bmp")   
    (vla-setBitmaps newToolbarButton SmallBitmapName LargeBitmapName)
 
    (vla-put-helpString newToolbarButton "Run a VBA Macro")
    ;;------------------------------------------------------------------
    ;; create the fourth Toolbar Button, Vbaman
    (setq openMacro (strcat (chr 3) (chr 3) (chr 95) "vbaman" (chr 32)))
    (setq newToolbarButton (vla-addToolbarButton
             newToolbar
             (1+ (vla-get-count newToolbar))
             "VBA Manager" "VBA Manager" openMacro
           )
    )
    (setq SmallBitmapName "Vbaman.bmp")
    (setq LargeBitmapName "Vbaman.bmp")   
    (vla-setBitmaps newToolbarButton SmallBitmapName LargeBitmapName)
 
    (vla-put-helpString newToolbarButton "Display the VBA Manager")
    ;;------------------------------------------------------------------
 
    ;; re-compile the VBATOOLBARMENU menu - VBATOOLBARMENU.MNC
    (vla-save currMenuGroup acMenuFileCompiled)
    ;; save it as a MNS file
    (vla-save currMenuGroup acMenuFileSource)
  )
 
  (setq flag nil)
  (if (not (findfile "VbaToolbarMenu.mns"))
    (progn
      (setq fn (open "VbaToolbarMenu.mns" "w"))
      (close fn)
    )
  )
  ;; get hold of the application object
  ;; we'll use it to reference the menuGroups collection
  (setq acadobj (vlax-get-acad-object))
  ;; .. and get the active document
  (setq thisdoc (vla-get-activeDocument acadobj))
  ;; get all menu groups loaded into AutoCAD
  (setq menus (vla-get-menuGroups acadobj))
  (princ "\nLoaded menus: ")
  (vlax-for n menus
    (if (= (vla-get-name n) "VbaToolbarMenu")
      (setq flag T)
    )
    (terpri)
    (princ (vla-get-name n))
  )
  ;; if VbaToolbarMenu wasn't among the loaded menus then load it
  (if (null flag)
    (vla-load menus "VbaToolbarMenu.mns")
  )
  (setq currMenuGroup (vla-item menus "VbaToolbarMenu"))
  ;; if no Toolbars exist in VbaToolbarMenu then go create one
  ;; otherwise exit with grace
  (if (<= (vla-get-count (vla-get-menus currMenuGroup)) 0)
    (createToolbar)
    (princ "\nThe Vba Toolbar Menu is already loaded")
  )
  (princ)
)
 
(princ)
(vl-load-com)
(defun c:test()
    (setq acadObj (vlax-get-acad-object))
    (setq currMenuGroup (vla-Item (vla-get-MenuGroups acadObj) "ACAD"))
 
    ;; Create the new toolbar
    (setq newToolBar (vla-Add (vla-get-Toolbars currMenuGroup) "HA1"))
 
    ;; Assign the macro string the VB equivalent of "ESC ESC _open "
    (setq openMacro (strcat (Chr 3) (Chr 3) (Chr 95) "open" (Chr 32)))
    (setq newButton1 (vla-AddToolbarButton newToolBar "" "NewButton1" "Open a file." openMacro))
 
    ;; Display the toolbar
    (vla-put-Visible newToolBar :vlax-true)
 
    (vla-put-CommandDisplayName newButton1 "Open a File")
 
    ;; Read the current value of the Help string
    (alert (strcat "The current CommandDisplayName for the toolbar button is: " (vla-get-CommandDisplayName newButton1)))
 
    ;; Change the value of the CommandDisplayName
    (vla-put-CommandDisplayName newButton1 "Open File")
 
    ;; Read the new value of the CommandDisplayName
    (alert (strcat "The new CommandDisplayName for the toolbar button is: " (vla-get-CommandDisplayName newButton1)))
)

<<

Filename: 304019_vbatoolbarmenu.lsp
Tác giả: Bee
Bài viết gốc: 408335
Tên lệnh: test
Xoay text thuộc tính trong block

- Trong 4 ý của bạn có ý 4 là ok nhưng lệnh này có khi cũng không dùng được. (có những bv vẽ ta không dùng được lệnh này)

- Ý 1 thì chỉ sử dụng được 1 att block được chọn thôi. 

---> Nói chung cũng không ổn lắm ! 

Ok, nếu thử lisp thì nghịch tí nào. Thêm cả 2...

>>

- Trong 4 ý của bạn có ý 4 là ok nhưng lệnh này có khi cũng không dùng được. (có những bv vẽ ta không dùng được lệnh này)

- Ý 1 thì chỉ sử dụng được 1 att block được chọn thôi. 

---> Nói chung cũng không ổn lắm ! 

Ok, nếu thử lisp thì nghịch tí nào. Thêm cả 2 cách Autolisp và Visual lisp.

 

Autolisp này: ^_^

(defun c:test (/ blk ss n name ins lst value)
  (if (setq blk (car (entsel "\nChon block: ")))
    (progn
      (setq
	ss (ssget "_X" (list '(0 . "INSERT") (assoc 2 (entget blk))))
      )
      (command "_justifytext" ss "" "MC")
      (setq name (cdr (assoc 2 (entget (ssname ss 0)))))
      (setq lst (get-block-entities name))
      (foreach ob lst
	(if (eq (cdr (assoc 0 (entget ob))) "CIRCLE")
	  (setq center (trans (cdr (assoc 10 (entget ob))) 1 0))
	  )
	);foreach
      (foreach ob lst
	(if (eq (cdr (assoc 0 (entget ob))) "ATTDEF")
	  (progn
	    (setq value (cdr (assoc 1 (entget ob))))
	    (entmod (subst (cons 11 center) (assoc 11 (entget ob)) (entget ob)))
	    )
	  )
	);foreach
      (entupd (ssname ss 0))
      (setq n 0)
      (repeat (sslength ss)
	(setq ins (cdr (assoc 10 (entget (ssname ss n)))))
	(setq value (cdr (assoc 1 (entget (entnext (ssname ss n))))))
	(command "_-insert" name "_none" ins 1 1 0 value
		 "_erase" (ssname ss n) "")
	(setq n (1+ n))
	)
      )
    )
  )
(defun get-block-entities ( blk / ent lst )
    (if (setq ent (tblobjname "block" blk))
      (while (setq ent (entnext ent))
	(setq lst (cons ent lst))
        ) ;; end WHILE
    ) ;; end IF
    (reverse lst) ;; Return the list
) ;; end DEFUN
;;;END CODE AUTOLISP HERE



<<

Filename: 408335_test.lsp
Tác giả: Bee
Bài viết gốc: 408336
Tên lệnh: mac
Xoay text thuộc tính trong block

- Trong 4 ý của bạn có ý 4 là ok nhưng lệnh này có khi cũng không dùng được. (có những bv vẽ ta không dùng được lệnh này)

- Ý 1 thì chỉ sử dụng được 1 att block được chọn thôi. 

---> Nói chung cũng không ổn lắm ! 

Thử cả VL xem nào ^_^

>>

- Trong 4 ý của bạn có ý 4 là ok nhưng lệnh này có khi cũng không dùng được. (có những bv vẽ ta không dùng được lệnh này)

- Ý 1 thì chỉ sử dụng được 1 att block được chọn thôi. 

---> Nói chung cũng không ổn lắm ! 

Thử cả VL xem nào ^_^

(defun c:MAC (/ acdoc mspace blk center temp)
  (setq acdoc (vla-get-activedocument (vlax-get-acad-object)))
  (setq mspace (vla-get-modelspace acdoc))
  (if (setq blk (car (entsel "\nChon block: ")))
    (progn
      (vlax-for	blks (vla-get-blocks acdoc)
	(if (wcmatch (vla-get-Name blks) (cdr (assoc 2 (entget blk))))
	  (progn
	    (vlax-for obj blks
	      (if (= (vla-get-ObjectName obj) "AcDbCircle")
		(setq center (vlax-get obj 'Center))
	      )
	    )
	    (vlax-for obj blks
	      (if
		(= (vla-get-ObjectName obj) "AcDbAttributeDefinition")
		 (progn
		   (vla-put-Rotation obj 0.0)
		   (vla-put-Alignment obj acAlignmentMiddleCenter)
		   (vla-put-TextAlignmentPoint
		     obj
		     (vlax-3d-point center)
		   )
		 )			;progn
	      )				;if
	    )				;vlax-for obj
	  )				;progn then
	)				;if
      )					;vlax-for blks
      (setq temp (vla-insertblock
		   mspace
		   (vlax-3d-point '(0. 0. 0.))
		   (cdr (assoc 2 (entget blk)))
		   1
		   1
		   1
		   0
		 )
      )
      (vla-sendcommand
	acdoc
	(strcat	"ATTSYNC\n"
		"Name\n"
		""
		(cdr (assoc 2 (entget blk)))
		"\n"
		""
	)
      )
      (vla-delete temp)
    )					;progn
  )					;if
  (princ)
)					;defun

;;;END CODE VISUAL LISP HERE

<<

Filename: 408336_mac.lsp

Trang 211/330

211