注册 登录
明经CAD社区 返回首页

20060510412的个人空间 http://www.mjtd.com/?7308598 [收藏] [复制] [分享] [RSS]

留言板

facelist doodle涂鸦板

您需要登录后才可以留言 登录 | 注册


waterchen 2022-9-29 20:52
20060510412: 您好,请问当年下载的DynamicLisp源代码还有么,可否共享一下哦?
;;
;; Copyright (c)2013 Gu_xl
;; 版权所有  Gu_xl
;;
;;作者保留本程序的一切权利,但你可以自由拷贝与复制、修改本程序用于非商业目的。
;;作者尽力将本程序做得完善,但不会因本软件的错失而造成的损失承担任何责任。
;;本程序仅提供作为应用上的参考, 而未声明或隐含任何保证; 对于任何特殊用途之适
;;应性, 以及商业销售所隐含作出的保证, 在此一概予以否认。
;;
(vl-load-com)
;;;*SysVarNL* 常用系统变量表
(setq *SysVarNL*
       (list 'AUNITS      'AUPREC             'ATTDIA           'ATTREQ
         'BLIPMODE    'DIMZIN             'CECOLOR           'CELTYPE
         'CLAYER      'CMDECHO     'TRIMMODE           'EXPERT
         'HIGHLIGHT   'LUNITS             'LUPREC           'EDGEMODE
         'OSMODE      'ORTHOMODE   'TEXTSTYLE   'PLINEWID 'PLINEGEN
         'FILEDIA     'PICKBOX     'QAFLAGS           'UCSAXISANG
         'CELTSCALE 'NOMUTT 'PEDITACCEPT 'Mirrtext 'limcheck
        )
) ;_ setq

;;;常量定义
(setq *Acad*           (vlax-get-acad-object)
      *AcDocument* (vla-get-activedocument *Acad*)
      *Model-Space* (vla-get-modelspace *AcDocument*)
      *Paper-Space* (vla-get-PaperSpace *AcDocument*)
      pi2           (* pi 0.5)
      pi4           (* pi 0.25)
      2pi           (* pi 2.)
      3pi2           (* 1.5 pi)
      3pi4   (+ pi2 pi4)
      5pi4   (+ pi pi4)
      7pi4 (+ 3pi2 pi4)
      pi6 (/ pi 6)
      2pi3 (/ pi 3 0.5)
      #ZJWS# 2
      *jd* 0.00001
      en2obj vlax-ename->vla-object
      obj2en vlax-vla-object->ename
      *Space* (vlax-get-property *AcDocument* (if (= 1 (getvar 'CVPORT)) 'PaperSpace 'ModelSpace))
)
;;;增加内置函数
(mapcar        'vl-arx-import
        '(ACAD_COLORDLG             ACAD_truecolordlg        ACAD_STRLSORT
          INITDIA             ACAD-POP-DBMOD        ACAD-PUSH-DBMOD
          STARTAPP             layoutlist Bpoly
         )
)
;;;*********************************************************************************


;;;*************函数 gxl-sel-mapcar.lsp  *************
;;;(gxl-Sel-Mapcar ss Fun) 遍历选择集对所包含的像素进行指定函数操作,返回操作后的表
(defun gxl-Sel-Mapcar (ss Fun / nn rtn)
  (if ss
    (repeat (setq nn (sslength ss))
      (setq rtn
             (cons (apply Fun (list (ssname ss (setq nn (1- nn))))) rtn)
            )
      )
    )
  )
;;;***************** 函数 gxl-Sel-Mapcar*****************


;;;*************函数 gxl-strparse.lsp  *************
;_ end of defun

;
(defun gxl-StrParse (str del / pos lst)
  (if (/= "" str)
    (progn
  (while (setq pos (vl-string-search del str))
    (setq lst (cons (substr str 1 pos) lst)
          str (substr str (+ pos 1 (strlen del)))
    )
  )
  ;(vl-remove "" (reverse (cons str lst)))
  
  (if (= " " Del)
    (vl-remove "" (reverse (cons str lst)))
    (reverse (cons str lst))
  )
  )
    )
)
;;;***************** 函数 gxl-StrParse*****************


;;;*************函数 gxl-sel-redrawsel.lsp  *************
;;;==================================================================
;;gxl-Sel-ReDrawSel 重画选择集中的对象,Sel 为选择集或像素名 mode 为方式码
;;;重画选择集中的对象,mode 为方式码,
;;;方式码 1 在屏幕重画该选择集对象
;;;方式码 2 隐藏该选择集对象
;;;方式码 3 “醒目显示”该选择集对象
;;;方式码 4 取消“醒目显示”该选择集对象
;;;==================================================================
(defun gxl-Sel-ReDrawSel  (Sel mode / m n)
  (if sel
    (progn
      (cond ((= 'pickset (type Sel))
             (setq m (sslength Sel)
                   n 0)
             (repeat m
               (redraw (ssname Sel n) mode)
               (setq n (1+ n))
               )
             )
            ((= 'ename (type Sel))
             (redraw Sel mode)
             )
            )
      )
    )
  )
;;;***************** 函数 gxl-Sel-ReDrawSel*****************


;;;*************函数 gxl-ge-grread.lsp  *************
;;;************************************************************************************
;;;gxl-Ge-grread 自定义带捕捉的GrRead函数
;;;参数:GR_MODE = 函数GrRead的参数表 如: (list [track] [allkeys [curtype]),参数个数按需要设置,可为nil
;;;     STARTPT = 基点,计算垂足点、正交模式等坐标的基点,若为nil,则基点默认为系统变量LastPoint值
;;;     SS = 捕捉避开的物体,可以是选择集或像素名
;;;测试
(DEFUN gxl-Ge-grread (GR_MODE STARTPT SS /             GET_OSMODE
                           GETGRVECS        DRAWVECS     TIME
                           F3                F8             STR_OSMODE
                           LST_OSMODE        DRAFTOBJ     AUTOSNAPMARKERSIZE
                           AUTOSNAPMARKERCOLOR             DRAG
                           DRAGMODE        GHOSTPT             X0
                           Y0                X1             Y1
                           Z1                DISTPERPIXEL BOLD
                          )
  ;;;返回捕捉模式字符串
  (DEFUN get_osmode (/ cur_mode mode$)
    (SETQ mode$ "")
    (IF    (< 0 (SETQ cur_mode (GETVAR "osmode")) 16384)
      (MAPCAR (FUNCTION    (LAMBDA    (x)
              (IF (NOT (ZEROP (LOGAND cur_mode (CAR x))))
                (IF    (ZEROP (STRLEN mode$))
                  (SETQ mode$ (CADR x))
                  (SETQ mode$ (STRCAT mode$ "," (CADR x)))
                )
              )
            )
          )
          '((1 "_end")
        (2 "_mid")
        (4 "_cen")
        (8 "_nod")
        (16 "_qua")
        (32 "_int")
        (64 "_ins")
        (128 "_per")
        (256 "_tan")
        (512 "_nea")
        (1024 "_qui")
        (2048 "_app")
        (4096 "_ext")
        (8192 "_par")
           )
      )
    )
    mode$
  )
  ;;;返回捕捉标记Vecs
  (DEFUN GetGrvecs (pt dragpt lst / KEY)
    (SETQ key T)
    (WHILE (AND key lst)
      (IF (EQUAL (OSNAP dragpt (CAR lst)) pt 1E-6)
    (SETQ key nil)
    (SETQ lst (CDR lst))
      )
    )
    (CDR (ASSOC    (CAR lst)
        '(("_end"
           ((-1 1) (-1 -1))
           ((-1 -1) (1 -1))
           ((1 -1) (1 1))
           ((1 1) (-1 1))
          )            ;正方形
          ("_mid"
           ((0 1.414) (-1.225 -0.707))
           ((-1.225 -0.707) (1.225 -0.707))
           ((1.225 -0.707) (0 1.414))
          )            ;三角形
          ("_cen"
           ((0 1) (-0.707 0.707))
           ((-0.707 0.707) (-1 0))
           ((-1 0) (-0.707 -0.707))
           ((-0.707 -0.707) (0 -1))
           ((0 -1) (0.707 -0.707))
           ((0.707 -0.707) (1 0))
           ((1 0) (0.707 0.707))
           ((0.707 0.707) (0 1))
          )            ;圆
          ("_nod"
           ((0 1) (-0.707 0.707))
           ((-0.707 0.707) (-1 0))
           ((-1 0) (-0.707 -0.707))
           ((-0.707 -0.707) (0 -1))
           ((0 -1) (0.707 -0.707))
           ((0.707 -0.707) (1 0))
           ((1 0) (0.707 0.707))
           ((0.707 0.707) (0 1))
           ((-1 1) (1 -1))
           ((-1 -1) (1 1))
          )            ;圆+十字交叉
          ("_qua"
           ((0 1.414) (-1.414 0))
           ((-1.414 0) (0 -1.414))
           ((0 -1.414) (1.414 0))
           ((1.414 0) (0 1.414))
          )            ;旋转45°的正方形
          ("_int"
           ((-1 1) (1 -1))
           ((-1 -1) (1 1))
           ((1 0.859) (-0.859 -1))
           ((-1 0.859) (0.859 -1))
           ((0.859 1) (-1 -0.859))
           ((-0.859 1) (1 -0.859))
          )            ;十字交叉
          ("_ins"
           ((-1 1) (-1 -0.1))
           ((-1 -0.1) (0 -0.1))
           ((0 -0.1) (0 -1.0))
           ((0 -1.0) (1 -1))
           ((1 -1) (1 0.1))
           ((1 0.1) (0 0.1))
           ((0 0.1) (0 1.0))
           ((0 1.0) (-1 1))
          )            ;两个正方形
          ("_per"
           ((-1 1) (-1 -1))
           ((-1 -1) (1 -1))
           ((0 -1) (0 0))
           ((0 0) (-1 0))
          )            ;半个正方形
          ("_tan"
           ((0 1) (-0.707 0.707))
           ((-0.707 0.707) (-1 0))
           ((-1 0) (-0.707 -0.707))
           ((-0.707 -0.707) (0 -1))
           ((0 -1) (0.707 -0.707))
           ((0.707 -0.707) (1 0))
           ((1 0) (0.707 0.707))
           ((0.707 0.707) (0 1))
           ((1 1) (-1 1))
          )            ;园+线
          ("_nea"
           ((-1 1) (1 -1))
           ((1 -1) (-1 -1))
           ((-1 -1) (1 1))
           ((1 1) (-1 1))
          )            ;两个三角形
          ("_qui")        ; ???
          ("_app"
           ((-1 1) (-1 -1))
           ((-1 -1) (1 -1))
           ((1 -1) (1 1))
           ((1 1) (-1 1))
           ((-1 1) (1 -1))
           ((-1 -1) (1 1))
          )            ;正方形+十字交叉
          ("_ext"
           ((0.1 0) (0.13 0))
           ((0.2 0) (0.23 0))
           ((0.3 0) (0.33 0))
          )            ;三个点
          ("_par" ((0 1) (-1 -1)) ((1 1) (0 -1))) ;两条线
          
         )
     )
    )
  )
  ;;绘制捕捉标记
  (DEFUN DrawVecs (Pt Vecs Size Color / lst xdir)
    (setq xdir (getvar 'ucsxdir))
    (setq vecs
           (mapcar
             '(lambda (x)
                (mapcar        '(lambda (a)
                           (setq a (trans a 0 xdir))
                           (setq a (list (caddr a) (car a)))
                           (list (+ (car pt) (* size (car a)))
                                 (+ (cadr pt) (* size (cadr a)))))
                        x))
             vecs))
    (SETQ lst (MAPCAR 'CONS
              (MAPCAR (FUNCTION (LAMBDA (x) Color)) Vecs)
              Vecs
          )
    )
    (VL-CATCH-ALL-APPLY 'GRVECS (list (APPLY 'APPEND lst)))
  )
  ;;;主程序开始
  (VL-LOAD-COM)
  (if STARTPT
    (setvar 'lastpoint STARTPT)
    (setq STARTPT (getvar 'lastpoint))
    )
  (SETQ time T)
  (setq F3 (getvar "osmode"))
  (setq F8 (getvar "ORTHOMODE"))
  (SETQ str_osmode (get_osmode))
  (SETQ lst_osmode (gxl-StrParse str_osmode ","))
  (SETQ    Draftobj (VLA-GET-DRAFTING
           (VLA-GET-PREFERENCES (VLAX-GET-ACAD-OBJECT))
         )
  )
  (SETQ AutoSnapMarkerSize (VLA-GET-AUTOSNAPMARKERSIZE Draftobj))
  (SETQ AutoSnapMarkerColor (VLA-GET-AUTOSNAPMARKERCOLOR Draftobj))
  (setq drag (apply 'GRREAD GR_mode)) ;_ 执行Gread函数
  (setq dragmode (car drag))
    (COND ((equal drag '(2 6));F3切换捕捉开关
             (if (< f3  16384)
               (progn (setq f3 (+ f3 16384))(prompt "\n&lt;对象捕捉 关&gt;"))
               (progn (setq f3 (- f3 16384))(prompt "\n&lt;对象捕捉 开&gt;"))
              )
           (setvar "OSMODE" f3)(redraw)
          )         
         ((equal drag '(2 15));F8切换正交开关
            (if (= f8 0)
               (progn(setq f8 1)(prompt "\n&lt;正交 开&gt;"))
               (progn(setq f8 0)(prompt "\n&lt;正交 关&gt;"))
              )
          (setvar "orthomode" f8)(redraw)
          )
      ((= dragmode 5)
       (REDRAW)
       (gxl-SEL-REDRAWSEL ss 2) ;_ 隐藏选择集
       (SETQ drag (CADR drag))
       (IF (or (zerop (strlen str_osmode))
               (null (SETQ ghostpt (OSNAP drag str_osmode)))
               )
         ;;;此处修改正交模式下坐标
         (if (and startpt (= 1 f8) (/= 2 (car drag)))
           (progn
             (setq x0 (car startpt)
                   y0 (cadr startpt)
                   x1 (car drag)
                   y1 (cadr drag)
                   z1 (caddr drag)
                   )
             (if (> (abs (- x0 x1)) (abs (- y0 y1)))
               (setq ghostpt (list x1 y0 z1))
               (setq ghostpt (list x0 y1 z1))
               )
             )
         (SETQ ghostpt drag)
           )
         ;;Beacuse of mouse middle button scroll , calculate "DistPerPixel" every time
         (PROGN (SETQ DistPerPixel (/ (GETVAR "VIEWSIZE") (CADR (GETVAR "SCREENSIZE"))))
            ;;Bold
            (SETQ Bold (MAPCAR '*
                       (LIST DistPerPixel DistPerPixel DistPerPixel)
                       (LIST (+ AutoSnapMarkerSize 0.5)
                         AutoSnapMarkerSize
                         (- AutoSnapMarkerSize 0.5)
                       )
                   )
            )
            (FOREACH item  Bold
              (DrawVecs
                ghostpt
                (GetGrvecs ghostpt drag lst_osmode)
                item
                AutoSnapMarkerColor
                )
              )
         )
       )
       (gxl-SEL-REDRAWSEL ss 1) ;_ 显示选择集
      )
      ((or (= dragmode 3)
           (= dragmode 12)
           )
       (gxl-SEL-REDRAWSEL ss 2) ;_ 隐藏选择集
       (IF (Null (SETQ ghostpt (OSNAP (CADR drag) (get_osmode))))
         ;;;此处修改正交模式下坐标
         (if (and startpt (= 1 f8) (/= 2 (car drag)))
           (progn
             (setq x0 (car startpt)
                   y0 (cadr startpt)
                   x1 (caadr drag)
                   y1 (cadadr drag)
                   z1 (caddar (cdr drag))
                   )
             (if (> (abs (- x0 x1)) (abs (- y0 y1)))
               (setq ghostpt (list x1 y0 z1))
               (setq ghostpt (list x0 y1 z1))
               )
             )
         (SETQ ghostpt (CADR drag))
           )
         
       )
       (REDRAW)
       (gxl-SEL-REDRAWSEL ss 1) ;_ 显示选择集
       (SETQ time nil)
      
      )
     (t
      ;;;此处修改正交模式下坐标
      (if (and startpt (= 1 f8) (/= 2 (car drag)))
           (progn
             (setq x0 (car startpt)
                   y0 (cadr startpt)
                   x1 (caadr drag)
                   y1 (cadadr drag)
                   z1 (caddar (cdr drag))
                   )
             (if (> (abs (- x0 x1)) (abs (- y0 y1)))
               (setq ghostpt (list x1 y0 z1))
               (setq ghostpt (list x0 y1 z1))
               )
             )
         (SETQ ghostpt (CADR drag))
           )
      (REDRAW)
      )
    )
; )
(list dragmode ghostpt)
)
;;;***************** 函数 gxl-Ge-grread*****************


;;;*************函数 gxl-mat-translation.lsp  *************
;;;-----------------------------------------------------------;;
;;; (gxl-Mat-Translation v) 平移变换矩阵方式1              ;;
;;; 参数:                                                      ;;
;;; v - 位移向量                                              ;;
;;;-----------------------------------------------------------;;
;;;---------------=={ Translate by Matrix }==-----------------;;
;;;                                                           ;;
;;; Translation Matrix                                        ;;
;;;-----------------------------------------------------------;;
;;; Author: highflybird, Copyright ? 2012                     ;;
;;;-----------------------------------------------------------;;
;;; Arguments:                                                ;;
;;; v  - Displacement vector by which to translate            ;;
;;;-----------------------------------------------------------;;
(defun gxl-Mat-Translation ( v )
  (list
    (list 1. 0. 0. (car v))
    (list 0. 1. 0. (cadr v))
    (list 0. 0. 1. (caddr v))
    (list 0. 0. 0. 1.)
  )
)
;;;***************** 函数 gxl-Mat-Translation*****************


;;;*************函数 gxl-mat-translateby2p.lsp  *************
;;;-----------------------------------------------------------;;
;;; (gxl-Mat-TranslateBy2P p1 p2) 平移变换矩阵方式2              ;;
;;; 参数:                                                      ;;
;;; p1 - 基点                                                 ;;
;;; p2 - 目标点                                               ;;
;;;-----------------------------------------------------------;;
;;;---------------=={ Translate by Matrix }==-----------------;;
;;;                                                           ;;
;;; Translation Matrix                                        ;;
;;;-----------------------------------------------------------;;
;;; Author: highflybird, Copyright ? 2012                     ;;
;;;-----------------------------------------------------------;;
;;; Arguments:                                                ;;
;;; p1, p2 - Points representing vector by which to translate ;;
;;;-----------------------------------------------------------;;
(defun gxl-Mat-TranslateBy2P ( p1 p2 )
  (gxl-Mat-Translation (mapcar '- p2 p1))
)
;;;***************** 函数 gxl-Mat-TranslateBy2P*****************


;;;*************函数 gxl-mat-rotation.lsp  *************
;;;-----------------------------------------------------------;;
;;; (gxl-Mat-Rotation cen ang) 二维旋转变换矩阵                ;;
;;; 参数:                                                      ;;
;;; Cen - 基点                                                ;;
;;; ang - 旋转角度                                            ;;
;;;-----------------------------------------------------------;;
;;;-----------------=={ Rotate by Matrix }==------------------;;
;;;                                                           ;;
;;; Rotation Matrix                                           ;;
;;;-----------------------------------------------------------;;
;;; Author: highflybird, Copyright ? 2012                     ;;
;;;-----------------------------------------------------------;;
;;; Arguments:                                                ;;
;;; Cen    - Base Point for Rotation Transformation           ;;
;;; ang    - Angle through which to rotate object             ;;
;;;-----------------------------------------------------------;;
(defun gxl-Mat-Rotation ( Cen ang / c s x y)
  (setq c (cos ang) s (sin ang))
  (setq x (car Cen) y (cadr Cen))
  (list
    (list c (- s) 0. (- x (- (* c x) (* s y))))
    (list s    c  0. (- y (+ (* s x) (* c y))))
    '(0. 0. 1. 0.)
    '(0. 0. 0. 1.)
  )
)
;;;***************** 函数 gxl-Mat-Rotation*****************


;;;*************函数 gxl-mat-reflect.lsp  *************
;;;-----------------------------------------------------------;;
;;; (gxl-Mat-Reflect p1 p2) 二维镜像变换矩阵                      ;;
;;; 参数:                                                      ;;
;;; p1     - 镜像向量第一点                                   ;;
;;; p2     - 镜像向量第二点                                   ;;
;;;-----------------------------------------------------------;;
;;;----------------=={ Reflect by Matrix }==------------------;;
;;;                                                           ;;
;;; Reflects a VLA-Object or Point List using a               ;;
;;; Transformation Matrix                                     ;;
;;;-----------------------------------------------------------;;
;;; Author: Lee Mac, Copyright ? 2010 - www.lee-mac.com       ;;
;;;-----------------------------------------------------------;;
;;; Arguments:                                                ;;
;;; target - VLA-Object or Point List to transform            ;;
;;; p1, p2 - Points representing vector in which to reflect   ;;
;;;-----------------------------------------------------------;;
(defun gxl-Mat-Reflect ( p1 p2 / a c s x y)
  (setq a (angle p1 p2) a (+ a a))
  (setq c (cos a) s (sin a))
  (setq x (car p1) y (cadr p1))
  (list
    (list c    s  0. (- x (+ (* c x) (* s y))))
    (list s (- c) 0. (- y (- (* s x) (* c y))))
    '(0. 0. 1. 0.)
    '(0. 0. 0. 1.)
  )
)
;;;***************** 函数 gxl-Mat-Reflect*****************


;;;*************函数 gxl-pt-》3d.lsp  *************
;;; (gxl-pt->3d p) 无条件转换为3维点,
(defun gxl-pt->3d (p)
  (cond ((= 'LIST (type p))
         (if (= 1 (length p))
           (list (if (= 'REAL (type (car p))) (car p) (atof (itoa (car p))))  0.0 0.0)
           (if (= 2 (length p))
           (list (if (= 'REAL (type (car p))) (car p) (atof (itoa (car p))))
                 (if (= 'REAL (type (cadr p))) (cadr p) (atof (itoa (cadr p))))
                 0.0
                 )
             (list (if (= 'REAL (type (car p))) (car p) (atof (itoa (car p))))
                 (if (= 'REAL (type (cadr p))) (cadr p) (atof (itoa (cadr p))))
                 (if (= 'REAL (type (caddr p))) (caddr p) (atof (itoa (caddr p))))
                 )
             )
           )
         )
        ((= 'REAL (type p))
         (list p 0.0 0.0)
         )
        ((= 'INT (type p))
         (list (atof (itoa p)) 0.0 0.0)
         )
        (t nil)
        )
  )
;;;***************** 函数 gxl-pt->3d*****************


;;;*************函数 gxl-mat-mxv.lsp  *************
;; Matrix x Vector - Lee Mac 2010
;; Args: m - nxn matrix, v - vector in R^n
;;;(gxl-Mat-MXV  m v ) 矩阵*向量 ,即坐标转换 4X4矩阵 * 向量
;;;(gxl-Mat-MXV '((1.57897 -1.84131 0.0 1144.8) (1.22754 2.36845 0.0 312.421) (0.0 0.0 2.0 0.0) (0.0 0.0 0.0 1.0)) (append (getpoint) '(1)))
;;(gxl-Mat-MXV (gxl-Mat-TRP (nth 2 (nentsel))) '(0 0 0 1))
(defun gxl-Mat-MXV (m v)
  (mapcar '(lambda (r) (apply '+ (mapcar '* r v))) m)
)
;;;***************** 函数 gxl-Mat-MXV*****************


;;;*************函数 gxl-mat-mxp.lsp  *************

;;;(gxl-Mat-MxP  m p ) 4X4矩阵*点 得到转换后的点
;;(gxl-Mat-MxP '((1.57897 -1.84131 0.0 1144.8) (1.22754 2.36845 0.0 312.421) (0.0 0.0 2.0 0.0) (0.0 0.0 0.0 1.0)) (getpoint))
(defun gxl-Mat-MxP (m p / v)
  (setq v (append (gxl-pt->3d p) '(1.0)))
  (reverse (cdr (reverse (gxl-Mat-MxV m v))))
)
;;;***************** 函数 gxl-Mat-MxP*****************


;;;*************函数 gxl-mat-mxm.lsp  *************
;; Matrix x Matrix - Lee Mac 2010
;; Args: m,n - nxn matrices
;;;(gxl-Mat-MxM  m v ) 矩阵*矩阵
;|(defun gxl-Mat-MxM ( m n )
  ( (lambda ( a ) (mapcar '(lambda ( r ) (gxl-Mat-MXV a r)) m)) (gxl-Mat-trp n))
)|;
(defun gxl-Mat-MxM (m n)
  (
   (lambda (a)
     (mapcar '(lambda (r)
                (mapcar '(lambda (s) (apply '+ (mapcar '* s r))) a)
                )
             m
             )
     )
    (apply 'mapcar (cons 'list n))
    )
  )
;;;***************** 函数 gxl-Mat-MxM*****************


;;;*************函数 gxl-mat-scalebase.lsp  *************
;;(gxl-Mat-Scalebase base s) 矩阵按基点缩放
(defun gxl-Mat-Scalebase (base s / s1)
  (cond
    ((and (= (type s) 'list) (= (length s) 3))
     ;;X Y Z 不等比缩放,CAD不接受非
     (list (list (car s) 0. 0. (* (- 1 (car s)) (car base)))                          ;等比矩阵
           (list 0. (cadr s) 0. (* (- 1 (cadr s)) (cadr base)))
           (list 0. 0. (caddr s) (* (- 1 (caddr s)) (caddr base)))
           '(0. 0. 0. 1.)
           )
     )
    ((numberp s)                                            ;等比缩放
     (setq s1 (- 1 s))
     (list (list s 0. 0. (* s1 (car base)))
           (list 0. s 0. (* s1 (cadr base)))
           (list 0. 0. s (* s1 (cadr base)))
           '(0. 0. 0. 1.)
           )
     )
    )
  )
;;;***************** 函数 gxl-Mat-Scalebase*****************


;;;*************************************************
(princ "\n**动态复制、移动 By Gu_xl 命令: DynDrag**")
;;动态复制、移动(c:DynDrag)
(defun c:DynDrag (/ SS       ORIGN    LOOP     COPYFLAG BASEPT
                    AXORIGN  AXBASEPT SOURCEOBJS        TARGETOBJS
                    TMP      GR       PT       TMAT     NEWORIGN
                    ROT      P1       P2       SCALE    P3
                    P4 TARGETDIS REFDIS LASTOBJS LASTBASEPT
                    KD MOVEFLAG    TMPBASEPT
                    )
  (princ "\n选择物体:")
  (if (and
        (setq ss (ssget))
        (progn
          (initget 6)
        (setq orign (getpoint "\n选择基点:"))
          )
        (setq Loop t)
        )
    (progn
      (initget "C M")
      (setq copyflag (getkword "\n[复制<C>/移动<M>]<C>:"))
      (setq copyflag (or (not copyflag) (= "C" copyflag)))
      (setq basept (trans orign 1 0))
      (setq SourceObjs
             (gxl-SEL-MAPCAR
               ss
               '(lambda (x) (vlax-ename->vla-object x))
               )
            )
      (if CopyFlag
          (setq targetObjs (mapcar 'vla-copy SourceObjs))
        (progn
          (setq targetObjs SourceObjs)
          (setq SourceObjs (mapcar 'vla-copy SourceObjs))
          )
        )
      (setq ss (ssadd)
            MoveFlag t)
      (foreach obj targetObjs (ssadd (vlax-vla-object->ename obj) ss))
      ;(setq lastobjs SourceObjs lastbasept basept)
      (prompt "\r**点取位置或 {改基点[T]/改转角[R]/转90度[A]/镜像[M]/左右翻[S]/上下翻[D]/缩放[L]/对齐[F]/}<退出>:")
      (while loop
        (setq gr (gxl-GE-GRREAD '(t 15) orign ss))
        (princ "\r**点取位置或 {改基点[T]/改转角[R]/转90度[A]/镜像[M]/左右翻[S]/上下翻[D]/缩放[L]/对齐[F]/}<退出>:")
        (cond
          ((and MoveFlag (= 5 (car gr))) ;_ 复制移动
           (grdraw orign (cadr gr) 7 1)
           (setq pt (trans (cadr gr) 1 0))
           (if (> (distance pt basept) (* 0.005 (getvar "viewsize")))
             (progn
           (setq tmat (vlax-tmatrix (gxl-Mat-TranslateBy2P basept pt)))
           (mapcar '(lambda (x)(vla-TransformBy x tmat)) targetObjs)
           (setq basept pt)
           (mapcar '(lambda (x) (vla-Highlight x :vlax-true)) targetObjs)
           )
             )
           )
          ((and MoveFlag (= 3 (car gr))) ;_ 确定
           (grdraw orign (cadr gr) 7 1)
           (setq pt (trans (cadr gr) 1 0))
           (setq tmat (vlax-tmatrix (gxl-Mat-TranslateBy2P basept pt)))
           (mapcar '(lambda (x)(vla-TransformBy x tmat)) targetObjs)
           (setq lastObjs targetObjs lastbasept basept)
           (if copyflag
             (progn               
               (setq targetObjs (mapcar 'vla-copy targetObjs))
               (setq ss (ssadd))
               (foreach obj targetObjs
                 (ssadd (vlax-vla-object->ename obj) ss)
                 )
               
               )
             (progn
               (setq MoveFlag nil)
               (mapcar 'vla-delete SourceObjs)
               )
             )
            
           )
          ((or (= 25 (car gr)) ;_ 退出
               (and (= 2 (car gr)) (or (= (cadr gr) 13) (= (cadr gr) 32)))
               )
           (redraw)
           (if copyFlag
             (progn
           (mapcar 'vla-delete targetObjs)
           )
             )
           (setq loop nil)
           )
          ((and (= 2 (car gr))
                (or (= (cadr gr) (ascii "t")) (= (cadr gr) (ascii "T")))
                ) ;_ 改基点[T]
           (redraw)
           
           (if (and
                 (not copyflag)
                 lastobjs
                 )
             (progn
               (initget 6)
           (while (not (setq Neworign (getpoint "\n选择基点:"))))
           (setq Neworign (trans Neworign 1 0))
               (setq tmat (vlax-tmatrix (gxl-Mat-TranslateBy2P  basept Neworign)))
               (mapcar '(lambda (x)(vla-TransformBy x tmat)) lastobjs)
               (setq basept Neworign)
               )
             (if (and copyflag lastobjs)
               (progn
                 (mapcar '(lambda (x) (vla-put-Visible x :vlax-false)) targetObjs)
                 (initget 6)
                 (while (not (setq Neworign (getpoint "\n选择基点:"))))
                 (setq Neworign (trans Neworign 1 0))
                 (setq tmat (vlax-tmatrix (gxl-Mat-TranslateBy2P lastbasept Neworign  )))
                 (mapcar '(lambda (x)(vla-TransformBy x tmat)) lastobjs)
                 (mapcar '(lambda (x) (vla-put-Visible x :vlax-true)) targetObjs)
                 )
               (progn
                 (while (not (setq basept (getpoint "\n选择基点:"))))
                 (setq basept (trans basept 1 0))
                 )
               )
             )
           
           )
          ((and (= 2 (car gr))
                (or (= (cadr gr) (ascii "r")) (= (cadr gr) (ascii "R")))
                ) ;_ 改转角
           (setq tmp targetObjs tmpbasept basept)
           (if copyflag
             (progn
           (mapcar '(lambda (x) (vla-put-Visible x :vlax-false)) tmp)
           (setq targetObjs lastObjs basept lastbasept)
           (setq ss (ssadd))
           (foreach obj targetObjs
                 (ssadd (vlax-vla-object->ename obj) ss)
                 )
           )
             )
           (command "_rotate" ss "" (trans basept 0 1))
           (while (= 1 (logand (getvar 'cmdactive) 1))
             (command pause)
             )
           (if copyflag
             (progn
           (mapcar '(lambda (x) (vla-put-Visible x :vlax-true)) tmp)
           (setq targetObjs tmp basept tmpbasept)
           (setq ss (ssadd))
           (foreach obj targetObjs
                 (ssadd (vlax-vla-object->ename obj) ss)
                 )
           )
             )
           )
          ((and  MoveFlag
                 (= 2 (car gr))
                (or (= (cadr gr) (ascii "a")) (= (cadr gr) (ascii "A")))
                ) ;_ 转90度
           (setq tmat (vlax-tmatrix (gxl-Mat-Rotation basept pi2)))
           (mapcar '(lambda (x)(vla-TransformBy x tmat)) targetObjs)
           )
          ((and MoveFlag
                (= 2 (car gr))
                (or (= (cadr gr) (ascii "m")) (= (cadr gr) (ascii "M")))
                ) ;_ 镜像
           (initget 7)
           (setq p1 (getpoint "\n指定第一点:"))
           (initget 7)
           (setq p2 (getpoint p1 "\n指定第二点:"))
           (setq tmat (gxl-Mat-Reflect p1 p2))
           (setq basept (gxl-MAT-MXP tmat basept)
                 tmat (vlax-tmatrix tmat)
                 )
           (mapcar '(lambda (x)(vla-TransformBy x tmat)) targetObjs)
           )
          ((and MoveFlag
                (= 2 (car gr))
                (or (= (cadr gr) (ascii "s")) (= (cadr gr) (ascii "S")))
                ) ;_ 左右翻
           (setq tmat (vlax-tmatrix (gxl-Mat-Reflect basept (polar basept pi2 10))))
           (mapcar '(lambda (x)(vla-TransformBy x tmat)) targetObjs)
           )
          ((and MoveFlag
                (= 2 (car gr))
                (or (= (cadr gr) (ascii "d")) (= (cadr gr) (ascii "D")))
                ) ;_ 上下翻
           (setq tmat (vlax-tmatrix (gxl-Mat-Reflect basept (polar basept 0 10))))
           (mapcar '(lambda (x)(vla-TransformBy x tmat)) targetObjs)
           )
          ((and MoveFlag
                (= 2 (car gr))
                (or (= (cadr gr) (ascii "l")) (= (cadr gr) (ascii "L")))
                ) ;_ 缩放
           (command "_scale&quo
434939575 2015-3-29 18:03
VBA我不会

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-3-29 17:54 , Processed in 0.095905 second(s), 9 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

返回顶部