发帖专用LISP函数简写&常用函数

caoyin

-------------------------------------------------------------------------------------------------------------------------------------------------
有时候回帖对于字符较多的函数拼写起来实在麻烦，为了方便大家发帖回帖，故把一些常用而字符较长函数和代码加以简化和整理，大家可以在帖子中直接引用，这样可以节省大家的时间。

以下为本人临时整理，可能有谬误。根据使用频率以下内容将会有所增删或修正，欢迎大家提出增删和修改意见！

代码见2楼，刚发现一个问题：测试不方便，还要加载函数？？！！

caoyin

;;明经通道发帖专用LISP函数简写&常用函数(2011.1)
;;;红色部分即为直接使用的常量和函数
;;;http://bbs.mjtd.com/forum.php?mod=post&action=edit&fid=3&tid=85250&pid=450859&page=1

(setq En2Obj   vlax-ename->vla-object
      Obj2En   vlax-vla-object->ename
      2PI      (* PI 2)
      0.5PI    (/ PI 2)
      0.25PI   (/ PI 4)
;;常用VLA对象、集合
      *ACAD*  (vlax-get-acad-object)
      *DOC*   (vla-get-ActiveDocument *ACAD*)
      *DOCS*  (vla-get-Documents *ACAD*)
      *MS*    (vla-get-modelSpace *DOC*)
      *PS*    (vla-get-paperSpace *DOC*)
      *BLKS*  (vla-get-Blocks *DOC*)
      *LAYS*  (vla-get-Layers *DOC*)
      *LTS*   (vla-get-Linetypes *DOC*)
      *STS*   (vla-get-TextStyles *DOC*)
      *GRPS*  (vla-get-groups *DOC*)
      *DIMS*  (vla-get-DimStyles *DOC*)
      *LOUTS* (vla-get-Layouts *DOC*)
      *VPS*   (vla-get-Viewports *DOC*)
      *VS*    (vla-get-Views *DOC*)
      *DICS*  (vla-get-Dictionaries *DOC*)
;;常用的几个外部接口对象
      *FSO*   (vlax-get-or-create-object "Scripting.FileSystemObject")
      *WSH*   (vlax-get-or-create-object "wscript.shell")
      *SHELL*  (vlax-get-or-create-object "Shell.Application")
      *SCR*   (vlax-get-or-create-object "ScriptControl")
      *WBEM*  (vlax-get-or-create-object "WbemScripting.SWbemLocator")
)

;; [功能] 将弧度转换为十进制角度
;; [参数] ang---弧度
;; [返回] 十进制角度
(defun MJ:R2D (ANG) (* (/ ANG 180.0) PI))

;; [功能] 将十进制角度转换为弧度
;; [参数] ang---十进制角度
;; [返回] 弧度
(defun MJ:D2R (ANG) (/ (* ANG 180.0) PI))

;; [功能] 在当前视图状况下将图形单位转换为像素
(defun MJ:U2P (UN)
  (* UN (/ (cadr (getvar 'SCREENSIZE)) (getvar 'VIEWSIZE)))
)
;; [功能] 获取 0~1 之间的随机数 (by zml84)
(defun MJ:RAD ()
  (/ (rem (getvar "CPUTICKS") 1984) 1983)
)
;; [功能] 判断 X 是否是图元名
(defun MJ:enP (X) (= (type X) 'ENAME))

;; [功能] 判断 X 是否是选择集且长度不为 0
(defun MJ:ssP (x) (and (= (type X) 'PICKSET) (> (sslength X) 0)))

;; [功能] 判断 X 是否是字符串
(defun MJ:strP (X) (= (type X) 'STR))

;; [功能] 判断 X 是否是实数
(defun MJ:realP (x) (= (type X) 'REAL))

;; [功能] 判断 X 是否是整数
(defun MJ:intP (X) (= (type X) 'INT))

;; [功能] 判断 FileName 是否为文件且存在(替代针对文件的findfile)
;; [参数] FileName---字符串
;; [返回] 包含路径的文件名或 nil
(defun MJ:FileP (FileName)
  (if (and (MJ:STRP FileName)
           (setq FileName (findfile FileName))
           (not (vl-file-directory-p FileName))
      )
    FileName
  )
)

;; [功能] 将 ACI 索引颜色转换成 RGB 配色系统
(defun MJ:ACI->RGB (ACI / COL)
  (setq COL (vla-get-truecolor (vla-get-ActiveLayer *DOC*))))
  (if (not (vl-catch-all-apply 'vla-put-ColorIndex (list COL ACI)))
    (list (vla-get-red COL)
          (vla-get-green COL)
          (vla-get-blue COL)
    )
  )
)

;; [功能] 将 RGB 配色系统转换成 ACI 索引颜色
(defun MJ:RGB->ACI (R G B / COL ACI)
  (setq COL (vla-get-truecolor (vla-get-ActiveLayer *DOC*)))
  (vl-catch-all-apply
    '(lambda ()
       (vla-SetRGB COL R G B)
       (setq ACI (vla-get-ColorIndex COL))
     )
  )
  ACI
)
;; [功能] 将选择集转换为图元列表
;; [参数] SS---选择集
;; [返回] 表(图元列表长度 图元列表)
(defun MJ:SS->LIST (SS)
  (vl-remove-if-not 'MJ:enP (mapcar 'cadr (ssnamex SS)))
)
;; [功能] 根据当前文档的图形单位精度将实数转换为字符串
;; [参数] REL----实数
(defun MJ:RTOS (REL / DZIN)
  (setq DZIN (getvar 'DIMZIN))
  (setvar 'DIMZIN 0)
  (setq REL (rtos REL 2 (getvar 'LUPREC)))
  (setvar 'DIMZIN DZIN)
  REL
)
;; [功能] 遍历选择集对所包含的图元进行指定函数操作
;; [参数] SS----选择集
;;        FUN---函数名
;; [返回] 包含每个图元的操作结果的表
(defun MJ:SS-MAP (SS FUN / N LST)
  (repeat (setq N (sslength SS))
    (setq LST (cons (apply FUN (list (ssname SS (setq N (1- N))))) LST))
  )
  LST
)
;; [功能] 遍历选择集对所包含的图元进行指定函数操作
;; [参数] SS----选择集
;;        FUN---函数名
;; [返回] 最后一个图元的操作结果
(defun MJ:SS-FOR (SS FUN / N)
  (repeat (setq N (sslength SS))
    (apply FUN (list (ssname SS (setq N (1- N)))))
  )
)
;; [功能] 获取当前 AutoCAD 的版本
(defun MJ:ACAD-VAR () (atof (getvar "ACADVER")))
;; [功能] 获取两点的中点坐标
;; [参数] p1，p2---二维点或三维点，但两个表的长度要一致
;; [返回] 点
(defun MJ:MIDPOINT (P1 P2)
  (mapcar '(lambda (X Y) (/ (+ X Y) 2.0)) P1 P2)
)
;; [功能] 获取 DXF 组码值
(defun MJ:DXF (IT LST)
  (cdr (assoc IT LST))
)
;; [功能] 获取在图元 en 之后产生的图元列表
;; [参数] en----图元名
;; [返回] 图元列表
;; [测试]1.(setq en (entlast))
;;         执行创建图元的命令，如 LINE,BOUNDARY
;;         (MJ:EntNextAll en)
;;       2.(MJ:EntNextAll (car(entsel)))
(defun MJ:EntNextAll (EN / LST)
  (if EN
    (while (setq EN (entnext EN))
      (if (not (member (cdr (assoc 0 (entget EN)))
                       '("ATTRIB" "VERTEX" "SEQEND")
               )
          )
        (setq LST (cons EN LST))
      )
    )
  )
  (reverse LST)
)

;; [功能] 打印列表中的数据
(defun MJ:Print-List (LST) (mapcar 'princ LST))

wen1235

下了几十个lisp函数,,就贴在这儿了

hubeiwdlue

谢谢C版分享的函数，对我们很有用。

cnks

支持

linshiyin2

tjuzkj

支持,好!

jackynine

辛苦~~~ 顶下

xhq1954425

谢谢！兔年吉祥！

vken7az2p

感谢您的提供分享
快收藏起来

pop159

yrgui

嗯，很好，希望能继续