[抛砖引玉]对象预览函数(grread运用一例)

netbee · 发表于 2005-12-16 10:45:51

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

实现对象预览功能并支持关键字
ET工具中有acet-ss-drag-move函数，但需要加载ARX，很不方便（我原来的坐标标注就是使用它）
后来决定用LISP来实现！下面的代码就是一个方法，但因为用着MOVE命令，所以对象不能太多。
大家来试试，帖出更优化的代码！

;;;======================
;;;NB-ss-drag-move v0.5 2005.12.12
;;;替代ET工具中的acet-ss-drag-move函数
;;调用(NB-ss-drag-move movess　pt0　msg keyword linetf)
;;
;;movess:选择集　pt1：基点　msg：提示信息　-
;;;keyword：关键字 linetf：拉线显示模式0或nil=无、1＝实线　2=虚线
;;;实例：[color=red](NB-ss-drag-move (ssget) (getpoint) "\n确定点或[方位角(A)/字高(H)/选择项(O)]<退出>:" "A H O" 1)[/color]
(defun NB-ss-drag-move (movess pt0 msg keyword linetf
/ e0 roop el
pt1 pt2 osmode_old backvar errnew errold set_close
)
(defun errnew(errmsg)
(set_close)
)
(defun set_close()
(setvar "cmdecho" 1)
(setq *error* errold)
(setvar "osmode" osmode_old)
)
;;--------------------
(setq errold *error*
*error* errnew)
(setq osmode_old (getvar "osmode"))
(setvar "osmode" 0)
(setvar "cmdecho" 0)
(VL-CMDF "_.undo" "be")
(if (and linetf
(> linetf 0)
) ;_ 结束and
(progn (VL-CMDF "_.line" '(0 0) '(1 0) "")
(setq l1 (entlast)
entl (entget l1)
) ;_ 结束setq
) ;_ 结束progn
) ;_ 结束if
(setq roop T
pt1 pt0
) ;_ 结束setq
(prompt (strcat msg "/<退出选择>:"))
(while roop
(setq el (grread t 2 0))
(cond
;;若按下空格或回车
((member el '((2 13) (2 32)))
(setq roop nil)
)
;;按下其他键
((= (car el) 2)
(if (or (vl-string-position (cadr el) (strcase keyword))
(vl-string-position (cadr el) (strcase keyword t))
) ;_ 结束or
(progn
(setq backvar (strcase (chr (cadr el)))
roop nil
) ;_ 结束setq
) ;_ 结束progn
(progn
(princ (strcat "\n需要选择对象或关键字：" keyword))
(prompt (strcat msg "/<退出选择>:"))
) ;_ 结束progn
) ;_ 结束if
)
((= (car el) 25)
;;(menucmd "B2")
(setq el nil)
;;(setq roop nil)
)
;;移动鼠标
((= (car el) 5)
(setq my_viewsize (getvar "viewsize")
pt2 (cadr el)
di (distance pt2 pt1)
) ;_ 结束setq
;;移动距离超过屏幕0.5%则刷新一次
(if (> (/ di my_viewsize) 0.005)
(progn
(VL-CMDF "_.Move" movess "" pt1 pt2)
(setq pt1 pt2)
(if (and linetf
(> linetf 0)
) ;_ 结束and
(progn (setq entl (subst (cons 10 pt0) (assoc 10 entl) entl))
(setq entl (subst (cons 11 pt2) (assoc 11 entl) entl))
(entmod entl)
) ;_ 结束progn
) ;_ 结束if
(if (and linetf
(= linetf 2)
) ;_ 结束and
(progn (redraw l1 3))
) ;_ 结束if
)
)
)
((= (car el) 3)
(setq backvar (cadr el))
(setq roop nil)
)
) ;_ 结束cond
) ;_ 结束while
(VL-CMDF "_.undo" "e")
(VL-CMDF "_.u")
(set_close)
backvar
) ;_ 结束defun

;;;====================== 
;;;NB-ss-drag-move v0.5 2005.12.12 
;;;替代ET工具中的acet-ss-drag-move函数 
;;调用(NB-ss-drag-move movess　pt0　msg keyword linetf) 
;; 
;;movess:选择集　pt1：基点　msg：提示信息　- 
;;;keyword：关键字 linetf：拉线显示模式0或nil=无、1＝实线　2=虚线 
;;;实例：[color=red](NB-ss-drag-move (ssget) (getpoint) "\n确定点或[方位角(A)/字高(H)/选择项(O)]<退出>:" "A H O" 1)[/color] 
(defun NB-ss-drag-move (movess         pt0          msg keyword linetf 
                        /         e0          roop           el             
                        pt1         pt2          osmode_old   backvar errnew errold set_close 
                       ) 
  (defun errnew(errmsg) 
    (set_close) 
    ) 
  (defun set_close() 
      (setvar "cmdecho" 1) 
    (setq *error* errold) 
    (setvar "osmode" osmode_old) 
    ) 
    ;;-------------------- 
    (setq errold *error* 
          *error* errnew) 
  (setq osmode_old (getvar "osmode")) 
  (setvar "osmode" 0) 
  (setvar "cmdecho" 0) 
  (VL-CMDF "_.undo" "be") 
  (if (and linetf 
           (> linetf 0) 
      ) ;_ 结束and 
    (progn (VL-CMDF "_.line" '(0 0) '(1 0) "") 
           (setq l1   (entlast) 
                 entl (entget l1) 
           ) ;_ 结束setq 
    ) ;_ 结束progn 
  ) ;_ 结束if 
  (setq        roop T 
        pt1  pt0 
  ) ;_ 结束setq 
  (prompt (strcat msg "/<退出选择>:")) 
  (while roop 
    (setq el (grread t 2 0)) 
    (cond 
      ;;若按下空格或回车 
      ((member el '((2 13) (2 32))) 
       (setq roop nil) 
      ) 
      ;;按下其他键 
      ((= (car el) 2) 
       (if (or (vl-string-position (cadr el) (strcase keyword)) 
               (vl-string-position (cadr el) (strcase keyword t)) 
           ) ;_ 结束or 
         (progn 
           (setq backvar (strcase (chr (cadr el))) 
                 roop         nil 
           ) ;_ 结束setq 
         ) ;_ 结束progn 
         (progn 
           (princ (strcat "\n需要选择对象或关键字：" keyword)) 
           (prompt (strcat msg "/<退出选择>:")) 
         ) ;_ 结束progn 
       ) ;_ 结束if 
      ) 
      ((= (car el) 25) 
       ;;(menucmd "B2") 
       (setq el nil) 
       ;;(setq roop nil) 
      ) 
      ;;移动鼠标 
      ((= (car el) 5) 
       (setq my_viewsize (getvar "viewsize") 
             pt2         (cadr el) 
             di                 (distance pt2 pt1) 
       ) ;_ 结束setq 
       ;;移动距离超过屏幕0.5%则刷新一次      
       (if (> (/ di my_viewsize) 0.005) 
         (progn 
      (VL-CMDF "_.Move" movess "" pt1 pt2) 
       (setq pt1 pt2) 
       (if (and        linetf 
                (> linetf 0) 
           ) ;_ 结束and 
         (progn        (setq entl (subst (cons 10 pt0) (assoc 10 entl) entl)) 
                (setq entl (subst (cons 11 pt2) (assoc 11 entl) entl)) 
                (entmod entl) 
         ) ;_ 结束progn 
       ) ;_ 结束if 
       (if (and        linetf 
                (= linetf 2) 
           ) ;_ 结束and 
         (progn (redraw l1 3)) 
       ) ;_ 结束if 
      ) 
         ) 
      ) 
      ((= (car el) 3) 
       (setq backvar (cadr el)) 
       (setq roop nil) 
      ) 
    ) ;_ 结束cond 
  ) ;_ 结束while 
  (VL-CMDF "_.undo" "e") 
  (VL-CMDF "_.u") 
  (set_close) 
  backvar 
) ;_ 结束defun

aeo · 发表于 2005-12-16 23:56:34

;;移动距离超过屏幕0.5%则刷新一次
(if (> (/ di my_viewsize) 0.005)

算出一个象素比较好
速度是可想而知的
et工具里又一现成的函数

狂刀 · 发表于 2005-12-17 09:12:00

能支持相对点更好
比如取第一点之后，输入　100, 即鼠标拉出方向的100距离点。
再支持输入绝对坐标，如(100 100 100) 及　"@100,200,0"等

netbee · 发表于 2005-12-18 14:16:46

速度肯定是比不上用ARX的ACET-SS-DRAG-MOVE的啦！！！
这里只不过是在找一个LISP的方法而已。

jx2008 · 发表于 2006-11-27 13:17:19

多谢密封的提供，但是你说你的坐标标注源代码是公布的，怎么没看到公布拟的源代码阿，还有就是你的坐标标注方向问题，在左边的时候，文字和横向不能朝左。请更正。

zwx62504 · 发表于 2007-4-15 10:01:06

[PHP]
;从栅栏选择集中计算与直线(point-point1)的交点,提取与point点最近的线
;栅栏选择从point至point1
;所提取的直线与ang角度平行
(defun selectminENT (ss aXX list1 /
 point point1 ang
 inC1 inR1
 i ent entg xp dis dis1 p1 p2 layer ang1 re
 c1 r1 an1 an2
 )
 (if (= "LINE" aXX)
(setq point (car list1) ;
 point1 (cadr list1)
 ang (caddr list1)
 dis (last list1)
)
(setq point (car list1)
 inC1 (cadr list1)
 inR1 (caddr list1)
 dis (last list1)
)
 )

(setq i -1 dis1 dis)
(while (and ss (setq ent (ssname ss (setq i (1+ i)))))
(if (= "LINE" aXX)
(progn
(setq entg (entget ent)
 layer (cdr (assoc 8 entg))
 p1 (cdr (assoc 10 entg))
 p2 (cdr (assoc 11 entg))
 ang1 (abs (- (angle p1 p2) ang))
);左选择集
;要求平行
(if (or (equal 0.00 ang1 0.00001) (equal pi ang1 0.00001) (equal (* 2 pi) ang1 0.00001))(progn
 (if (equal point point1 0.001)
 (setq xp point)
 (setq xp (inters p1 p2 point point1)
 dis1 (distance xp point)
 )
 )
 ;计算距离
;;; (if (not (equal dis1 0 0.001))
 (cond
 ((equal dis1 dis 0.001)
 (setq re (cons (list ent xp dis1 layer) re))
 )
 ((< dis1 dis)
 (setq dis dis1 re (list (list ent xp dis1 layer)))
 )
 )
;;; )
))
)
(progn
(setq entg (entget ent)
 layer (cdr (assoc 8 entg))
 c1 (cdr (assoc 10 entg))
 r1 (cdr (assoc 40 entg))
);左选择集
;要求平行
(if (equal c1 inc1 0.00001)(progn
 (if (equal r1 inR1 0.001)
 (setq xp point dis1 dis)
 (setq dis1 (abs (- r1 inR1))
 xp (polar c1 (angle c1 point) r1)
)
 )
 ;计算距离
;;; (if (not (equal dis1 0 0.001))
 (cond
 ((equal dis1 dis 0.001)
 (setq re (cons (list ent xp dis1 layer) re))
 )
 ((< dis1 dis)
 (setq dis dis1 re (list (list ent xp dis1 layer)))
 )
 )
;;; )
))
)
)
)
 (list re dis)
)

(defun search_wall_ent ($ent $point / $fi $fi2 $lp $rp $ss $ss1 $ss2 $ent1 $ent2 $return_list
 $entg $dis1 $dis2 $dis $i $layer1 $layer2 $layer3 $layer
 xx a
 _p1 _p2 _p3 _p4_xp1 _xp2 _xp exit_
 c1 r1 an1 an2
 ang $angle
 $entL $entR is_wall
 )
 ;;;起始搜索点$point,该点对应的实体对象$ent,该对象的方向值$angle,图层$layer
 (if (and $ent (listp $point))(progn

 (setq $entg (entget $ent)
 $layer (cdr (assoc 8 $entg))
 xx (cdr (assoc 0 $entg))
 )

 (if (= "LINE" xx)
 (setq $p1 (cdr (assoc 10 $entg))
 $p2 (cdr (assoc 11 $entg))
 $angle (angle $p1 $p2)
 )

 (setq c1 (cdr (assoc 10 $entg))
 r1 (cdr (assoc 40 $entg))
 an1 (cdr (assoc 50 $entg))
 an2 (cdr (assoc 51 $entg))
 $angle (+ (angle c1 $point) (* pi 0.5))
 )
 )

 (cond
 ((= "外墙外" $layer)
 (setq $fi (list (cons 0 xx) '(8 . "墙中-打印,墙中-计算")) $fi2 (list (cons 0 xx)))
 )
 ((= "墙中-打印" $layer)
 (setq $fi (list (cons 0 xx) '(8 . "外墙外")) $fi2 (list (cons 0 xx)))
 )
 ((= "墙中-计算" $layer)
 (setq $fi (list (cons 0 xx) '(8 . "外墙外")) $fi2 (list (cons 0 xx)))
 )
 (t
 (setq $fi (list (cons 0 xx)) $fi2 (list (cons 0 xx)))
 )
 )

 (setq $rp (polar $point (+ $angle 1.5708) 1.0)
 $lp (polar $point (- $angle 1.5708) 1.0)
 $ss1 (ssget "f" (list $point $lp) $fi) ;left
 $ss2 (ssget "f" (list $point $rp) $fi) ;right
 )

 ;从左选择集中提取离基点最近的一条线
 (if $ss1
 (setq a (if (= "LINE" xx) (list $point $lp $angle 1.0) (list $point c1 r1 1.0))
 $entL (selectminENT $ss1 xx a)
 $dis1 (if $entL (cadr $entL) nil)
 $entL (if $entL (car $entL) nil)
 )
 )

 ;从右选择集中提取离基点最近的一条直线
 (if $ss2
 (setq a (if (= "LINE" xx) (list $point $rp $angle 1.0) (list $point c1 r1 1.0))
 $entR (selectminENT $ss2 xx a)
 $dis2 (if $entR (cadr $entR) nil)
 $entR (if $entR (car $entR) nil)
 )
 )

 ;查找重合直线
 (if (setq $ss1 (ssget "_c" $point $point $fi2))
 (if (< 1 (sslength $ss1))
 (setq $ss1 (ssdel $ent $ss1)
 a (if (= "LINE" xx) (list $point $point $angle 0.0) (list $point c1 r1 0.0))
 $ent1 (selectminENT $ss1 xx a)
 $ent1 (if $ent1 (car $ent1) nil)
 )
 )
 )

 (cond
 ((and $entL $entR)
 (if (< $dis1 $dis2)
 (setq $return_list (cons (list $ent $point 0 $layer) $entL))
 (setq $return_list (cons (list $ent $point 0 $layer) $entR))
 )(setq is_wall "wall")
 )
 ((and $entL (not $entR))
 (setq $return_list (cons (list $ent $point 0 $layer) $entL))
 (setq is_wall "wall")
 )
 ((and (not $entL) $entR)
 (setq $return_list (cons (list $ent $point 0 $layer) $entR))
 (setq is_wall "wall")
 )
 (t (setq $return_list (list (list $ent $point 0 $layer)))
 (setq is_wall "singlewall")
 )
 );cond

 (if $ent1;(and (= is_wall "wall") $ent1)
 (setq $return_list (append $ent1 $return_list))
 )

 (setq $return_list (list $return_list _xp1 _xp2 is_wall))
 ))
 $return_list
)

;;;p1 p2 p3 三点一直线.判断p3是在p1,p2之间还是在p1,p2之外,若在p1,p2之外判断p3是在p1端还是在p2端
 ;;;1在左边,2 p1与p3重点,3在p1 p2之间,4 p2 p3重点,5在右边

 ;;;返回值 1 2 3 4 5
 ;;;点名 p3 p1(p3) p3 p2 (p3) p3
 ;;;示意图 o───────┴━━━━──━┴───────┴───────o
 ;;;第三点位于直线的位置
(defun 3rdpoint_locate_Line (_p1 _p2 _p3 / _a _b _c _d _e _f)
(setq _a (angle _p1 _p3) _b (angle _p2 _p3)
 _c (angle _p1 _p2) _d (distance _p1 _p3)
 _e (distance _p2 _p3)
)
(if (equal _a 6.28318 0.00001)(setq _a 0))
(if (equal _b 6.28318 0.00001)(setq _b 0))
(if (equal _c 6.28318 0.00001)(setq _c 0))
(cond
 ((equal _d 0 0.00001)(setq _f 2))
 ((equal _e 0 0.00001)(setq _f 4))
 ((and (equal _a _b 0.00001) (equal _a _c 0.00001))(setq _f 5))
 ((and (equal _a _b 0.00001) (/= _a _c))(setq _f 1))
 (t (setq _f 3))
) _f
)

;;;(if (not (member 'search_wall_ent (atoms-family 0))) (load "FCsearchwall.fas"))
;;;(if (not (member 'ckdian (atoms-family 0))) (load "FCReference.fas"))

;mode=t 为拖动模式;
;mode=nil 为绘制模式;
;;; fp(rp1) sp(rp4) ;
;;;━━━━━━━●━━━━━━━━●━━━━━━━ 直线1;
;;; ┋jp1 jp2┋ ;
;;;─────○─●────────●─○───── 直线2;
;;; rp1┆ ┋ ┋ ┆rp4 │ ;
;;; ┆ ┋rp2 rp3┋ ┆ 拉伸方向│ ;
;;; ┆ ●┅┅┅┅┅┅┅┅● ┆ ↓ ;
;;; ┆ ┋ ┆ ;
;;; rp2○┄┋┄┄┄┄┄┄┄┄┄─○rp3 ;
;;; ┋ ;
;;; ┋tp ;
;;;计算<直线2>的重绘线rp1-rp2-rp3-rp4的步骤:
;;;1. 计算分别由基线<直线1>上的两个拉伸点fp及sp的垂直线与<直线2>的交点jp1及jp2;
;;;2. 根据拉伸方向可以判断rp1位于jp1的方向(左边或者右边)
;;; 若fp-jp1的方位角度和拉伸方向相同则位于rp1位于jp1左边;
;;; 若fp-jp1的方位角度和拉伸方向相反则位于rp1位于jp1右边;
;;;3. 由jp1向rp1的方向偏移fp-jp1的间距即rp1的真实坐标;
;;;4. 同理可以计算rp4的坐标;
;;;5. 分别由rp1-rp4向拉伸方向按拉伸的距离计算另外两个拐点rp2-rp3
;;;特殊情况:
;;;1. 如果jp1至<直线2>端点的距离等于fp-jp1的距离则rp1归算至该端点上;
;;;2. 同样处理rp4;
;;;
;;;
;;;
(defun WS:GetinterpL (tp mode /
 lashen_fx lashen_jl
 entg ent wz
 la lt color
 interpL
 p1 p2 jp1 jp2 rp1 rp2 rp3 rp4
 j1 j2 j3
 an
 )
 (setq lashen_fx (angle fp tp)
 lashen_jl (distance fp tp)
 )
 (foreach ent ent0
(setq entg (entget ent)
 p1 (cdr (assoc 10 entg))
 p2 (cdr (assoc 11 entg))
 la (cdr (assoc 8 entg))
 lt (cdr (assoc 6 entg))
 color (if (assoc 62 entg)
 (cdr (assoc 62 entg))
 (cdr (assoc 62 (tblsearch "layer" la)))
 )
 jp1 (inters p1 p2 fp tp nil)
 jp2 (inters p1 p2 sp (polar sp lashen_fx 1) nil)

 j1 (distance fp jp1)
 j2 (distance sp jp2)
 j3 (distance fp sp)

 wz (eq 1 (3rdpoint_locate_Line fp tp jp1)); (equal (+ j1 (distance jp1 tp)) lashen_jl 0.0001)
)
;首先排除拉伸长度小于两端的墙厚之和;
(if (and (not wz)
 (<= j3 (+ j1 j2))
 )
 (if (not mode) (setq interpL (append (list nil) interpL)))
 (setq rp1 (cond
 ((equal (distance jp1 p1) j1 0.0001) p1)
 ((equal (distance jp1 p2) j1 0.0001) p2)
 (t (polar jp1 (+ (if wz 0 pi) (angle jp1 jp2)) j1))
)
 rp4 (cond
 ((equal (distance jp2 p1) j2 0.0001) p1)
 ((equal (distance jp2 p2) j2 0.0001) p2)
 (t (polar jp2 (+ (if wz 0 pi) (angle jp2 jp1)) j2))
)
 rp2 (polar rp1 lashen_fx lashen_jl)
 rp3 (polar rp4 lashen_fx lashen_jl)

 j1 (or (equal rp1 p1 0.0001) (equal rp1 p2 0.0001))
 j2 (or (equal rp4 p1 0.0001) (equal rp4 p2 0.0001))
 j1 (cond
 ((and j1 j2) 3)
 ((and j1 (not j2)) 1)
 ((and (not j1) j2) 2)
 (t 0)
 )

 interpL (append interpL
 (if mode
 (list (list rp1 rp2 color -1)
 (list rp2 rp3 color -1)
 (list rp3 rp4 color -1)
 )
 (list (list la lt rp1 rp2 rp3 rp4 j1))
 )
 )
 )
)
 ) ;(foreach
 interpL
)

(defun WS:GetPointA (p / p0)
 (setq p0 (inters fp sp p (polar p (+ (* 0.5 pi) (angle fp sp)) 1) nil)
p0 (polar fp (angle p0 p) (distance p0 p))
 )
 p0
)
;;
;;
(defun WS:Grdraw ( / a)
 (mapcar '(lambda (a) (grdraw (car a) (cadr a) 0)) oldl)
 (mapcar '(lambda (a) (apply 'grdraw a)) newl)
 (setq oldl newl)
 nil
)

(defun WS:ClearCMD (n / )
 (repeat n (princ (chr 8)) (princ " ") (princ (chr 8)))
 nil
)

(defun WS:Drag (fp sp /
p oldp flag
a newl oldl
tp va
dist
 )
 (setq va "" dist "0.000")
 (princ "\n\t输入拉伸距离(0.000米):")
 (grread t 4 0)
;;; (gc)
 (while (not flag)
 (setq p (grread t 4 0))
 (cond
 ;拖动模式;
 ((equal 5 (car p))
 (setq newl (WS:GetinterpL (setq oldp (WS:GetPointA (cadr p))) t)
 a (WS:Grdraw)
 a (WS:ClearCMD (+ (strlen dist) (strlen va) 4))
 dist (rtos (distance fp oldp) 2 3)
 )
 (princ (strcat dist "米):" va))
 );cond 1
 ((equal 3 (car p));and
 (setq tp (WS:GetPointA (cadr p))
 tp (if (equal (distance tp fp) 0 0.0001) nil tp)
 flag t
 )
 );cond 2

 ((or (equal p '(2 13)) ;return
 (equal p '(2 32)) ;space
 (equal p '(11 0)) ;right click
 );or
 (setq tp (if (equal 0 (setq va (atof va)) 0.0001) nil (polar fp (angle fp oldp) va))
 flag t
 )
 );cond 3

 ((equal 2 (car p))
 (cond
 ((and (= (setq p (cadr p)) 8)
 (> (strlen va) 0)
 )
 (WS:ClearCMD 1)
 (setq va (substr va 1 (max 0 (- (strlen va) 1))))
 )
 ((= p 45)
 (WS:ClearCMD (strlen va))
 (if (= "-" (substr va 1 1))
 (setq va (substr va 2))
 (setq va (strcat (chr p) va))
 )
 (princ va)
 )
 ((or (and (= p 46)
 (not (vl-string-position p va))
)
 (and (< 47 p) (> 58 p))
 )
 (princ (chr p))
 (setq va (strcat va (strcase (chr p))))
 )
 );if
 );cond 4
 (t (setq flag t))
 );cond

 );while
 tp
)

(defun WS:ReDrawWall ( /
 la lt entg ent an
 i j
 ss ss1 ss2
 a b
 p1 p2 p3 p4 p10 p11
 jp1 jp2
 ll L1 oldl tmp tag

 oldvar1
 )
 ;(list la lt p1 p2 p3 p4 tag)
 (setq ll (WS:GetinterpL tp nil)
i 0
 la (getvar "clayer")
lt (getvar "CELTYPE")
ss1 nil ss2 nil
an (angle fp tp)
oldvar1 (list (getvar "clayer") (getvar "CELTYPE") (getvar "osmode"))
 )
 (setvar "osmode" 0)

 (foreach L1 ll
(if L1 (progn
 (setq p1 (nth 2 L1)
 p2 (nth 3 L1)
 p3 (nth 4 L1)
 p4 (nth 5 L1)
 tag (last L1)
 ss (ssget "_c" p1 p4 '((0 . "LINE")))
 ent (nth i ent0)
 )
 (if (and ss (ssmemb ent ss))(setq ss (ssdel ent ss)))
 (if (/= 3 tag) (command "break" (list ent p1) p4))


 (setvar "clayer" (car L1))
 (setvar "CELTYPE" (if (cadr L1) (cadr L1) "ByLayer"))
 (setq j 0 ss1 (ssadd))
 (foreach a (list "line" p1 p2 p3 p4 "")
(if (not (or (and (= 1 (Boole 1 tag 1)) (= 1 j))
 (and (= 2 (Boole 1 tag 2)) (= 4 j))
 )
 )
 (command a)
)
(if (= 3 j)(setq ss1 (ssadd (entlast) ss1)))
(setq j (1+ j))
 )
 (if (= 3 tag)(command "erase" ent ""))

 (setq tmp (list p1 p2 p3 p4) j -1)

 (if (not (member tmp oldl))
 (while (and ss
 (< 0 (sslength ss))
 (setq a (ssname ss (setq j (1+ j))))
 )
 (setq entg (entget a)
 p10 (cdr (assoc 10 entg))
 p11 (cdr (assoc 11 entg))
 jp1 (inters p10 p11 p1 p4)
 jp2 (cond
 ((not jp1) nil)
 ((equal jp1 p10 0.0001) 10)
 ((equal jp1 p11 0.0001) 11)
 (t nil)
 )
 )
 (if jp2 (entmod (subst (cons jp2 (inters p10 p11 p2 p3 nil))
 (assoc jp2 entg) entg)))
 )
 )
 (setq oldl (cons tmp oldl))
))
(setq i (1+ i))
 )
 (mapcar 'setvar (list "clayer" "CELTYPE" "osmode") oldvar1)
)

;;;-----------------------------------------------------------
(defun WS:GrVecsPoint (inp inang / )
(if (and inp (listp inp))
 (grvecs (list 2 (polar inp inang showlen) (polar inp (+ inang pi) showlen)
 2 (polar inp (+ inang 1.5708) showlen) (polar inp (- inang 1.5708) showlen)
 ) )
)
)

(defun WS:SelopWall ( / p re)
 (if (and (setq ent (entsel "\n点选一条墙体线:"))
 (setq p (cadr ent)
 ent (car ent)
 )
 (= "LINE" (cdr (assoc 0 (entget ent))))
 )
 (setq p1 (cdr (assoc 10 (entget ent)))
 p2 (cdr (assoc 11 (entget ent)))
 an (+ (angle p1 p2) (* 0.5 pi))
 bp (inters p (polar p an 1.0) p1 p2 nil)

 ent0 (car (search_wall_ent ent bp))
 ent0 (mapcar 'car ent0)
 re t
 )
 )
 re
)

(defun WS:ChangeBaseLine (en / )
 (setq p1 (cdr (assoc 10 (entget en)))
 p2 (cdr (assoc 11 (entget en)))
 an (+ (angle p1 p2) (* 0.5 pi))
bp nil
 )
 (mapcar 'setvar (list "snapang" "snapmode" "orthomode") (list an 0 1))
 t
)

(defun WS:PickStartPoint (p Valid / ss en i exit0 re)
 (if (setq i -1
 ss (ssget "c" p p '((0 . "LINE")))
 )(progn
(while (and (not exit0)
 (setq en (nth (setq i (1+ i)) ent0))
 )
 (if (ssmemb en ss)(setq exit0 en))
)
(if exit0
 (if (and Valid (not (equal exit0 ent)))
 (setq ent exit0
 en (WS:ChangeBaseLine en)
 )
 )
 (princ "\t点不在所选墙体的线上,重新点取.")
)
 ))
 exit0
)

(defun WS:PickOffSetPoint ( / p o ss en i exit0 re)
 (redraw)
 (while (and (not exit0)
 (setq p (getpoint "\n位于所选墙体的线上指定点: (回车结束):"))
 )
(setq exit1 nil)
(if (WS:PickStartPoint p t)(progn
 (WS:GrVecsPoint p an)
 (while (and (not exit1)
 (setq o (getpoint p "\n从指定点的偏移距离: (回车结束):"))
 )
 (if (WS:PickStartPoint o nil)
 (setq exit1 t exit0 t)
 )
 )
 (setq exit0 t)
))
 )
 o
)

(DEFUN c:w1 (/ ent0 fp sp
 an ent
 p1 p2 oldvar
 a bp exit0
 xzoom1 showlen
 );墙线局部拉伸

 (princ "\n=====墙线局部拉伸=====")
 (if (WS:SelopWall)(progn
 (foreach a ent0 (redraw a 3))

 (setvar "cmdecho" 0)
 (command "undo" "control" "all" "undo" "begin")
 (setq oldvar (list (getvar "snapang") (getvar "snapmode") (getvar "orthomode")))


 (mapcar 'setvar (list "snapang" "snapmode" "orthomode") (list an 0 1))
 (setq xzoom1 (xzoom)
 showlen (* (abs (- (caar xzoom1) (caadr xzoom1))) 0.04)
 exit0 nil
)
 (while (and (not fp)
 (not exit0)
 )
 (redraw)
 (if bp (WS:GrVecsPoint bp an))
 (initget "O")
 (setq a (getpoint "\n拉伸起点 [指定点偏移O](回车结束):")
 )
 (cond
 ((not a) (setq exit0 t))
 ((listp a)(if (WS:PickStartPoint a t)(setq fp a)))
 ((= "O" a)(setq fp (WS:PickOffSetPoint)))
 )
 )

 (redraw)
 (if (and fp
 (setq fp (inters fp (polar fp an 1) p1 p2 nil))
 (setq fp (cond ((> 3 (setq a (3rdpoint_locate_Line p1 p2 fp))) p1)
((< 3 a) p2)
(t fp)
 )
 )
;;; (not (initget "K"))
 (setq sp (getpoint fp "\n\t拉伸段到(回车结束):"))
 (setq sp (inters sp (polar sp an 1) p1 p2 nil))
 (setq sp (cond ((> 3 (setq a (3rdpoint_locate_Line p1 p2 sp))) p1)
((< 3 a) p2)
(t sp)
 )
 )
 (not (equal fp sp 0.0001))
 (setq tp (WS:Drag fp sp))
 )
(WS:ReDrawWall)
 )
(redraw)
 (foreach a ent0 (redraw a 4))
 (mapcar 'setvar (list "snapang" "snapmode" "orthomode") oldvar)
 (command "undo" "end")(setvar "cmdecho" 1)

 )(princ "\t\t====退出===="))
 (princ)
)
[/PHP]

gufengyin · 发表于 2007-5-13 16:54:47

感觉ET那个快点，学习

jx2008 · 发表于 2007-7-6 14:02:28

6楼的程序很好，多谢了，支持！

测试了一下，出现以下错误

命令: W1
=====墙线局部拉伸=====
点选一条墙体线:; 错误: no function definition: XZOOM

账号		自动登录	找回密码
密码			立即注册

[抛砖引玉]对象预览函数(grread运用一例)

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子

我新近编写了一个支持对象预览函数的次序