Jump to content
InfoFile
Tác giả: Superlong
Bài viết gốc: 396432
Tên lệnh: yeah
Hỏi Về Lisp Tạo Boundary Từ Các Polyline Không Giao Nhau

sau khi sửa lại thì nó báo  error: bad argument type: listp 6.7799
(defun c:yeah ( / dt dt1 dt2 rec1 rec2 ss)

(setq dt (ssget '((0 . "LWPOLYLINE"))))

(setq dt1 (ssname dt 0)

dt2 (ssname dt 1)

rec1 (acet-geom-vertex-list dt1)

rec2 (acet-geom-vertex-list dt2))

(setq ss (append rec1 rec2))

(acet-pline-make ss))


Filename: 396432_yeah.lsp
Tác giả: Superlong
Bài viết gốc: 396458
Tên lệnh: zx
Hỏi Về Luật So Sánh Trong Autolisp

ở đây lisp của em khi so sánh 2 tham số là kc1 và kc2 nếu cả 2 đều là số dương hoặc 1 âm 1 dương thì vẫn so sánh đúng nhưng khi so sánh 2 số âm vd: -2 và -22 thì nó lại hiểu là -22 lớn sao kì vậy có ai giải thích giúp em
(defun DXF (code elist)
(cdr (assoc code elist))
)

(defun c:ZX(/ dt tenfile f lst lst2 i ls )
(if (not scale) (setq scale 1))
(setq sc1 (getreal (strcat "\n Cao text <"(rtos scale 2...

>>

ở đây lisp của em khi so sánh 2 tham số là kc1 và kc2 nếu cả 2 đều là số dương hoặc 1 âm 1 dương thì vẫn so sánh đúng nhưng khi so sánh 2 số âm vd: -2 và -22 thì nó lại hiểu là -22 lớn sao kì vậy có ai giải thích giúp em
(defun DXF (code elist)
(cdr (assoc code elist))
)

(defun c:ZX(/ dt tenfile f lst lst2 i ls )
(if (not scale) (setq scale 1))
(setq sc1 (getreal (strcat "\n Cao text <"(rtos scale 2 0)">:")))
(if sc1 (setq scale sc1))
(setq sc9 (cdr (assoc 1 (entget (car (entsel "\nChon Text Ly Trinh : "))))))
(setq p (getpoint "\nChon tim trac ngang: "))
(setq TX (Car P))
(setq TY (Cadr P))
(setq ed (entget (car (entsel "\nChon cao do tim : "))))
(setq H0 (read (DXF 1 ed)))
(setq ATLAST (getvar "Attreq"))
(setq dt (ssget '((0 . "LWPOLYLINE")))
sdt (sslength dt)
K (+ SDT 1)
i 0)

(repeat sdt
(setq dt1 (ssname dt i)
i (1+ i)
K (- K 1)
rec (acet-geom-vertex-list dt1))
(setq x1 (car (nth 0 Rec))
y1 (cadr (nth 0 Rec))
x2 (car (nth 1 Rec))
y2 (cadr (nth 1 Rec))
x3 (car (nth 2 Rec))
y3 (cadr (nth 2 Rec))
)
(setq kc1 (rtos (- x1 tx) 2 2))
(setq kc2 (rtos (- x3 tx) 2 2))
(setq kctim (rtos (- x2 tx) 2 2))
(setq cd1 (rtos (abs (+ (- y1 ty) H0)) 2 2))
(setq cdtim (rtos (abs (+ (- y2 ty) H0)) 2 2))
(setq cd2 (rtos (abs (+ (- y3 ty) H0)) 2 2))
(setvar "attreq" 1)

(if (not (tblsearch "block" "DTPHANLOP"))
(progn (command "insert" "D:\\Lisp CAD\\BLOCK.dwg" 0 "" "" "")
(command "erase" (entlast) "")))
(if (> kc1 KC2) (command "INSERT" "DTPHANLOP" (nth 2 rec) scale scale 0 K sc9 CD2 KC2 cdtim kctim CD1 KC1))

(if (< kc1 KC2) (command "INSERT" "DTPHANLOP" (nth 0 rec) scale scale 0 K sc9 CD1 KC1 cdtim kctim CD2 KC2))
))


<<

Filename: 396458_zx.lsp
Tác giả: Superlong
Bài viết gốc: 396443
Tên lệnh: yeah
Hỏi Về Lisp Tạo Boundary Từ Các Polyline Không Giao Nhau
ロレックス スーパーコピー 柵 diy http://www.brandiwc.com/brand-54-copy-0.html

Filename: 396443_yeah.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 396716
Tên lệnh: ocd
Hỏi Cách Lồng Lệnh Extrim Vào Lisp

Bạn tham khảo lisp này (của ai quên mất) rồi tự nghiên cứu thôi. HỌC HỎI là tốt nhưng HỌC nhiều thì tốt hơn HỎI nhiều.

;----- Trim and Delete outside of closed polyline (C¾t vµ xo¸ phÇn bªn ngoµi cña 1 polyline ®ãng).
; Required Express tools. OutSide Contour Delete with Extrim.
(defun C:OCD (  / en ss lst ssall bbox)
 (vl-load-com)
 (if (and (setq en (car (entsel "\nSelect...
>>

Bạn tham khảo lisp này (của ai quên mất) rồi tự nghiên cứu thôi. HỌC HỎI là tốt nhưng HỌC nhiều thì tốt hơn HỎI nhiều.

;----- Trim and Delete outside of closed polyline (C¾t vµ xo¸ phÇn bªn ngoµi cña 1 polyline ®ãng).
; Required Express tools. OutSide Contour Delete with Extrim.
(defun C:OCD (  / en ss lst ssall bbox)
 (vl-load-com)
 (if (and (setq en (car (entsel "\nSelect contour (polyline): ")))
               (wcmatch (cdr (assoc 0 (entget en))) "*POLYLINE"))
  (progn
   (setq bbox (ACET-ENT-GEOMEXTENTS en))
   (setq bbox (mapcar '(lambda(x)(trans x 0 1)) bbox))
   (setq lst (ACET-GEOM-OBJECT-POINT-LIST en 1e-3))
   (ACET-SS-ZOOM-EXTENTS (ACET-LIST-TO-SS (list en)))
   (command "_.Zoom" "0.95x")
   (if (null etrim) (load "extrim.lsp"))
   (etrim en (polar (car bbox) (angle (car bbox) (cadr bbox)) (* (distance (car bbox)(cadr bbox)) 1.1)))
   (if (and
         (setq ss (ssget "_CP" lst))
         (setq ssall (ssget "_X" (list (assoc 410 (entget en))))))
    (progn
     (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
     (foreach e1 lst (ssdel e1 ssall))
      (ACET-SS-ENTDEL ssall))))))
(princ "\nType OCD to start")
(princ)

<<

Filename: 396716_ocd.lsp
Tác giả: Tue_NV
Bài viết gốc: 85119
Tên lệnh: vespl
Hướng dẫn lập trình Lisp

Chào bác Thiep cùng các bác trên diễn đàn.
Dựa vào ý của bác Thiep, Tue_NV đã thử tạo 1 Spline nhưng kết quả không như ý muốn
Nhập 3 điểm nhưng chỉ có 2 segments

Tue_NV có vài chổ không hiểu trong ý của bác Thiep. Mong các bác chỉ giúp :
- PointsArray là safearray các controlpoint, bác có thể tham khảo đoạn mã sau:
(setq PointsArray (vlax-make-safearray
vlax-vbDouble
>>

Chào bác Thiep cùng các bác trên diễn đàn.
Dựa vào ý của bác Thiep, Tue_NV đã thử tạo 1 Spline nhưng kết quả không như ý muốn
Nhập 3 điểm nhưng chỉ có 2 segments

Tue_NV có vài chổ không hiểu trong ý của bác Thiep. Mong các bác chỉ giúp :
- PointsArray là safearray các controlpoint, bác có thể tham khảo đoạn mã sau:
(setq PointsArray (vlax-make-safearray
vlax-vbDouble
(cons 0 (1- (length Lpoint)))
)
)
(vlax-safearray-fill PointsArray Lpoint)
Khi mình chọn 3 điểm và chuyển PointsArray sang list thì được 1 list gồm 6 phần tử 0.0
-> (0.0 0.0 0.0 0.0 0.0 0.0) -> Như vậy là sao ạ? Tue_NV không hiểu?
(cons 0 (1- (length Lpoint))) -> Cái này được giải thích như thế nào ạ?
Có phải (1- (length Lpoint)) là số phần tử Lpoint trừ đi 1 còn lại 2 phần tử không?
Tại sao mhư thế nhỉ? Các bác có thể sửa giúp code trên và giải thích dùm Tue_NV 1 tí được không?

Cảm ơn các bác thật nhiều
<<

Filename: 85119_vespl.lsp
Tác giả: gia_bach
Bài viết gốc: 85287
Tên lệnh: vespl
Hướng dẫn lập trình Lisp
Hàm tạo mảng
(vlax-make-safearray type '(l-bound . u-bound)
với '(l-bound . ubound) :là chỉ số dưới và trên của 1 chiều.
- Chỉ số (Index) có thể bắt đầu bằng 0, 1 hay 1 số nguyên nào đó.

Vd: để tạo mảng 1 chiều có 3 ptử kiểu vlax-vbDouble, 2 dòng lệnh sau cho kết quả như nhau :
(vlax-make-safearray vlax-VBDouble (cons 0 2)) -> chỉ số dưới là 0, chỉ số trên là 2
>>
Hàm tạo mảng
(vlax-make-safearray type '(l-bound . u-bound)
với '(l-bound . ubound) :là chỉ số dưới và trên của 1 chiều.
- Chỉ số (Index) có thể bắt đầu bằng 0, 1 hay 1 số nguyên nào đó.

Vd: để tạo mảng 1 chiều có 3 ptử kiểu vlax-vbDouble, 2 dòng lệnh sau cho kết quả như nhau :
(vlax-make-safearray vlax-VBDouble (cons 0 2)) -> chỉ số dưới là 0, chỉ số trên là 2
(vlax-make-safearray vlax-VBDouble (cons 1 3)) -> chỉ số dưới là 1, chỉ số trên là 3

Như vậy :
(vlax-make-safearray vlax-vbDouble (cons 0 (1- (length Lpoint)))
sẽ tạo mảng 1 chiều có (length Lpoint) ptử kiểu vlax-vbDouble, với chỉ số dưới là 0, chỉ số trên là (1- (length Lpoint))

dĩ nhiên bạn vẫn có thể khai báo như sau :
(vlax-make-safearray vlax-vbDouble (cons 1 (length Lpoint))
sẽ tạo mảng 1 chiều có (length Lpoint) ptử kiểu vlax-vbDouble, với chỉ số dưới là 1, chỉ số trên là (length Lpoint)

Vấn đề Nhập 3 điểm nhưng chỉ có 2 segments là do bạn chưa ADD điểm p vào Lpoint
(setq Lpoint (list p))
nên trong Lpoint chỉ có các điểm p2.

Gửi bạn Lisp sửa đổi và vẽ “khung xương hình hài” của spline như ý của thiep
<<

Filename: 85287_vespl.lsp
Tác giả: Superlong
Bài viết gốc: 396729
Tên lệnh: tpl
Hỏi Cách Lồng Lệnh Extrim Vào Lisp

đây là lisp vẽ đường phân lớp theo độ dốc nhưng sau khi tạo các đường dốc xong em muốn cho nó vẽ thêm 1 đường pline ở dưới đáy nửa nên lấy toạ độ x của điểm end + 1  và giữ nguyên y ra điểm thứ 1  sau đó lấy x của end -1 giữ nguyên y thành điểm thứ 3 điểm thứ 2 chính là end để vẽ thì nó nhãy loạn cả lên

em nghĩ do ãnh hưởng của hàm nào đó trong lisp này vì ở...

>>

đây là lisp vẽ đường phân lớp theo độ dốc nhưng sau khi tạo các đường dốc xong em muốn cho nó vẽ thêm 1 đường pline ở dưới đáy nửa nên lấy toạ độ x của điểm end + 1  và giữ nguyên y ra điểm thứ 1  sau đó lấy x của end -1 giữ nguyên y thành điểm thứ 3 điểm thứ 2 chính là end để vẽ thì nó nhãy loạn cả lên

em nghĩ do ãnh hưởng của hàm nào đó trong lisp này vì ở công đoạn vẽ pline theo độ dốc lisp vẫn tính toán ra kết quả đúng
(vl-load-all "C:/Program Files/AutoCAD 2010/Express/extrim.lsp")
(defun c:tpl ()
(setq s1 (entsel "\nCh\U+1ECDn \U+0111\U+01B0\U+1EDDng bao"))
(setq dinh (getpoint "\nCh\U+1ECDn \U+0111\U+1EC9nh")
end (getpoint "\nCh\U+1ECDn \U+0111\U+00E1y"))
(setq dodoc (getreal "\nNh\U+1EADp \U+0111\U+1ED9 d\U+1ED1c c\U+1EE7a \U+0111\U+01B0\U+1EDDng ph\U+00E2n l\U+1EDBp i%: ")
ydinh (cadr dinh)
yend (cadr end)
xdinh (car dinh)
xend (car end)
xtdpl1 (- xdinh 100)
xtdpl2 (+ xdinh 100)
ytdpl (- ydinh DODOC)
dpl1 (list xtdpl1 ytdpl 0)
dpl2 (list xtdpl2 ytdpl 0)
kc (abs(- ydinh yend))
h (getreal "\nNh\U+1EADp b\U+1EC1 d\U+00E0y ph\U+00E2n l\U+1EDBp : ")
nl1 (ATOI (RTOS (/ kc h) 2 0))
nl2 (/ kc h))
(if (> nl1 nl2) (setq nl (- nl1 1 )))
(if (< nl1 nl2) (setq nl nl1))
(setq kr (strcase (getstring "\nCh\U+1ECDn h\U+01B0\U+1EDBng r\U+1EA3i-Tr\U+00EAn xu\U+1ED1ng/D\U+01B0\U+1EDBi l\U+00EAn: ")))
(if (= kr "T") (setq h1 (* h -1)))
(if (= kr "D") (setq h1 h))

(setq phud (entlast))
(command "pline" dpl1 dinh dpl2 "" "")
(setq ss (entlast))
(command "array" ss "" "r" (+ 1 nl) "1" h1)
(setq da (entlast))



(setq pt2 (nth 0 (acet-geom-vertex-list da)))
(setq pt3 (nth 2 (acet-geom-vertex-list da)))
(setq pt4 (+ (car dinh) 2))
(setq pt1 (- (car dinh) 2)
pt5 (list pt4 (+(nth 1 dinh) 0.1) 0)

pt6 (list pt1 (+(nth 1 dinh) 0.1) 0)
goc (list 0 0 0))

(command "extend" s1 "" "f" pt6 pt2)
(command "" "f" pt3 pt5 "" "")
(vl-load-all "C:/Program Files/AutoCAD 2010/Express/extrim.lsp")

(setq
xcut1 (+ (CAR (NTH 0 (acet-geom-vertex-list da))) 1)
xcut2 (- (CAR (NTH 2 (acet-geom-vertex-list da))) 1)
)
(IF (= KR "T")
(SETQ
PCUT1 (LIST XCUT1 YDINH)
PCUT2 (LIST XCUT1 (- YEND 100))
PCUT3 (LIST XCUT2 YDINH)
PCUT4 (LIST XCUT2 (- YEND 100))
))
(IF (= KR "D")
(SETQ
PCUT1 (LIST XCUT1 (- YDINH 100))
PCUT2 (LIST XCUT1 (+ YEND 100))
PCUT3 (LIST XCUT2 (- YDINH 100))
PCUT4 (LIST XCUT2 (+ YEND 100))
))

(COMMAND "_.TRIM" (CAR S1) "" "F" PCUT1 PCUT2 "" "F" PCUT3 PCUT4 "" "")
(setq xphut1 (- xend 5)
xphut2 (+ xend 5)
phut1 (list xphut1 yend 0)
phut2 (list xphut2 yend 0))
(command "pline" phut1 end phut2 "" "")

)


<<

Filename: 396729_tpl.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 396775
Tên lệnh: rd rs%C2%A0
Nh? Vi?t Lisp: ??i Tr?c T?a ?? Theo C?nh Ch?n Trên Màn Hình

B?n th? cái này xem:

(defun c:rd () (setvar 'SNAPANG 0) (princ))
(defun c:rs  (/ pt1 pt2)
 (and (setq pt1 (getpoint "\nFirst point: "))
      (setq pt2 (getpoint pt1 "\nSecond point: "))
      (setvar 'SNAPANG (angle pt1 pt2)))
 (princ))

Filename: 396775_rd_rs%C2%A0.lsp
Tác giả: Tot77
Bài viết gốc: 318089
Tên lệnh: ttx+%C2%A0 tty
Nhờ sửa Lisp Copy Text Cad sang Excel

Bạn dùng cái này. Lúc chạy lần đầu nó có hỏi chọn layer, bạn pick 3 cái text để lấy 3 layer.

(vl-load-com)
(defun batdau ()
  (defun dxf (id v) (cdr (assoc id (entget v))))
  (setq xlApp   (vlax-get-or-create-object "Excel.Application")
            xlCells (vlax-get-property
                      (vlax-get-property
                        (vlax-get-property
                 ...
>>

Bạn dùng cái này. Lúc chạy lần đầu nó có hỏi chọn layer, bạn pick 3 cái text để lấy 3 layer.

(vl-load-com)
(defun batdau ()
  (defun dxf (id v) (cdr (assoc id (entget v))))
  (setq xlApp   (vlax-get-or-create-object "Excel.Application")
            xlCells (vlax-get-property
                      (vlax-get-property
                        (vlax-get-property
                          (vlax-invoke-method
                            (vlax-get-property xlApp "Workbooks")
                            "Add") "Sheets") "Item" 1) "Cells"))
   (vla-put-visible xlApp :vlax-true)
  
   (if (not tlayer1)
    (progn (alert "Hay chon Layer")
      (setq tlayer1 (dxf 8 (car (entsel "\nChon text thuoc layer 1:")))
 tlayer2 (dxf 8 (car (entsel "\nChon text thuoc layer 2:")))
 tlayer3 (dxf 8 (car (entsel "\nChon text thuoc layer 3:")))))
  )
  (setq row1 0 row2 0 row3 0)
  (setq col1 1 col2 5 col3 9)
)
 
(defun ghi (tlayer row col dau / ss1 ss0 y i iPt)
    (setq ss1 (vl-remove-if-not '(lambda (x) (= (dxf 8 x) tlayer)) ss)
 ss1 (mapcar '(lambda (x) (list (vlax-get (vlax-ename->vla-object x) 'InsertionPoint)
 (vlax-ename->vla-object x))) ss1)
 cao (vla-get-Height (last (car ss1))))
    (while ss1
(setq  ss1 (vl-sort ss1 '(lambda (x y) (dau (cadr (car x)) (cadr (car y)))))
      ss0 (vl-remove-if-not '(lambda (x) (equal (cadr (caar ss1)) (cadr (car x)) cao)) ss1)
      ss0 (vl-sort ss0 '(lambda (x y) (< (caar x) (caar y))))
      ss1 (vl-remove-if '(lambda (x) (member x ss0)) ss1)
)
(foreach z ss0
          (setq iPt (car z)
y (list (vla-get-TextString (last z))  (rtos (car iPt) 2 2)  (rtos (cadr iPt) 2 2) (rtos (caddr iPt) 2 2))
 ) 
          (setq i -1 row (1+ row))
          (mapcar '(lambda (x) (vlax-put-property xlCells "Item" row  (+ col (setq i (1+ i))) x)) y)
)
      )
  row
)
 
(defun c:ttx  (/ ss ss1 y xlApp xlCells row col i iPt)
  (batdau) (prompt "\nChon text")
  (if (setq ss (ssget '((0 . "*TEXT"))))
    (progn
      (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
      (setq row1 (ghi tlayer1 row1 col1 <))
      (setq row2 (ghi tlayer2 row2 col2 <))
      (setq row3 (ghi tlayer3 row3 col3 <))      
    )
  )
  (mapcar 'vlax-release-object (list xlApp xlCells))
  (princ)
)
 
(defun c:tty (/ ss xlApp xlCells row1 row2 row3)
  (batdau) (prompt "\nChon text")
  (while (setq ss (ssget '((0 . "TEXT"))))
    (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
    (setq row1 (ghi tlayer1 row1 col1 >))
    (setq row2 (ghi tlayer2 row2 col2 >))
    (setq row3 (ghi tlayer3 row3 col3 >))
  )
  (mapcar 'vlax-release-object (list xlApp xlCells))  
  (princ)
)

 

@tientracdia : cái này chỉ đỡ hơn ở chỗ không cần chọn text mà chỉ cần chọn khung pline, nhưng không quét và sắp xếp theo thứ tự mà bạn phải pick từng cái thôi, thứ tự do bạn chọn.

(defun c:tta (/ ss sst ssc ssd pl oo txt xlApp xlCells row col i lst area)
  (vl-load-com)
  (defun inside(pt l)
    (defun tgoc(a b c) (abs (- pi (abs (- (angle b c) (angle a b))))))
    (equal 6.28319 (apply '+ (mapcar '(lambda(x y) (tgoc x pt y)) l (append (cdr l) (list (car l))))) 0.001)
  )
  (setq xlApp   (vlax-get-or-create-object "Excel.Application")
            xlCells (vlax-get-property
                      (vlax-get-property
                        (vlax-get-property
                          (vlax-invoke-method
                            (vlax-get-property xlApp "Workbooks")
                            "Add") "Sheets") "Item" 1) "Cells") row 0 col 1)
  (vla-put-visible xlApp :vlax-true)
 
  (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "X" '((0 . "TEXT"))))))
sst (vl-remove-if-not '(lambda (x) (distof (vla-get-TextString (vlax-ename->vla-object x)))) ss)
ssc (vl-remove-if '(lambda (x) (member x sst)) ss)
sst (mapcar '(lambda (x) (list (vlax-get (vlax-ename->vla-object x) 'TextAlignmentPoint)
 (vla-get-TextString (vlax-ename->vla-object x)))) sst) 
  )
  (prompt "\nChon khung pline:")
  (while (setq pl (ssget ":E:S" '((0 . "LWPOLYLINE"))))
    (setq pl (ssname pl 0)) (redraw pl 3)    
    (setq ssd (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= 10 (car x))) (entget pl)))
 oo (vl-remove-if-not '(lambda (x) (inside (vlax-get (vlax-ename->vla-object x) 'TextAlignmentPoint) ssd)) ssc))
    (if oo
      (progn 
(setq oo (car oo)
     ssc (vl-remove oo ssc)
     lst (list (vla-get-TextString (vlax-ename->vla-object oo))))
        (foreach pt ssd
          (setq txt (car (vl-sort sst '(lambda (x y) (< (distance (car x) pt) (distance (car y) pt)))))
       lst (append lst (list (last txt))) 
          )
        )
        (setq area (rtos (* 0.000001 (vla-get-Area (vlax-ename->vla-object pl))) 2 2)
     i -1 row (1+ row))
        (mapcar '(lambda (x) (vlax-put-property xlCells "Item" row  (+ col (setq i (1+ i))) x)) lst)
        (vlax-put-property xlCells "Item" row 9 area)
       )
    )
    (prompt "\nChon khung pline:")
  )
  (mapcar 'vlax-release-object (list xlApp xlCells))
  (mapcar '(lambda (x) (redraw x 4)) (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "X")))))
  (redraw)
  (princ)
)

<<

Filename: 318089_ttx+%C2%A0_tty.lsp
Tác giả: lemanhhung0302
Bài viết gốc: 393405
Tên lệnh: ar
Array trong Cad 2012

Th? lisp bên d??i:
 

(defun c:ar ( / ss p1 p2 therows thecols drows dcols)
	(vl-load-com)
	(setq ss (ssget))
	(setq p1 (getpoint " Specify first point: "))
	(setq p2 (getpoint p1 " Specify second point: "))
	(if (and p1 p2)
		(progn
			(if (= (car p1) (car p2))
				(setq therows 2 thecols 1 drows (- (cadr p2) (cadr p1)) dcols (- (cadr p2) (cadr p1)))
				(if (= (cadr p1) (cadr p2))
					(setq therows 1 thecols 2 drows (- (car p2) (car p1)) dcols (-...
>>

Th? lisp bên d??i:
 

(defun c:ar ( / ss p1 p2 therows thecols drows dcols)
	(vl-load-com)
	(setq ss (ssget))
	(setq p1 (getpoint " Specify first point: "))
	(setq p2 (getpoint p1 " Specify second point: "))
	(if (and p1 p2)
		(progn
			(if (= (car p1) (car p2))
				(setq therows 2 thecols 1 drows (- (cadr p2) (cadr p1)) dcols (- (cadr p2) (cadr p1)))
				(if (= (cadr p1) (cadr p2))
					(setq therows 1 thecols 2 drows (- (car p2) (car p1)) dcols (- (car p2) (car p1)))
					(setq therows 2 thecols 2 drows (- (cadr p2) (cadr p1)) dcols (- (car p2) (car p1)))
				)
			)
			(vla-sendcommand
				(vla-get-activedocument (vlax-get-acad-object))
				(strcat "array\rp\r\rR\rROW\r" (itoa therows) "\n" (rtos drows 2 10) "\n\nCOL\r" (itoa thecols) "\r" (rtos dcols 2 10) "\r\r")
			)
		)
	)
	(princ "\nwww.tankhanh.com.vn")
	(princ)
)

Chi ti?t t?i
http://www.cadviet.com/forum/topic/158911-cách-s?-d?ng-array-m?i-trong-autocad-v?i-lisp/


<<

Filename: 393405_ar.lsp
Tác giả: ketxu
Bài viết gốc: 396969
Tên lệnh: mbl
S?a Lisp ?ã Có

Quick code, m?i nhóm m?t phát Space nhé b?n :)  :

(defun c:mbl(/ _mBlock _ss->l)
	;; Private function
	(defun _ss->l (s / n e l)
	  (setq n (sslength s))
	  (while (setq e (ssname s (setq n (1- n))))
		(setq l (cons e l))
	  )  
	)
	(defun _mBlock(s p)			
	(entmake
	(list '(0 . "INSERT")
		(cons 2 
				(cond ((entmake (list '(0 . "BLOCK")
					(cons 2 "*anon")
					(cons 70  1)
					(cons 10 p)
					)
				)
				(mapcar...
>>

Quick code, m?i nhóm m?t phát Space nhé b?n :)  :

(defun c:mbl(/ _mBlock _ss->l)
	;; Private function
	(defun _ss->l (s / n e l)
	  (setq n (sslength s))
	  (while (setq e (ssname s (setq n (1- n))))
		(setq l (cons e l))
	  )  
	)
	(defun _mBlock(s p)			
	(entmake
	(list '(0 . "INSERT")
		(cons 2 
				(cond ((entmake (list '(0 . "BLOCK")
					(cons 2 "*anon")
					(cons 70  1)
					(cons 10 p)
					)
				)
				(mapcar '(lambda(i)
					(entmake (vl-remove-if '(lambda(x)(= (car x) 5)) (entget i)))
					(entdel i))
					(_ss->l s)
				)
				 (entmake '((0 . "ENDBLK")))			
				))
		)
	(cons 10 p)
	))
	(entmake (list (cons 0   "SEQEND")))
	)
	;Main 
	(while (setq s (ssget '((0 . "TEXT,LINE"))))
			(_mBlock s '(0 0))
	)
)

<<

Filename: 396969_mbl.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 397306
Tên lệnh: ha
Where are you from? how to buy clomid online no prescription uk Small companies don"t always want to take on the responsibility of helping employees to prepare for

Filename: 397306_ha.lsp
Tác giả: hoangkimoanh
Bài viết gốc: 397497
Tên lệnh: hh
[Nhờ chỉnh sửa] Lisp hatch nhanh.

Nhờ các anh giúp em sửa đoạn code dưới đây có lực nét của Hatch (lineweight = 0.09) giúp em với. em tìm mọi cách mà không được!

(defun c:Hh(/)  (vl-load-com)
 (command "-boundary" "") (SETQ A (GETPOINT "==> PICK DIEM : "))
(command "-layer" "m" "Hatch" "c" "8" "" "") 
 (command "bhatch" "P" "ANSI31" "20" "0" A "")
 (princ))

Filename: 397497_hh.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 394759
Tên lệnh: tt%C2%A0
Nhờ Sửa Lisp Copy Cộng Dồn Khoảng Cách

Gửi bạn: (bổ sung => hoặc chọn text để ghi kết quả hoặc chèn text mới)

(defun c:TT  (/ ent kqua obj sobichia sobitru sochia sotru ss ent-l poi)
 (vl-load-com)
 (initget "1 2 3 4")
 (or phep_tinh (setq phep_tinh "1"))
 (setq phep_tinh (cond ((getkword (strcat "\nChon phep tinh [1+/2-/3*/4:] <" phep_tinh ">:...
>>

Gửi bạn: (bổ sung => hoặc chọn text để ghi kết quả hoặc chèn text mới)

(defun c:TT  (/ ent kqua obj sobichia sobitru sochia sotru ss ent-l poi)
 (vl-load-com)
 (initget "1 2 3 4")
 (or phep_tinh (setq phep_tinh "1"))
 (setq phep_tinh (cond ((getkword (strcat "\nChon phep tinh [1+/2-/3*/4:] <" phep_tinh ">: ")))
                       (phep_tinh)))
 (cond ;; cong
       ((= phep_tinh "1")
        (prompt "\nChon text de cong:")
        (setq ss   (ssget '((0 . "*TEXT")))
              kqua 0)
        (while (and ss (> (sslength ss) 0))
         (setq kqua (+ kqua (atof (cdr (assoc 1 (entget (setq ent (ssname ss 0))))))))
         (ssdel ent ss)))
       ;;nhan
       ((= phep_tinh "3")
        (prompt "\nChon text de nhan:")
        (setq ss   (ssget '((0 . "*TEXT")))
              kqua 1)
        (while (and ss (> (sslength ss) 0))
         (setq kqua (* kqua (atof (cdr (assoc 1 (entget (setq ent (ssname ss 0))))))))
         (ssdel ent ss)))
       ;;tru
       ((= phep_tinh "2")
        (and (princ "\nChon so bi tru:")
             (setq sobitru (ssget "_+.:E:S" '((0 . "*TEXT"))))
             (setq sobitru (distof (cdr (assoc 1 (entget (setq ent (ssname sobitru 0)))))))
             (princ "\nChon so tru:")
             (setq sotru (ssget "_+.:E:S" '((0 . "*TEXT"))))
             (setq sotru (distof (cdr (assoc 1 (entget (setq ent (ssname sotru 0)))))))
             (setq kqua (- sobitru sotru))))
       ;;chia
       ((= phep_tinh "4")
        (and (princ "\nChon so bi chia:")
             (setq sobichia (ssget "_+.:E:S" '((0 . "*TEXT"))))
             (setq sobichia (distof (cdr (assoc 1 (entget (setq ent (ssname sobichia 0)))))))
             (princ "\nChon so chia:")
             (setq sochia (ssget "_+.:E:S" '((0 . "*TEXT"))))
             (setq sochia (distof (cdr (assoc 1 (entget (setq ent (ssname sochia 0)))))))
             (not (eq sochia 0))
             (setq kqua (/ sobichia sochia)))))
 (if (and (or ss (and sobitru sotru) (and sobichia sochia)) kqua)
  (progn (or ssle (setq ssle 0))
         (setq ssle (cond ((getint (strcat "\nSo so le <" (itoa ssle) ">: ")))
                          (ssle)))
         (princ (strcat "\nChon text de ghi ket qua [Enter->Insert Text] <" (rtos kqua 2 ssle) ">: "))
         (if (setq ss (ssget "_+.:E:S" '((0 . "*TEXT"))))
          (progn (setq obj (vlax-ename->vla-object (ssname ss 0)))
                 (vla-put-TextString obj (rtos kqua 2 ssle)))
          (and (setq poi (getpoint "\nDiem chen Text: "))
               (setq ent-l (vl-remove-if-not '(lambda (x) (member (car x) '(0 1 7 8 40 41 42 50 51 62 100))) (entget ent))
                     ent-l (append (subst (cons 1 (rtos kqua 2 ssle)) (assoc 1 ent-l) ent-l) (list (cons 10 poi))))
               (entmakex ent-l)))))
 (princ))

<<

Filename: 394759_tt%C2%A0.lsp
Tác giả: pphung183
Bài viết gốc: 398054
Tên lệnh: l1
Nh? Các Bác Vi?t Dùm Lisp Này Cho Ae Xd Tri?n Khai K?t C?u ^^

Lisp làm theo hướng bác ndtnv (không dùng Active X) + gợi ý của bạn  quocmanh04tt

Post Tham Khảo :

(defun c:l1 (/ dxf mid ss i en lst e lf lm p13 p14 l ang pt lt1...
>>

Lisp làm theo hướng bác ndtnv (không dùng Active X) + gợi ý của bạn  quocmanh04tt

Post Tham Khảo :

(defun c:l1 (/ dxf mid ss i en lst e lf lm p13 p14 l ang pt lt1 x lg1 ptm13 ptm14 lmg)
(defun dxf (code en) (cdr (assoc code (entget en))) )
(defun mid (p1 p2) (mapcar '(lambda (x y) (* (+ x y) 0.5)) p1 p2) )
(command "undo" "be")
(setq ss (ssget '((0 . "dimension") (-4 . "<or") (70 . 32) (70 . 33) (-4 . "or>")))) 
(setq i (sslength ss)) (while (setq en (ssname ss (setq i (1- i)))) (setq lst (entget en))
(setq e (tblobjname "dimstyle" (dxf 3 en)) lf (dxf 144 e))
(setq lm (vl-remove-if '(lambda (x) (member (car x) (list -1 330 5 410 2))) lst))
(setq p13 (dxf 13 en) p14 (dxf 14 en) l (dxf 42 en) pt (mid p13 p14))
(setq lt1 (/ l 6) lt1 (- lt1 (setq x (* 100 (fix (/ lt1 100)))))
lt1 (/ (+ (cond ((> lt1 50) 100) ((= lt1 0) 0) (50)) x) lf) lg1 (- (/ l lf) (* 2 lt1)))
(setq ang (angle p13 p14) pm13 (polar pt ang (* lg1 0.5)) 
pm14 (polar pt (+ pi ang) (* lg1 0.5)))
(entmod (subst (cons 13 pm13) (assoc 13 lm) lst))
(entmakex (subst (cons 14 pm14) (assoc 14 lm) lm))
(setq lmg (subst (cons 13 pm14) (assoc 13 lm) lm))
(entmakex (subst (cons 14 pm13) (assoc 14 lmg) lmg)) )
(command  "undo" "e") (princ))


<<

Filename: 398054_l1.lsp
Tác giả: friendship293a
Bài viết gốc: 113335
Tên lệnh: ch cso
Sửa hộ em code tính tổng lỗi này
Code sau em tìm được trên diễn đàn tính tổng tất cả các số và chọn số ghi kết quả nhưng báo lỗi
Select objects: Specify opposite corner: 2 found
Select objects: ; error: no function definition: TAO1
Command:
Ai sửa hộ em với ạ

Filename: 113335_ch_cso.lsp
Tác giả: ketxu
Bài viết gốc: 398227
Tên lệnh: fg
?óng Ngo?c Text, Mtext, Dim
(defun c:fg(/ s)
(vl-load-com)
(ssget '((0 . "*TEXT")))
(vlax-for o (setq s(vla-get-ActiveSelectionSet (vla-get-ActiveDocument (vlax-get-acad-object))))
	(vla-put-Textstring o (strcat "(" (vla-get-Textstring o) ")"))
)
(vla-delete s)
)

Filename: 398227_fg.lsp
Tác giả: Luu Nguyen
Bài viết gốc: 398209
Tên lệnh: fg
Đóng Ngoặc Text, Mtext, Dim

Chào các bạn trên diễn đàn cadviet.com, mình có sưu tầm được 1 lsp dùng để đóng ngoặc text(), nhưng phải thực hiện đến 3 bước mới xong chức năng này(phải nhập tiền tố, hậu tố rồi mới chọn đối tượng). Bây giờ mình nhờ mọi người trên diễn đàn ai biết giúp mình với, mình xin cảm ơn trước:
Khi gõ lệnh FG sau đó chọn đối tượng thì đối tượng sẽ được đóng...

>>

Chào các bạn trên diễn đàn cadviet.com, mình có sưu tầm được 1 lsp dùng để đóng ngoặc text(), nhưng phải thực hiện đến 3 bước mới xong chức năng này(phải nhập tiền tố, hậu tố rồi mới chọn đối tượng). Bây giờ mình nhờ mọi người trên diễn đàn ai biết giúp mình với, mình xin cảm ơn trước:
Khi gõ lệnh FG sau đó chọn đối tượng thì đối tượng sẽ được đóng ngoặc().


(Defun c:FG (/ c e ss txt cmde ttdangs ttdangt)
  (setq cmde (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)
  (setq ttdangt (getstring 5"\nChuoi muon them phia truoc:")) 
  (setq ttdangs (getstring 5"\nChuoi muon them phia sau:")) 
  (if (null ttdangt)(setq ttdangt ""))
  (if (null ttdangs)(setq ttdangs ""))
 (prompt "\nChon chu muon chinh.")
  (setq ss (ssget))
  (setq c 0)
  (if ss (setq e (ssname ss c)))
  (while e
    (setq e (entget e))
    ; Ensure entity is text
    (if (= (cdr (assoc 0 e)) "TEXT")
        (progn
                 (setq txt (strcat ttdangt (cdr (assoc 1 e)) ttdangs))
           (setq e (subst (cons 1 txt) (assoc 1 e) e))
           (entmod e)
        )
    )
    (setq c (1+ c)) ; Increment counter.
    (setq e (ssname ss c))  ; Obtain next entity.
   )
   (setvar "CMDECHO" cmde)
      (PrinC)
)


<<

Filename: 398209_fg.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 398435
Tên lệnh: ha
Xem giúp đoạn lisp của mình vẽ pline có nhập chiều dài và góc

Sẵn topic này, mình có thể hỏi các Pác lisp vẽ đường thẳng nối 2 đường thẳng cho trước với khoảng cách cố định và điểm băt đầu

 http://www.cadviet.com/upfiles/5/14941_drawing1.dwg

>>

Sẵn topic này, mình có thể hỏi các Pác lisp vẽ đường thẳng nối 2 đường thẳng cho trước với khoảng cách cố định và điểm băt đầu

 http://www.cadviet.com/upfiles/5/14941_drawing1.dwg

Tôi đã post lisp 22/4/2016, nhưng tôi đã xóa 26/4/2016 vì người hỏi đã ngủ quên.

<<

Filename: 398435_ha.lsp
Tác giả: ketxu
Bài viết gốc: 398539
Tên lệnh: fg
Đóng Ngoặc Text, Mtext, Dim
Quick code :
(defun c:fg(/ s sd)
(vl-load-com)
(ssget '((0 . "*TEXT,*DIMENSION")))
(vlax-for o (setq s(vla-get-ActiveSelectionSet (vla-get-ActiveDocument (vlax-get-acad-object))))
	(cond 
		(	(wcmatch (vla-get-ObjectName o) "*Text")
			(vla-put-Textstring o (strcat "(" (vla-get-Textstring o) ")"))
		)
		((vla-put-TextOverride o
			(strcat
				"("
					(if (/= (setq sd (vla-get-TextOverride o)) "") sd...
>>
Quick code :
(defun c:fg(/ s sd)
(vl-load-com)
(ssget '((0 . "*TEXT,*DIMENSION")))
(vlax-for o (setq s(vla-get-ActiveSelectionSet (vla-get-ActiveDocument (vlax-get-acad-object))))
	(cond 
		(	(wcmatch (vla-get-ObjectName o) "*Text")
			(vla-put-Textstring o (strcat "(" (vla-get-Textstring o) ")"))
		)
		((vla-put-TextOverride o
			(strcat
				"("
					(if (/= (setq sd (vla-get-TextOverride o)) "") sd "<>")
				")"
			)
		))			
	)
)
(and s (vla-delete s))
)

<<

Filename: 398539_fg.lsp

Trang 203/330

203