[求助]：求解柱子替换程序

alwaysbin · 发表于 2007-8-16 14:28:52

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

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

×

平面上有无数个500x500的方柱，都是在轴线的交点上。居中位置。
现在想把500x500的柱子全部改为600x600，如何实现？？？
所有柱都是用多段线画的，是一个整体，但不是块，是块就比较好办。在同一个图层上，如何实现啊？？
请高手指点？？？

snoopychen · 发表于 2007-8-16 15:34:53

以前写过的一个程序，对于所有选中物体，采用分别对每个物体按照其boundary box（就是物体的矩形包围框）的中心进行缩放。
对于这个问题应该合适。

;; The Aim of the Rountine:
;; To center scale the object according to their boundary center
;; The command name :scc
;; The platform: Acad2000 and after
;; by qjchen at [url]http://www.xdcad.net[/url] 2006.02.07
;; South China University of Technology, Architecture Department
;; Some code taken from Mr.Tony Hotchkiss, Thanks you, Tony
;; The codes frame camed from Mr. Tony Hotchkiss's Alignit.lsp, 2006.01
;; main program
(defun c:scc ()
(command ".undo" "be")
(setting)
(zxs)
(resetting)
(command ".undo" "e")
(princ)
)
;;end main program
(prompt "\nCopyright (c) 2006 qjchen\n")
(prompt "Enter scc to start.")
(princ)
;;;subrountine to scale,
(defun zxs (/ ssets scal len-ssets i entss objss res midpoint)
(prompt "\nthe object to be Scale:") ;(setq ssets (ssget))
;;;(setq ssets (ssget '((0 . "CIRCLE,TEXT"))))
(setq ssets (ssget '((0 . "LWPOLYLINE"))))
(setq scal (getreal "\nthe Scale factor:"))
(setq len-ssets (sslength ssets))
(setq i 0) ;;;Get the left bottom boundarybox point of the objects---> list (lst-pt-lef-bot)
(repeat len-ssets
(setq entss (ssname ssets i))
(setq objss (vlax-ename->vla-object entss))
(setq res (xyval1 objss))
(setq midpoint (midp (list (nth 0 res) (nth 1 res)) (list (nth 2 res)
(nth 3 res)
)
)
)
(command "scale" entss "" midpoint scal)
(setq i (1+ i))
)
)
;;; _ end of xyval
;;;;---The following codes are copy from Tony Hotchkiss at cadalyst
;;Get the boundingbox of one object
(defun xyval1 (obj / minpt maxpt topy bottmy leftx rightx)
(vla-GetBoundingBox obj 'minpt 'maxpt)
(setq pt1 (vlax-safearray->list minpt)
pt2 (vlax-safearray->list maxpt)
topy (cadr pt2)
bottmy (cadr pt1)
leftx (car pt1)
rightx (car pt2)
) ; _ end of setq
(list leftx bottmy rightx topy)
)
;;;;The error function
(defun err (s)
(if (= s "Function cancelled")
(princ "\nALIGNIT - cancelled: ")
(progn
(princ "\nALIGNIT - Error: ")
(princ s)
(terpri)
) ;_ end of progn
) ;_ end of if
(resetting)
(princ "SYSTEM VARIABLES have been reset\n")
(princ)
)
; err
;;;setting and resetting the system variables
(defun setv (systvar newval / x)
(setq x (read (strcat systvar "1")))
(set x (getvar systvar))
(setvar systvar newval)
)
; setv
(defun setting ()
(setq oerr *error*)
(setq *error* err)
(setv "BLIPMODE" 0)
(setv "CMDECHO" 0)
(setv "OSMODE" 0)
)
; setting
(defun rsetv (systvar)
(setq x (read (strcat systvar "1")))
(setvar systvar (eval x))
)
; rsetv
(defun resetting ()
(rsetv "BLIPMODE")
(rsetv "CMDECHO")
(rsetv "OSMODE")
(setq *error* oerr)
)
;-------------------------------------------------------
(defun midp (p1 p2)
(mapcar
'(lambda (x)
(/ x 2.)
)
(mapcar
'+
p1
p2
)
)
)

;; The Aim of the Rountine: 
;; To center scale the object according to their boundary center 
;; The command name :scc 
;; The platform: Acad2000 and after 
;; by qjchen at [url]http://www.xdcad.net[/url] 2006.02.07 
;; South China University of Technology, Architecture Department 
;; Some code taken from Mr.Tony Hotchkiss, Thanks you, Tony 
;; The codes frame camed from Mr. Tony Hotchkiss's Alignit.lsp, 2006.01 
;; main program 
(defun c:scc () 
  (command ".undo" "be") 
  (setting) 
  (zxs) 
  (resetting) 
  (command ".undo" "e") 
  (princ) 
) 
;;end main program 
(prompt "\nCopyright (c) 2006 qjchen\n") 
(prompt "Enter scc to start.") 
(princ) 
;;;subrountine to scale, 
(defun zxs (/ ssets scal len-ssets i entss objss res midpoint) 
  (prompt "\nthe object to be Scale:")  ;(setq ssets (ssget)) 
;;;(setq ssets (ssget '((0 . "CIRCLE,TEXT")))) 
  (setq ssets (ssget '((0 . "LWPOLYLINE")))) 
  (setq scal (getreal "\nthe Scale factor:")) 
  (setq len-ssets (sslength ssets)) 
  (setq i 0)  ;;;Get the left bottom boundarybox point of the objects---> list (lst-pt-lef-bot) 
  (repeat len-ssets 
    (setq entss (ssname ssets i)) 
    (setq objss (vlax-ename->vla-object entss)) 
    (setq res (xyval1 objss)) 
    (setq midpoint (midp (list (nth 0 res) (nth 1 res)) (list (nth 2 res) 
                                                              (nth 3 res) 
                                                        ) 
                   ) 
    ) 
    (command "scale" entss "" midpoint scal) 
    (setq i (1+ i)) 
  ) 
) 
;;; _ end of xyval 
;;;;---The following codes are copy from Tony Hotchkiss at cadalyst 
;;Get the boundingbox of one object 
(defun xyval1 (obj / minpt maxpt topy bottmy leftx rightx) 
  (vla-GetBoundingBox obj 'minpt 'maxpt) 
  (setq pt1 (vlax-safearray->list minpt) 
        pt2 (vlax-safearray->list maxpt) 
        topy (cadr pt2) 
        bottmy (cadr pt1) 
        leftx (car pt1) 
        rightx (car pt2) 
  )                                       ; _ end of setq 
  (list leftx bottmy rightx topy) 
) 
;;;;The error function 
(defun err (s) 
  (if (= s "Function cancelled") 
    (princ "\nALIGNIT - cancelled: ") 
    (progn 
      (princ "\nALIGNIT - Error: ") 
      (princ s) 
      (terpri) 
    ) ;_ end of progn 
  ) ;_ end of if 
  (resetting) 
  (princ "SYSTEM VARIABLES have been reset\n") 
  (princ) 
) 
 ; err 
;;;setting and resetting the system variables 
(defun setv (systvar newval / x) 
  (setq x (read (strcat systvar "1"))) 
  (set x (getvar systvar)) 
  (setvar systvar newval) 
) 
 ; setv 
(defun setting () 
  (setq oerr *error*) 
  (setq *error* err) 
  (setv "BLIPMODE" 0) 
  (setv "CMDECHO" 0) 
  (setv "OSMODE" 0) 
) 
 ; setting 
(defun rsetv (systvar) 
  (setq x (read (strcat systvar "1"))) 
  (setvar systvar (eval x)) 
) 
 ; rsetv 
(defun resetting () 
  (rsetv "BLIPMODE") 
  (rsetv "CMDECHO") 
  (rsetv "OSMODE") 
  (setq *error* oerr) 
) 
;------------------------------------------------------- 
(defun midp (p1 p2) 
  (mapcar 
    '(lambda (x) 
       (/ x 2.) 
     ) 
    (mapcar 
      '+ 
      p1 
      p2 
    ) 
  ) 
)

alwaysbin · 发表于 2007-8-17 00:06:02

谢谢楼上，你真是高手中的高手…………
非常感谢！！！

xyz518mm · 发表于 2007-8-17 06:49:12

真是不错的程序
谢谢您的分享

xyp1964 · 发表于 2007-8-17 09:01:08

[FONT=courier new];;; 网络U盘 [url]http://xyp1964.ys168.com/[/url] 下载并加载通用函数xyplib.vlx
;;; 500方柱改600方柱
(defun c:test ()
(CMDLA0)
(setq ss (ssget '((0 . "*POLYLINE")))
i -1
)
(while (setq s1 (ssname ss (setq i (1+ i))))
(setq leng (xyp-get-CurveLength s1))
(if (and (= leng 2000)
(equal (xyp-get-CurveStartPoint s1)
(xyp-get-CurveEndPoint s1)
)
)
(progn
(setq pt (xyp-get-MinMaxPoint s1 5))
(command "scale" s1 "" pt (/ 2400 2000.0))
)
)
)
(CMDLA1)
)[/FONT]

xyp1964 · 发表于 2007-8-17 09:25:40

优化版

[FONT=courier new](defun c:test ()
(CMDLA0)
(setvar"osmode"0)
(if(null no1)(setq no1 500))
(if(null no2)(setq no2 600))
(setq NO1 (UREAL 7 "" "原柱宽" NO1)
NO2 (UREAL 7 "" "新柱宽" NO2)
ss (ssget '((0 . "*POLYLINE")))
i -1
)
(while (setq s1 (ssname ss (setq i (1+ i))))
(if (and (= (xyp-get-CurveLength s1) (* 4.0 no1))
(equal (xyp-get-CurveStartPoint s1)
(xyp-get-CurveEndPoint s1)
)
(= (length (xyp-get-Vertexs s1 3)) 4)
)
(command "scale" s1 "" (xyp-get-MinMaxPoint s1 5) (/ no2 no1 1.0))
)
)
(CMDLA1)
)[/FONT]

alwaysbin · 发表于 2007-8-18 09:56:54

谢谢斑竹，
另外延伸一下，如果是不等边柱，比如400x500要替换为500x600有没有办法呢？？？

snoopychen · 发表于 2007-8-18 19:58:50

:)
这个方法有两种
第一种比较简单，很容易编出来
就是用不等比例的scale（具体过程大概就是做临时块，插入，explode，purge）
不过这种不等比例的缩放后果就是矩形变成线了
必须用把线连成多义线的程序再把他们连起来。
这种方法对于柱子是斜向布置的话有点问题

第二种方法复杂点
就是找出每个柱子多义线的顶点，然后排序，依次计算各个点的偏移距离，entmod之。
应该可以做到斜向柱子的缩放。
以前做过II级钢筋（断点）批量转I级钢筋的程序就是这么做的。

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

[求助] [求助]：求解柱子替换程序

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

相关帖子