发一些自己经常用的源码，希望大家去支持下我的其他的

lixiangyu1025

发一些自己经常用的源码，希望大家去支持下我的其他的帖子

lixiangyu1025

插件源码               

lixiangyu1025

(defun mas (obj / Area Area1 Area2 Perimeter Centroid Centroid1 Centroid2 MomentOfInertia
              MomentOfInertia1 PrincipalDirections PrincipalMoments minpt maxpt Sx Sy
              roductOfInertia ProductOfInertia1 RadiiOfGyration Wx1 Wx2 Wy1 Wy2 obj1
              obj2 recPt1 recPt2 reg1 reg2 CenX CenY)
  (if (= "AcDbRegion" (vla-get-objectname obj))                        ;如果是截面则计算
    (progn
      (setq Area (vla-get-area obj)                                    ;面积
            erimeter (vla-get-Perimeter obj)                          ;周长
            Centroid (V2L (vla-get-Centroid obj))                      ;质心
        MomentOfInertia (V2L (vla-get-MomentOfInertia obj))        ;惯性矩
            rincipalDirections (V2L (vla-get-PrincipalDirections obj));主矩方向
        rincipalMoments (V2L (vla-get-PrincipalMoments obj))      ;主力矩与质心的X-Y方向
        roductOfInertia (vla-get-ProductOfInertia obj)            ;惯性积
      )                                                                ;setq
      (vla-move obj (vlax-3d-point Centroid) (vlax-3d-point '(0 0)))   ;移动质心到原点
      (setq MomentOfInertia1 (V2L (vla-get-MomentOfInertia obj))       ;质心的惯性矩
        ProductOfInertia1 (vla-get-ProductOfInertia obj)           ;质心的惯性积
        RadiiOfGyration (V2L (vla-get-RadiiOfGyration obj))        ;回旋半径
      )                                                                ;setq
      (vla-getboundingbox obj 'minpt 'maxpt)                           ;边界框
      (setq minpt (vlax-safearray->list minpt)                         ;左下角点
            maxpt (vlax-safearray->list maxpt)                         ;右上角点
            Wx1 (/ (car MomentOfInertia1) (cadr minpt))                ;抵抗矩
        Wx2 (/ (car MomentOfInertia1) (cadr maxpt))
        Wy1 (/ (cadr MomentOfInertia1) (car minpt))
        Wy2 (/ (cadr MomentOfInertia1) (car maxpt))                                                   
      )                                                                ;setq
      (vla-move obj (vlax-3d-point '(0 0)) (vlax-3d-point Centroid))   ;移回原来位置
      (setq obj1 (vla-copy obj)                                        ;拷贝物体以用来算X面积矩
            obj2 (vla-copy obj)                                        ;拷贝物体以用来算Y面积矩
            CenX (car Centroid)
        CenY (cadr Centroid)
            recPt1 (list (+ CenX (car minpt) -1) CenY                  ;建立两个矩形面域的点表
                     (+ CenX (car maxpt) +1) CenY              
                 (+ CenX (car maxpt) +1) (+ CenY (cadr minpt) -1)         
                 (+ CenX (car minpt) -1) (+ CenY (cadr minpt) -1))                           
        recPt2 (list (+ CenX (car minpt) -1) (+ CenY (cadr minpt) -1)               
                 (+ CenX (car minpt) -1) (+ CenY (cadr maxpt) +1)         
                 CenX (+ CenY (cadr maxpt) +1)
                 CenX (+ CenY (cadr minpt) -1))
            reg1 (draw-rectange recPt1)                                ;创建面域1
        reg2 (draw-rectange recPt2)                                ;创建面域2
      )
      (vla-boolean obj1 acSubtraction reg1)                            ;求obj1与面域1之差
      (vla-boolean obj2 acSubtraction reg2)                            ;求obj2与面域2之差
      (setq Area1 (vla-get-area obj1)                                  ;求obj1的面积
        Area2 (vla-get-area obj2)                                  ;求obj2的面积
        Centroid1 (V2L (vla-get-Centroid obj1))                    ;求obj1的质心
        Centroid2 (V2L (vla-get-Centroid obj2))                    ;求obj2的质心
            Sx (* Area1 (- (cadr Centroid1) (cadr Centroid)))          ;绕X轴面积矩（静矩）
        Sy (* Area2 (- (car  Centroid2) (car  Centroid)))          ;绕Y轴面积矩（静矩）
      )
      (vla-delete obj1)                                                ;删除面域1
      (vla-delete obj2)                                                ;删除面域2
      (list (cons "面积        " Area)                                 ;返回各种参数值
        (cons "gao周长        " Perimeter)
        (cons "gao质心        " Centroid)
        (cons "gao X 轴主惯性矩" (car PrincipalMoments))
        (cons "gao X 轴惯性矩  " (car MomentOfInertia1))
        (cons "gao Y 轴主惯性矩" (cadr PrincipalMoments))
        (cons "gao Y 轴惯性矩  " (cadr MomentOfInertia1))
        (cons "gao XY惯性积    " ProductOfInertia1)
        (cons "gao X 轴上抗弯距" Wx2)
        (cons "gao X 轴下抗弯距" Wx1)
        (cons "gao Y 轴左抗弯距" Wy1)
        (cons "gao Y 轴右抗弯距" Wy2)
        (cons "gao X 轴面积矩  " Sx )
        (cons "gao Y 轴面积矩  " Sy )
        (cons "gao 回旋半径ix  " (car RadiiOfGyration))
        (cons "gao 回旋半径iy  " (cadr RadiiOfGyration))
        (cons "gao 主矩方向1   " (list (car PrincipalDirections) (caddr PrincipalDirections)))
        (cons "gao 主矩方向2   " (list (cadr PrincipalDirections) (cadddr PrincipalDirections)))
        (cons "gao 距左边距离  " (abs (car minpt)))
        (cons "gao 距右边距离  " (abs (car maxpt)))
        (cons "gao 距上边距离  " (abs (cadr maxpt)))
        (cons "gao 距下边距离  " (abs (cadr minpt)))
      )
    )
  )
)
;;;用ActiveX的方式画矩形面域
(defun draw-rectange (recpts / pts rec reg)
  (setq pts (vlax-make-safearray vlax-vbdouble '(0 . 7)))
  (vlax-safearray-fill pts recpts)
  (setq rec (vla-addlightweightPolyline *MSp pts));创建矩形
  (vla-put-closed rec 1)                  ;封闭矩形
  (setq reg (vla-addregion *MSp (O2L rec)))       ;对矩形求面域
  (vla-delete rec)                      ;删除矩形的轻多段线
  (car (V2L reg))                                 ;取得矩形面域物体
)
;;;ActiveX的变量转化为lisp列表
(defun V2L (x)
  (vlax-safearray->list (vlax-variant-value x))
)
;;;把选择集的物体转化为安全数组
(defun S2A (ss / i l objs curves)
  (setq i -1 l (sslength ss) objs nil)
  (repeat l
    (setq objs (cons (vlax-ename->vla-object (ssname ss (setq i (1+ i)))) objs))
  )
  (setq curves (vlax-make-safearray vlax-vbobject (eval '(cons 0 (1- l)))))
  (vlax-safearray-fill curves objs)
)
;;;把选择集的物体转化为Lisp表
(defun S2L (ss / i l objs)
  (setq i -1 l (sslength ss) objs nil)
  (repeat l
    (setq objs (cons (vlax-ename->vla-object (ssname ss (setq i (1+ i)))) objs))
  )
)
;;;物体组成lisp列表
(defun O2L (obj / curves)
  (setq curves (vlax-make-safearray vlax-vbobject '(0 . 0)))
  (vlax-safearray-fill curves (list obj))
)
;;;打印截面表并计数
(defun GetNum (regobjs Num / Number reglst)
  (setq Number Num)                                 ;计数归零
  (foreach obj regobjs                       
    (setq reglst (mas obj))                       ;对其分别求值
    (princ obj)                          ;打印region名
    (princ "\n下面为该物体的参数的列表: ")
    (foreach n reglst (princ "\n") (princ n))     ;打印region参数表
    (setq Number (1+ Number))                     ;计数累加
  )
)
;;;表转化成字符串
(defun list->string (lst)
  (strcat "(" (apply 'strcat (mapcar '(lambda (x) (strcat (rtos x) " ")) lst)) ")")
)
;;;写数据函数
(defun WrData (regobjs Num / Number reglst string str1 str2 str)
  (setq Number Num)                               ;计数归零
  (foreach obj regobjs                       
    (setq reglst (mas obj))                       ;对其分别求值
    (setq Number (1+ Number))                     ;计数累加
    (write-line "***********************************" file)
    (setq string (strcat "截面" (itoa Number) "的参数表:"))
    (write-line string file)                      ;写入region名
    (foreach n reglst
      (setq str1 (car n))                         ;参数名称
      (if (listp (setq str2 (cdr n)))             ;参数值
    (setq str2 (list->string str2))           
    (setq str2 (rtos str2))
      )
      (setq str (strcat str1 ": " str2))
      (write-line str file)                       ;写入region参数表
    )                                             
  )
  Number
)
;;;以下测试程序
(defun C:gjmjs (/ i j ss ss1 err objlst REGs W&P OLDCMD file)
  (vl-load-com)
  (setq    *Obj (vlax-get-acad-object)
    *Doc (vla-get-activeDocument *Obj)
    *MSp (vla-get-Modelspace *Doc)
  )
  (princ)
  (princ "\n你要想用的话，用一次给老高五十块钱，一旦使用即表示默认")
  (if (setq ss (ssget))                           ;建立选择集
    (progn
      (initget 1 "W P")                           ;选择写入文件或屏幕打印
      (setq W&P (getkword "\n你确定掏钱了吗:\n你没掏钱就选择[W]你掏钱了选择[P])?"))
      (princ "\n")   
      (setq OLDCMD (getvar "CMDECHO"))
      (setvar "CMDECHO" 0)
      (command ".UCS" "W")
      (setq objlst (S2A ss))                      ;选择集列表
      (setq file (open "C:\gaozhongjie\截面几何参数.dat""w"));打开文件
      (if (setq ss1 (ssget "P" '((0 . "REGION"))));选择集中已有的region
    (setq i (if (= W&P "P")                   ;计算并求出region数目
          (GetNum (S2L ss1) 0)               
                  (Wrdata (S2L ss1) 0)
        )
    )
    (setq i 0)
      )                           
      (defun addreg ()
    (setq REGs (vla-addregion *Msp objlst))
      )
      (setq err (vl-catch-all-apply 'addreg))     ;建立区域并出错检测
      (if (vl-catch-all-error-p err)              ;如果没有新建任何region
        (setq j 0)                                ;则计数为0
    (setq REGs (V2L REGs)                     ;否则转化成region集合
              i (if (= W&P "P")                   ;计算并求出region数目
          (GetNum REGs i)                  
          (Wrdata REGs i)
        )
          j (mapcar 'vla-delete REGs)         ;删除刚建立的截面
    )
      )
      (close file)                                ;关闭文件
      (if (/= 0 i)
    (progn
          (princ "\n\n已经列出")
          (princ i)
          (princ "个截面几何参数表.")
    )
    (alert "没有选中有效的截面!")
      )
      (command ".UCS" "P")
      (setvar "CMDECHO" OLDCMD)
    )
    (alert "你没有选中物体! ")
  )
  (princ)
)

哆啦A梦_oELxg

谢谢楼主分享

sdls

非常感谢楼主，最近在学习啃码

fengche1915@

yoyoho

非常感谢楼主!!!!!

1028695446

lixiangyu1025 发表于 2019-2-27 12:44
(defun mas (obj / Area Area1 Area2 Perimeter Centroid Centroid1 Centroid2 MomentOfInertia
       ...

[*****************************修正版***************]

• (defun mas (obj / Area Area1 Area2 Perimeter Centroid Centroid1 Centroid2 MomentOfInertia
•              MomentOfInertia1 PrincipalDirections PrincipalMoments minpt maxpt Sx Sy
•              roductOfInertia ProductOfInertia1 RadiiOfGyration Wx1 Wx2 Wy1 Wy2 obj1
•              obj2 recPt1 recPt2 reg1 reg2 CenX CenY)
•   (if (= "AcDbRegion" (vla-get-objectname obj))                        ;如果是截面则计算
•     (progn
•       (setq Area (vla-get-area obj)                                    ;面积
•         Perimeter (vla-get-Perimeter obj)                          ;周长
•         Centroid (V2L (vla-get-Centroid obj))                      ;质心
•         MomentOfInertia (V2L (vla-get-MomentOfInertia obj))        ;惯性矩
•         principalDirections (V2L (vla-get-PrincipalDirections obj));主矩方向
•         principalMoments (V2L (vla-get-PrincipalMoments obj))      ;主力矩与质心的X-Y方向
•         productOfInertia (vla-get-ProductOfInertia obj)            ;惯性积
•       )                                                                ;setq
•       (vla-move obj (vlax-3d-point Centroid) (vlax-3d-point '(0 0)))   ;移动质心到原点
•       (setq MomentOfInertia1 (V2L (vla-get-MomentOfInertia obj))       ;质心的惯性矩
•         ProductOfInertia1 (vla-get-ProductOfInertia obj)           ;质心的惯性积
•         RadiiOfGyration (V2L (vla-get-RadiiOfGyration obj))        ;回旋半径
•       )                                                                ;setq
•       (vla-getboundingbox obj 'minpt 'maxpt)                           ;边界框
•       (setq minpt (vlax-safearray->list minpt)                         ;左下角点
•         maxpt (vlax-safearray->list maxpt)                         ;右上角点
•         Wx1 (/ (car MomentOfInertia1) (cadr minpt))                ;抵抗矩
•         Wx2 (/ (car MomentOfInertia1) (cadr maxpt))
•         Wy1 (/ (cadr MomentOfInertia1) (car minpt))
•         Wy2 (/ (cadr MomentOfInertia1) (car maxpt))
•       )                                                                ;setq
•       (vla-move obj (vlax-3d-point '(0 0)) (vlax-3d-point Centroid))   ;移回原来位置
•       (setq obj1 (vla-copy obj)                                        ;拷贝物体以用来算X面积矩
•         obj2 (vla-copy obj)                                        ;拷贝物体以用来算Y面积矩
•         CenX (car Centroid)
•         CenY (cadr Centroid)
•         recPt1 (list (+ CenX (car minpt) -1) CenY                  ;建立两个矩形面域的点表
•                  (+ CenX (car maxpt) +1) CenY
•                  (+ CenX (car maxpt) +1) (+ CenY (cadr minpt) -1)
•                  (+ CenX (car minpt) -1) (+ CenY (cadr minpt) -1))
•         recPt2 (list (+ CenX (car minpt) -1) (+ CenY (cadr minpt) -1)
•                  (+ CenX (car minpt) -1) (+ CenY (cadr maxpt) +1)
•                  CenX (+ CenY (cadr maxpt) +1)
•                  CenX (+ CenY (cadr minpt) -1))
•         reg1 (draw-rectange recPt1)                                ;创建面域1
•         reg2 (draw-rectange recPt2)                                ;创建面域2
•       )
•       (vla-boolean obj1 acSubtraction reg1)                            ;求obj1与面域1之差
•       (vla-boolean obj2 acSubtraction reg2)                            ;求obj2与面域2之差
•       (setq Area1 (vla-get-area obj1)                                  ;求obj1的面积
•         Area2 (vla-get-area obj2)                                  ;求obj2的面积
•         Centroid1 (V2L (vla-get-Centroid obj1))                    ;求obj1的质心
•         Centroid2 (V2L (vla-get-Centroid obj2))                    ;求obj2的质心
•         Sx (* Area1 (- (cadr Centroid1) (cadr Centroid)))          ;绕X轴面积矩（静矩）
•         Sy (* Area2 (- (car  Centroid2) (car  Centroid)))          ;绕Y轴面积矩（静矩）
•       )
•       (vla-delete obj1)                                                ;删除面域1
•       (vla-delete obj2)                                                ;删除面域2
•       (list (cons "面积        " Area)                                 ;返回各种参数值
•         (cons "周长        " Perimeter)
•         (cons "质心        " Centroid)
•         (cons "X 轴主惯性矩" (car PrincipalMoments))
•         (cons "X 轴惯性矩  " (car MomentOfInertia1))
•         (cons "Y 轴主惯性矩" (cadr PrincipalMoments))
•         (cons "Y 轴惯性矩  " (cadr MomentOfInertia1))
•         (cons "XY惯性积    " ProductOfInertia1)
•         (cons "X 轴上抗弯距" Wx2)
•         (cons "X 轴下抗弯距" Wx1)
•         (cons "Y 轴左抗弯距" Wy1)
•         (cons "Y 轴右抗弯距" Wy2)
•         (cons "X 轴面积矩  " Sx )
•         (cons "Y 轴面积矩  " Sy )
•         (cons "回旋半径ix  " (car RadiiOfGyration))
•         (cons "回旋半径iy  " (cadr RadiiOfGyration))
•         (cons "主矩方向1   " (list (car PrincipalDirections) (caddr PrincipalDirections)))
•         (cons "主矩方向2   " (list (cadr PrincipalDirections) (cadddr PrincipalDirections)))
•         (cons "距左边距离  " (abs (car minpt)))
•         (cons "距右边距离  " (abs (car maxpt)))
•         (cons "距上边距离  " (abs (cadr maxpt)))
•         (cons "距下边距离  " (abs (cadr minpt)))
•       )
•     )
•   )
• )
• ;;;用ActiveX的方式画矩形面域
• (defun draw-rectange (recpts / pts rec reg)
•   (setq pts (vlax-make-safearray vlax-vbdouble '(0 . 7)))
•   (vlax-safearray-fill pts recpts)
•   (setq rec (vla-addlightweightPolyline *MSp pts));创建矩形
•   (vla-put-closed rec 1)                  ;封闭矩形
•   (setq reg (vla-addregion *MSp (O2L rec)))       ;对矩形求面域
•   (vla-delete rec)                      ;删除矩形的轻多段线
•   (car (V2L reg))                                 ;取得矩形面域物体
• )
• ;;;ActiveX的变量转化为lisp列表
• (defun V2L (x)
•   (vlax-safearray->list (vlax-variant-value x))
• )
• ;;;把选择集的物体转化为安全数组
• (defun S2A (ss / i l objs curves)
•   (setq i -1 l (sslength ss) objs nil)
•   (repeat l
•     (setq objs (cons (vlax-ename->vla-object (ssname ss (setq i (1+ i)))) objs))
•   )
•   (setq curves (vlax-make-safearray vlax-vbobject (eval '(cons 0 (1- l)))))
•   (vlax-safearray-fill curves objs)
• )
• ;;;把选择集的物体转化为Lisp表
• (defun S2L (ss / i l objs)
•   (setq i -1 l (sslength ss) objs nil)
•   (repeat l
•     (setq objs (cons (vlax-ename->vla-object (ssname ss (setq i (1+ i)))) objs))
•   )
• )
• ;;;物体组成lisp列表
• (defun O2L (obj / curves)
•   (setq curves (vlax-make-safearray vlax-vbobject '(0 . 0)))
•   (vlax-safearray-fill curves (list obj))
• )
• ;;;打印截面表并计数
• (defun GetNum (regobjs Num / Number reglst)
•   (setq Number Num)                                 ;计数归零
•   (foreach obj regobjs
•     (setq reglst (mas obj))                       ;对其分别求值
•     (princ obj)                          ;打印region名
•     (princ "\n下面为该物体的参数的列表: ")
•     (foreach n reglst (princ "\n") (princ n))     ;打印region参数表
•     (setq Number (1+ Number))                     ;计数累加
•   )
• )
• ;;;数字表转化成字符串
• (defun #list->string (lst)
•   (strcat
•     "("
•     (apply
•       'strcat
•       (mapcar
•         '(lambda (x) (strcat (if x (rtos x) "nil")" "))
•         lst)
•     )
•     ")"
•   )
• )
• ;;;写数据函数
• (defun WrData (regobjs Num / Number reglst string str1 str2 str)
•   (setq Number Num)                               ;计数归零
•   (foreach obj regobjs
•     (setq reglst (mas obj))                       ;对其分别求值
•     (setq Number (1+ Number))                     ;计数累加
•     (write-line "***********************************" file)
•     (setq string (strcat "截面" (itoa Number) "的参数表:"))
•     (write-line string file)                      ;写入region名
•     (foreach n reglst
•       (setq str1 (car n))                         ;参数名称
•       (if (listp (setq str2 (cdr n)))             ;参数值
•         (setq str2 (#list->string str2))          ;数字表转字符
•         (setq str2 (rtos str2))                   ;数转字符
•       )
•       (setq str (strcat str1 ": " str2))
•       (write-line str file)                       ;写入region参数表
•     )
•   )
•   Number
• )
• ;;;以下测试程序
• (defun C:gjmjs (/ i j ss ss1 err objlst REGs  OLDCMD file temp)
•   (vl-load-com)
•   (setq    *Obj (vlax-get-acad-object)
•     *Doc (vla-get-activeDocument *Obj)
•     *MSp (vla-get-Modelspace *Doc)
•   )
•   (princ)
•   (if (setq ss (ssget))                           ;建立选择集
•     (progn
•       (initget  "W P")                           ;选择写入文件或屏幕打印
•       (if(setq temp (getkword "\n[写入文件(W)/屏幕显示(P)]<W>"))
•         (setq W&P temp)
•         (setq W&P "W")
•       )
•       (princ "\n")
•       (setq OLDCMD (getvar "CMDECHO"))
•       (setvar "CMDECHO" 0)
•       (command ".UCS" "W")
•       (setq objlst (S2A ss))                      ;选择集列表
•       (setq file (open "D:\\截面几何参数.txt" "w"));打开文件
•       (if (setq ss1 (ssget "P" '((0 . "REGION"))));选择集中已有的region
•         (setq i (if (= W&P "P")                   ;计算并求出region数目
•                   (GetNum (S2L ss1) 0)
•                   (Wrdata (S2L ss1) 0)
•                 )
•         )
•         (setq i 0)
•       )
•       (defun addreg ()
•         (setq REGs (vla-addregion *Msp objlst))
•       )
•       (setq err (vl-catch-all-apply 'addreg))     ;建立区域并出错检测
•       (if (vl-catch-all-error-p err)              ;如果没有新建任何region
•         (setq j 0)                                ;则计数为0
•         (setq REGs (V2L REGs)                     ;否则转化成region集合
•           i (if (= W&P "P")                   ;计算并求出region数目
•               (GetNum REGs i)
•               (Wrdata REGs i)
•             )
•           j (mapcar 'vla-delete REGs)         ;删除刚建立的截面
•         )
•       )
•       (close file)                                ;关闭文件
•       (if (/= 0 i)
•         (progn
•           (princ "\n\n已经列出")
•           (princ i)
•           (princ "个截面几何参数表.")
•         )
•         (alert "没有选中有效的截面!")
•       )
•       (command ".UCS" "P")
•       (setvar "CMDECHO" OLDCMD)
•       (if (= W&P "W")(startapp "notepad.exe" "D:\\截面几何参数.txt"))
•     )
•     (alert "你没有选中物体! ")
•   )
•   (princ)
• )
  

yubihai

非常感谢楼主，最近在学习