Đến nội dung


Hình ảnh
- - - - -

[Yêu Cầu]Lisp Copy đường Bình đồ Từ Tim Tuyến


  • Please log in to reply
20 replies to this topic

#1 anpha3

anpha3

    biết vẽ arc

  • Members
  • PipPip
  • 48 Bài viết
Điểm đánh giá: -2 (bình thường)

Đã gửi 11 September 2011 - 08:49 AM

Em có 1 bài toán thế này nhờ các Bác giải giúp:
Em có 1 bản đồ địa hình có đường đồng mức và cao độ cũng như địa hình địa vật.Yêu cầu như sau:
1. Vạch 1 đường tim tuyến trên bản đồ địa hình đó.
2.Copy đường đồng mức cao độ địa hình địa vật và tim tuyến đó ra khoảng cách copy đường đồng mức và địa hình địa vật từ tim tuyến ra theo khoảng cách tuỳ ý có thể là 25m có thể là 50m....
3.Đường đồng mức địa hình địa vật và tim tuyến copy ra có thể thay đổi theo tỷ lệ tuỳ ý có thể 1/1;1/2;1/5....
Nhờ các bác giải quyết hộ em bài toán này

http://www.cadviet.c...es/3/binhdo.dwg
  • 0

#2 anpha3

anpha3

    biết vẽ arc

  • Members
  • PipPip
  • 48 Bài viết
Điểm đánh giá: -2 (bình thường)

Đã gửi 14 September 2011 - 06:29 AM

Sao không thấy Bác nào quan tâm tới chủ đề này nhỉ?..
  • 0

#3 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5678 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 14 September 2011 - 07:10 AM

Chắc chủ đề của bạn hơi khó nhằn ???
Hướng giải quyết của mình là như sau, tuy nhiên, dài thoòng ^^
1- vla-offset 2 bên đường tim tuyến (e1,e2)
2- Lấy list tọa độ đỉnh của e1, e2 (lst1, lst2)
3- Với mỗi đỉnh của e1 kẻ đường thẳng tương ứng với e2
4- ssget "cp" / "c" qua list đỉnh append lst1 lst2 (ss)
5- Copy ss + e1,e2 ra điểm đặt, dùng entlast và while entnext để lấy lại toàn bộ tập ss mới copy (ss_copy + e1_copy, e2_copy)
6- Scale theo tỉ lệ
7- Joint e1_copy, e2_copy thành đường bao e
8- Extrim e
...Chẹp chẹp, tư duy cổ hủ, nên thấy nó dài quá ^^
  • 0

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#4 cd2k44

cd2k44

    Edu level: li5

  • Members
  • PipPipPipPipPipPipPip
  • 648 Bài viết
Điểm đánh giá: 121 (tàm tạm)

Đã gửi 14 September 2011 - 10:29 AM

Chắc chủ đề của bạn hơi khó nhằn ???
Hướng giải quyết của mình là như sau, tuy nhiên, dài thoòng ^^
1- vla-offset 2 bên đường tim tuyến (e1,e2)
2- Lấy list tọa độ đỉnh của e1, e2 (lst1, lst2)
3- Với mỗi đỉnh của e1 kẻ đường thẳng tương ứng với e2
4- ssget "cp" / "c" qua list đỉnh append lst1 lst2 (ss)
5- Copy ss + e1,e2 ra điểm đặt, dùng entlast và while entnext để lấy lại toàn bộ tập ss mới copy (ss_copy + e1_copy, e2_copy)
6- Scale theo tỉ lệ
7- Joint e1_copy, e2_copy thành đường bao e
8- Extrim e
...Chẹp chẹp, tư duy cổ hủ, nên thấy nó dài quá ^^

Bạn ketxu có thời gian thì chỉnh lại lisp trích thửa của bác thiệp thì sẽ thực hiện được yêu cầu của bạn này.Lisp của bác thiệp làm được việc bạn muốn chỉ có điều đường bao mà bạn mong muốn thì bác thiệp đã cố định nó là khung chữ nhật hoặc elisp... chứ không có chức năng chọn đường bao như bạn yêu cầu.Mình post lisp đó lên bạn có thể nhờ chính tác giả hoặc các anh trong diễn đàn chỉnh sửa lisp này cho phù hợp yêu cầu của bạn

;;;-----------------------
(defun SS-enlst (ss / c L)
(setq c -1)
(repeat (sslength ss)
(setq L (cons (ssname ss (setq c (1+ c))) L))
)
(reverse L)
)
;;;---------------------- -
(defun Text (model str po h ang / obj)
(setq obj (vla-AddText
*Model*
str
(vlax-3d-point po)
h
)
)
(vla-put-Alignment obj acAlignmentTopCenter)
(vla-put-TextAlignmentPoint obj (vlax-3d-point po))
)
;;;====================================================================
(defun break_with (Lstent enL / lst masterlist ss oc break_obj intpts)
(princ "\nCalculating Break Points, Please Wait.\n")

;;========================================
;; Break entity at break points in list
;;========================================
(defun break_obj (ent brkptlst / brkobjlst en
enttype maxparam closedobj minparam
obj obj2break p1param p2param
brkpt2 dlst idx brkptS
brkptE brkpt result result
ignore dist tmppt #ofpts
enddist lastent obj2break stdist
)
(setq obj2break ent
brkobjlst (list ent)
enttype (dxf 0 ent)
)
(if (not (or (eq (dxf 0 obj2break) "TEXT")
(eq (dxf 0 obj2break) "MTEXT")
)
)
(setq closedobj (vlax-curve-isclosed obj2break))
)
(setq spt (vlax-curve-getstartpoint ent)
ept (vlax-curve-getendpoint ent)
brkptlst (vl-remove-if
'(lambda (x)
(or (< (distance x spt) 0.0001)
(< (distance x ept) 0.0001)
)
)
brkptlst
)
)
;)
(if (and brkptlst
(not (or (eq (dxf 0 obj2break) "TEXT")
(eq (dxf 0 obj2break) "MTEXT")
)
)
)
(progn
(setq brkptlst
(mapcar
'(lambda (x)
(list
x
(vlax-curve-getdistatparam
obj2break
(cond
((vlax-curve-getparamatpoint obj2break x)
)
((vlax-curve-getparamatpoint
obj2break
(vlax-curve-getclosestpointto
obj2break
x
)
)
)
)
)
)
)
brkptlst
)
)
(setq
brkptlst (vl-sort brkptlst
'(lambda (a1 a2) (< (cadr a1) (cadr a2)))
)
)
(foreach brkpt (reverse brkptlst)
(setq brkptS (car brkpt)
brkptE brkptS
)
;; get last entity created via break in case multiple breaks
(if brkobjlst
(progn
(setq tmppt brkptS) ; use only one of the pair of breakpoints
;; if pt not on object x, switch objects
(if (not (numberp (vl-catch-all-apply
'vlax-curve-getdistatpoint
(list obj2break tmppt)
)
)
)
(progn ; find the one that pt is on
(setq idx (length brkobjlst))
(while
(and (not (minusp (setq idx (1- idx))))
(setq obj (nth idx brkobjlst))
(if (numberp (vl-catch-all-apply
'vlax-curve-getdistatpoint
(list obj tmppt)
)
)
(null (setq obj2break obj))
; switch objects, null causes exit
t
)
)
)
)
)
)
); end (if brkobjlst

;;; Handle any objects that can not be used with the Break Command
;;; using one point, gap of 0.000001 is used
(if (not (or (eq (dxf 0 obj2break) "TEXT")
(eq (dxf 0 obj2break) "MTEXT")
)
)
(setq closedobj (vlax-curve-isclosed obj2break))
)
;;; single breakpoint ----------------------------------------------------
(if
(and closedobj
(not (setq
brkptE (vlax-curve-getPointAtDist
obj2break
(+ (vlax-curve-getdistatparam
obj2break
(cond
((vlax-curve-getparamatpoint
obj2break
brkpts
)
)
((vlax-curve-getparamatpoint
obj2break
(vlax-curve-getclosestpointto
obj2break
brkpts
)
)
)
)
)
0.00001
)
)
)
)
)
(setq
brkptE (vlax-curve-getPointAtDist
obj2break
(- (vlax-curve-getdistatparam
obj2break
(cond ((vlax-curve-getparamatpoint
obj2break
brkpts
)
)
((vlax-curve-getparamatpoint
obj2break
(vlax-curve-getclosestpointto
obj2break
brkpts
)
)
)
)
)
0.00001
)
)
); end setq brkptE
); end fi (and closedobj
;; (if (null brkptE) (princ)) ; debug
(setq LastEnt (GetLastEnt))
(if (not (or (eq (dxf 0 obj2break) "TEXT")
(eq (dxf 0 obj2break) "MTEXT")
)
)
(command "._break"
obj2break
"_non"
(trans brkptS 0 1)
"_non"
(trans brkptE 0 1)
)
)
(and (= "CIRCLE" enttype) (setq enttype "ARC"))
(if (and (not closedobj) ; new object was created
(not (equal LastEnt (entlast)))
)
(setq brkobjlst (cons (entlast) brkobjlst))
); end (if (and
); end (foreach brkpt
);end progn brkptlst
); end if brkptlst
); defun break_obj
;;====================================
;; CAB - get last entity in datatbase
(defun GetLastEnt (/ ename result)
(if (setq result (entlast))
(while (setq ename (entnext result))
(setq result ename)
)
)
result
)
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; S T A R T S U B R O U T I N E H E R E
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
(if (and Lstent enL)
(progn
;; CREATE a list of entity & it's break points
(foreach en Lstent
; check each object in Lstent
(if (not (acet-layer-locked (dxf 8 en)))
(progn
(setq lst nil)
;; check for break pts with other objects in Lstentwith
(if (and (not (equal en enint))
(setq intpts (acet-geom-intersectwith en enL 0))
)
(setq lst (append intpts lst))
; entity w/ break points
)
(if lst
(setq masterlist
(cons (cons en lst) masterlist)
)
)
)
)
)
(princ "\nBreaking Objects.\n")
(if masterlist
(progn
(acet-ui-progress "hoan thanh %" (length masterlist))
(foreach obj2brk masterlist
(break_obj (car obj2brk) (cdr obj2brk))
(acet-ui-progress -1)
)
(acet-ui-progress)
)
)
)
)
);end break_with
;;===========================================================================
;; get all objects touching entities in the sscross
;; limited obj types to "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"
;; returns a list of enames
;;===========================================================================
(defun gettouching (en / ss lst lstb lstc objl)
(and
(setq objl (vlax-ename->vla-object en))
(setq
ss
(ssget
"_A"
(list
(cons 0
"LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"
)
(cons 410 (getvar "ctab"))
)
)
)
(setq lst (SS-enlst ss)
lst (mapcar 'vlax-ename->vla-object lst))
(mapcar
'(lambda (x)
(if (not
(vl-catch-all-error-p
(vl-catch-all-apply
'(lambda ()
(vlax-safearray->list
(vlax-variant-value
(vla-intersectwith objl x acextendnone)
)
)
)
)
)
)
(setq lstc (cons (vlax-vla-object->ename x) lstc))
)
)
lst
)
)
lstc
)
;;;------------------------------------------------
(defun LWP (Lpoint *Model* / PntArr)
(setq PntArr (vlax-make-safearray
vlax-vbDouble
(cons 0 (1- (length Lpoint)))
)
)
(vlax-safearray-fill PntArr Lpoint)
(vla-AddLightWeightPolyline *Model* PntArr)
)
;;;------------------------------------------------
(defun DXF (code en) (cdr (assoc code (entget en))))
;;;============================================================
;;;=======================MAIN LISP============================
;;;============================================================
(defun c:trichBD (/ ActDoc *Model* ss encur lsten p1 p2 p3 LenssBR lstp objCE)
(setq ActDoc (vla-get-ActiveDocument (vlax-get-acad-object))
*Model* (vla-get-ModelSpace ActDoc)
)
(setq bit1 (cond (bit1)
("Rectangle")
)
)
(initget "Square Rectangle Circle Ellipse Different")
(setq tmp (strcat "\nChon duong bao: [Square/Rectangle/Circle/Ellipse/Different] <" bit1 ">: ")
bit1 (cond ((getkword tmp))
(bit1)
)
)
(vla-StartUndoMark ActDoc)
(setvar "cecolor" "104")
(setq p1 (list (car (getvar "extmin")) (cadr (getvar "extmin"))))
(cond ((eq bit1 "Square")
(setq a (cond (a)
(50)
)
)
(setq olda a)
(setq a (getreal (strcat "\nChon kich thuoc canh Square <"
(rtos olda 2 1)
"> : "
)
)
)
(if (null a)
(setq a olda)
)
(setq lstp (list (list (car p1) (cadr p1) 0)
(list (+ (car p1) a) (cadr p1) 0)
(list (+ (car p1) a) (+ (cadr p1) a) 0)
(list (car p1) (+ (cadr p1) a) 0)
(list (car p1) (cadr p1) 0)
)
)
)
((eq bit1 "Rectangle")
(setq a (cond (a)
(50)
)
)
(setq olda a)
(setq a (getreal (strcat "\nChon chieu dai Rectangle <"
(rtos olda 2 1)
"> : "
)
)
)
(if (null a)
(setq a olda)
)
(setq b (cond (B)
(50)
)
)
(setq oldb B)
(setq b (getreal (strcat "\nChon chieu rong Rectangle <"
(rtos oldb 2 1)
"> : "
)
)
)
(if (null B)
(setq b oldb)
)
(setq lstp (list (list (car p1) (cadr p1) 0)
(list (+ (car p1) a) (cadr p1) 0)
(list (+ (car p1) a) (+ (cadr p1) B) 0)
(list (car p1) (+ (cadr p1) B) 0)
(list (car p1) (cadr p1) 0)
)
)
)
((eq bit1 "Circle")
(setq a (cond (a)
(50)
)
)
(setq olda a)
(setq a (getreal (strcat "\nChon ban kinh Circle <"
(rtos olda 2 1)
"> : "
)
)
)
(if (null a)
(setq a olda)
)
(setq objCE (vla-addCircle *Model* (vlax-3d-point p1) a))
(setq cir (entlast))
(setq cv (* a 2 pi)
lstp (list (vlax-curve-getStartPoint cir))
d (/ cv 160)
l 0.0
)
(repeat 160
(setq l (+ l d)
p (vlax-curve-getPointAtDist cir l)
lstp (append lstp (List p))
)
)
);end bit1 "Circle"

;;; ((eq bit1 "Ellipse")
;;; (setq a (getpoint p1 "\nPick diem ban kinh lon cua Ellipse"))
;;; (vl-cmdf ".Ellipse" pause pause pause); erro ttuc
;;; (setq objCE (entlast)
;;; p1 (vlax-curve-getStartPoint objCE))
;;; (command ".LENGTHEN" objCE "")
;;; (setq cv (getvar "perimeter")
;;; lstp (list p1)
;;; d (/ cv 160)
;;; l 0.0
;;; )
;;; (repeat 160
;;; (setq l (+ l d)
;;; p (vlax-curve-getPointAtDist objCE l)
;;; lstp (append lstp (List p))
;;; )
;;; )
;;; );end bit1 "Ellipse"
;;; ((eq bit1 "Different")
;;; (prompt "\nchon 1 curve kin:")
;;; (setq ss (ssget)
;;; encur (ssname ss 0)
;;; objCE (vlax-ename->vla-object encur)
;;; p1 (vlax-curve-getStartPoint encur))
;;; (if (or (eq (dxf 0 encur) "LWPOLYLINE")
;;; (eq (dxf 0 encur) "POLYLINE")
;;; )
;;; (setq lstp (acet-geom-VERTEX-LIST encur))
;;; (progn
;;; (command ".LENGTHEN" encur "")
;;; (setq cv (getvar "perimeter")
;;; lstp (list p1)
;;; d (/ cv 160)
;;; l 0.0
;;; )
;;; (repeat 160
;;; (setq l (+ l d)
;;; p (vlax-curve-getPointAtDist encur l)
;;; lstp (append lstp (List p))
;;; )
;;; )
;;; )
;;; )
;;; )
);end cond
(vla-ZoomExtents (vlax-get-acad-object))
(ACET-LWPLINE-MAKE (list lstp))
(setq ss (ssadd (entlast) (ssadd)))
(setq p2 (ACET-SS-DRAG-MOVE
ss
(list (car p1) (cadr p1))
"Chon vi tri bat dau trich thua: "
)
)
(command ".move" ss "" p1 p2)
(setq encur (entlast)
lstp (acet-geom-VERTEX-LIST encur))
(setq ss (ssdel encur (ssget "_CP" lstp)))
(command ".copy" ss "" p2 p2)
(setq p3 (ACET-SS-DRAG-MOVE
(ssadd encur ss)
p2
"Chon vi tri dat ban do trich thua: "
)
)
(command ".move" ss encur "" p2 p3)
(setvar "cecolor" "0")
(setq lsten (vl-remove encur (gettouching encur)))
(break_with lsten encur)
(vlax-invoke-method ActDoc 'Regen acActiveViewport)
(vla-offset (vlax-ename->vla-object encur) (* (getvar "viewsize") 0.0001))
(setq lstp (acet-geom-vertex-list (entlast)))
(entdel (entlast))
(if (equal (vlax-curve-getEndParam encur) 160 1) (entdel encur))
(setq LenssBR (SS-enlst (ssget "F" lstp)))
(mapcar '(lambda (x)
(if (or (not (eq (dxf 0 x) "TEXT"))
(not (eq (dxf 0 x) "MTEXT"))
)
(entdel x)
)
)
LenssBR
)
(if objCE (vla-move objCE (vlax-3d-point p1) (vlax-3d-point p3)))
(vla-EndUndoMark ActDoc)
(princ "\nChuc cac ban gat hai nhieu thanh cong. Thiep")
(princ)
)
Ngoài ra nếu bạn có thể sử dụng lisp sau của bác gia_bach

(defun c:CWB (/ ov vl bit ss cur ssInside ssOutside ssN ssT ssAll curT plSet) ;CWB -> Copy With Boundary
(defun *error* (msg)
(if ov (mapcar 'setvar vl ov)) ; reset Sys vars
(princ (strcat "\n<< Error: " msg " >>")) ; Print Error Message
(princ) ; Exit Cleanly
)
(command "_.undo" "_begin")
(setq vl '("CMDECHO" "OSMODE" "ORTHOMODE") ; Sys Var list
ov (mapcar 'getvar vl)) ; Get Old values
(mapcar 'setvar vl '(0 0 0)) ; Turn off CMDECHO, OSMODE, ORTHOMODE
(initget "T N")
(setq bit (getkword "\nBan muon chon Trong hay Ngoai duong bao <T/N>: " ) )
(princ"\n<<< Chon duong bao >>> ")
(setq ss (ssget "_:S" '((0 . "LWPOLYLINE,CIRCLE,ELLIPSE")))
cur (ssname ss 0))
(setq p1 (vlax-curve-getStartPoint cur)
p2 (getpoint p1 "\nDiem den :"))
(command "_copy" cur "" p1 p2)
(if (and (setq lstTouching (gettouching ss))
(setq ssTouching (ssadd))
(mapcar '(lambda (x) (ssadd x ssTouching)) lstTouching)
)
(progn
(command "_copy" ssTouching "" p1 p1)
(setq temp (ssget "p"))
(unvisible ssTouching)
(setq ssTouching temp)
)
)
(if (= bit "T") ;chon Trong duong bao
(progn
(setq ptLst (GetPtLst cur)
ssInside (ssget "_WP" ptLst ) )
(if ssInside
(command "_copy" ssInside "" p1 p2 )
)
(if (and (setq ssInside (GetssBreak ss "in"))
(> (sslength ssInside) 0))
(command "_move" ssInside "" p1 p2 )
)
)
(progn ;(= bit "N") ;chon Ngoai duong bao
;chi chon doi tuong Giao voi duong bao
(if (and (setq ssOutside (GetssBreak ss "out"))
(> (sslength ssOutside) 0))
(command "_move" ssOutside "" p1 p2 )
)
);;chon Ngoai duong bao
);cond
(Visible)
(mapcar 'setvar vl ov) ; reset Sys Vars
(command "_.undo" "_end")
(princ)
)
(defun GetssBreak (ss2 opt / ptLst cur ssInside lstss1 ss1)
(if (and (setq lstss1 (gettouching ss2))
(setq ss1 (ssadd))
(mapcar '(lambda (x) (ssadd x ss1)) lstss1)
)
(progn ; co ssTouching
(break_with ss1 ss2 nil 0)
(setq cur (ssname ss2 0)
ssBreak (ssadd))
(mapcar '(lambda (x) (ssadd x ssBreak)) (gettouching ss2))
;loc ssTouching -> ssOutside
(foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssBreak)))
(if (= opt "in")
(if
(or
(not(insidep (vlax-curve-getStartPoint e) cur))
(not(insidep (vlax-curve-getEndPoint e) cur))
(not(insidep (vlax-curve-getPointAtParam e (/(+(vlax-curve-getStartParam e)(vlax-curve-getEndParam e))2)) cur))
);or
(entdel e)
)
(if ;(= opt "out")
(and (insidep (vlax-curve-getStartPoint e) cur)
(insidep (vlax-curve-getEndPoint e) cur)
(insidep (vlax-curve-getPointAtParam e (/(+(vlax-curve-getStartParam e)(vlax-curve-getEndParam e))2)) cur)
);and
(entdel e)
)
);if
);foreach
);progn
);if
(if (ssmemb cur ssBreak) (ssdel cur ssBreak))
ssBreak
)
;;;(defun GetssInside (ss2 / ptLst cur ssInside lstss1 ss1 ssTouching)
;;; (if (and (setq lstss1 (gettouching ss2))
;;; (setq ss1 (ssadd))
;;; (mapcar '(lambda (x) (ssadd x ss1)) lstss1)
;;; )
;;; (progn ; co ssTouching
;;; (break_with ss1 ss2 nil 0)
;;; (setq ssTouching (ssadd))
;;; (mapcar '(lambda (x) (ssadd x ssTouching)) (gettouching ss2))
;;; ;loc ssTouching -> ssInside
;;; (or ssInside (setq ssInside (ssadd)) )
;;; (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssTouching)))
;;; (if
;;; (and (insidep (vlax-curve-getStartPoint e) cur)
;;; (insidep (vlax-curve-getEndPoint e) cur)
;;; (insidep (vlax-curve-getPointAtParam e (/(+(vlax-curve-getStartParam e)(vlax-curve-getEndParam e))2)) cur)
;;; )
;;; (ssadd e ssInside)
;;; (entdel e)
;;; );if
;;; );foreach
;;; );progn
;;; );if
;;; (if (ssmemb cur ssInside) (ssdel cur ssInside))
;;; ssInside
;;; )

(defun GetPtLst (obj / startparam endparam anginc delta div inc pt ptlst)
(defun ZClosed (lst)
(if (and (vlax-curve-isClosed obj)
(not(equal (car lst)(last lst) 1e-6)))
(append lst (list (car lst)))
lst))

(or (eq (type obj) 'VLA-OBJECT)
(setq obj (vlax-ename->vla-object obj)))
(setq typ (vlax-get obj 'ObjectName))
(if (or (eq typ "AcDbCircle") (eq typ "AcDbEllipse"))
(progn
(setq param 0)
(while (< param (* pi 2))
(setq pt (vlax-curve-getPointAtParam obj param)
ptlst (cons pt ptlst)
param (+ (/ (* pi 2) 72) param))
)
(reverse ptlst)
)
(progn ;Pline (eq typ "AcDbPolyline")
(setq param (vlax-curve-getStartParam obj)
endparam (vlax-curve-getEndParam obj)
anginc (* pi (/ 7.5 180.0)))
(setq tparam param)
(while (<= param endparam)
(setq pt (vlax-curve-getPointAtParam obj param))
(if (not (equal pt (car ptlst) 1e-12))
(setq ptlst (cons pt ptlst)))
(if (and (/= param endparam)
(setq blg (abs (vlax-invoke obj 'GetBulge param)))
(/= 0 blg))
(progn
(setq delta (* 4 (atan blg)) ;included angle
inc (/ 1.0 (1+ (fix (/ delta anginc))))
arcparam (+ param inc))
(while (< arcparam (1+ param))
(setq pt (vlax-curve-getPointAtParam obj arcparam)
ptlst (cons pt ptlst)
arcparam (+ inc arcparam))))
)
(setq param (1+ param))
)
(if (and (apply 'and ptlst)
(> (length ptlst) 1))
(ZClosed (reverse ptlst))
)
)
)
)

;; Copyright (c) 2009, Lee McDonnell
;; (Contact Lee Mac, CADTutor.net)
(defun insidep (pt Obj / Obj Tol ang doc spc flag int lin xV yV)
(defun vlax-list->3D-point (lst flag)
(if lst
(cons ((if flag car cadr) lst)
(vlax-list->3D-point (cdddr lst) flag))))
(or (eq 'VLA-OBJECT (type Obj))
(setq Obj (vlax-ename->vla-object Obj)))
(if (not(vlax-curve-getParamAtPoint Obj pt))
(progn
(setq Tol (/ pi 6) ; Uncertainty
ang 0.0 flag T)
(setq doc (vla-get-ActiveDocument (vlax-get-Acad-Object))
spc (if (zerop (vla-get-activespace doc))
(if (= (vla-get-mspace doc) :vlax-true)
(vla-get-modelspace doc)
(vla-get-paperspace doc))
(vla-get-modelspace doc)))
(while (and (< ang (* 2 pi)) flag)
(setq flag (and
(setq int
(vlax-invoke
(setq lin
(vla-addLine spc
(vlax-3D-point pt)
(vlax-3D-point
(polar pt ang
(if (vlax-property-available-p Obj 'length)
(vla-get-length Obj) 1.0)))))
'IntersectWith Obj
acExtendThisEntity))
(<= 6 (length int))
(setq xV (vl-sort (vlax-list->3D-point int T) '<)
yV (vl-sort (vlax-list->3D-point int nil) '<))
(or (<= (car xV) (car pt) (last xV))
(<= (car yV) (cadr pt) (last yV))))
ang (+ ang Tol))
(vla-delete lin))
flag
)
T
))

;;; Author: Copyright&#169; 2006-2008 Charles Alan Butler
;;; Contact @ www.TheSwamp.org
;;===========================================================================
;; get all objects touching entities in the sscross
;; limited obj types to "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"
;; returns a list of enames
;;===========================================================================
(defun gettouching (sscros / ss lst lstb lstc objl)
(and
(setq lstb (vl-remove-if 'listp (mapcar 'cadr (ssnamex sscros)))
objl (mapcar 'vlax-ename->vla-object lstb)
)
(setq ss (ssget "_A" (list '(-4 . "<AND")
'(-4 . "<NOT") '(60 . 1) '(-4 . "NOT>")
'(0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
(cons 410 (getvar "ctab"))
'(-4 . "AND>")
)
)
)
(setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq lst (mapcar 'vlax-ename->vla-object lst))
(mapcar
'(lambda (x)
(mapcar
'(lambda (y)
(if (not
(vl-catch-all-error-p
(vl-catch-all-apply
'(lambda ()
(vlax-safearray->list
(vlax-variant-value
(vla-intersectwith y x acextendnone)
))))))
(setq lstc (cons (vlax-vla-object->ename x) lstc))
)
) objl)
) lst)
)
lstc
)
;;; Author: Copyright&#169; 2006-2008 Charles Alan Butler
;;; Contact @ www.TheSwamp.org
(defun break_with (ss2brk ss2brkwith self Gap / cmd intpts lst masterlist ss ssobjs
onlockedlayer ssget->vla-list list->3pair GetNewEntities oc
get_interpts break_obj GetLastEnt LastEntInDatabase ss2brkwithList
)
;; ss2brk selection set to break
;; ss2brkwith selection set to use as break points
;; self when true will allow an object to break itself
;; note that plined will break at each vertex
;;
;; return list of enames of new objects
(vl-load-com)
(princ "\nCalculating Break Points, Please Wait.\n")
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; S U B F U N C T I O N S
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; return T if entity is on a locked layer
(defun onlockedlayer (ename / entlst)
(setq entlst (tblsearch "LAYER" (cdr (assoc 8 (entget ename)))))
(= 4 (logand 4 (cdr (assoc 70 entlst))))
)
;; return a list of objects from a selection set
;| (defun ssget->vla-list (ss)
(mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss ))))
)|;
(defun ssget->vla-list (ss / i ename allobj) ; this is faster, changed in ver 1.7
(setq i -1)
(while (setq ename (ssname ss (setq i (1+ i))))
(setq allobj (cons (vlax-ename->vla-object ename) allobj))
)
allobj
)

;; return a list of lists grouped by 3 from a flat list
(defun list->3pair (old / new)
(while (setq new (cons (list (car old) (cadr old) (caddr old)) new)
old (cdddr old)))
(reverse new)
)

;;=====================================
;; return a list of intersect points
;;=====================================
(defun get_interpts (obj1 obj2 / iplist)
(if (not (vl-catch-all-error-p
(setq iplist (vl-catch-all-apply
'vlax-safearray->list
(list
(vlax-variant-value
(vla-intersectwith obj1 obj2 acextendnone)
))))))
iplist
)
)
;;========================================
;; Break entity at break points in list
;;========================================
(defun break_obj (ent brkptlst BrkGap / brkobjlst en enttype maxparam closedobj
minparam obj obj2break p1param p2param brkpt2 dlst idx brkptS
brkptE brkpt result GapFlg result ignore dist tmppt
#ofpts 2gap enddist lastent obj2break stdist
)
(or BrkGap (setq BrkGap 0.0)) ; default to 0
(setq BrkGap (/ BrkGap 2.0)) ; if Gap use 1/2 per side of break point

(setq obj2break ent
brkobjlst (list ent)
enttype (cdr (assoc 0 (entget ent)))
GapFlg (not (zerop BrkGap)) ; gap > 0
closedobj (vlax-curve-isclosed obj2break)
)
;; when zero gap no need to break at end points
(if (zerop Brkgap)
(setq spt (vlax-curve-getstartpoint ent)
ept (vlax-curve-getendpoint ent)
brkptlst (vl-remove-if '(lambda(x) (or (< (distance x spt) 0.0001)
(< (distance x ept) 0.0001)))
brkptlst)
)
)
(if brkptlst
(progn
;; sort break points based on the distance along the break object
;; get distance to break point, catch error if pt is off end
;; ver 2.0 fix - added COND to fix break point is at the end of a
;; line which is not a valid break but does no harm
(setq brkptlst (mapcar '(lambda(x) (list x (vlax-curve-getdistatparam obj2break
;; ver 2.0 fix
(cond ((vlax-curve-getparamatpoint obj2break x))
((vlax-curve-getparamatpoint obj2break
(vlax-curve-getclosestpointto obj2break x))))))
) brkptlst))
;; sort primary list on distance
(setq brkptlst (vl-sort brkptlst '(lambda (a1 a2) (< (cadr a1) (cadr a2)))))

(if GapFlg ; gap > 0
;; Brkptlst starts as the break point and then a list of pairs of points
;; is creates as the break points
(progn
;; create a list of list of break points
;; ((idx# stpoint distance)(idx# endpoint distance)...)
(setq idx 0)
(foreach brkpt brkptlst

;; ----------------------------------------------------------
;; create start break point, then create end break point
;; ((idx# startpoint distance)(idx# endpoint distance)...)
;; ----------------------------------------------------------
(setq dist (cadr brkpt)) ; distance to center of gap
;; subtract gap to get start point of break gap
(cond
((and (minusp (setq stDist (- dist BrkGap))) closedobj )
(setq stdist (+ (vlax-curve-getdistatparam obj2break
(vlax-curve-getendparam obj2break)) stDist))
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getparamatdist obj2break stDist))
stDist) dlst))
)
((minusp stDist) ; off start of object so get startpoint
(setq dlst (cons (list idx (vlax-curve-getstartpoint obj2break) 0.0) dlst))
)
(t
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getparamatdist obj2break stDist))
stDist) dlst))
)
)
;; add gap to get end point of break gap
(cond
((and (> (setq stDist (+ dist BrkGap))
(setq endDist (vlax-curve-getdistatparam obj2break
(vlax-curve-getendparam obj2break)))) closedobj )
(setq stdist (- stDist endDist))
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getparamatdist obj2break stDist))
stDist) dlst))
)
((> stDist endDist) ; off end of object so get endpoint
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getendparam obj2break))
endDist) dlst))
)
(t
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getparamatdist obj2break stDist))
stDist) dlst))
)
)
;; -------------------------------------------------------
(setq idx (1+ IDX))
) ; foreach brkpt brkptlst

(setq dlst (reverse dlst))
;; remove the points of the gap segments that overlap
(setq idx -1
2gap (* BrkGap 2)
#ofPts (length Brkptlst)
)
(while (<= (setq idx (1+ idx)) #ofPts)
(cond
((null result) ; 1st time through
(setq result (list (car dlst)) ; get first start point
result (cons (nth (1+(* idx 2)) dlst) result))
)
((= idx #ofPts) ; last pass, check for wrap
(if (and closedobj (> #ofPts 1)
(<= (+(- (vlax-curve-getdistatparam obj2break
(vlax-curve-getendparam obj2break))
(cadr (last BrkPtLst))) (cadar BrkPtLst)) 2Gap))
(progn
(if (zerop (rem (length result) 2))
(setq result (cdr result)) ; remove the last end point
)
;; ignore previous endpoint and present start point
(setq result (cons (cadr (reverse result)) result) ; get last end point
result (cdr (reverse result))
result (reverse (cdr result)))
)
)
)
;; Break Gap Overlaps
((< (cadr (nth idx Brkptlst)) (+ (cadr (nth (1- idx) Brkptlst)) 2Gap))
(if (zerop (rem (length result) 2))
(setq result (cdr result)) ; remove the last end point
)
;; ignore previous endpoint and present start point
(setq result (cons (nth (1+(* idx 2)) dlst) result)) ; get present end point
)
;; Break Gap does Not Overlap previous point
(t
(setq result (cons (nth (* idx 2) dlst) result)) ; get this start point
(setq result (cons (nth (1+(* idx 2)) dlst) result)) ; get this end point
)
) ; end cond stmt
) ; while

(setq dlst (reverse result)
brkptlst nil)
(while dlst ; grab the points only
(setq brkptlst (cons (list (cadar dlst)(cadadr dlst)) brkptlst)
dlst (cddr dlst))
)
)
)
;; -----------------------------------------------------
;; (if (equal a ent) (princ)) ; debug CAB -------------

(foreach brkpt (reverse brkptlst)
(if GapFlg ; gap > 0
(setq brkptS (car brkpt)
brkptE (cadr brkpt))
(setq brkptS (car brkpt)
brkptE brkptS)
)
;; get last entity created via break in case multiple breaks
(if brkobjlst
(progn
(setq tmppt brkptS) ; use only one of the pair of breakpoints
;; if pt not on object x, switch objects
(if (not (numberp (vl-catch-all-apply
'vlax-curve-getdistatpoint (list obj2break tmppt))))
(progn ; find the one that pt is on
(setq idx (length brkobjlst))
(while (and (not (minusp (setq idx (1- idx))))
(setq obj (nth idx brkobjlst))
(if (numberp (vl-catch-all-apply
'vlax-curve-getdistatpoint (list obj tmppt)))
(null (setq obj2break obj)) ; switch objects, null causes exit
t
)
)
)
)
)
)
)
(setq closedobj (vlax-curve-isclosed obj2break))
(if GapFlg ; gap > 0
(if closedobj
(progn ; need to break a closed object
(setq brkpt2 (vlax-curve-getPointAtDist obj2break
(- (vlax-curve-getDistAtPoint obj2break brkptE) 0.00001)))
(command "._break" obj2break "_non" (trans brkpt2 0 1)
"_non" (trans brkptE 0 1))
(and (= "CIRCLE" enttype) (setq enttype "ARC"))
(setq BrkptE brkpt2)
)
)
(if (and closedobj
(not (setq brkptE (vlax-curve-getPointAtDist obj2break
(+ (vlax-curve-getdistatparam obj2break
;;(vlax-curve-getparamatpoint obj2break brkpts)) 0.00001))))
;; ver 2.0 fix
(cond ((vlax-curve-getparamatpoint obj2break brkpts))
((vlax-curve-getparamatpoint obj2break
(vlax-curve-getclosestpointto obj2break brkpts))))) 0.00001)))))
(setq brkptE (vlax-curve-getPointAtDist obj2break
(- (vlax-curve-getdistatparam obj2break
;;(vlax-curve-getparamatpoint obj2break brkpts)) 0.00001)))
;; ver 2.0 fix
(cond ((vlax-curve-getparamatpoint obj2break brkpts))
((vlax-curve-getparamatpoint obj2break
(vlax-curve-getclosestpointto obj2break brkpts))))) 0.00001)))
)
) ; endif

;; (if (null brkptE) (princ)) ; debug

(setq LastEnt (GetLastEnt))
(command "._break" obj2break "_non" (trans brkptS 0 1) "_non" (trans brkptE 0 1))
(and *BrkVerbose* (princ (setq *brkcnt* (1+ *brkcnt*))) (princ "\r"))
(and (= "CIRCLE" enttype) (setq enttype "ARC"))
(if (and (not closedobj) ; new object was created
(not (equal LastEnt (entlast))))
(setq brkobjlst (cons (entlast) brkobjlst))
)
)
)
) ; endif brkptlst

) ; defun break_obj
;;====================================
;; CAB - get last entity in datatbase
(defun GetLastEnt ( / ename result )
(if (setq result (entlast))
(while (setq ename (entnext result))
(setq result ename)
)
)
result
)
;;===================================
;; CAB - return a list of new enames
(defun GetNewEntities (ename / new)
(cond
((null ename) (alert "Ename nil"))
((eq 'ENAME (type ename))
(while (setq ename (entnext ename))
(if (entget ename) (setq new (cons ename new)))
)
)
((alert "Ename wrong type."))
)
new
)

;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; S T A R T S U B R O U T I N E H E R E
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

(setq LastEntInDatabase (GetLastEnt))
(if (and ss2brk ss2brkwith)
(progn
(setq oc 0
ss2brkwithList (ssget->vla-list ss2brkwith))
(if (> (* (sslength ss2brk)(length ss2brkwithList)) 5000)
(setq *BrkVerbose* t)
)
(and *BrkVerbose*
(princ (strcat "Objects to be Checked: "
(itoa (* (sslength ss2brk)(length ss2brkwithList))) "\n")))
;; CREATE a list of entity & it's break points
(foreach obj (ssget->vla-list ss2brk) ; check each object in ss2brk
(if (not (onlockedlayer (vlax-vla-object->ename obj)))
(progn
(setq lst nil)
;; check for break pts with other objects in ss2brkwith
(foreach intobj ss2brkwithList
(if (and (or self (not (equal obj intobj)))
(setq intpts (get_interpts obj intobj))
)
(setq lst (append (list->3pair intpts) lst)) ; entity w/ break points
)
(and *BrkVerbose* (princ (strcat "Objects Checked: " (itoa (setq oc (1+ oc))) "\r")))
)
(if lst
(setq masterlist (cons (cons (vlax-vla-object->ename obj) lst) masterlist))
)
)
)
)
(and *BrkVerbose* (princ "\nBreaking Objects.\n"))
(setq *brkcnt* 0) ; break counter
;; masterlist = ((ent brkpts)(ent brkpts)...)
(if masterlist
(foreach obj2brk masterlist
(break_obj (car obj2brk) (cdr obj2brk) Gap)
)
)
)
)
;;==============================================================
(and (zerop *brkcnt*) (princ "\nNone to be broken."))
(setq *BrkVerbose* nil)
(GetNewEntities LastEntInDatabase) ; return list of enames of new objects
)
(defun unvisible (objSet)
(vl-load-com)
(foreach obj (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr(ssnamex objSet))))
(vl-catch-all-error-p
(vl-catch-all-apply
'vla-put-visible
(list obj :vlax-false)))
)
(princ)
)
(defun visible(/ objSet)
(vl-load-com)
(setq objSet (ssget "_X" '((60 . 1))))
(if objSet
(foreach obj (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr(ssnamex objSet))))
(vl-catch-all-error-p
(vl-catch-all-apply
'vla-put-visible
(list obj :vlax-true)))
)
)
(princ)
)

  • 0

#5 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5678 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 14 September 2011 - 10:53 AM

Mình đã từng làm việc như thế rồi, với 1 đường bao bất kỳ nhưng giờ không còn code nữa, không biết nó ở mô ^^ Và nếu sử dụng hướng extrim của express thì sẽ nhanh hơn rất nhiều.
Sửa lại của các bác ấy mình e không đủ khả năng, hì hì ( chữ ký nè ^^)
  • 0

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#6 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

  • Moderator
  • PipPipPipPipPipPipPip
  • 6007 Bài viết
Điểm đánh giá: 3113 (tuyệt vời)

Đã gửi 14 September 2011 - 11:40 AM

Chắc chủ đề của bạn hơi khó nhằn ???
Hướng giải quyết của mình là như sau, tuy nhiên, dài thoòng ^^
1- vla-offset 2 bên đường tim tuyến (e1,e2)
2- Lấy list tọa độ đỉnh của e1, e2 (lst1, lst2)
3- Với mỗi đỉnh của e1 kẻ đường thẳng tương ứng với e2
4- ssget "cp" / "c" qua list đỉnh append lst1 lst2 (ss)
5- Copy ss + e1,e2 ra điểm đặt, dùng entlast và while entnext để lấy lại toàn bộ tập ss mới copy (ss_copy + e1_copy, e2_copy)
6- Scale theo tỉ lệ
7- Joint e1_copy, e2_copy thành đường bao e
8- Extrim e
...Chẹp chẹp, tư duy cổ hủ, nên thấy nó dài quá ^^

Hề hề hề,
Tư duy của mình cũng cổ hủ như vầy, song minh chả biết cái hàm vla-offset nó tròn méo ra răng nên có nhẽ cứ chơi kiểu chuối là dùng hàm command vậy.
Chả cần thiết phải : Với mỗi đỉnh của e1 kẻ đường thẳng tương ứng với e2 làm chi cho nó rườm rà bác ạ.
Sau khi extrim e bác còn phải xóa e và lấy scale nữa ạ.
Vậy là nó lại thoòng thêm tí nữa.
Hề hề hề,
Để mình thử khai triển lisp theo hướng này xem nó ra sao, không thành công cũng thành ...... củ các bác nhể....
Việc sửa lisp của bác Thiếp e rằng cũng không nhanh hơn việc viết mới. Thôi thì ......
  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#7 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5678 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 14 September 2011 - 12:21 PM

À, em kẻ tương ứng là vì trong bản vẽ của bạn ấy nó có các đường nối đó ^^
  • 0

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#8 cd2k44

cd2k44

    Edu level: li5

  • Members
  • PipPipPipPipPipPipPip
  • 648 Bài viết
Điểm đánh giá: 121 (tàm tạm)

Đã gửi 14 September 2011 - 12:22 PM

Hồi trước bác Bình cũng viết 1 lisp có tính chất tương tự lisp của bác thiệp mà.Bác phát triển tiếp lisp đó có được không ah
  • 0

#9 gia_bach

gia_bach

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1432 Bài viết
Điểm đánh giá: 1425 (rất tốt)

Đã gửi 14 September 2011 - 02:16 PM

Chắc chủ đề của bạn hơi khó nhằn ???
Hướng giải quyết của mình là như sau, tuy nhiên, dài thoòng ^^
1- vla-offset 2 bên đường tim tuyến (e1,e2)
2- Lấy list tọa độ đỉnh của e1, e2 (lst1, lst2)
3- Với mỗi đỉnh của e1 kẻ đường thẳng tương ứng với e2
4- ssget "cp" / "c" qua list đỉnh append lst1 lst2 (ss)
5- Copy ss + e1,e2 ra điểm đặt, dùng entlast và while entnext để lấy lại toàn bộ tập ss mới copy (ss_copy + e1_copy, e2_copy)
6- Scale theo tỉ lệ
7- Joint e1_copy, e2_copy thành đường bao e
8- Extrim e
...Chẹp chẹp, tư duy cổ hủ, nên thấy nó dài quá ^^

Lisp Vẽ đuờng bao và chọn các đối tượng giao với đuờng bao này.
(thực hiện theo ý của Ket nhưng chỉ tới bước 4 , các bước sau bác nào có th/gian thì tiếp tục ...)

Chú ý : CodeBox của Forum bị lỗi !


(defun c:SWE (/ dis ent obj objoff ss)
(vl-load-com)
(if (and (setq ent (ssget "_:S" '((0 . "LWPOLYLINE"))))
(setq dis (getdist "nhap kh/cach :" )) )
(progn
(setq obj (vlax-Ename->Vla-Object(ssname ent 0))
objOff (makePlineOffset obj dis) )
(ACET-SS-ZOOM-EXTENTS (ACET-LIST-TO-SS (list (ssname ent 0))))
(if (setq ss (ssget "_CP" (poly-pts objOff) ))
(sssetfirst ss ss) ) ) )
(princ))
(defun makeLWPolyline(lst-pt)
(entmakex
(apply
(function append)
(cons
(list
'(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline")
(cons 90 (length lst-pt)) '(70 . 0) '(70 . 1) )
(mapcar
(function list)
(mapcar (function (lambda (a) (cons 10 a))) lst-pt) ) ) ) ) )
(defun poly-pts (ent)
(mapcar
(function cdr)
(vl-remove-if-not (function (lambda (a) (= (car a) 10))) (entget ent)) ) )
(defun makePlineOffset (obj dis / lst el)
(vla-offset obj dis)
(setq lst (poly-pts (setq el(entlast))) )
(entdel el)
(vla-offset obj (- dis))
(foreach pt (poly-pts (setq el(entlast)))
(setq lst (cons pt lst)))(entdel el)
(makeLWPolyline lst) )

  • 1

#10 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

  • Moderator
  • PipPipPipPipPipPipPip
  • 6007 Bài viết
Điểm đánh giá: 3113 (tuyệt vời)

Đã gửi 14 September 2011 - 02:30 PM

Em có 1 bài toán thế này nhờ các Bác giải giúp: Em có 1 bản đồ địa hình có đường đồng mức và cao độ cũng như địa hình địa vật.Yêu cầu như sau: 1. Vạch 1 đường tim tuyến trên bản đồ địa hình đó. 2.Copy đường đồng mức cao độ địa hình địa vật và tim tuyến đó ra khoảng cách copy đường đồng mức và địa hình địa vật từ tim tuyến ra theo khoảng cách tuỳ ý có thể là 25m có thể là 50m.... 3.Đường đồng mức địa hình địa vật và tim tuyến copy ra có thể thay đổi theo tỷ lệ tuỳ ý có thể 1/1;1/2;1/5.... Nhờ các bác giải quyết hộ em bài toán này http://www.cadviet.c...es/3/binhdo.dwg

Hề hề hề,
bạn dùng thử cái này coi đã ưng ý chưa hè,

(defun c:copart (/ pl k plst p1 p2 goc pl1 pl2 plst1 plst2 plst3 ss ss1 a plg pt l)
(vl-load-com)
(command "undo" "be")
(setq pl (car (entsel "\n Chon pline chuan"))
k (getreal "\n Nhap khoang cach offset: ")
;;;; obj (vlax-ename->vla-object pl)
plst (acet-geom-vertex-list pl)
p1 (car plst)
p2 (cadr plst)
goc (angle p1 p2)
)
(command "offset" k pl (polar p1 (+ (/ pi 2) goc) k) "")
(setq pl1 (entlast)
plst1 (acet-geom-vertex-list pl1))
(command "offset" k pl (polar p1 (- goc (/ pi 2)) k) "")
(command "zoom" "e")
(setq pl2 (entlast)
plst2 (append plst1 (reverse (acet-geom-vertex-list pl2)))
plst2 (append plst2 (list (car plst1)))
ss (ssget "cp" plst2)
ss (ssdel pl1 ss)
ss (ssdel pl2 ss)
a (acet-pline-make (list plst2))
plg (entlast)
;;;; ss (ssadd plg ss)
pt (getpoint p1 "\n Chon diem dat hinh trich")
l (getreal "\n Nhap ty le hinh trich: "))
;;;;(command "zoom" "p")
(command "copy" ss plg "" p1 pt)
(command "erase" pl1 pl2 plg "")
(setq plg (entlast))
(etrim plg (polar pt (+ goc (/ pi 2)) (1+ k)))
(setq plst3 (acet-ent-geomextents plg)
ss1 (ssget "w" (car plst3) (cadr plst3))
ss1 (ssdel plg ss1))
(command "zoom" "w" (car plst3) (cadr plst3))
(command "erase" plg "")
(command "scale" ss1 "" pt l)

(command "undo" "e")
(princ)
)


Chúc bạn vui.

Hề hề hề, chán quá, thẻ code của diễn đàn bị lỗi. Bạn hãy lưu ý rằng các dấu (') phải được thay thế bằng các dấu (") nhé.
Nếu không được bạn cho địa chỉ mail mình sẽ gửi file cho .
  • 1
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#11 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

  • Moderator
  • PipPipPipPipPipPipPip
  • 6007 Bài viết
Điểm đánh giá: 3113 (tuyệt vời)

Đã gửi 14 September 2011 - 02:49 PM

Hề hề hề,
bạn dùng thử cái này coi đã ưng ý chưa hè,

Chúc bạn vui.

Hề hề hề, chán quá, thẻ code của diễn đàn bị lỗi. Bạn hãy lưu ý rằng các dấu (') phải được thay thế bằng các dấu (") nhé.
Nếu không được bạn cho địa chỉ mail mình sẽ gửi file cho .

Hề hề hề,
Thử chơi thẻ codebox xem có ngon hơn không:


(defun c:copart (/ pl k plst p1 p2 goc pl1 pl2 plst1 plst2 plst3 ss ss1 a plg pt l)
(vl-load-com)
(command "undo" "be")
(setq pl (car (entsel "\n Chon pline chuan"))
k (getreal "\n Nhap khoang cach offset: ")
;;;; obj (vlax-ename->vla-object pl)
plst (acet-geom-vertex-list pl)
p1 (car plst)
p2 (cadr plst)
goc (angle p1 p2)
)
(command "offset" k pl (polar p1 (+ (/ pi 2) goc) k) "")
(setq pl1 (entlast)
plst1 (acet-geom-vertex-list pl1))
(command "offset" k pl (polar p1 (- goc (/ pi 2)) k) "")
(command "zoom" "e")
(setq pl2 (entlast)
plst2 (append plst1 (reverse (acet-geom-vertex-list pl2)))
plst2 (append plst2 (list (car plst1)))
ss (ssget "cp" plst2)
ss (ssdel pl1 ss)
ss (ssdel pl2 ss)
a (acet-pline-make (list plst2))
plg (entlast)
;;;; ss (ssadd plg ss)
pt (getpoint p1 "\n Chon diem dat hinh trich")
l (getreal "\n Nhap ty le hinh trich: "))
;;;;(command "zoom" "p")
(command "copy" ss plg "" p1 pt)
(command "erase" pl1 pl2 plg "")
(setq plg (entlast))
(etrim plg (polar pt (+ goc (/ pi 2)) (1+ k)))
(setq plst3 (acet-ent-geomextents plg)
ss1 (ssget "w" (car plst3) (cadr plst3))
ss1 (ssdel plg ss1))
(command "zoom" "w" (car plst3) (cadr plst3))
(command "erase" plg "")
(command "scale" ss1 "" pt l)

(command "undo" "e")
(princ)
)

  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#12 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

  • Moderator
  • PipPipPipPipPipPipPip
  • 6007 Bài viết
Điểm đánh giá: 3113 (tuyệt vời)

Đã gửi 14 September 2011 - 02:54 PM

Hề hề hề,
Thử chơi thẻ codebox xem có ngon hơn không:

 (defun c:copart (/ pl k plst p1 p2 goc pl1 pl2 plst1 plst2 plst3 ss ss1 a plg pt l)(vl-load-com)(command "undo" "be")(setq pl (car (entsel "\n Chon pline chuan"))        k (getreal "\n Nhap khoang cach offset: ")        ;;;; obj (vlax-ename->vla-object pl)        plst (acet-geom-vertex-list pl)        p1 (car plst)        p2 (cadr plst)        goc (angle p1 p2))(command "offset" k pl (polar p1 (+ (/ pi 2) goc) k) "")(setq pl1 (entlast)        plst1 (acet-geom-vertex-list pl1))(command "offset" k pl (polar p1 (- goc (/ pi 2)) k) "")(command "zoom" "e")(setq pl2 (entlast)        plst2 (append plst1 (reverse (acet-geom-vertex-list pl2)))        plst2 (append plst2 (list (car plst1)))        ss (ssget "cp" plst2)        ss (ssdel pl1 ss)        ss (ssdel pl2 ss)           	a  (acet-pline-make (list plst2))        plg (entlast)        ;;;; ss (ssadd plg ss)        pt (getpoint p1 "\n Chon diem dat hinh trich")        l (getreal "\n Nhap ty le hinh trich: "));;;;(command "zoom" "p")(command "copy" ss plg "" p1 pt)(command "erase" pl1 pl2 plg "")(setq plg (entlast))(etrim plg (polar pt (+ goc (/ pi 2)) (1+ k)))(setq plst3 (acet-ent-geomextents plg)        ss1 (ssget "w" (car plst3) (cadr plst3))        ss1 (ssdel plg ss1))(command "zoom" "w" (car plst3) (cadr plst3))(command "erase" plg "")(command "scale" ss1 "" pt l) (command "undo" "e")(princ))

Thôi thì chơi kiều chuối này cho chắc ăn vậy:


(defun c:copart (/ pl k plst p1 p2 goc pl1 pl2 plst1 plst2 plst3 ss ss1 a plg pt l)
(vl-load-com)
(command "undo" "be")
(setq pl (car (entsel "\n Chon pline chuan"))
k (getreal "\n Nhap khoang cach offset: ")
;;;; obj (vlax-ename->vla-object pl)
plst (acet-geom-vertex-list pl)
p1 (car plst)
p2 (cadr plst)
goc (angle p1 p2)
)
(command "offset" k pl (polar p1 (+ (/ pi 2) goc) k) "")
(setq pl1 (entlast)
plst1 (acet-geom-vertex-list pl1))
(command "offset" k pl (polar p1 (- goc (/ pi 2)) k) "")
(command "zoom" "e")
(setq pl2 (entlast)
plst2 (append plst1 (reverse (acet-geom-vertex-list pl2)))
plst2 (append plst2 (list (car plst1)))
ss (ssget "cp" plst2)
ss (ssdel pl1 ss)
ss (ssdel pl2 ss)
a (acet-pline-make (list plst2))
plg (entlast)
;;;; ss (ssadd plg ss)
pt (getpoint p1 "\n Chon diem dat hinh trich")
l (getreal "\n Nhap ty le hinh trich: "))
;;;;(command "zoom" "p")
(command "copy" ss plg "" p1 pt)
(command "erase" pl1 pl2 plg "")
(setq plg (entlast))
(etrim plg (polar pt (+ goc (/ pi 2)) (1+ k)))
(setq plst3 (acet-ent-geomextents plg)
ss1 (ssget "w" (car plst3) (cadr plst3))
ss1 (ssdel plg ss1))
(command "zoom" "w" (car plst3) (cadr plst3))
(command "erase" plg "")
(command "scale" ss1 "" pt l)

(command "undo" "e")
(princ)
)

Mong các bác chớ giận vì mình không muốn người dùng phải vất vả,
  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#13 anpha3

anpha3

    biết vẽ arc

  • Members
  • PipPip
  • 48 Bài viết
Điểm đánh giá: -2 (bình thường)

Đã gửi 14 September 2011 - 07:36 PM

Quả là cao thủ võ lâm, Cám ơn Các Bác nhé...
  • 0

#14 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5678 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 14 September 2011 - 08:39 PM

@bác Bình : nó show vậy thôi, còn down về vẫn bình thường bác ạ ^^
@anpha3 : bạn hãy nhấn Thank (nút You like It)các bác ấy kèm theo lời cảm ơn của mình
  • 0

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#15 thiep

thiep

    biết dimbaseline

  • Members
  • PipPipPipPipPip
  • 369 Bài viết
Điểm đánh giá: 260 (khá)

Đã gửi 15 September 2011 - 02:21 PM

Chào anpha3
Trước hết, xin nhận xét:
- cái đường bao quanh tim tuyến bản vẽ của bạn không phải do offset tim tuyến ra 2 bên, nó không cân đối qua tim tuyến
- Trong bản vẽ có nhiều đối tượng nằm trùng với nhau,
Vì vậy, trước khi sử dụng lisp Thiệp gửi đề nghị bạn như sau:
- Dùng lệnh "overkill" để xóa hết các đối tượng trùng nhau,
- Offset tim tuyến ra 2 bên theo ý bạn rồi nối chúng lại thành 1 đường bao,
Thiep đã nâng cấp TRICHBD.LSP đê trích thửa bản đồ với các loại đường bao là: Square/Rectangle/Circle/Ellipse/Lwpolyline, trong bản vẽ của bạn với trích thửa là Lwpolyline (bạn chỉ cần đánh "L")

http://www.cadviet.c...3/trichbd_1.lsp

Sau khi chạy lisp, bạn scale bao nhiêu thì tùy bạn.
@thanhbinh, lisp của bác chỉ chạy được khi trong bản vẽ đã từng sử dụng lệnh extrim, ngoài ra lisp của bác nó etrim lẫn lộn: có khi nó xóa các đối tượng trong đường bao đó!
  • 0

#16 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

  • Moderator
  • PipPipPipPipPipPipPip
  • 6007 Bài viết
Điểm đánh giá: 3113 (tuyệt vời)

Đã gửi 15 September 2011 - 03:55 PM

Chào anpha3
Trước hết, xin nhận xét:
- cái đường bao quanh tim tuyến bản vẽ của bạn không phải do offset tim tuyến ra 2 bên, nó không cân đối qua tim tuyến
- Trong bản vẽ có nhiều đối tượng nằm trùng với nhau,
Vì vậy, trước khi sử dụng lisp Thiệp gửi đề nghị bạn như sau:
- Dùng lệnh "overkill" để xóa hết các đối tượng trùng nhau,
- Offset tim tuyến ra 2 bên theo ý bạn rồi nối chúng lại thành 1 đường bao,
Thiep đã nâng cấp TRICHBD.LSP đê trích thửa bản đồ với các loại đường bao là: Square/Rectangle/Circle/Ellipse/Lwpolyline, trong bản vẽ của bạn với trích thửa là Lwpolyline (bạn chỉ cần đánh "L")

http://www.cadviet.c...3/trichbd_1.lsp

Sau khi chạy lisp, bạn scale bao nhiêu thì tùy bạn.
@thanhbinh, lisp của bác chỉ chạy được khi trong bản vẽ đã từng sử dụng lệnh extrim, ngoài ra lisp của bác nó etrim lẫn lộn: có khi nó xóa các đối tượng trong đường bao đó!

Hề hề hề,
Chào bác Thiếp.
1/- Cái vụ Etrim thì mình cũng đã dính đòn và nghiệm ra rằng, tốt nhất là cho nó vào trong start suit thì sẽ luôn Ok.
2/- Việc etrim nhầm có nhẽ do bác nhầm chi đó chứ trong lisp thì khó mà nhầm được bởi điểm chọn để etrim là : (polar pt (+ goc (/ pi 2)) (1+ k)) luôn nằm ngoài khung xác định bởi đối tượng plg mà bác.
Mong bác check lại giùm nhé.
  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#17 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5678 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 15 September 2011 - 04:09 PM

Cái vụ extrim thì em nghĩ tốt nhất lúc nào cũng nên có dòng (or etrim (load "extrim.lsp")) ở đầu ^^
  • 0

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#18 TrangA

TrangA

    Chưa sử dụng CAD

  • Members
  • Pip
  • 2 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 17 September 2011 - 05:18 AM

Các Bác Xem lại Code này em chạy hay báo lỗi etrim và lúc chạy được thì xoá hết đối tượng bên trong đường bao
  • 0

#19 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 992 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 17 September 2011 - 07:28 AM

Bác Thiệp lại ra tay trượng nghĩa rồi. Chắc lâu roài bác cũng ko viết ấy nhở? Hic. Em cũng ngứa nghề quá bác ah. Muốn mót mà ko được, hic. Khi nào về em mót vậy.
  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#20 TrangA

TrangA

    Chưa sử dụng CAD

  • Members
  • Pip
  • 2 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 18 September 2011 - 09:04 AM

Lisp Copart của bác PhanThanhBình thật là hay nhưng không hiểu sao có máy tính em dùng được có máy tính thì báo lỗi và có máy tính thì xoá bỏ hết địa hình địa vật bên trong vùng bao và có máy thì báo
error: no function definition: ETRIM

Không biết là lỗi sao ??
  • 0