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

caoyin 发表于 2011-1-28 02:44:18

本帖最后由 caoyin 于 2011-9-8 12:18 编辑

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

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

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

caoyin 发表于 2011-1-28 04:15:50

本帖最后由 caoyin 于 2011-9-8 12:11 编辑

;;明经通道发帖专用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 发表于 2011-2-20 08:20:02

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

hubeiwdlue 发表于 2024-3-9 23:17:47

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

cnks 发表于 2011-1-28 16:01:35

支持

linshiyin2 发表于 2011-1-30 08:30:18

tjuzkj 发表于 2011-1-30 12:17:44

支持,好!

jackynine 发表于 2011-1-30 20:28:45

辛苦~~~ 顶下

xhq1954425 发表于 2011-2-2 08:08:29

谢谢！兔年吉祥！

vken7az2p 发表于 2011-2-16 06:54:57

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

pop159 发表于 2011-2-16 21:10:38

yrgui 发表于 2011-2-18 12:18:51

嗯，很好，希望能继续

页: [1] 2 3 4 5

明经CAD社区's Archiver

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