Jump to content
InfoFile
Tác giả: Doan Van Ha
Bài viết gốc: 236291
Tên lệnh: ha
Cách tạo 1 khoảng cách chung tới đối tượng cho nhiều dim line?

Vậy thì vầy!

(defun C:HA()
 (princ "\nCho cac Dim...")
 (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "Dimension"))))))
  (DimSpace ent))
 (princ))
(defun DimSpace(ent)
 (* 5 (getvar "dimscale") (Get_height ent)))
(defun Get_height(ent / blk1 blklst hei)
 (setq blk1 (cdr (assoc -2 (tblsearch "BLOCK" (cdr (assoc 2 (entget ent (list...
>>

Vậy thì vầy!

(defun C:HA()
 (princ "\nCho cac Dim...")
 (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "Dimension"))))))
  (DimSpace ent))
 (princ))
(defun DimSpace(ent)
 (* 5 (getvar "dimscale") (Get_height ent)))
(defun Get_height(ent / blk1 blklst hei)
 (setq blk1 (cdr (assoc -2 (tblsearch "BLOCK" (cdr (assoc 2 (entget ent (list "*"))))))))
 (while (setq blk1 (entnext blk1))
  (setq blklst (entget blk1))
  (if (= (cdr (assoc 0 blklst)) "MTEXT")
   (setq hei (cdr (assoc 40 blklst)))))
 hei)
 


<<

Filename: 236291_ha.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 236272
Tên lệnh: ha
tìm hình chiếu của 1 điểm lên mặt phẳng cho trước

Giao của đường thẳng đi qua điểm pt và vuông góc với mặt phẳng xác định bởi 3 điểm p1, p2, p3.

;----- Giao cua duong thang qua diem pt va vuong goc voi mat phang p1,p2,p3.
(defun C:HA( / pt p1 p2 p3 pt1 pg vt pt1)
 (or cal (arxload "geomcal"))
 (setq pt (getpoint "\nPick diem pt: "))
 (setq p1 (getpoint...
>>

Giao của đường thẳng đi qua điểm pt và vuông góc với mặt phẳng xác định bởi 3 điểm p1, p2, p3.

;----- Giao cua duong thang qua diem pt va vuong goc voi mat phang p1,p2,p3.
(defun C:HA( / pt p1 p2 p3 pt1 pg vt pt1)
 (or cal (arxload "geomcal"))
 (setq pt (getpoint "\nPick diem pt: "))
 (setq p1 (getpoint "\nPick diem p1 cua mat phang: "))
 (setq p2 (getpoint "\nPick diem p2 cua mat phang: "))
 (setq p3 (getpoint "\nPick diem p3 cua mat phang: "))
 (setq vt (cal "nor(p1,p2,p3)"))
 (setq pt1 (cal "pt+vt"))
 (setq pg (cal "ilp(pt,pt1,p1,p2,p3)"))
 (command "point" pg))

 

 


<<

Filename: 236272_ha.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 236344
Tên lệnh: ha
Lệnh Trim mở rộng

Thank bác Tue_NV đã phát hiện ra lỗi với POLYLINE. Chưa test nó nên sinh lắm chuyện phiền hà khi gặp nó.

Code mới.

;27/5/2013. Doan Van Ha -CadViet.com
;Co 3 kieu Trim:
;1). Trim theo Phia: pick diem phia nao thi Trim phia do (tuong tu offset).
;2). Trim doan Ngan: Trim phan ngan.
;3). Trim doan Dai: Trim phan dai.
;Khong Trim cac truong hop: doi tuong la duong kin; giao nhau tai hon 1...
>>

Thank bác Tue_NV đã phát hiện ra lỗi với POLYLINE. Chưa test nó nên sinh lắm chuyện phiền hà khi gặp nó.

Code mới.

;27/5/2013. Doan Van Ha -CadViet.com
;Co 3 kieu Trim:
;1). Trim theo Phia: pick diem phia nao thi Trim phia do (tuong tu offset).
;2). Trim doan Ngan: Trim phan ngan.
;3). Trim doan Dai: Trim phan dai.
;Khong Trim cac truong hop: doi tuong la duong kin; giao nhau tai hon 1 diem; giao nhau bieu kien.
(defun C:HA( / ent0 ent ent2 ss typ p ento lstg lst len1 len2)
 (vl-load-com) (command "undo" "be") (setq cmd (getvar "cmdecho")) (setvar "cmdecho" 0)
 (if
  (and
   (princ "\nChon 1 doi tuong dao cat...")
   (setq ss (ssget ":S" '((0 . "Line,Polyline,Lwpolyline,Spline,Arc"))))
   (setq ent0 (ssname ss 0))
   (setq ss (ssget '((0 . "Line,Polyline,Lwpolyline,Spline,Arc")))))
  (progn
   (initget "P N D")
   (setq typ (getkword "\nChon kieu Trim <P>: "))
   (if (not typ) (setq typ "P"))
   (if (= typ "P")
    (progn
(initget 65)
     (setq p (getdist (GetP (vlax-curve-getStartPoint ent0) (vlax-curve-getEndPoint ent0) (/ (HA:LenCur ent0) 2) ent0) "\nPick chon phia can Trim: "))
     (command "offset" 1E-3 ent0 p "")
     (setq ento (entlast))))
   (setq objlst (mapcar 'vlax-ename->vla-object (setq entlst (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssadd ent0 ss)))))))
   (command "zoom" "w" (setq pll (car (LM:ListBoundingBox objlst))) (setq pur (cadr (LM:ListBoundingBox objlst))))
   (foreach ent1 (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
    (setq lstg (HA:Giao (vlax-ename->vla-object ent0) (vlax-ename->vla-object ent1) acExtendNone))
    (if (and (= (length lstg) 1) (not (equal (car lstg) (vlax-curve-getStartPoint ent1) 1E-3)) (not (equal (car lstg) (vlax-curve-getEndPoint ent1) 1E-3)))
     (progn
 (setq lst (HA:GetNewEnt12 ent1 pll pur (car lstg)))
      (setq len1 (HA:LenCur (setq ent1 (car lst))) len2 (HA:LenCur (setq ent2 (cadr lst))))
      (cond
       ((or (and (= typ "N") (> len1 len2)) (and (= typ "D") (< len1 len2))) (entdel ent2))
  ((or (and (= typ "N") (< len1 len2)) (and (= typ "D") (> len1 len2))) (entdel ent1))
       ((= typ "P")
        (if (HA:Giao (vlax-ename->vla-object ento) (vlax-ename->vla-object ent1) acExtendNone)
    (entdel ent1)
    (entdel ent2)))))))
   (if ento (entdel ento))))
 (command "undo" "e") (setvar "cmdecho" cmd) (princ))
(defun GetP (pg ph kc cur / dg dh dp)
 (setq dg (vlax-curve-getDistAtPoint cur pg))
 (setq dh (vlax-curve-getDistAtPoint cur ph))
 (if (> dh dg)
  (setq dp (+ dg kc))
  (setq dp (- dg kc)))
 (vlax-curve-getPointAtDist cur dp))
(defun HA:GetNewEnts1(ename / new)
 (while (setq ename (entnext ename))
  (if (entget ename) (setq new (cons ename new))))
 new)
(defun HA:GetNewEnt12(ent pll pur pt / typ1 ss1 ss2 entlst)
 (setq typ1 (cdr (assoc 0 (entget ent))))
 (setq ss1 (ssget "c" pll pur '((0 . "POLYLINE"))))
 (command ".break" ent "_non" pt "_non" pt)
 (if (equal typ1 "POLYLINE")
  (progn
   (setq ss2 (ssadd))
   (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "c" pll pur '((0 . "POLYLINE"))))))
    (if (not (ssmemb ent ss1))
     (ssadd ent ss2))
   (setq entlst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss2))))
   (list (car entlst) (cadr entlst))))
  (list ent (entlast))))
(defun HA:LenCur(ent)
 (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent)))
(defun HA:Giao(obj1 obj2 mode / l r)
 (setq l (vlax-invoke obj1 'intersectwith obj2 mode))
 (repeat (/ (length l) 3)
  (setq r (cons (list (car l) (cadr l) (caddr l)) r) l (cdddr l)))
 r)
(defun LM:ListBoundingBox(objlst / l1 l2 ll ur)
 (foreach obj objlst
  (vla-getboundingbox obj 'll 'ur)
  (setq l1 (cons (vlax-safearray->list ll) l1) l2 (cons (vlax-safearray->list ur) l2)))
  (mapcar (function (lambda(a b) (apply 'mapcar (cons a b)))) '(min max) (list l1 l2)))
 


<<

Filename: 236344_ha.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 236395
Tên lệnh: ha
[Đã xong] Lệnh Trim mở rộng
Phát hiện ra rồi! Chắc do thiếu "non"?

  Code chép lên 4R tự dưng nó mất đi mấy chữ rất buồn cười: mất chu "kin", mất dòng "Chon cac doi tuong bi cat..." 

4R dạo này lỡ post lisp là không sửa...

>>
Phát hiện ra rồi! Chắc do thiếu "non"?

  Code chép lên 4R tự dưng nó mất đi mấy chữ rất buồn cười: mất chu "kin", mất dòng "Chon cac doi tuong bi cat..." 

4R dạo này lỡ post lisp là không sửa code lisp được, đành phải post bài mới tốn đất. Không biết mọi người có bị như tôi không?

;27/5/2013. Doan Van Ha -CadViet.com
;Co 3 kieu Trim:
;1). Trim theo Phia: pick diem phia nao thi Trim phia do (tuong tu offset).
;2). Trim doan Ngan: Trim phan ngan.
;3). Trim doan Dai: Trim phan dai.
;Khong Trim cac truong hop: doi tuong la duong kin ; giao nhau tai hon 1 diem; giao nhau bieu kien.
(defun C:HA( / ent0 ent ent2 ss typ ento lstg lst len1 len2)
 (vl-load-com) (command "undo" "be") (setq cmd (getvar "cmdecho") osm (getvar "osmode")) (setvar "cmdecho" 0) (setvar "osmode" 0)
 (if
  (and
   (princ "\nChon 1 doi tuong dao cat...")
   (setq ss (ssget ":S" '((0 . "Line,Polyline,Lwpolyline,Spline,Arc"))))
   (setq ent0 (ssname ss 0))
   (princ "\nChon cac doi tuong bi cat...")
   (setq ss (ssget '((0 . "Line,Polyline,Lwpolyline,Spline,Arc")))))
  (progn
   (initget "P N D")
   (setq typ (getkword "\nChon kieu Trim <P>: "))
   (if (not typ) (setq typ "P"))
   (if (= typ "P")
    (progn
(initget 65)
     (setq p (getdist (GetP (vlax-curve-getStartPoint ent0) (vlax-curve-getEndPoint ent0) (/ (HA:LenCur ent0) 2) ent0) "\nPick chon phia can Trim: "))
     (command "offset" 1E-3 ent0 p "")
     (setq ento (entlast))))
   (setq objlst (mapcar 'vlax-ename->vla-object (setq entlst (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssadd ent0 ss)))))))
   (command "zoom" "w" (setq pll (car (LM:ListBoundingBox objlst))) (setq pur (cadr (LM:ListBoundingBox objlst))))
   (foreach ent1 (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
    (setq lstg (HA:Giao (vlax-ename->vla-object ent0) (vlax-ename->vla-object ent1) acExtendNone))
    (if (and (= (length lstg) 1) (not (equal (car lstg) (vlax-curve-getStartPoint ent1) 1E-3)) (not (equal (car lstg) (vlax-curve-getEndPoint ent1) 1E-3)))
     (progn
 (setq lst (HA:GetNewEnt12 ent1 pll pur (car lstg)))
      (setq len1 (HA:LenCur (setq ent1 (car lst))) len2 (HA:LenCur (setq ent2 (cadr lst))))
      (cond
       ((or (and (= typ "N") (> len1 len2)) (and (= typ "D") (< len1 len2))) (entdel ent2))
  ((or (and (= typ "N") (< len1 len2)) (and (= typ "D") (> len1 len2))) (entdel ent1))
       ((= typ "P")
        (if (HA:Giao (vlax-ename->vla-object ento) (vlax-ename->vla-object ent1) acExtendNone)
    (entdel ent1)
    (entdel ent2)))))))
   (if ento (entdel ento))))
 (command "undo" "e") (setvar "cmdecho" cmd) (setvar "osmode" osm) (princ))
(defun GetP (pg ph kc cur / dg dh dp)
 (setq dg (vlax-curve-getDistAtPoint cur pg))
 (setq dh (vlax-curve-getDistAtPoint cur ph))
 (if (> dh dg)
  (setq dp (+ dg kc))
  (setq dp (- dg kc)))
 (vlax-curve-getPointAtDist cur dp))
(defun HA:GetNewEnts1(ename / new)
 (while (setq ename (entnext ename))
  (if (entget ename) (setq new (cons ename new))))
 new)
(defun HA:GetNewEnt12(ent pll pur pt / typ1 ss1 ss2 entlst)
 (setq typ1 (cdr (assoc 0 (entget ent))))
 (setq ss1 (ssget "c" pll pur '((0 . "POLYLINE"))))
 (command ".break" ent pt pt)
 (if (equal typ1 "POLYLINE")
  (progn
   (setq ss2 (ssadd))
   (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "c" pll pur '((0 . "POLYLINE"))))))
    (if (not (ssmemb ent ss1))
     (ssadd ent ss2))
   (setq entlst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss2))))
   (list (car entlst) (cadr entlst))))
  (list ent (entlast))))
(defun HA:LenCur(ent)
 (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent)))
(defun HA:Giao(obj1 obj2 mode / l r)
 (setq l (vlax-invoke obj1 'intersectwith obj2 mode))
 (repeat (/ (length l) 3)
  (setq r (cons (list (car l) (cadr l) (caddr l)) r) l (cdddr l)))
 r)
(defun LM:ListBoundingBox(objlst / l1 l2 ll ur)
 (foreach obj objlst
  (vla-getboundingbox obj 'll 'ur)
  (setq l1 (cons (vlax-safearray->list ll) l1) l2 (cons (vlax-safearray->list ur) l2)))
  (mapcar (function (lambda(a B) (apply 'mapcar (cons a B)))) '(min max) (list l1 l2)))
 


<<

Filename: 236395_ha.lsp
Tác giả: Nguyen Hoanh
Bài viết gốc: 129739
Tên lệnh: cad2geo cad2geo
Cần lisp chuyển dwg/dxf sang Plaxis

Lisp dưới đây sẽ giúp bạn chuyển dữ liệu từ AutoCAD sang file . Tên lệnh là cad2geo
The lisp routine below will help you to transfer data from AutoCAD to file format. Command's name is cad2geo


Filename: 129739_cad2geo_cad2geo.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 236450
Tên lệnh: adjustdim selfadjustdim
Cách tạo 1 khoảng cách chung tới đối tượng cho nhiều dim line?

Đây bạn!

(defun GetDxf(n e)
 (cdr (assoc n e)))
(defun ModDxf(n v e)
 (if (GetDxf n e)
  (entmod (subst (cons n  v) (assoc n e) e))
  (entmod (append e (list (cons n  v))))))
(defun TSel(et ms)
 (if ms (princ ms))
 (ssget (if et (list (cons 0 et)))))
(defun AdjustDim1 (p l e / a)
 (if (= 0 (logand 92 (GetDxf 70 e)))
  (progn
 ...
>>

Đây bạn!

(defun GetDxf(n e)
 (cdr (assoc n e)))
(defun ModDxf(n v e)
 (if (GetDxf n e)
  (entmod (subst (cons n  v) (assoc n e) e))
  (entmod (append e (list (cons n  v))))))
(defun TSel(et ms)
 (if ms (princ ms))
 (ssget (if et (list (cons 0 et)))))
(defun AdjustDim1 (p l e / a)
 (if (= 0 (logand 92 (GetDxf 70 e)))
  (progn
   (setq a (angle (GetDxf 14 e) (GetDxf 10 e)))
   (ModDxf 10 (polar p a  (if (= 1 (rem  (GetDxf 70 e) 2)) l (/ l (abs (sin (- a (GetDxf 50 e))))))) e))))
(defun AdjustDim(ss / i p)
 (if ss
  (progn
   (setq p (trans (getpoint "\nBase point:")1 0) i -1)
   (repeat (sslength ss)
(setq i (1+ i))
(AdjustDim1 p (DimSpace (ssname ss i)) (entget (ssname ss i))))))
 (princ))
(defun C:AdjustDim()
 (AdjustDim (TSel "DIMENSION" "\nSelect Dimensions :")))
(defun C:SelfAdjustDim( / e)
 (setq i -1 ss (TSel "DIMENSION" "\nSelect Dimensions :"))
 (if ss
  (repeat (sslength ss)
   (setq i (1+ i) e (entget (ssname ss i)))
   (AdjustDim1 (GetDxf 14 e) (DimSpace (ssname ss i)) e)))
 (princ))
(defun DimSpace(ent / blk1 blklst hei)
 (setq blk1 (cdr (assoc -2 (tblsearch "BLOCK" (cdr (assoc 2 (entget ent (list "*"))))))))
 (while (setq blk1 (entnext blk1))
  (setq blklst (entget blk1))
  (if (= (cdr (assoc 0 blklst)) "MTEXT")
   (setq hei (cdr (assoc 40 blklst)))))
 (* 5 (getvar "dimscale") hei))
 


<<

Filename: 236450_adjustdim_selfadjustdim.lsp
Tác giả: Tue_NV
Bài viết gốc: 236519
Tên lệnh: mtr
[Đã xong] Lệnh Trim mở rộng

Như đã hẹn, Tue_NV post lisp trim "mở rộng" các đối tượng gồm: Trim theo phía, trim cạnh ngắn của đối tượng, trim cạnh dài của đối tượng. Đường dao cắt là 1 Curve bất kì: Line, Pline, Spline, Arc, Circle, ellipse. 

 

(defun c:mtr(/ ssdao sscat pt Tue-list-ss Tue-geom-inters dgiao)
;;write by Tue_NV
  (defun Tue-ss-list (L-ss-vlaobj / n L Lst ssg vlaobj)
  (mapcar 'set '(ssg vlaobj)...
>>

Như đã hẹn, Tue_NV post lisp trim "mở rộng" các đối tượng gồm: Trim theo phía, trim cạnh ngắn của đối tượng, trim cạnh dài của đối tượng. Đường dao cắt là 1 Curve bất kì: Line, Pline, Spline, Arc, Circle, ellipse. 

 

(defun c:mtr(/ ssdao sscat pt Tue-list-ss Tue-geom-inters dgiao)
;;write by Tue_NV
  (defun Tue-ss-list (L-ss-vlaobj / n L Lst ssg vlaobj)
  (mapcar 'set '(ssg vlaobj) L-ss-vlaobj)
  (setq L (sslength ssg))
  (Repeat L
        (setq ename (ssname ssg (setq L (1- L))))
          (setq Lst (cons (if vlaobj (vlax-ename->vla-object ename) ename) Lst))
  )
)
(defun Tue-geom-inters(e1 e2 flag / Lst_tong Lst);;;Tue-list-tach
  (if (= (type e1) 'ENAME) (setq e1 (vlax-ename->vla-object e1)))
  (if (= (type e2) 'ENAME) (setq e2 (vlax-ename->vla-object e2)))
  (vlax-invoke e1 'IntersectWith e2 flag)
)
(setvar "cmdecho" 0)
  (princ "\nChon cac doi tuong bi cat :")
   (setq sscat (ssget '((0 . "*line,Arc"))))
  (command ".draworder" sscat "" "F")
  (princ "\nChon Dao cat :")
  (setq ssdao (ssget ":S" '((0 . "*Line,Arc,ELLIPSE,CIRCLE"))))
  (sssetfirst nil ssdao)
  (initget "N D")
  (setq pt (getpoint "\nPick chon theo phia /doanNgan/doanDai] : "))
(if (eq (type pt) 'LIST)
  (foreach x (Tue-ss-list (list sscat))
       (if (Tue-geom-inters
                       (setq entps (entmakex (list (cons 0 "LINE") (cons 10 pt) (cons 11 (vlax-curve-getendpoint x)) (cons 60 1) )));
                      (ssname ssdao 0) 0)
            (Command "trim" ssdao x "" (vlax-curve-getstartpoint x) "")
            (Command "trim" ssdao x "" (vlax-curve-getendpoint x) "")
          )
        (entdel entps)
   )
 )
(if (= pt "N")
  (foreach x (Tue-ss-list (list sscat))
    (if (= (length (setq dgiao (Tue-geom-inters (ssname ssdao 0) x 0))) 3)
       (if (< (vlax-curve-getparamatpoint x (Tue-geom-inters (ssname ssdao 0) x 0))
                (/ (vlax-curve-getendparam x) 2.0))
            (Command "trim" ssdao x "" (vlax-curve-getstartpoint x) "")
            (Command "trim" ssdao x "" (vlax-curve-getendpoint x) "")
          )
      )
   )
 )
 (if (= pt "D")
  (foreach x (Tue-ss-list (list sscat))
    (if (= (length (setq dgiao (Tue-geom-inters (ssname ssdao 0) x 0))) 3)
       (if (> (vlax-curve-getparamatpoint x (Tue-geom-inters (ssname ssdao 0) x 0))
                (/ (vlax-curve-getendparam x) 2.0))
            (Command "trim" ssdao x "" (vlax-curve-getstartpoint x) "")
            (Command "trim" ssdao x "" (vlax-curve-getendpoint x) "")
          )
      )
   )
 )
 )
(defun c:mtr(/ ssdao sscat pt Tue-list-ss Tue-geom-inters dgiao)
  (defun Tue-ss-list (L-ss-vlaobj / n L Lst ssg vlaobj)
  (mapcar 'set '(ssg vlaobj) L-ss-vlaobj)
  (setq L (sslength ssg))
  (Repeat L
        (setq ename (ssname ssg (setq L (1- L))))
(setq Lst (cons (if vlaobj (vlax-ename->vla-object ename) ename) Lst))
  ) 
)
(defun Tue-geom-inters(e1 e2 flag / Lst_tong Lst);;;Tue-list-tach
  (if (= (type e1) 'ENAME) (setq e1 (vlax-ename->vla-object e1)))
  (if (= (type e2) 'ENAME) (setq e2 (vlax-ename->vla-object e2)))
  (vlax-invoke e1 'IntersectWith e2 flag)
)
(setvar "cmdecho" 0)
  (princ "\nChon cac doi tuong bi cat :")
   (setq sscat (ssget '((0 . "*line,Arc"))))
  (command ".draworder" sscat "" "F")
  (princ "\nChon Dao cat :")
  (setq ssdao (ssget ":S" '((0 . "*Line,Arc,ELLIPSE,CIRCLE"))))
  (sssetfirst nil ssdao)
  (initget "N D")
  (setq pt (getpoint "\nPick chon theo phia /doanNgan/doanDai] : "))
(if (eq (type pt) 'LIST)
  (foreach x (Tue-ss-list (list sscat))
       (if (Tue-geom-inters
   (setq entps (entmakex (list (cons 0 "LINE") (cons 10 pt) (cons 11 (vlax-curve-getendpoint x)) (cons 60 1) )));
           (ssname ssdao 0) 0)
 (Command "trim" ssdao x "" (vlax-curve-getstartpoint x) "")
 (Command "trim" ssdao x "" (vlax-curve-getendpoint x) "")
)
        (entdel entps) 
   )
 )
(if (= pt "N")
  (foreach x (Tue-ss-list (list sscat))
    (if (= (length (setq dgiao (Tue-geom-inters (ssname ssdao 0) x 0))) 3)
       (if (< (vlax-curve-getparamatpoint x (Tue-geom-inters (ssname ssdao 0) x 0))
     (/ (vlax-curve-getendparam x) 2.0))
 (Command "trim" ssdao x "" (vlax-curve-getstartpoint x) "")
 (Command "trim" ssdao x "" (vlax-curve-getendpoint x) "")
)
      )
   )
 )
 (if (= pt "D")
  (foreach x (Tue-ss-list (list sscat))
    (if (= (length (setq dgiao (Tue-geom-inters (ssname ssdao 0) x 0))) 3)
       (if (> (vlax-curve-getparamatpoint x (Tue-geom-inters (ssname ssdao 0) x 0))
     (/ (vlax-curve-getendparam x) 2.0))
 (Command "trim" ssdao x "" (vlax-curve-getstartpoint x) "")
 (Command "trim" ssdao x "" (vlax-curve-getendpoint x) "")
)
      )
   )
 )
 )
(defun c:mtr(/ ssdao sscat pt Tue-list-ss Tue-geom-inters dgiao)
  (defun Tue-ss-list (L-ss-vlaobj / n L Lst ssg vlaobj)
  (mapcar 'set '(ssg vlaobj) L-ss-vlaobj)
  (setq L (sslength ssg))
  (Repeat L
        (setq ename (ssname ssg (setq L (1- L))))
(setq Lst (cons (if vlaobj (vlax-ename->vla-object ename) ename) Lst))
  ) 
)
(defun Tue-geom-inters(e1 e2 flag / Lst_tong Lst);;;Tue-list-tach
  (if (= (type e1) 'ENAME) (setq e1 (vlax-ename->vla-object e1)))
  (if (= (type e2) 'ENAME) (setq e2 (vlax-ename->vla-object e2)))
  (vlax-invoke e1 'IntersectWith e2 flag)
)
(setvar "cmdecho" 0)
  (princ "\nChon cac doi tuong bi cat :")
   (setq sscat (ssget '((0 . "*line,Arc"))))
  (command ".draworder" sscat "" "F")
  (princ "\nChon Dao cat :")
  (setq ssdao (ssget ":S" '((0 . "*Line,Arc,ELLIPSE,CIRCLE"))))
  (sssetfirst nil ssdao)
  (initget "N D")
  (setq pt (getpoint "\nPick chon theo phia /doanNgan/doanDai] : "))
(if (eq (type pt) 'LIST)
  (foreach x (Tue-ss-list (list sscat))
       (if (Tue-geom-inters
   (setq entps (entmakex (list (cons 0 "LINE") (cons 10 pt) (cons 11 (vlax-curve-getendpoint x)) (cons 60 1) )));
           (ssname ssdao 0) 0)
 (Command "trim" ssdao x "" (vlax-curve-getstartpoint x) "")
 (Command "trim" ssdao x "" (vlax-curve-getendpoint x) "")
)
        (entdel entps) 
   )
 )
(if (= pt "N")
  (foreach x (Tue-ss-list (list sscat))
    (if (= (length (setq dgiao (Tue-geom-inters (ssname ssdao 0) x 0))) 3)
       (if (< (vlax-curve-getparamatpoint x (Tue-geom-inters (ssname ssdao 0) x 0))
     (/ (vlax-curve-getendparam x) 2.0))
 (Command "trim" ssdao x "" (vlax-curve-getstartpoint x) "")
 (Command "trim" ssdao x "" (vlax-curve-getendpoint x) "")
)
      )
   )
 )
 (if (= pt "D")
  (foreach x (Tue-ss-list (list sscat))
    (if (= (length (setq dgiao (Tue-geom-inters (ssname ssdao 0) x 0))) 3)
       (if (> (vlax-curve-getparamatpoint x (Tue-geom-inters (ssname ssdao 0) x 0))
     (/ (vlax-curve-getendparam x) 2.0))
 (Command "trim" ssdao x "" (vlax-curve-getstartpoint x) "")
 (Command "trim" ssdao x "" (vlax-curve-getendpoint x) "")
)
      )
   )
 )
 )

<<

Filename: 236519_mtr.lsp
Tác giả: Tue_NV
Bài viết gốc: 236581
Tên lệnh: mtr
Lệnh Trim mở rộng

Hình tôi khoanh tròn nhé!

http://www.cadviet.com/upfiles/3/67029_trim_loi.dwg

 

Tue_NV đã có tính tới "vòi bấu víu không được chọn" mà chưa tính tới "vòi bấu víu" được chọn nên mới xảy ra tình trạng...

>>

Hình tôi khoanh tròn nhé!

http://www.cadviet.com/upfiles/3/67029_trim_loi.dwg

 

Tue_NV đã có tính tới "vòi bấu víu không được chọn" mà chưa tính tới "vòi bấu víu" được chọn nên mới xảy ra tình trạng này.

Đã sửa lại code. Bác DVH và các bạn thử xem :

@KetXu: Có TH như bạn nêu. Nên chăng sử dụng Offset dẫn hướng rồi trim. Ý bạn thế nào?

 

 
(defun c:mtr(/ ssdao sscat pt Tue-list-ss Tue-geom-inters dgiao lst-cat lst-cat2 XYmin XYmax Lx Ly)
;;;;;write by Tue_NV
  (defun Tue-ss-list (L-ss-vlaobj / n L Lst ssg vlaobj)
  (mapcar 'set '(ssg vlaobj) L-ss-vlaobj)
  (setq L (sslength ssg))
  (Repeat L
        (setq ename (ssname ssg (setq L (1- L))))
(setq Lst (cons (if vlaobj (vlax-ename->vla-object ename) ename) Lst))
  ) 
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
(defun Tue-geom-inters(e1 e2 flag / Lst_tong Lst);;;Tue-list-tach
  (if (= (type e1) 'ENAME) (setq e1 (vlax-ename->vla-object e1)))
  (if (= (type e2) 'ENAME) (setq e2 (vlax-ename->vla-object e2)))
  (vlax-invoke e1 'IntersectWith e2 flag)
)
(command "undo" "be")
(setvar "cmdecho" 0)
  (princ "\nChon cac doi tuong bi cat :")
   (setq sscat (ssget '((0 . "*line,Arc"))))
  (command ".draworder" sscat "" "F")
  (princ "\nChon Dao cat :")
  (setq ssdao (ssget ":S" '((0 . "*Line,Arc,ELLIPSE,CIRCLE"))))
  (sssetfirst nil ssdao)
  (setq sscat2 (ssadd))
  (foreach x (vl-remove (ssname ssdao 0) (Tue-ss-list (list sscat)))
     (if (Tue-geom-inters x (ssname ssdao 0) 0) 
(setq lst-cat (append lst-cat (list x)))
(setq lst-cat2 (append lst-cat2 (list x)))
    )
  )
(foreach x (Tue-ss-list (list sscat))
(vla-getboundingbox (vlax-ename->vla-object x) 'minp 'maxp)
(setq LX (append LX (list (car(safearray-value minp)))
   (list (car(safearray-value maxp)))))
(setq LY (append LY (list (cadr(safearray-value minp)))
   (list (cadr(safearray-value maxp)))))
)
   (setq XYmin (list (apply 'min LX) (apply 'min LY) 0.0))
   (setq XYmax (list (apply 'max LX) (apply 'max LY) 0.0))
 
  (initget "N D")
  (setq pt (getpoint "\nPick chon theo phia /doanNgan/doanDai] : "))
(command "zoom" XYmin XYmax)
(if (eq (type pt) 'LIST)
  (progn (mapcar 'entdel lst-cat2)
  (foreach x lst-cat
       (if (Tue-geom-inters
   (setq entps (entmakex (list (cons 0 "LINE") (cons 10 pt) (cons 11 (vlax-curve-getendpoint x)) (cons 60 1) )));
           (ssname ssdao 0) 0)
 (Command "trim" ssdao x "" (vlax-curve-getstartpoint x) "")
 (Command "trim" ssdao x "" (vlax-curve-getendpoint x) "")
)
        (entdel entps) 
   )
(mapcar 'entdel lst-cat2)
  )
 )
(if (= pt "N")
  (progn (mapcar 'entdel lst-cat2)
  (foreach x lst-cat
    (if (= (length (setq dgiao (Tue-geom-inters (ssname ssdao 0) x 0))) 3)
       (if (< (vlax-curve-getparamatpoint x (Tue-geom-inters (ssname ssdao 0) x 0))
     (/ (vlax-curve-getendparam x) 2.0))
 (Command "trim" ssdao x "" (vlax-curve-getstartpoint x) "")
 (Command "trim" ssdao x "" (vlax-curve-getendpoint x) "")
)
      )
   )
(mapcar 'entdel lst-cat2)
  )
 )
 (if (= pt "D")
  (progn (mapcar 'entdel lst-cat2)
  (foreach x lst-cat
    (if (= (length (setq dgiao (Tue-geom-inters (ssname ssdao 0) x 0))) 3)
       (if (> (vlax-curve-getparamatpoint x (Tue-geom-inters (ssname ssdao 0) x 0))
     (/ (vlax-curve-getendparam x) 2.0))
 (Command "trim" ssdao x "" (vlax-curve-getstartpoint x) "")
 (Command "trim" ssdao x "" (vlax-curve-getendpoint x) "")
)
      )
   )
(mapcar 'entdel lst-cat2)
  )
 )
(command "zoom" "p")
(command "undo" "end")
 )

<<

Filename: 236581_mtr.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 236595
Tên lệnh: ha
Lệnh Trim mở rộng

Lisp đã sửa theo các góp ý từ bài #14 đến #16.

;28/5/2013. Doan Van Ha -CadViet.com
;Co 3 kieu Trim:
;1). Trim theo Phia: pick diem phia nao thi Trim phia do (tuong tu offset).
;2). Trim doan Ngan.
;3). Trim doan Dai.
;Khong Trim cac truong hop: doi tuong la duong kin ; giao nhau tai hon 1 diem ; giao nhau bieu kien.
(defun C:HA( / ent0 ent ent2 ss ento lstg lst len1 len2 objlst...
>>

Lisp đã sửa theo các góp ý từ bài #14 đến #16.

;28/5/2013. Doan Van Ha -CadViet.com
;Co 3 kieu Trim:
;1). Trim theo Phia: pick diem phia nao thi Trim phia do (tuong tu offset).
;2). Trim doan Ngan.
;3). Trim doan Dai.
;Khong Trim cac truong hop: doi tuong la duong kin ; giao nhau tai hon 1 diem ; giao nhau bieu kien.
(defun C:HA( / ent0 ent ent2 ss ento lstg lst len1 len2 objlst typ)
 (vl-load-com) (command "undo" "be") (setq cmd (getvar "cmdecho") osm (getvar "osmode"))
 (if
  (and
   (princ "\nChon 1 doi tuong dao cat...")
   (setq ss (ssget ":S" '((0 . "Line,Polyline,Lwpolyline,Spline,Arc"))))
   (setq ent0 (ssname ss 0))
   (princ "\nChon cac doi tuong bi cat...")
   (setq ss (ssget '((0 . "Line,Polyline,Lwpolyline,Spline,Arc")))))
  (progn
   (initget "N D") (setq typ (getpoint "Pick phia can Trim hoac chon kieu Trim <N>: "))
   (if (not typ) (setq typ "N"))
   (setvar "cmdecho" 0) (setvar "osmode" 0)
   (setq objlst (mapcar 'vlax-ename->vla-object (setq entlst (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssadd ent0 ss)))))))
   (command "zoom" "w" (setq pll (car (LM:ListBoundingBox objlst))) (setq pur (cadr (LM:ListBoundingBox objlst))))
   (if (listp typ) 
    (progn
     (command "offset" (* (getvar "viewsize") 1E-6) ent0 typ "")
     (setq ento (entlast))))
   (foreach ent1 (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
    (setq lstg (HA:Giao (vlax-ename->vla-object ent0) (vlax-ename->vla-object ent1) acExtendNone))
    (if (and (= (length lstg) 1) (not (equal (car lstg) (vlax-curve-getStartPoint ent1) 1E-3)) (not (equal (car lstg) (vlax-curve-getEndPoint ent1) 1E-3)))
     (progn
 (setq lst (HA:GetNewEnt12 ent1 pll pur (car lstg)))
      (setq len1 (HA:LenCur (setq ent1 (car lst))) len2 (HA:LenCur (setq ent2 (cadr lst))))
      (cond
       ((or (and (= typ "N") (> len1 len2)) (and (= typ "D") (< len1 len2))) (entdel ent2))
  ((or (and (= typ "N") (< len1 len2)) (and (= typ "D") (> len1 len2))) (entdel ent1))
       ((listp typ)
        (if (HA:Giao (vlax-ename->vla-object ento) (vlax-ename->vla-object ent1) acExtendNone)
      (entdel ent1)
    (entdel ent2)))))))
   (if ento (entdel ento))))
 (setvar "cmdecho" cmd) (setvar "osmode" osm) (command "zoom" "p") (command "undo" "e") (princ))
(defun HA:GetNewEnt12(ent pll pur pt / typ1 ss1 ss2 entlst)
 (setq typ1 (cdr (assoc 0 (entget ent))))
 (setq ss1 (ssget "c" pll pur '((0 . "POLYLINE"))))
 (command ".break" ent pt pt)
 (if (equal typ1 "POLYLINE")
  (progn
   (setq ss2 (ssadd))
   (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "c" pll pur '((0 . "POLYLINE"))))))
    (if (not (ssmemb ent ss1))
     (ssadd ent ss2))
   (setq entlst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss2))))
   (list (car entlst) (cadr entlst))))
  (list ent (entlast))))
(defun HA:LenCur(ent)
 (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent)))
(defun HA:Giao(obj1 obj2 mode / l r)
 (setq l (vlax-invoke obj1 'intersectwith obj2 mode))
 (repeat (/ (length l) 3)
  (setq r (cons (list (car l) (cadr l) (caddr l)) r) l (cdddr l)))
 r)
(defun LM:ListBoundingBox(objlst / l1 l2 ll ur)
 (foreach obj objlst
  (vla-getboundingbox obj 'll 'ur)
  (setq l1 (cons (vlax-safearray->list ll) l1) l2 (cons (vlax-safearray->list ur) l2)))
  (mapcar (function (lambda(a b) (apply 'mapcar (cons a b)))) '(min max) (list l1 l2)))
 


<<

Filename: 236595_ha.lsp
Tác giả: ketxu
Bài viết gốc: 162964
Tên lệnh: f+nil
(Yêu cầu) lisp fillet. lấy một đối tuợng chọn làm chuân
Định nghĩa lại thì mệt lắm hè...

Filename: 162964_f+nil.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 236626
Tên lệnh: vht
?Needle or Cannula Depth. A number of insertion depths that allow the needle or cannula to be used on a variety of fatty tissue levels are available. Two or three depths are available and a doctor can provide guidance on which one to use.

Giải pháp bẫy lỗi đề xuất cho bài #12. Ai có giải pháp hay hơn thì đề xuất nhé?

(defun C:VHT( / p r)
 (if
  (and
   (not (initget 1))
   (setq p (getpoint "\nSpecify center point for circle: "))
   (not (initget 7))
   (setq r (getdist p "\nSpecify radius of circle: ")))
  (command ".circle" "non" p r))
 (princ))
 


Filename: 236626_vht.lsp
Tác giả: tien2005
Bài viết gốc: 236799
Tên lệnh: rt
Lisp rải mặt cắt thép theo tỷ lệ bản vẽ

Bạn thử lisp sau, mình chỉ lấy những cái sẵn có rồi sửa lại theo yêu cầu của bạn

(defun c:rt (/ a pt1 pt2  times pt #dia1 #inter1)
  (setq #OSMODE (getvar "OSMODE"))
  (setvar "cmdecho" 0)
  (or #dia(setq #dia 16))
  (or #inter(setq #inter 200))
  (or #tl(setq #tl 20))
  (if(and(setq	pt1    (getpoint "\nDiem dau..."))
	 (setq pt2    (getpoint "\n... diem cuoi" pt1))
	 (not (initget 6))
	 (setq #dia   (cond((getdist pt2...
>>

Bạn thử lisp sau, mình chỉ lấy những cái sẵn có rồi sửa lại theo yêu cầu của bạn

(defun c:rt (/ a pt1 pt2  times pt #dia1 #inter1)
  (setq #OSMODE (getvar "OSMODE"))
  (setvar "cmdecho" 0)
  (or #dia(setq #dia 16))
  (or #inter(setq #inter 200))
  (or #tl(setq #tl 20))
  (if(and(setq	pt1    (getpoint "\nDiem dau..."))
	 (setq pt2    (getpoint "\n... diem cuoi" pt1))
	 (not (initget 6))
	 (setq #dia   (cond((getdist pt2 (strcat"\nDuong kinh thep <" (rtos #dia 2 2)">: ")))(#dia)))
	 (not (initget 6))
	 (setq #inter (cond((getdist(strcat"\nKhoang cach giua cac thanh thep  <" (rtos #inter 2 2)">: ")))(#inter)) )
	 (not (initget 6))
	 (setq #tl (cond((getint (strcat"\nTy le <" (rtos #tl 2 0)">: ")))(#tl)))
	 )
    (progn
      (setq #dia1 (/ #dia #tl)
	    #inter1 (/ #inter #tl)
	    a      (angle pt1 pt2)
	    times  (fix (/ (distance pt1 pt2) #inter1))
	    )

      (command "_.Undo" "be")
      (setvar "osmode" 0)

      (while (>= times 0)
	(setq pt (polar pt1 a (* times #inter1)))
	(command "_.DONUT" 0 #dia1 pt "")
	(setq times (1- times))
	)
      )
    )
  (command "_.Undo" "be")
  (setvar "osmode" #OSMODE)
  (princ)
)

<<

Filename: 236799_rt.lsp
Tác giả: tien2005
Bài viết gốc: 236943
Tên lệnh: rt
Lisp rải mặt cắt thép theo tỷ lệ bản vẽ

Bạn thử lisp này xem đã chưa

(defun c:rt (/ a pt1 pt2  times pt #dia1 #inter1 dyn)
  (setq #OSMODE (getvar "OSMODE"))
  (setq dyn (getvar "DYNMODE"))
  (setvar "cmdecho" 0)
  (setvar "DYNMODE" 3)
  (or #dia(setq #dia 16))
  (or #inter(setq #inter 200))
  (or #tl(setq #tl 20))
  (if(and(setq	pt1    (getpoint "\nDiem dau..."))
	 (setq pt2    (getpoint "\n... diem cuoi" pt1))
	 (not (initget 6))
	 (setq #dia   (cond((getdist pt2 (strcat"\nDuong...
>>

Bạn thử lisp này xem đã chưa

(defun c:rt (/ a pt1 pt2  times pt #dia1 #inter1 dyn)
  (setq #OSMODE (getvar "OSMODE"))
  (setq dyn (getvar "DYNMODE"))
  (setvar "cmdecho" 0)
  (setvar "DYNMODE" 3)
  (or #dia(setq #dia 16))
  (or #inter(setq #inter 200))
  (or #tl(setq #tl 20))
  (if(and(setq	pt1    (getpoint "\nDiem dau..."))
	 (setq pt2    (getpoint "\n... diem cuoi" pt1))
	 (not (initget 6))
	 (setq #dia   (cond((getdist pt2 (strcat"\nDuong kinh thep <" (rtos #dia 2 2)">: ")))(#dia)))
	 (not (initget 6))
	 (setq #inter (cond((getdist(strcat"\nKhoang cach giua cac thanh thep  <" (rtos #inter 2 2)">: ")))(#inter)) )
	 (not (initget 6))
	 (setq #tl (cond((getint (strcat"\nTy le <" (rtos #tl 2 0)">: ")))(#tl)))
	 )
    (progn
      (setq #dia1 (/ #dia #tl)
	    #inter1 (+(/ #inter #tl)(* #dia1 1))
	    a      (angle pt1 pt2)
	    times  (fix (/ (distance pt1 pt2) #inter1))
	    pt1 (polar pt1 (+ a (/ pi 4)) ( * #dia1 0.5 (sqrt 2.0)))
	    )

      (command "_.Undo" "be")
      (setvar "osmode" 0)

      (while (>= times 0)
	(setq pt (polar pt1 a (* times #inter1)))
	(command "_.DONUT" 0 #dia1 pt "")
	(setq times (1- times))
	)
      )
    )
  (command "_.Undo" "en")
  (setvar "osmode" #OSMODE)
  (setvar "DYNMODE" dyn)
  (princ)
)

<<

Filename: 236943_rt.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 237023
Tên lệnh: ha
Lệnh Trim mở rộng

Tôi chỉ down được bản thứ 2 còn bản thứ 1 lỗi server. Sửa lisp chút xíu cho nó ổn.

P/S: CadViet bị lỗi up file nên các bạn down về chịu khó delete mấy chữ này trong lisp nhé:  <span> </span>

;01/6/2013....
>>

Tôi chỉ down được bản thứ 2 còn bản thứ 1 lỗi server. Sửa lisp chút xíu cho nó ổn.

P/S: CadViet bị lỗi up file nên các bạn down về chịu khó delete mấy chữ này trong lisp nhé:  <span> </span>

;01/6/2013. Doan Van Ha -CadViet.com
;Co 3 kieu Trim:
;1). Trim theo Phia: pick diem phia nao thi Trim phia do (tuong tu offset).
;2). Trim doan Ngan.
;3). Trim doan Dai.
;Khong Trim cac truong hop: doi tuong la duong kin ; giao nhau tai hon 1 diem ; giao nhau bieu kien.
(defun C:HA( / ent0 ent ent2 ss ento lstg lst len1 len2 objlst typ)
 (vl-load-com) (command "undo" "be") (setq cmd (getvar "cmdecho") osm (getvar "osmode"))
 (if
  (and
   (princ "\nChon 1 doi tuong dao cat...")
   (setq ss (ssget ":S" '((0 . "Line,Polyline,Lwpolyline,Spline,Arc"))))
   (setq ent0 (ssname ss 0))
   (princ "\nChon cac doi tuong bi cat...")
   (setq ss (ssget '((0 . "Line,Polyline,Lwpolyline,Spline,Arc")))))
  (progn
   (initget "N D") (setq typ (getpoint "Pick phia can Trim hoac chon kieu Trim <N>: "))
   (if (not typ) (setq typ "N"))
   (setvar "cmdecho" 0) (setvar "osmode" 0)
   (setq objlst (mapcar 'vlax-ename->vla-object (setq entlst (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssadd ent0 ss)))))))
   (command "zoom" "w" (setq pll (car (LM:ListBoundingBox objlst))) (setq pur (cadr (LM:ListBoundingBox objlst))))
   (if (listp typ) 
    (progn
     (command "offset" 1E-8 ent0 typ "")
     (setq ento (entlast))))
   (foreach ent1 (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
    (setq lstg (HA:Giao (vlax-ename->vla-object ent0) (vlax-ename->vla-object ent1) acExtendNone))
    (if (and (= (length lstg) 1) (not (equal (car lstg) (vlax-curve-getStartPoint ent1) 1E-3)) (not (equal (car lstg) (vlax-curve-getEndPoint ent1) 1E-3)))
     (progn
 (setq lst (HA:GetNewEnt12 ent1 pll pur (car lstg)))
      (setq len1 (HA:LenCur (setq ent1 (car lst))) len2 (HA:LenCur (setq ent2 (cadr lst))))
      (cond
       ((or (and (= typ "N") (> len1 len2)) (and (= typ "D") (< len1 len2))) (entdel ent2))
  ((or (and (= typ "N") (< len1 len2)) (and (= typ "D") (> len1 len2))) (entdel ent1))
       ((listp typ)
        (if (HA:Giao (vlax-ename->vla-object ento) (vlax-ename->vla-object ent1) acExtendNone)
      (entdel ent1)
    (entdel ent2)))))))
   (if ento (entdel ento))))
 (setvar "cmdecho" cmd) (setvar "osmode" osm) (command "zoom" "p") (command "undo" "e") (princ))
(defun HA:GetNewEnt12(ent pll pur pt / typ1 ss1 ss2 entlst)
 (setq typ1 (cdr (assoc 0 (entget ent))))
 (setq ss1 (ssget "c" pll pur '((0 . "POLYLINE"))))
 (command ".break" ent pt pt)
 (if (equal typ1 "POLYLINE")
  (progn
   (setq ss2 (ssadd))
   (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "c" pll pur '((0 . "POLYLINE"))))))
    (if (not (ssmemb ent ss1))
     (ssadd ent ss2))
   (setq entlst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss2))))
   (list (car entlst) (cadr entlst))))
  (list ent (entlast))))
(defun HA:LenCur(ent)
 (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent)))
(defun LM:ListBoundingBox(objlst / l1 l2 ll ur)
 (foreach obj objlst
  (vla-getboundingbox obj 'll 'ur)
  (setq l1 (cons (vlax-safearray->list ll) l1) l2 (cons (vlax-safearray->list ur) l2)))
  (mapcar (function (lambda(a B) (apply 'mapcar (cons a B)))) '(min max) (list l1 l2)))
(defun HA:Giao(obj1 obj2 mode / l r)
 (setq l (vlax-invoke obj1 'intersectwith obj2 mode))
 (if (and l (equal (vlax-curve-getClosestPointTo obj2 l nil) l 1E-15))
  (repeat (/ (length l) 3)
   (setq r (cons (list (car l) (cadr l) (caddr l)) r) l (cdddr l))))
 r)
 


<<

Filename: 237023_ha.lsp
Tác giả: ketxu
Bài viết gốc: 119993
Tên lệnh: vsw vse vne vnw vw
Chọn đối tượng theo layer
1.Bạn click Thanks là được rồi^^
2.Với những lệnh nhiều hơn 1 thao tác chọn, bạn nên làm 1 lisp lệnh tắt nhỏ nhỏ.
Cách làm thường là bạn thực hiện các bước làm như thủ công,sau đó ấn f2 để xem thứ tự các thao tác.Sau đó tạo file lisp với nội dung

Lần lượt các view khác là :..

Các yêu cầu khác bạn cứ tự khám phá nhé
>>
1.Bạn click Thanks là được rồi^^
2.Với những lệnh nhiều hơn 1 thao tác chọn, bạn nên làm 1 lisp lệnh tắt nhỏ nhỏ.
Cách làm thường là bạn thực hiện các bước làm như thủ công,sau đó ấn f2 để xem thứ tự các thao tác.Sau đó tạo file lisp với nội dung

Lần lượt các view khác là :..

Các yêu cầu khác bạn cứ tự khám phá nhé :leluoi: Chúc bạn thành công
<<

Filename: 119993_vsw_vse_vne_vnw_vw.lsp
Tác giả: lyky
Bài viết gốc: 237247
Tên lệnh: cba
Tạo liên kết Text với Block attribute trong cad

Sau khi gia công xong, nếu bạn hiệu chỉnh giá trị chiều dài biểu kiến trên thanh thép ---> kết quả tự động link vào Block Attribute thì thật là tiện dụng. Tuy nhiên, nếu có thể chấp nhận một chút phiền toái, sau khi bạn hiệu chỉnh giá trị chiều dài biểu kiến, sử dụng code sau để hiệu chỉnh giá trị trong Block:

(defun C:CBA( / ENT KQUA LST LST2 LST3...
>>

Sau khi gia công xong, nếu bạn hiệu chỉnh giá trị chiều dài biểu kiến trên thanh thép ---> kết quả tự động link vào Block Attribute thì thật là tiện dụng. Tuy nhiên, nếu có thể chấp nhận một chút phiền toái, sau khi bạn hiệu chỉnh giá trị chiều dài biểu kiến, sử dụng code sau để hiệu chỉnh giá trị trong Block:

(defun C:CBA( / ENT KQUA LST LST2 LST3 OBJLST SS SS1)
(vl-load-com)
(prompt"\nChon so lieu:\n") (setq ss (ssget '((0 . "TEXT")))) (setq kqua 0)
(while (and ss (> (sslength ss) 0))
(setq kqua (+ kqua (atof (cdr (assoc 1 (entget (setq ent (ssname ss 0))))))))
(ssdel ent ss))
(prompt"\nChon Block:\n") (setq ss1 (ssget '((0 . "INSERT"))))
(setq objlst (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss1)))))
(foreach obj objlst (setq lst (GetAtt obj))
(foreach lst1 lst
(if (= (strcase (car lst1)) "LTHANH")
  (setq lst2 (cons (car lst1) kqua))
  (setq lst2 lst1))
  (setq lst3 (cons lst2 lst3)))
  (SetAtt obj lst3))
(princ))
;-----by MENZI ENGINEERING GmbH, Switzerland-----;
(defun GetAtt (obj) (mapcar '(lambda (att) (cons (vla-get-TagString att) (vla-get-TextString att))) (vlax-invoke obj 'GetAttributes)))
(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))

Download LISP file
Download TEST file


P/S: À, nếu bạn muốn làm tròn 10 kết quả tổng chiều dài trước khi gán vào Block thì bổ xung thêm vào code nhé!


<<

Filename: 237247_cba.lsp
Tác giả: gia_bach
Bài viết gốc: 237262
Tên lệnh: linkt
Tạo liên kết Text với Block attribute trong cad

Mình có file cad và hình ảnh bên dưới với yêu cầu: Tạo liên kết Text với Block attribute trong cad.

Nhờ các bạn giúp mình. Thanks!

Mình có file cad và hình ảnh bên dưới với yêu cầu: Tạo liên kết Text với Block attribute trong cad.

Nhờ các bạn giúp mình. Thanks!

lienket_zpsbe4195bb.jpg

 

file cad: http://www.mediafire.com/?7eeeb4dmkzrfy8p

Lisp tạo liên kết các Text vào Block ứng với file Cad bạn gửi.

(defun c:linkT (/ blk fieldexp ss);link Text to Attribute
  ;; By : Gia_Bach 2013 ;;
  (vl-load-com)
  (if (> (atof (substr (getvar "ACADVER") 1 4)) 16.1)
    (if (and
	  (princ "\nChon cac Text nguon : ")
	  (setq ss (ssget '((0 . "TEXT"))))
	  (princ "\nChon Block can link : ")
	  (setq blk (ssget "_+.:S:E" (list (cons 0 "INSERT")(cons 2 "THONG KE THEP"))))) 
      (progn
	(setq fieldExp "%<\\AcExpr (0")
	(foreach e (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
	  (setq fieldExp (strcat fieldExp
				 "+%<\\AcObjProp Object(%<\\_ObjId "
				 (itoa (vla-get-objectid e))
				 ">%).TextString>%")) )
	(foreach att (vlax-invoke (vlax-Ename->Vla-Object (ssname blk 0)) 'GetAttributes)
	  (if (= (vla-get-TagString att) "LTHANH")
	    (progn
	      (vla-put-textstring att (strcat fieldExp ") \\f \"%lu2%pr0\">%"))
	      (vla-regen (vla-get-ActiveDocument (vlax-get-acad-object))  acActiveViewport ) ) ) )
	(princ)))
    (alert "\nChi chay tu Autocad 2006")  )  )

<<

Filename: 237262_linkt.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 237326
Tên lệnh: ha
Giúp e giải đề này với ( bản vẽ đính kèm)

Với bài toán theo file bạn gởi thì dùng lisp này.

(defun C:HA( / ent1 ent2 pt p1 p2 px lst1 lst2)
 (if
  (and
   (setq ent1 (car (entsel "\nChon duong mat: ")))
   (setq pt (getpoint "\nChon diem tim: "))
   (setq ent2 (car (entsel "\nChon cao do diem tim: "))))
  (while (setq p (getpoint "\nPick diem can tinh: "))
   (setq lst1 (entget ent1) p1 (cdr (assoc 10...
>>

Với bài toán theo file bạn gởi thì dùng lisp này.

(defun C:HA( / ent1 ent2 pt p1 p2 px lst1 lst2)
 (if
  (and
   (setq ent1 (car (entsel "\nChon duong mat: ")))
   (setq pt (getpoint "\nChon diem tim: "))
   (setq ent2 (car (entsel "\nChon cao do diem tim: "))))
  (while (setq p (getpoint "\nPick diem can tinh: "))
   (setq lst1 (entget ent1) p1 (cdr (assoc 10 lst1)))
   (setq lst2 (entget ent2) p2 (cdr (assoc 11 lst2)) txt2 (cdr (assoc 1 lst2)))
   (entmake (list (cons 0 "LINE") (cons 10 p) (cons 11 (list (car p) (cadr p1)))))
   (setq txt (rtos (+ (distof txt2) (- (cadr p) (cadr pt))) 2 3))
   (setq px (polar p2 0 (- (car p) (car pt))))
   (setq lst2 (subst (cons 1 txt) (cons 1 txt2) lst2))
   (setq lst2 (subst (cons 11 px) (cons 11 p2) lst2))
   (entmake lst2)))
 (princ))
 


<<

Filename: 237326_ha.lsp
Tác giả: Nguyen Hoanh
Bài viết gốc: 5814
Tên lệnh: 3 cur
Viết Lisp theo yêu cầu
Tham khảo các mã viết cho Xaydung chắc các bạn cũng biết cách viết rồi. Về sau những lệnh tương tự như thế này, mọi người tự viết nhé!

Filename: 5814_3_cur.lsp
Tác giả: nataca
Bài viết gốc: 47447
Tên lệnh: 3q 12q
Viết Lisp theo yêu cầu


Filename: 47447_3q_12q.lsp

Trang 132/303

132