- 积分
- 11672
- 明经币
- 个
- 注册时间
- 2011-9-17
- 在线时间
- 小时
- 威望
-
- 金钱
- 个
- 贡献
-
- 激情
-
|
楼主 |
发表于 2019-12-30 22:21:04
|
显示全部楼层
本帖最后由 树櫴希德 于 2019-12-31 11:27 编辑
旧版有问题
- ;;
- ;;;
- ;;; EXTRIM.LSP
- ;;; Copyright ?1999 by Autodesk, Inc.
- ;;;
- ;;; Your use of this software is governed by the terms and conditions of the
- ;;; License Agreement you accepted prior to installation of this software.
- ;;; Please note that pursuant to the License Agreement for this software,
- ;;; "[c]opying of this computer program or its documentation except as
- ;;; permitted by this License is copyright infringement under the laws of
- ;;; your country. If you copy this computer program without permission of
- ;;; Autodesk, you are violating the law."
- ;;;
- ;;; AUTODESK PROVIDES THIS PROGRAM "AS IS" AND WITH ALL FAULTS.
- ;;; AUTODESK SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY OF
- ;;; MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE. AUTODESK, INC.
- ;;; DOES NOT WARRANT THAT THE OPERATION OF THE PROGRAM WILL BE
- ;;; UNINTERRUPTED OR ERROR FREE.
- ;;;
- ;;; Use, duplication, or disclosure by the U.S. Government is subject to
- ;;; restrictions set forth in FAR 52.227-19 (Commercial Computer
- ;;; Software - Restricted Rights) and DFAR 252.227-7013(c)(1)(ii)
- ;;; (Rights in Technical Data and Computer Software), as applicable.
- ;;;
- ;;; ----------------------------------------------------------------
-
-
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;Extended-TRIM - cookie-cutter routine
- ;
- ;Select a polyline, line, circle or arc and a side to trim on
- ;
- (defun pzx-extrim (na p1 / na e1 p1 redraw_it lst n )
-
- (acet-error-init (list
- (list "cmdecho" 0
- "highlight" 0
- "regenmode" 1
- "osmode" 0
- "ucsicon" 0
- "offsetdist" 0
- "attreq" 0
- "plinewid" 0
- "plinetype" 1
- "gridmode" 0
- "celtype" "CONTINUOUS"
- "ucsfollow" 0
- "limcheck" 0
- )
- T ;flag. True means use undo for error clean up.
- '(if redraw_it (redraw na 4))
- );list
- );acet-error-init
-
-
- (princ "\nPick a POLYLINE, LINE, CIRCLE, ARC, ELLIPSE, IMAGE or TEXT for cutting edge...")
- ;setq
- (if na
- (progn
- (setq e1 (entget na));;setq
- (if (or (equal "TEXT" (cdr (assoc 0 e1)))
- (equal "MTEXT" (cdr (assoc 0 e1)))
- (equal "ATTDEF" (cdr (assoc 0 e1)))
- (equal "IMAGE" (cdr (assoc 0 e1)))
- (equal "INSERT" (cdr (assoc 0 e1)))
- (equal "SOLID" (cdr (assoc 0 e1)))
- (equal "3DFACE" (cdr (assoc 0 e1)))
- (equal "TRACE" (cdr (assoc 0 e1)))
- );or
- (progn
- (setq lst (acet-geom-object-point-list na nil))
- (setq n 0)
- (command "_.pline")
- (repeat (length lst)
- (command (nth n lst))
- (setq n (+ n 1));setq
- );repeat
- (if (not (equal (car lst) (last lst) 0.0000001))
- (command "_cl")
- (command "")
- );if
- (setq na (entlast)
- e1 na
- );setq
- );progn then draw a temp pline to be the cutting edge.
- (setq e1 nil)
- );if
- (redraw na 3)
- (setq redraw_it T)
-
- ;setq
- (redraw na 4)
- (setq redraw_it nil)
- (if p1 (etrim na p1));if
- (if e1
- (progn
- (if (setq p1 (acet-layer-locked (getvar "clayer")))
- (command "_.layer" "_un" (getvar "clayer") "")
- );if
- (entdel e1)
- (if p1
- (command "_.layer" "_lock" (getvar "clayer") "")
- );if
- );progn then
- );if
- );progn
- );if
-
- (acet-error-restore)
- (princ)
- );defun c:extrim
-
- ;!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ;Entity-TRIM function
- ;takes: na - entity name
- ; a - a point, the side to trim on
- ;NOTE: This function does not allow for the possible miss of
- ; non-continuous linetypes.
- ;
- (defun etrim ( na a / la b d e1 lst lst2 n j k m ss na2 na3 na4
- x y z flag flag2 flag3 zlst vpna vplocked
- )
-
-
- (setq e1 (entget na));setq
- (if (or (setq flag (equal (acet-dxf 0 e1) "OLYLINE"))
- (setq flag (equal (acet-dxf 0 e1) "LWPOLYLINE"))
- (equal (acet-dxf 0 e1) "LINE")
- (equal (acet-dxf 0 e1) "CIRCLE")
- (equal (acet-dxf 0 e1) "ARC")
- (equal (acet-dxf 0 e1) "ELLIPSE")
- (equal (acet-dxf 0 e1) "TEXT")
- (equal (acet-dxf 0 e1) "ATTDEF")
- (equal (acet-dxf 0 e1) "MTEXT")
- (equal (acet-dxf 0 e1) "SPLINE")
- );or
- (progn
- (if (and flag
- (equal 8 (logand 8 (acet-dxf 70 e1)))
- );and
- (setq flag nil)
- );if
- (setq a (trans a 1 0)
- vpna (acet-currentviewport-ename)
- );setq
- (acet-ucs-cmd (list "_View"))
-
- (setq lst (acet-geom-object-point-list na nil) ;;;find extents of selected cutting edge object
- lst (acet-geom-list-extents lst)
- x (- (car (cadr lst)) (car (car lst)))
- y (- (cadr (cadr lst)) (cadr (car lst)))
- x (* 0.075 x)
- y (* 0.075 y)
- z (list x y)
- x (list (+ (car (cadr lst)) (car z))
- (+ (cadr (cadr lst)) (cadr z))
- );list
- y (list (- (car (car lst)) (car z))
- (- (cadr (car lst)) (cadr z))
- );list
- zlst (zoom_2_object (list x y))
- );setq
- (if vpna
- (setq vplocked (acet-viewport-lock-set vpna nil)) ;unlock cur viewport if needed.
- );if
- (command "_.zoom" "_w" (car zlst) (cadr zlst))
-
- (entupd na) ;;;update the ent. so it's curves display smoothly
-
- (setq lst (acet-geom-object-point-list na
- (/ (acet-geom-pixel-unit) 2.0)
- )
- );setq
- (if (or (not flag)
- (not (acet-geom-self-intersect lst nil))
- );or
- (progn ;then the object is valid and not a self intersecting polyline.
- (if (and flag
- (equal (car lst) (last lst) 0.0001)
- );and
- (setq flag3 T);then the polyline could potentialy need a second offset
- );if
- (if (setq la (acet-layer-locked (getvar "clayer")))
- (command "_.layer" "_unl" (getvar "clayer") "")
- );if
-
- (command "_.pline")
- (setq b nil)
- (setq n 0);setq
- (repeat (length lst)
- (setq d (nth n lst))
- (if (not (equal d b 0.0001))
- (progn
- (command d)
- (setq lst2 (append lst2 (list d)));setq
- (setq b d);setq
- );progn
- );if
- (setq n (+ n 1))
- );repeat
- (command "")
- (setq na2 (entlast)
- ss (ssadd)
- ss (ssadd na2 ss)
- lst nil
- );setq
- (acet-ss-visible ss 1)
- (setq lst2 (get_fence_points na2 a lst2 flag3 flag));setq
-
- (if la
- (command "_.layer" "_lock" (getvar "clayer") "")
- );if
- (acet-ucs-cmd (list "_p"))
- ;Move the ents to force a display update of the ents to avoid viewres problems.
- (setvar "highlight" 0)
- (if (setq ss (ssget "_f" (last lst2)))
- (command "_.move" ss "" "0,0,0" "0,0,0")
- );if
- (if flag
- (progn
- (if (setq la (acet-layer-locked (acet-dxf 8 e1)))
- (command "_.layer" "_unl" (acet-dxf 8 e1) "")
- );if
- (acet-ucs-set-z (acet-dxf 210 e1))
- (command "_.copy" na "" "0,0,0" "0,0,0")
- ;(entdel na)
- (acet-ss-visible (ssadd na (ssadd)) 1);make it invisible for a while.
- ;rk 12:01 PM 3/10/98
- (setq na3 na
- na (entlast)
- );setq
- (command "_.pedit" na "_w" "0.0" "_x")
- (acet-ucs-cmd (list "_p"))
- (if la (command "_.layer" "_lock" (acet-dxf 8 e1) ""));if
- );progn
- );if
- (command "_.trim" na "")
- (setq m (- (length lst2) 1));setq
- (setq k 0)
- (repeat (length lst2)
- (setq lst (nth k lst2))
- (setq a (trans (car lst) 0 1))
- (setq n 1)
- (repeat (- (length lst) 1) ;repeat each fence list
- (setq b (trans (nth n lst) 0 1))
- (if (equal a b 0.0001)
- (setq flag2 T)
- (setq flag2 nil)
- );if
- (setq na4 nil);setq
- (setq j 0);setq
- (while (not flag2) ;repeat each segment of the fence until no new ents are created.
- (setq na4 (entlast));setq
- (command "_F" a b "")
- (if (and (equal na4 (entlast))
- (or (not (equal k m))
- (> j 0)
- );or
- );and
- (setq flag2 T)
- );if
- (setq j (+ j 1));setq
- );while
- (setq a b);setq
- (setq n (+ n 1));setq
- );repeat
-
- (setq k (+ k 1))
- );repeat
- (command "")
-
- (if flag
- (progn
- (if (setq la (acet-layer-locked (acet-dxf 8 e1)))
- (command "_.layer" "_unl" (acet-dxf 8 e1) "")
- );if
- (entdel na) ;get rid of the copy
-
- ;(entdel na3);bring back the original
- (acet-ss-visible (ssadd na3 (ssadd)) 0) ;bring back the original
- ;rk 12:01 PM 3/10/98
- (if la (command "_.layer" "_lock" (acet-dxf 8 e1) ""));if
- );progn
- );if
- );progn
- (progn
- (acet-ucs-cmd (list "_p"))
- (princ "\nSelf intersecting edges are not acceptable.")
- );progn else invalid self intersecting polyline
- );if
- (command "_.zoom" "_p")
- (if vplocked
- (acet-viewport-lock-set vpna T) ;then re-lock the viewport
- );if
- );progn then it's a most likely a valid entity.
- );if
- );defun etrim
-
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (defun another_offset ( pl1 pl2 a1 a2 b na2 lst2 a lst3 lst4 / na ss lst da1 da2)
-
- (setq da1 (abs (- a2 a1)));setq
- (setq da2 (- (* b (max pl2 pl1))
- (/ (* b (abs (- pl2 pl1)))
- 2.0
- )
- )
- );setq
- (if (> (abs (- da2 da1))
- (* 0.01 (max a1 a2))
- )
- (progn
-
- (acet-pline-make (list lst2))
- (setq na (entlast)
- na2 (entlast)
- ss (ssadd)
- ss (ssadd na ss)
- );setq
- (acet-ss-visible ss 1)
- (command "_.offset" b na2 a "")
- (if (and (not (equal na (entlast)))
- (setq lst3 (acet-geom-vertex-list (entlast)))
- (setq lst3 (intersect_check lst2 lst3 lst4))
- );and
- (progn
- (acet-ss-visible (ssadd (entlast) (ssadd)) 1)
- (command "_.area" "_ob" (entlast))
- (setq pl2 (getvar "perimeter")
- a2 (getvar "area")
- );setq
- (setq lst (list (acet-geom-vertex-list (list (entlast) 0))));setq
- (entdel (entlast));then offset was a success so delete the ent after getting it's info
- );progn then
- (if (not (equal na (entlast))) (entdel (entlast)));if else
- );if
- (entdel na2)
- );progn then let's do that second offset
- );if
-
- lst
- );defun another_offset
-
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (defun get_fence_points ( na2 a lst2 flag plflag / a1 a2 pl1 pl2 b c d n
- lst lst2 lst3 lst4 na
- )
-
- (if flag
- (progn
- (setq lst2 (cdr lst2));setq
- (repeat (fix (/ (length lst2) 2))
- (setq lst2 (append (cdr lst2) (list (car lst2)));append
- );setq
- );repeat
- (setq lst2 (append lst2 (list (car lst2))));setq
- (command "_.area" "_ob" na2)
- (setq pl1 (getvar "perimeter")
- a1 (getvar "area")
- );setq
- );progn
- );if
-
- (setq a (trans a 0 1)
- b (* (getvar "viewsize") 0.05);initial offset distance
- n 3.0 ;number of offsets
- d (/ b (- n 1)) ;delta offset
- c (acet-geom-pixel-unit)
- lst4 (acet-geom-view-points)
- );setq
-
- (while (> b c)
- (setq na (entlast))
- (command "_.offset" b na2 a "")
- (if (and (not (equal na (entlast)))
- (setq lst3 (acet-geom-vertex-list (entlast)))
- (or (not plflag)
- (setq lst3 (intersect_check lst2 lst3 lst4))
- );or
- );and
- (progn
- (setq lst3 (acet-geom-m-trans lst3 1 0))
- (acet-ss-visible (ssadd (entlast) (ssadd)) 1)
- (if flag
- (progn
- (command "_.area" "_ob" (entlast))
- (setq pl2 (getvar "perimeter")
- a2 (getvar "area")
- );setq
- );progn
- );if
- (setq lst (append lst (list lst3)));setq
- (entdel (entlast)) ;delete the ent after getting it's vertex info
- (if flag
- (setq lst (append lst
- (another_offset pl1 pl2 a1 a2 b na2 lst2 a lst3 lst4)
- );append
- );setq
- );if
- );progn then offset was a success
- (if (not (equal na (entlast))) (entdel (entlast)));if else
- );if
- (setq b (- b d));setq
- );while
- (setq na (entlast))
- (command "_.offset" c na2 a "")
- (if (and (not (equal na (entlast)))
- (setq lst3 (acet-geom-vertex-list (entlast)))
- (or (not plflag)
- (setq lst3 (intersect_check lst2 lst3 lst4))
- );or
- );and
- (progn
- (setq lst3 (acet-geom-m-trans lst3 1 0))
- (acet-ss-visible (ssadd (entlast) (ssadd)) 1)
- (if flag
- (progn
- (command "_.area" "_ob" (entlast))
- (setq pl2 (getvar "perimeter")
- a2 (getvar "area")
- );setq
- );progn
- );if
- (setq lst (append lst (list lst3)));setq
- (entdel (entlast));then offset was a success so delete the ent after getting it's info
- (if flag
- (setq lst (append lst
- (another_offset pl1 pl2 a1 a2 c na2 lst2 a lst3 lst4)
- );append
- );setq
- );if
- );progn then
- (if (not (equal na (entlast))) (entdel (entlast)));if else
- );if
- (entdel na2)
-
- lst
- );defun get_fence_points
-
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;returns a list of points on screen if the first two lists do not
- ;contain segments that intersect each other.
- ;
- (defun intersect_check ( lst lst2 lst3 / x x2 y y2 lst4 flag len len2
- a aa b bb c d n j)
-
- (setq len (length lst)
- len2 (length lst2)
- x (car (car lst3))
- x2 (car (cadr lst3))
- y (cadr (car lst3))
- y2 (cadr (cadr lst3))
- );setq
-
- (setq n 0);setq
- (while (and (not flag)
- (< (+ n 1) len2)
- );and
- (setq aa (nth n lst2)
- bb (nth (+ n 1) lst2)
- a (bns_truncate_2_view aa bb x y x2 y2)
- b (bns_truncate_2_view bb aa x y x2 y2)
- lst4 (append lst4 (list a))
- );setq
- (if (or (not (equal a aa))
- (not (equal b bb))
- );or
- (setq lst4 (append lst4 (list b)))
- );if
- (setq j 0);setq
- (while (and (not flag)
- (< (+ j 1) len)
- );and
- (setq c (nth j lst)
- d (nth (+ j 1) lst)
- flag (inters a b c d)
- );setq
-
- (setq j (+ j 1));setq
- );while
-
- (setq n (+ n 1));setq
- );while
- (if (not (equal b (last lst4)))
- (setq lst4 (append lst4 (list b)));setq
- );if
- (if (not flag)
- (setq flag lst4)
- (setq flag nil)
- );if
- flag
- );defun intersect_check
-
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (defun zoom_2_object ( lst / p1 p2 p3 p4 p5 p6 mp dx dy dx2 dy2
- r1 r2 na e1 x w h dv1 dv2 x
- )
-
- (setq lst (acet-geom-m-trans lst 1 2)
- p1 (acet-geom-m-trans (acet-geom-view-points) 1 2) ;p1 and p2 are the viewpnts
- p2 (cadr p1)
- p1 (car p1)
- p1 (list (car p1) (cadr p1))
- p2 (list (car p2) (cadr p2))
- );setq
- (if lst
- (progn
- (setq p5 (acet-geom-list-extents lst) ;p5 and p6 are the geometry points
- p6 (cadr p5)
- p5 (car p5)
- p5 (list (car p5) (cadr p5))
- p6 (list (car p6) (cadr p6))
- mp (acet-geom-midpoint p5 p6) ;prepare to resize the geometry rectang to
- dx (- (car p2) (car p1)) ;have the same dy/dx ratio as p1 p2.
- dy (- (cadr p2) (cadr p1))
- dx2 (- (car p6) (car p5))
- dy2 (- (cadr p6) (cadr p5))
- );setq
- (if (equal dx 0.0) (setq dx 0.000001)) ;just in case div by zero
- (if (equal dx2 0.0) (setq dx2 0.000001))
- (setq r1 (/ dy dx)
- r2 (/ dy2 dx2)
- );setq
- (if (< r2 r1)
- (setq dy2 (* r1 dx2));then scale dy2 up
- (progn
- (if (equal r1 0.0) (setq r1 0.000001)) ;just in case div by zero
- (setq dx2 (* dy2 (/ 1.0 r1)));else scale dx2 up
- );progn
- );if
- (setq p5 (list (- (car mp) (/ dx2 1.98)) ;1.98 is used instead of 2.0 to expand
- (- (cadr mp) (/ dy2 1.98)) ;the rectangle slightly
- );list
- p6 (list (+ (car mp) (/ dx2 1.98))
- (+ (cadr mp) (/ dy2 1.98))
- );list
- );setq
- );progn then lst
- );if
- (if (and lst
- (equal 0 (getvar "tilemode"))
- (not (equal 1 (getvar "cvport")))
- (setq na (acet-currentviewport-ename))
- );and
- (progn
- (setq e1 (entget na)
- x (cdr (assoc 10 e1))
- w (cdr (assoc 40 e1))
- h (cdr (assoc 41 e1))
- p3 (list (- (car x) (/ w 2.0))
- (- (cadr x) (/ h 2.0))
- );list
- p4 (list (+ (car x) (/ w 2.0))
- (+ (cadr x) (/ h 2.0))
- );list
- p3 (trans p3 3 2) ;p3 and p4 are the viewport points
- p4 (trans p4 3 2)
- dv1 (acet-geom-delta-vector p1 p3)
- dv2 (acet-geom-delta-vector p2 p4)
- x (distance p1 p2)
- );setq
- (if (equal 0 x) (setq x 0.000001));just in case
- (setq x (/ (distance p5 p6)
- x
- )
- dv1 (acet-geom-vector-scale dv1 x)
- dv2 (acet-geom-vector-scale dv2 x)
- p5 (acet-geom-vector-add p5 dv1)
- p6 (acet-geom-vector-add p6 dv2)
- );setq
- );progn then
- );if
- (setq p1 (list (car p1) (cadr p1) 0.0)
- p2 (list (car p2) (cadr p2) 0.0)
- p5 (list (car p5) (cadr p5) 0.0)
- p6 (list (car p6) (cadr p6) 0.0)
- );setq
- (if lst
- (setq lst (list (trans p5 2 1)
- (trans p6 2 1)
- );list
- );setq
- (setq lst nil)
- );if
-
- lst
- );defun zoom_2_object
- (princ)
- ;;;;;;;;;;;;;;;;
- (defun LM:outline (sel / LM:ssboundingbox app
- are box cmd dis enl
- ent lst obj rtn tmp
- )
- (defun LM:ssboundingbox (s / a b i m n o)
- (repeat (setq i (sslength s))
- (if
- (and
- (setq o (vlax-ename->vla-object (ssname s (setq i (1- i)))))
- (vlax-method-applicable-p o 'getboundingbox)
- (not
- (vl-catch-all-error-p
- (vl-catch-all-apply 'vla-getboundingbox (list o 'a 'b))
- )
- )
- )
- (setq m (cons (vlax-safearray->list a) m)
- n (cons (vlax-safearray->list b) n)
- )
- )
- )
- (if (and m n)
- (mapcar '(lambda (a b) (apply 'mapcar (cons a b)))
- '(min max)
- (list m n)
- )
- )
- )
- (if (setq box (LM:ssboundingbox sel))
- (progn
- (setq app (vlax-get-acad-object)
- dis (/ (apply 'distance box) 20.0)
- lst (mapcar '(lambda (a o) (mapcar o a (list dis dis)))
- box
- '(- +)
- )
- are (apply '* (apply 'mapcar (cons '- (reverse lst))))
- dis (* dis 1.5)
- ent
- (entmakex
- (append
- '((000 . "LWPOLYLINE")
- (100 . "AcDbEntity")
- (100 . "AcDbPolyline")
- (090 . 4)
- (070 . 1)
- )
- (mapcar '(lambda (x)
- (cons 10 (mapcar '(lambda (y) ((eval y) lst)) x))
- )
- '((caar cadar)
- (caadr cadar)
- (caadr cadadr)
- (caar cadadr)
- )
- )
- )
- )
- )
- (apply
- 'vlax-invoke
- (vl-list* app
- 'zoomwindow
- (mapcar '(lambda (a o) (mapcar o a (list dis dis 0.0)))
- box
- '(- +)
- )
- )
- )
- (setq cmd (getvar 'cmdecho)
- enl (entlast)
- rtn (ssadd)
- )
- (while (setq tmp (entnext enl)) (setq enl tmp))
- (setvar 'cmdecho 0)
- (command
- "_.-boundary"
- "_a"
- "_b"
- "_n"
- sel
- ent
- ""
- "_i"
- "_y"
- "_o"
- "_p"
- ""
- (trans (mapcar '- (car box) (list (/ dis 3.0) (/ dis 3.0)))
- 0
- 1
- )
- ""
- )
- (while (< 0 (getvar 'cmdactive)) (command ""))
- (entdel ent)
- (while (setq enl (entnext enl))
- (if (and (vlax-property-available-p
- (setq obj (vlax-ename->vla-object enl))
- 'area
- )
- (equal (vla-get-area obj) are 1e-4)
- )
- (entdel enl)
- (ssadd enl rtn)
- )
- )
- (vla-zoomprevious app)
- (setvar 'cmdecho cmd)
- rtn
- )
- )
- )
- ;(LM:outline(ssget))
- (defun PoInPl(pt lst / i p1 p2 an anl ret)
- (setq i -1 p1 (last lst))
- (while(and(not ret)(setq p2(nth(setq i(1+ i))lst)))
- (cond((equal p2 pt 1e-6)(setq ret t))
- (t(setq an(-(angle pt p1)(angle pt p2)))
- (if(equal pi(abs an) 1e-6)
- (setq ret t)
- (setq anl(cons(rem an PI)anl)))))
- (setq p1 p2))
- (cond(ret 0);线上;
- (t(if(equal PI(abs(apply'+ anl))1e-6)1 -1))))
- (defun vxs(e / p a b n ob q et d d1 en et)
- (setq a(entget e)ob(vlax-ename->vla-object e)et(cdr(assoc 0 a))n 0 p nil d nil)
- (cond((="LWPOLYLINE"et)
- (repeat(length a)(setq b (nth n a) n (+ n 1))
- (if (= 10 (car b))(progn
- (setq q(list (cadr b) (caddr b))d1(vlax-curve-getDistAtPoint ob q))
- (if p (if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))
- (setq p (list q)))))))
- ((="OLYLINE"et)
- (SETQ EN (ENTGET (SETQ E (ENTNEXT E))))
- (WHILE (/= (CDR (ASSOC 0 EN)) "SEQEND")
- (SETQ q (CDR (ASSOC 10 EN))d1(vlax-curve-getDistAtPoint ob q)q(reverse(cdr(reverse q))))
- (if p(if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))(setq p(list q)))
- (SETQ EN (ENTGET (SETQ E (ENTNEXT E)))))
- (setq p(reverse p))))P)
- ;;;;;;;;;;
- (vl-load-com)
- (defun c:dmfc ( / zxbl pt p1 p2 p3 p4 fchd lst gcz nn i ss p5 ssa);
- (setq fchd (getreal "\n请输入回填土压实后厚度(一般0.25米) :"))
- (setq zxbl (getint "\n请输入断面纵向比例 1 :"))
- (setq pt (getpoint "\n请点击横断面图上96区顶中桩位置 :"))
- (setq p1 (car(entsel "\n请选择96区顶横断面多段线:")))
- (setq p2 (car(entsel "\n请选择左边坡断面多段线:")))
- (setq p3 (car(entsel "\n请选择右边坡横断面多段线:")))
- (setq p4 (car(entsel "\n请选择原地面横断面多段线:")))
- (setq ss(ssadd)) (ssadd p1 ss)(ssadd p2 ss)(ssadd p3 ss)(ssadd p4 ss)
- (LM:outline ss ) (setq p5 (entlast))
-
- (setq lst (vl-sort (vxs p4)(function (lambda (e1 e2) (< (cadr e1) (cadr e2))))))
- (setq gcz (* (- (cadr pt) (cadr(car lst)) ) (/ zxbl 1000.000) ) )
- (setq nn (fix (/ gcz fchd)))
- (setq i 0) (setvar "osmode" 16384) (setvar "CMDECHO" 0)
- (repeat (- nn 1)
-
- (command "_.copy" p1 "" pt (polar pt (* 1.5 pi ) (/ (* fchd (+ i 1)) (/ zxbl 1000.000) ) ) "" )
- ;
- (command "_.extend" p2 "" (list (entlast)(car(vxs (entlast)))) "" )
- (command "_.extend" p2 "" (list (entlast) (last(vxs (entlast))) ) "" )
- (command "_.extend" p3 "" (list (entlast)(car(vxs (entlast)))) "" )
- (command "_.extend" p3 "" (list (entlast) (last(vxs (entlast))) ) "" )
- (command "_.extend" p4 "" (list (entlast)(car(vxs (entlast)))) "" )
- (command "_.extend" p4 "" (list (entlast) (last(vxs (entlast))) ) "" )
-
- (setq i (1+ i))
- ) (setvar "osmode" 16384) (setvar "CMDECHO" 0)
- ;(TrimByFence0 (GetListOfPline0 p5))
- ;(entdel p5)
- (pzx-extrim p5 (polar pt (* 0.5 pi ) (/ (* fchd 3) (/ zxbl 1000.000) ) ) )
- (setvar "osmode" 9) (setvar "CMDECHO" 1)
- (princ)
- )
|
本帖子中包含更多资源
您需要 登录 才可以下载或查看,没有账号?注册
x
|