动态阵列(强烈推荐)

xiaxiang · 发表于 2011-1-7 16:55:37

本帖最后由 xiaxiang 于 2011-1-9 17:11 编辑

Author: TheSwamp@Andrea
DARRAY FUNCTION ;;
By: andrea Andreetti 2009-01-03 ;;

(setq Dmess1 "\nNumber of CopyArray: "
Dmess2 "\nAttach point..."
Dmess3 "\nPress (A)ngle/(Q)uantity : "
Dmess4 "\n(L)inear/(R)ectangular/(P)olar/(A)rc ?: "
Dmess5 "\nBase point..."
Dmess6 "\nArc direction..."
Dmess7 "\nNumber of CopyArray X: "
Dmess8 "\nNumber of CopyArray Y: "
MTmess1 "Cursor Angle: "
MTmess2 "Cursor Points: "
MTmess3 "Base Point: "
MTmess4 "Qty. X: "
MTmess5 "Qty. Y: "
MTmess6 "Object Orientation: "
MTmess7 "Items Angle: "
MTmess8 "Qty.: "
)

小毛草 · 发表于 2022-5-23 14:26:15

;| ;;
DARRAY FUNCTION ;;
By: andrea Andreetti 2009-01-03 ;;
;;
Update 1.1 By A.A. 2009-01-03 ;;
OrthoMode Added ;;
;;
Update 1.2 By A.A. 2009-01-04 ;;
Allow User to enter an Angle Value ;;
;;
Update 1.3 By A.A. 2009-01-04 ;;
Allow Polar array ;;
not abort anymore when anykey is pressed ;;
;;
Update 1.4 By A.A. 2009-01-23 ;;
New Features: ;;
- Rectangular Polar Arc ;;
- Allow to change Qty Dinamicly ;;
- Allow to change Angle Dynamicly ;;
- Allow to align Object By pressing Shift ;;
- New Darray Menu ;;
|;
(defun c:Drr (/ sent Dbasepoint DtoPoint #Copy SSlist P0 ang dist
entcopy input Operation orthm Dmess1 Dmess2 Dmess3)
(if (vl-string-search "FR" (strcase (ver)))
(setq Dmess1 "\n拷贝数目: "
Dmess2 "\n点阵列专项..."
Dmess3 "\nApp u 叶形 (A)角度/(Q)动态数量: "
Dmess4 "\n(L)线性的/(R)长方形的/(P)极向坐标的/(A)曲线的: "
Dmess5 "\n点取基点..."
Dmess6 "\n直曲判断方向..."
Dmess7 "\n在X方向动态阵列数 : "
Dmess8 "\n在Y方向动态阵列数: "
MTmess1 "指针确定角度: "
MTmess2 "指针确定点: "
MTmess3 "指针确定基础点: "
MTmess4 "X方向动态数量"
MTmess5 "Y方向动态数量: "
MTmess6 "物体方向: "
MTmess7 "多个项目确定角度: "
MTmess8 "角度数目: "
)
(setq Dmess1 "\n拷贝阵列数: "
Dmess2 "\n贴附点"
Dmess3 "\n按下 (A)角度/(Q)数量 : "
Dmess4 "\n(L)线性/(R)矩形/(P)极坐标/(A)曲线: "
Dmess5 "\n基点..."
Dmess6 "\n曲线方向..."
Dmess7 "\n在 X方向动态阵列数 : "
Dmess8 "\n在 Y方向动态阵列数 : "
MTmess1 "指针角度: "
MTmess2 "指针点集: "
MTmess3 "基点: "
MTmess4 "X方向数量: "
MTmess5 "Y方向数量: "
MTmess6 "物体方向: "
MTmess7 "角度项目: "
MTmess8 "角度数目: "
)
)
(vl-load-com)
(setvar "CMDECHO" 0)
(setq cecolor (getvar "CECOLOR"))
(defun *error* (msg)
(DarrayFinishMode T)
(princ (strcat "\n" msg))
)
(initget "L R P A")
(setq RorP (getKword Dmess4))
(vl-cmdf "._-purge" "_B" "_{DarrayBlock}_" "_N")
(setq sent (ssget))
(if (eq RorP "R")
(progn
(setq #Copy_X (getint Dmess7))
(setq #Copy_Y (getint Dmess8))
)
(setq #Copy (getint Dmess1))
)
(setq Dbasepoint (getpoint Dmess2))
(setvar "PDMODE" 34)
(setq PDitem1
(entmakex (list
'(0 . "POINT")
'(62 . 1)
(cons 10 Dbasepoint))
)
)
(setq DbasePolar (getpoint Dmess5))
(setq PDitem2
(entmakex (list
'(0 . "POINT")
'(62 . 114)
(cons 10 DbasePolar))
)
)
(if (eq RorP "A")
(progn
(setq DbaseArcPoint (getpoint Dmess6))
(setq PDitem3
(entmakex (list
'(0 . "POINT")
'(62 . 8)
(cons 10 DbaseArcPoint))
)
)
)
)
(vla-StartUndoMark
(vla-get-ActiveDocument (vlax-get-ACAD-Object))
)
(vl-cmdf "._-block" "_{DarrayBlock}_" Dbasepoint sent "")
(vl-cmdf "._-insert" "_{DarrayBlock}_" Dbasepoint "" "" "")
(setq item (entlast))
(setq Bdatax (entget item))
(setq Ang50 (assoc 50 Bdatax))
(setq snapA (getvar "snapang"))
(setq orthm (getvar "ORTHOMODE"))
(princ Dmess3)
(DarrayWhile);_while
(while
(and
(not (= (car input) 25));RIGHT CLICK
(not (= (car input) 3));LEFT CLICK
(not (and (= (car input) 2) (= (cadr input) 32)));ESCAPE
(not (and (= (car input) 2) (= (cadr input) 13)));ENTER
)
(DarrayWhile)
)
(redraw)
(DarrayFinishMode Nil)
(vla-EndUndoMark
(vla-get-ActiveDocument (vlax-get-ACAD-Object))
)
(princ)
)
;;
;| ;;
DYNARRAY FUNCTION ;;
|;
;| ;;
WHILE FUNCTION ;;
|;
;;
(defun DarrayWhile ()
(while (or
(and (setq input (grread t 4 4))(= (car input) 5))
(and (= (car input) 2) (= (cadr input) 15)) ; F8 Orthomode
(and (= (car input) 2) (= (cadr input) 97)) ;a
(and (= (car input) 2) (= (cadr input) 65)) ;A
(and (= (car input) 2) (= (cadr input) 113)) ;q
(and (= (car input) 2) (= (cadr input) 81)) ;Q
)
(if (= (car input) 5) (setq DtoPoint (cadr input)))
(if (and (= (car input) 2)(= (cadr input) 15))
(setq Operation "ORTHO")
)
(if (or
(and (= (car input) 2) (= (cadr input) 97)) ;a
(and (= (car input) 2) (= (cadr input) 65)) ;A
)
(setq Operation "ANGLE")
)
(if (or
(and (= (car input) 2) (= (cadr input) 113)) ;q
(and (= (car input) 2) (= (cadr input) 81)) ;Q
)
(setq Operation "QTY")
)
(if (eq Operation "ANGLE")
(progn
(setq snapA (dtr (getint "\n特定角度 :")))
(setq orthm 1)
(setq Operation nil)
(princ Dmess3)
)
)
(if (eq Operation "QTY")
(progn
(setq #Copy (getint "\n数量数组. :"))
(if (= #Copy 0)(setq #Copy 1))
(setq Operation nil)
(princ Dmess3)
)
)
;;SWITCH ORTHOMODE ;;
;;
(if (eq Operation "ORTHO")
(progn
(if (eq orthm 1)
(progn (setvar "ORTHOMODE" 0) (setq orthm 0))
(progn (setvar "ORTHOMODE" 1) (setq orthm 1))
)
(setq Operation nil)
)
)
(if (eq orthM 1)
(DarrayOrthoMode1)
)
;;
;;SWITCH ORTHOMODE ;;
;;RECTANGULAR
(if (eq RorP "L")
(progn
(setq ang (angle DbasePolar DtoPoint))
(setq dist (/ (distance DbasePolar DtoPoint) (1- #Copy)))
(redraw)
(if SSlist
(progn
(foreach n SSlist
(vl-cmdf "._erase" n "")
(princ)
)
(setq SSlist nil)
)
)
(setq P0 DbasePoint)
(setq FC DbasePolar)
(DAMTEXT 254 DtoPoint (rtd ang) angP DbasePolar #Copy (acet-sys-shift-down))
(repeat (1- #Copy)
(setq P0 (polar P0 ang dist))
(setq FC (polar FC ang dist))
(DynArray_go P0)
(princ)
)
)
)
;;Polar
(if (eq RorP "P")
(progn
(setq ang (angle DbasePolar DtoPoint))
(setq dist (distance DbasePolar DtoPoint))
(redraw)
(if SSlist
(progn
(foreach n SSlist
(vl-cmdf "._erase" n "")
(princ)
)
(setq SSlist nil)
)
)
(setq angP (/ 360 #Copy))
(setq PC DtoPoint)
(DAMTEXT 254 DtoPoint (rtd ang) angP DbasePolar #Copy (acet-sys-shift-down))
(repeat #Copy
(DynArray_go PC)
(setq ang (dtr (+ (rtd ang) angP)))
(setq PC (polar DbasePolar ang dist))
(princ)
)
)
)
;;ARC
(if (eq RorP "A")
(progn
(if arcitem
(progn
(vl-cmdf "._erase" arcitem "")
(setq arcitem nil)
)
)
(if (and
(/= (car DbaseArcPoint)(car DtoPoint))
(/= (cadr DbaseArcPoint)(cadr DtoPoint))
)
(progn
(setvar "CECOLOR" "4")
(vl-cmdf "._arc" DbasePolar DbaseArcPoint DtoPoint)
(setq arcitem (entlast))
(setq arc10 (cdr (assoc 10 (entget arcitem))))
(setq arc40 (cdr (assoc 40 (entget arcitem))))
(setq arc50 (rtd (cdr (assoc 50 (entget arcitem)))))
(setq arc51 (rtd (cdr (assoc 51 (entget arcitem)))))
(setq ang (dtr arc50))
(setq dist (distance arc10 DtoPoint))
(redraw)
(if SSlist
(progn
(foreach n SSlist
(vl-cmdf "._erase" n "")
(princ)
)
(setq SSlist nil)
)
)
(setq Tang (- arc50 arc51))
(setq angP (/ Tang #Copy))
(setq PC DtoPoint)
;;;(princ (strcat "\n" (vl-princ-to-string angP)))
(if (> angP 0)
(progn
(setq Tang (- (- arc50 arc51) 360))
(setq angP (/ Tang #Copy))
)
)
(DAMTEXT 254 DtoPoint (rtd ang) angP DbasePolar #Copy (acet-sys-shift-down))
(repeat #Copy
(DynArray_go PC)
(setq ang (dtr (- (rtd ang) angP)))
(setq PC (polar arc10 ang dist))
(princ)
)
)
)
)
)
(if (eq RorP "R")
(progn
(setq Xbase (list (car DtoPoint) (cadr DbasePolar) (getvar "ELEVATION")))
(setq Xang (angle DbasePolar Xbase))
(setq dist_X (/ (distance DbasePolar Xbase) (1- #Copy_X)))
(setq Ybase (list (car DbasePolar) (cadr DtoPoint) (getvar "ELEVATION")))
(setq Yang (angle DbasePolar Ybase))
(setq dist_Y (/ (distance DbasePolar Ybase) (1- #Copy_Y)))
(setq ang (angle DbasePolar DtoPoint))
(redraw)
(if SSlist
(progn
(foreach n SSlist
(vl-cmdf "._erase" n "")
(princ)
)
(setq SSlist nil)
)
)
(setq P0 DbasePolar)
(setq FC (polar DbasePolar (angle DbasePolar DtoPoint)(/ (distance DbasePolar DtoPoint) 2.0)))
(setq PQ DbasePolar)
(DAMTEXT 254 DtoPoint (rtd ang) #Copy_X DbasePolar #Copy_Y (acet-sys-shift-down))
(repeat #Copy_Y
(repeat #Copy_X
(DynArray_go P0)
(setq P0 (polar P0 Xang dist_X))
(princ)
)
(setq P0 (polar PQ Yang dist_Y))
(setq PQ P0)
)
)
)
)
)
;;
;| ;;
WHILE FUNCTION ;;
|;
;;;;| ;;
;;; DYNARRAY COPY ;;
;;; |;
;;; ;;
(defun DynArray_go ( NP / entcopy Bent)
(setq Bdatax (subst (cons 10 NP) (assoc 10 Bdatax) Bdatax))
(if (acet-sys-shift-down)
(progn
(if (eq RorP "R")
(progn
(setq DBC FC)
(grdraw NP FC 4 1)
)
)
(if (eq RorP "L")
(progn
(setq DBC DbasePolar)
(grdraw DbasePolar FC 4 1)
)
)
(if (eq RorP "P")
(progn
(setq DBC DbasePolar)
(grdraw Dbasepolar NP 4 1)
)
)
(if (eq RorP "A")
(progn
(setq DBC arc10)
(grdraw arc10 NP 4 1)
)
)
(setq Bdatax (subst (cons 50 (angle NP DBC)) (assoc 50 Bdatax) Bdatax))
)
(progn
(if (eq RorP "R")
(grdraw DbasePolar NP 4 1)
)
(if (eq RorP "L")
(progn
(grdraw FC NP 4 1)
(grdraw Dbasepolar DbasePoint 4 1)
(grdraw DbasePolar FC 4 1)
)
)
(if (eq RorP "P")
(grdraw Dbasepolar NP 4 1)
)
(if (eq RorP "A")
(grdraw Dbasepolar NP 4 1)
)
(setq Bdatax (subst Ang50 (assoc 50 Bdatax) Bdatax))
)
)
(entmake Bdatax)
(setq Bent (entlast))
(setq SSlist (append SSlist (list Bent)))
)
;;; ;;
;;;;| ;;
;;; DYNARRAY COPY ;;
;;; |;
;| ;;
DYNARRAY ORTHOMODE ;;
|;
;;
(defun DarrayOrthoMode1 (/ distP NorthP WestP EastP SouthP)
(setq distP (distance Dbasepolar DtoPoint))
(setq NorthP (polar Dbasepolar (+ snapA (dtr 90)) distP))
(setq WestP (polar Dbasepolar (+ snapA (dtr 180)) distP))
(setq EastP (polar Dbasepolar snapA distP))
(setq SouthP (polar Dbasepolar (- snapA (dtr 90)) distP))
(if (and
(< (distance DtoPoint NorthP) (distance DtoPoint WestP))
(< (distance DtoPoint NorthP) (distance DtoPoint EastP))
(< (distance DtoPoint NorthP) (distance DtoPoint SouthP))
)
(setq DtoPoint NorthP)
)
(if (and
(< (distance DtoPoint WestP) (distance DtoPoint NorthP))
(< (distance DtoPoint WestP) (distance DtoPoint EastP))
(< (distance DtoPoint WestP) (distance DtoPoint SouthP))
)
(setq DtoPoint WestP)
)
(if (and
(< (distance DtoPoint EastP) (distance DtoPoint WestP))
(< (distance DtoPoint EastP) (distance DtoPoint NorthP))
(< (distance DtoPoint EastP) (distance DtoPoint SouthP))
)
(setq DtoPoint EastP)
)
(if (and
(< (distance DtoPoint SouthP) (distance DtoPoint WestP))
(< (distance DtoPoint SouthP) (distance DtoPoint EastP))
(< (distance DtoPoint SouthP) (distance DtoPoint NorthP))
)
(setq DtoPoint SouthP)
)
)
;;
;| ;;
DYNARRAY ORTHOMODE ;;
|;
;; ;;
;; Degree Conversion ;;
;; ;;
;;
(defun dtr (a)
(* pi (/ a 180.0))
)
(defun rtd (a)
(/ (* a 180) pi)
)
;;
;; ;;
;; Degree Conversion ;;
;; ;;
;;(DAMTEXT 254 DtoPoint (rtd Xang) angP DbasePolar #Copy_X (acet-sys-shift-down))
(defun DAMTEXT (bakgr ;background color
coord ;cursor point
CA ;CursorAngle
IA ;Item Angle
BP ;Base Ppoint
QT ;Qty
RV ;Reverse
)
(if RV
(setq RVT "Polar")
(setq RVT "Fix")
)
(if DAMTdata
(progn (vl-cmdf "._erase" DAMTdata "")
(setq DAMTdata nil)
)
)
;;; MTmess1 "Cursor Angle: "
;;; MTmess2 "Cursor Points: "
;;; MTmess3 "Base Point: "
;;; MTmess4 "Qty. X: "
;;; MTmess5 "Qty. Y: "
;;; MTmess6 "Object Orientation: "
;;;
;;; MTmess7 "Items Angle: "
(if (eq RorP "R")
(setq DAMTSTRING (strcat "\\pxsm1.5,ql;{\\fArial|b0|i0|c0|p34;\\L\\O - DARRAY 菜单 -\\P\\ps*,q*;\\l\\o}"
"{\\fArial|b0|i0|c0|p34;\\C250;"
MTmess1 "\\C5;" (vl-princ-to-string CA) "To\C250\\P"
MTmess2 "\\C5;" (vl-princ-to-string coord) "\\C250\\P"
MTmess3 "\\C5;" (vl-princ-to-string BP) "\\C250\\P"
MTmess4 "\\C5;" (vl-princ-to-string IA) "\\C250\\P"
MTmess5 "\\C5;" (vl-princ-to-string QT) "\\C250\\P"
MTmess6 "\\C5;" RVT "\\C250\\P}"
)
)
(setq DAMTSTRING (strcat "\\pxsm1.5,ql;{\\fArial|b0|i0|c0|p34;\\L\\O - DARRAY 菜单 -\\P\\ps*,q*;\\l\\o}"
"{\\fArial|b0|i0|c0|p34;\\C250;"
MTmess1 "\\C5;" (vl-princ-to-string CA) "To\C250\\P"
MTmess7 "\\C5;" (vl-princ-to-string IA) "To\C250\\P"
MTmess2 "\\C5;" (vl-princ-to-string coord) "To\C250\\P"
MTmess3 "\\C5;" (vl-princ-to-string BP) "\\C250\\P"
MTmess8 "\\C5;" (vl-princ-to-string QT) "\\C250\\P"
MTmess6 "\\C5;" RVT "\\C250\\P}"
)
)
)
(setq ViewSize (getvar "VIEWSIZE"))
(setq DAMTdata
(entmakex
(list
(cons 0 "MTEXT")
(cons 100 "AcDbEntity")
(cons 100 "AcDbMText")
(cons 1 DAMTSTRING)
(cons 10
(polar coord 0 (/ ViewSize 90.0))
)
(cons 40 (/ ViewSize 70.0))
(cons 50 0.0)
(cons 62 250)
(cons 71 1)
(cons 72 5)
(cons 90 1)
(cons 63 bakgr)
(cons 45 1.2)
)
)
)
)
;; ;;
;; FinishMode ;;
;; ;;
;;
(defun DarrayFinishMode (val)
(setvar "CECOLOR" cecolor)
(if DAMTdata
(progn (vl-cmdf "._erase" DAMTdata "")
(setq DAMTdata nil)
)
)
(if val
(progn
(if SSlist
(progn
(foreach n SSlist
(vl-cmdf "._erase" n "")
)
(setq SSlist nil)
)
)
(if item
(progn
(vl-cmdf "._explode" item)
(setq item nil)
)
)
(vl-cmdf "._-purge" "_B" "_{DarrayBlock}_" "_N")
)
(progn
(if SSlist
(progn
(foreach n SSlist
(vl-cmdf "._explode" n)
)
(setq SSlist nil)
)
)
(if item
(progn
(vl-cmdf "._explode" item)
(setq item nil)
)
)
(vl-cmdf "._-purge" "_B" "_{DarrayBlock}_" "_N")
)
)
(if arcitem
(progn
(vl-cmdf "._erase" arcitem "")
(setq arcitem nil)
)
)
(if PDitem1
(progn
(vl-cmdf "._erase" PDitem1 "")
(setq PDitem1 nil)
)
)
(if PDitem2
(progn
(vl-cmdf "._erase" PDitem2 "")
(setq PDitem2 nil)
)
)
(if PDitem3
(progn
(vl-cmdf "._erase" PDitem3 "")
(setq PDitem3 nil)
)
)
(redraw)
)
;;
;; ;;
;; FinishMode ;;
;; ;;

;|                                                        ;; 
        DARRAY FUNCTION                                        ;; 
        By: andrea Andreetti 2009-01-03                        ;; 
                                                        ;; 
        Update 1.1 By A.A. 2009-01-03                        ;; 
        OrthoMode Added                                        ;; 
                                                        ;; 
        Update 1.2 By A.A. 2009-01-04                        ;; 
        Allow User to enter an Angle Value                ;; 
                                                        ;; 
        Update 1.3 By A.A. 2009-01-04                        ;; 
        Allow Polar array                                ;; 
        not abort anymore when anykey is pressed        ;; 
                                                        ;; 
        Update 1.4 By A.A. 2009-01-23                        ;; 
        New Features:                                        ;; 
         - Rectangular Polar Arc                        ;; 
         - Allow to change Qty Dinamicly                ;; 
         - Allow to change Angle Dynamicly                ;; 
         - Allow to align Object By pressing Shift        ;; 
         - New Darray Menu                                ;; 
                                                        |; 
(defun c:Drr        (/ sent        Dbasepoint DtoPoint #Copy SSlist P0 ang        dist 
                 entcopy input Operation orthm Dmess1 Dmess2 Dmess3) 
 
(if (vl-string-search "FR" (strcase (ver))) 
(setq Dmess1 "\n拷贝数目: "       
      Dmess2 "\n点阵列专项..." 
      Dmess3 "\nApp u 叶形 (A)角度/(Q)动态数量: " 
      Dmess4 "\n(L)线性的/(R)长方形的/(P)极向坐标的/(A)曲线的: " 
      Dmess5 "\n点取基点..." 
      Dmess6 "\n直曲判断方向..." 
      Dmess7 "\n在X方向动态阵列数 : " 
      Dmess8 "\n在Y方向动态阵列数: " 
 
      MTmess1 "指针确定角度: " 
      MTmess2 "指针确定点: " 
      MTmess3 "指针确定基础点: " 
      MTmess4 "X方向动态数量" 
      MTmess5 "Y方向动态数量: " 
      MTmess6 "物体方向: " 
      MTmess7 "多个项目确定角度: " 
      MTmess8 "角度数目: " 
) 
(setq Dmess1 "\n拷贝阵列数: "       
      Dmess2 "\n贴附点" 
      Dmess3 "\n按下 (A)角度/(Q)数量 : " 
      Dmess4 "\n(L)线性/(R)矩形/(P)极坐标/(A)曲线: " 
      Dmess5 "\n基点..." 
      Dmess6 "\n曲线方向..." 
      Dmess7 "\n在 X方向动态阵列数 : " 
      Dmess8 "\n在 Y方向动态阵列数 : " 
 
      MTmess1 "指针角度: " 
      MTmess2 "指针点集: " 
      MTmess3 "基点: " 
      MTmess4 "X方向数量: " 
      MTmess5 "Y方向数量: " 
      MTmess6 "物体方向: " 
      MTmess7 "角度项目: " 
      MTmess8 "角度数目: " 
)         
) 
 
 
(vl-load-com) 
(setvar "CMDECHO" 0) 
(setq cecolor (getvar "CECOLOR"))   
   
  (defun *error* (msg) 
(DarrayFinishMode T) 
(princ (strcat "\n" msg)) 
  ) 
 
 
(initget "L R P A") 
(setq RorP (getKword Dmess4)) 
 
   
  (vl-cmdf "._-purge" "_B" "_{DarrayBlock}_" "_N") 
  (setq sent (ssget)) 
 
(if (eq RorP "R") 
  (progn 
    (setq #Copy_X (getint Dmess7)) 
    (setq #Copy_Y (getint Dmess8)) 
   ) 
    (setq #Copy (getint Dmess1)) 
) 
   
  (setq Dbasepoint (getpoint Dmess2)) 
   
 
(setvar "PDMODE" 34)   
(setq PDitem1 
       (entmakex (list 
            '(0 . "POINT") 
            '(62 . 1) 
             (cons 10 Dbasepoint)) 
          ) 
) 
 
   
(setq DbasePolar (getpoint Dmess5)) 
(setq PDitem2 
       (entmakex (list 
            '(0 . "POINT") 
            '(62 . 114) 
             (cons 10 DbasePolar)) 
          ) 
) 
 
(if (eq RorP "A") 
  (progn    
  (setq DbaseArcPoint (getpoint Dmess6)) 
(setq PDitem3 
       (entmakex (list 
            '(0 . "POINT") 
            '(62 . 8) 
             (cons 10 DbaseArcPoint)) 
          ) 
) 
) 
) 
   
   
  (vla-StartUndoMark 
    (vla-get-ActiveDocument (vlax-get-ACAD-Object)) 
  ) 
  (vl-cmdf "._-block" "_{DarrayBlock}_" Dbasepoint sent "") 
  (vl-cmdf "._-insert" "_{DarrayBlock}_" Dbasepoint "" "" "") 
  (setq item (entlast)) 
  (setq Bdatax (entget item)) 
  (setq Ang50 (assoc 50 Bdatax)) 
 
(setq snapA (getvar "snapang")) 
(setq orthm (getvar "ORTHOMODE")) 
 
(princ Dmess3)   
   
 (DarrayWhile);_while 
(while 
  (and 
     (not (= (car input) 25));RIGHT CLICK 
     (not (= (car input) 3));LEFT CLICK 
     (not (and (= (car input) 2) (= (cadr input) 32)));ESCAPE 
     (not (and (= (car input) 2) (= (cadr input) 13)));ENTER 
   ) 
 (DarrayWhile) 
) 
   
(redraw) 
(DarrayFinishMode Nil)   
   
  (vla-EndUndoMark 
    (vla-get-ActiveDocument (vlax-get-ACAD-Object)) 
  ) 
  (princ) 
) 
                                                ;; 
;|                                                ;; 
        DYNARRAY FUNCTION                        ;; 
                                                |; 
 
 
 
 
 
 
;|                                                ;; 
        WHILE FUNCTION                                ;; 
                                                |; 
                                                ;; 
(defun DarrayWhile () 
  (while (or 
           (and (setq input (grread t 4 4))(= (car input) 5)) 
           (and (= (car input) 2) (= (cadr input) 15))        ; F8 Orthomode 
           (and (= (car input) 2) (= (cadr input) 97))        ;a 
           (and (= (car input) 2) (= (cadr input) 65))        ;A 
           (and (= (car input) 2) (= (cadr input) 113))        ;q 
           (and (= (car input) 2) (= (cadr input) 81))        ;Q 
            
         ) 
 
(if (= (car input) 5) (setq DtoPoint (cadr input))) 
 
 
    
(if (and (= (car input) 2)(= (cadr input) 15)) 
  (setq Operation "ORTHO") 
) 
 
(if (or 
      (and (= (car input) 2) (= (cadr input) 97))        ;a 
      (and (= (car input) 2) (= (cadr input) 65))        ;A 
    )   
(setq Operation "ANGLE") 
) 
 
 
(if (or 
      (and (= (car input) 2) (= (cadr input) 113))        ;q 
      (and (= (car input) 2) (= (cadr input) 81))        ;Q 
    )   
(setq Operation "QTY") 
) 
 
(if (eq Operation "ANGLE") 
  (progn 
    (setq snapA (dtr (getint "\n特定角度 :"))) 
    (setq orthm 1) 
    (setq Operation nil) 
    (princ Dmess3) 
  ) 
) 
    
(if (eq Operation "QTY") 
  (progn 
    (setq #Copy (getint "\n数量数组. :")) 
    (if (= #Copy 0)(setq #Copy 1))    
    (setq Operation nil) 
    (princ Dmess3) 
  ) 
) 
    
    
;;SWITCH ORTHOMODE                ;; 
                                ;; 
(if (eq Operation "ORTHO") 
  (progn 
    (if (eq orthm 1) 
      (progn (setvar "ORTHOMODE" 0) (setq orthm 0)) 
      (progn (setvar "ORTHOMODE" 1) (setq orthm 1)) 
         ) 
    (setq Operation nil) 
  ) 
) 
(if (eq orthM 1) 
  (DarrayOrthoMode1) 
)       
                                ;; 
;;SWITCH ORTHOMODE                ;; 
 
    
;;RECTANGULAR 
(if (eq RorP "L") 
   (progn    
    (setq ang (angle DbasePolar DtoPoint)) 
    (setq dist (/ (distance DbasePolar DtoPoint) (1- #Copy))) 
    (redraw)    
    (if        SSlist 
      (progn 
        (foreach n SSlist 
          (vl-cmdf "._erase" n "") 
          (princ) 
        ) 
        (setq SSlist nil) 
      ) 
    ) 
    (setq P0 DbasePoint) 
    (setq FC DbasePolar) 
    (DAMTEXT 254 DtoPoint (rtd ang) angP DbasePolar #Copy (acet-sys-shift-down)) 
    (repeat (1- #Copy) 
      (setq P0 (polar P0 ang dist)) 
      (setq FC (polar FC ang dist)) 
      (DynArray_go P0) 
      (princ) 
    ) 
    ) 
 ) 
 
 
    
;;Polar 
(if (eq RorP "P") 
   (progn 
    (setq ang  (angle DbasePolar DtoPoint)) 
    (setq dist (distance DbasePolar DtoPoint)) 
    (redraw) 
(if        SSlist 
      (progn 
        (foreach n SSlist 
          (vl-cmdf "._erase" n "") 
          (princ) 
 
        ) 
        (setq SSlist nil) 
      ) 
    ) 
    
(setq angP (/ 360 #Copy)) 
(setq PC DtoPoint) 
 
(DAMTEXT 254 DtoPoint (rtd ang) angP DbasePolar #Copy (acet-sys-shift-down))    
    
(repeat #Copy 
      (DynArray_go PC) 
      (setq ang (dtr (+ (rtd ang) angP))) 
      (setq PC (polar DbasePolar ang dist))   
      (princ) 
)    
    
) 
) 
 
;;ARC 
(if (eq RorP "A") 
   (progn 
     (if arcitem 
       (progn 
         (vl-cmdf "._erase" arcitem "") 
         (setq arcitem nil) 
       ) 
     ) 
(if (and 
      (/= (car DbaseArcPoint)(car DtoPoint)) 
      (/= (cadr DbaseArcPoint)(cadr DtoPoint)) 
    ) 
  (progn 
     (setvar "CECOLOR" "4") 
     (vl-cmdf "._arc" DbasePolar DbaseArcPoint DtoPoint)      
     (setq arcitem (entlast)) 
     (setq arc10 (cdr (assoc 10 (entget arcitem)))) 
     (setq arc40 (cdr (assoc 40 (entget arcitem)))) 
     (setq arc50 (rtd (cdr (assoc 50 (entget arcitem))))) 
     (setq arc51 (rtd (cdr (assoc 51 (entget arcitem)))))    
 
    (setq ang (dtr arc50)) 
    (setq dist (distance arc10 DtoPoint)) 
    (redraw) 
    
(if SSlist 
      (progn 
        (foreach n SSlist 
          (vl-cmdf "._erase" n "") 
          (princ) 
        ) 
        (setq SSlist nil) 
      ) 
 ) 
 
 
(setq Tang (- arc50 arc51)) 
(setq angP (/ Tang #Copy)) 
(setq PC DtoPoint) 
    
;;;(princ (strcat "\n" (vl-princ-to-string angP))) 
    
(if (> angP 0) 
  (progn 
   (setq Tang (- (- arc50 arc51) 360)) 
   (setq angP (/ Tang #Copy))    
  ) 
) 
 
(DAMTEXT 254 DtoPoint (rtd ang) angP DbasePolar #Copy (acet-sys-shift-down))    
    
(repeat #Copy 
      (DynArray_go PC) 
      (setq ang (dtr (- (rtd ang) angP))) 
      (setq PC (polar arc10 ang dist))   
      (princ) 
)    
    
) 
) 
)    
) 
 
 
(if (eq RorP "R") 
   (progn    
    (setq Xbase (list (car DtoPoint) (cadr DbasePolar) (getvar "ELEVATION"))) 
    (setq Xang (angle DbasePolar Xbase)) 
    (setq dist_X (/ (distance DbasePolar Xbase) (1- #Copy_X))) 
 
    (setq Ybase (list (car DbasePolar) (cadr DtoPoint) (getvar "ELEVATION"))) 
    (setq Yang (angle DbasePolar Ybase)) 
    (setq dist_Y (/ (distance DbasePolar Ybase) (1- #Copy_Y))) 
 
    (setq ang (angle DbasePolar DtoPoint)) 
    
    (redraw)    
    (if        SSlist 
      (progn 
        (foreach n SSlist 
          (vl-cmdf "._erase" n "") 
          (princ) 
        ) 
        (setq SSlist nil) 
      ) 
    ) 
    (setq P0 DbasePolar) 
    (setq FC (polar DbasePolar (angle DbasePolar DtoPoint)(/ (distance DbasePolar DtoPoint) 2.0))) 
    (setq PQ DbasePolar) 
    (DAMTEXT 254 DtoPoint (rtd ang) #Copy_X DbasePolar #Copy_Y (acet-sys-shift-down)) 
   (repeat #Copy_Y 
    (repeat #Copy_X 
      (DynArray_go P0) 
      (setq P0 (polar P0 Xang dist_X)) 
      (princ) 
    )   
   (setq P0 (polar PQ Yang dist_Y)) 
   (setq PQ P0) 
     ) 
    
    ) 
 ) 
) 
) 
                                                ;; 
;|                                                ;; 
        WHILE FUNCTION                                ;; 
                                                |; 
 
 
 
 
 
 
;;;;|                                                ;; 
;;;        DYNARRAY COPY                                ;; 
;;;                                                |; 
;;;                                                ;; 
(defun DynArray_go ( NP / entcopy Bent) 
 
 
(setq Bdatax (subst (cons 10 NP) (assoc 10 Bdatax) Bdatax)) 
   
(if (acet-sys-shift-down) 
  (progn 
    (if (eq RorP "R") 
      (progn 
        (setq DBC FC) 
        (grdraw NP FC 4 1) 
      ) 
    ) 
    (if (eq RorP "L") 
      (progn 
        (setq DBC DbasePolar) 
        (grdraw DbasePolar FC 4 1) 
      ) 
    ) 
    (if (eq RorP "P") 
      (progn 
        (setq DBC DbasePolar) 
        (grdraw Dbasepolar NP 4 1) 
      ) 
    ) 
    (if (eq RorP "A") 
      (progn 
        (setq DBC arc10) 
        (grdraw arc10 NP 4 1) 
      ) 
    )    
 
    (setq Bdatax (subst (cons 50 (angle NP DBC)) (assoc 50 Bdatax) Bdatax)) 
   ) 
  (progn 
  (if (eq RorP "R") 
        (grdraw DbasePolar NP 4 1) 
    ) 
  (if (eq RorP "L") 
      (progn 
        (grdraw FC NP 4 1) 
        (grdraw Dbasepolar DbasePoint 4 1) 
        (grdraw DbasePolar FC 4 1) 
      ) 
    ) 
  (if (eq RorP "P") 
      (grdraw Dbasepolar NP 4 1) 
  ) 
   
  (if (eq RorP "A")       
      (grdraw Dbasepolar NP 4 1) 
  )    
    (setq Bdatax (subst Ang50 (assoc 50 Bdatax) Bdatax)) 
  ) 
) 
   
(entmake Bdatax) 
(setq Bent (entlast)) 
 
(setq SSlist (append SSlist (list Bent))) 
) 
;;;                                                ;; 
;;;;|                                                ;; 
;;;        DYNARRAY COPY                                ;; 
;;;                                                |; 
 
 
 
 
 
 
;|                                                ;; 
        DYNARRAY ORTHOMODE                        ;; 
                                                |; 
                                                ;; 
(defun DarrayOrthoMode1 (/ distP NorthP WestP EastP SouthP) 
   
    (setq distP (distance Dbasepolar DtoPoint)) 
    (setq NorthP (polar Dbasepolar (+ snapA (dtr 90)) distP)) 
    (setq WestP  (polar Dbasepolar (+ snapA (dtr 180)) distP)) 
    (setq EastP  (polar Dbasepolar snapA distP)) 
    (setq SouthP (polar Dbasepolar (- snapA (dtr 90)) distP)) 
   
(if (and 
      (< (distance DtoPoint NorthP) (distance DtoPoint WestP)) 
      (< (distance DtoPoint NorthP) (distance DtoPoint EastP)) 
      (< (distance DtoPoint NorthP) (distance DtoPoint SouthP)) 
    ) 
(setq DtoPoint NorthP) 
) 
 
(if (and 
      (< (distance DtoPoint WestP) (distance DtoPoint NorthP)) 
      (< (distance DtoPoint WestP) (distance DtoPoint EastP)) 
      (< (distance DtoPoint WestP) (distance DtoPoint SouthP)) 
    ) 
(setq DtoPoint WestP) 
)   
 
(if (and 
      (< (distance DtoPoint EastP) (distance DtoPoint WestP)) 
      (< (distance DtoPoint EastP) (distance DtoPoint NorthP)) 
      (< (distance DtoPoint EastP) (distance DtoPoint SouthP)) 
    ) 
(setq DtoPoint EastP) 
) 
 
(if (and 
      (< (distance DtoPoint SouthP) (distance DtoPoint WestP)) 
      (< (distance DtoPoint SouthP) (distance DtoPoint EastP)) 
      (< (distance DtoPoint SouthP) (distance DtoPoint NorthP)) 
    ) 
(setq DtoPoint SouthP) 
)   
) 
                                                ;; 
;|                                                ;; 
        DYNARRAY ORTHOMODE                        ;; 
                                                |; 
 
 
 
 
;;                                ;; 
;;        Degree Conversion        ;; 
;;                                ;; 
                                ;; 
(defun dtr (a) 
(* pi (/ a 180.0)) 
) 
 
(defun rtd (a) 
(/ (* a 180) pi) 
) 
                                ;; 
;;                                ;; 
;;        Degree Conversion        ;; 
;;                                ;; 
 
 
 
 
;;(DAMTEXT 254 DtoPoint (rtd Xang) angP DbasePolar #Copy_X (acet-sys-shift-down)) 
(defun DAMTEXT (bakgr ;background color 
                coord ;cursor point 
                CA ;CursorAngle 
                IA ;Item Angle 
                BP ;Base Ppoint 
                QT ;Qty 
                RV ;Reverse 
                ) 
 
(if RV 
  (setq RVT "Polar") 
  (setq RVT "Fix") 
) 
 
(if DAMTdata 
  (progn (vl-cmdf "._erase" DAMTdata "") 
         (setq DAMTdata nil) 
  ) 
) 
 
 
 
;;;      MTmess1 "Cursor Angle: " 
   
;;;      MTmess2 "Cursor Points: " 
;;;      MTmess3 "Base Point: " 
;;;      MTmess4 "Qty. X: " 
;;;      MTmess5 "Qty. Y: " 
;;;      MTmess6 "Object Orientation: " 
;;;   
;;;      MTmess7 "Items Angle: " 
 
   
(if (eq RorP "R") 
(setq DAMTSTRING (strcat "\\pxsm1.5,ql;{\\fArial|b0|i0|c0|p34;\\L\\O - DARRAY 菜单 -\\P\\ps*,q*;\\l\\o}" 
                          "{\\fArial|b0|i0|c0|p34;\\C250;" 
                          MTmess1 "\\C5;" (vl-princ-to-string CA) "To\C250\\P" 
                          MTmess2 "\\C5;" (vl-princ-to-string coord) "\\C250\\P" 
                          MTmess3 "\\C5;" (vl-princ-to-string BP) "\\C250\\P" 
                          MTmess4 "\\C5;" (vl-princ-to-string IA) "\\C250\\P" 
                          MTmess5 "\\C5;" (vl-princ-to-string QT) "\\C250\\P" 
                          MTmess6 "\\C5;" RVT "\\C250\\P}" 
                  ) 
) 
(setq DAMTSTRING (strcat "\\pxsm1.5,ql;{\\fArial|b0|i0|c0|p34;\\L\\O - DARRAY 菜单 -\\P\\ps*,q*;\\l\\o}" 
                          "{\\fArial|b0|i0|c0|p34;\\C250;" 
                          MTmess1 "\\C5;" (vl-princ-to-string CA) "To\C250\\P" 
                          MTmess7 "\\C5;" (vl-princ-to-string IA) "To\C250\\P" 
                          MTmess2 "\\C5;" (vl-princ-to-string coord) "To\C250\\P" 
                          MTmess3 "\\C5;" (vl-princ-to-string BP) "\\C250\\P" 
                          MTmess8 "\\C5;" (vl-princ-to-string QT) "\\C250\\P" 
                          MTmess6 "\\C5;" RVT "\\C250\\P}" 
                  ) 
)    
) 
 
   
   
 
             (setq ViewSize (getvar "VIEWSIZE")) 
             (setq DAMTdata 
                    (entmakex 
                      (list 
                        (cons 0 "MTEXT") 
                        (cons 100 "AcDbEntity") 
                        (cons 100 "AcDbMText") 
                        (cons 1 DAMTSTRING) 
                        (cons 10 
                              (polar coord 0 (/ ViewSize 90.0)) 
                        ) 
                        (cons 40 (/ ViewSize 70.0)) 
                        (cons 50 0.0) 
                        (cons 62 250) 
                        (cons 71 1) 
                        (cons 72 5) 
                        (cons 90 1) 
                        (cons 63 bakgr) 
                        (cons 45 1.2) 
                      ) 
                    ) 
             ) 
 ) 
 
 
 
 
 
 
 
 
 
 
 
 
 
;;                                ;; 
;;        FinishMode                ;; 
;;                                ;; 
                                ;; 
(defun DarrayFinishMode (val) 
 
(setvar "CECOLOR" cecolor) 
   
 
(if DAMTdata 
  (progn (vl-cmdf "._erase" DAMTdata "") 
         (setq DAMTdata nil) 
  ) 
) 
 
 
   
(if val 
  (progn 
(if SSlist 
    (progn 
      (foreach n SSlist 
        (vl-cmdf "._erase" n "") 
 
      ) 
      (setq SSlist nil) 
    ) 
  ) 
(if item 
  (progn 
(vl-cmdf "._explode" item) 
(setq item nil) 
) 
) 
(vl-cmdf "._-purge" "_B" "_{DarrayBlock}_" "_N") 
) 
 
(progn   
  (if SSlist 
    (progn 
      (foreach n SSlist 
        (vl-cmdf "._explode" n) 
 
      ) 
      (setq SSlist nil) 
    ) 
  ) 
(if item 
  (progn 
(vl-cmdf "._explode" item) 
(setq item nil) 
) 
) 
  (vl-cmdf "._-purge" "_B" "_{DarrayBlock}_" "_N") 
) 
 
) 
 
 
(if arcitem 
   (progn 
     (vl-cmdf "._erase" arcitem "") 
     (setq arcitem nil) 
   ) 
) 
   
   
(if PDitem1 
  (progn 
  (vl-cmdf "._erase" PDitem1 "") 
  (setq PDitem1 nil) 
  ) 
) 
 
(if PDitem2 
  (progn 
  (vl-cmdf "._erase" PDitem2 "")   
  (setq PDitem2 nil) 
  ) 
) 
 
(if PDitem3 
  (progn 
  (vl-cmdf "._erase" PDitem3 "") 
  (setq PDitem3 nil) 
  ) 
) 
  (redraw) 
) 
                                ;; 
;;                                ;; 
;;        FinishMode                ;; 
;;                                ;;

zmzk · 发表于 2022-1-31 17:37:24

11年前的程序，现在看还是那么优秀的！

crazylsp · 发表于 2011-1-7 17:29:30

牛啊

cumtjh · 发表于 2011-1-8 16:50:28

牛呀，不知道代码是否能直接用

bai2000 · 发表于 2011-1-8 22:42:12

楼主，菜单汉化下，更好

bai2000 · 发表于 2011-1-8 22:50:20

楼主，我怎么会出现：no function definition: ACET-SYS-SHIFT-DOWN 错误？？？？？

ZZXXQQ · 发表于 2011-1-8 22:54:12

这个是ET的函数。要安装ET。

edsion24 · 发表于 2011-1-10 09:12:03

下来试试。。。

lrd1861 · 发表于 2011-1-11 09:00:37

又是转人家的吧

xjf · 发表于 2011-1-16 16:52:53

好啊, 不过明经币不多了

wqz123 · 发表于 2011-1-28 11:07:02

确实牛，呵呵。推荐。

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

[资源] 动态阵列(强烈推荐)

本帖子中包含更多资源

本帖被以下淘专辑推荐: