准备重写XYP-LISP函数包，希望大家捧场（开场篇）

Lispboy

昨天下载到XYP-LISP 文档包，里面有XYP写的一些通用的LISP函数库，文档帮助里面不少函数都提供了源代码，这里感谢作者XYP的共享精神，不过，还有一些函数可能由于时间的关系，并没有给出源码，写这个函数包，也算是对作者XYP的致敬。

看了XYP的函数，受到很大的启发和灵感，所以准备在晓东这里重新写下那些没有提供源码的LISP函数，对于提供源码的，本着学习和交流的精神，如果精力够，也准备完善下，希望大家欢迎捧场，如果精力够，尽可能的给出注释。

其实写这些也是自己熟练LISP的过程，也希望大家也动起手来，一起来完善咱们自己的通用LISP函数库

声明：
1、发帖准备一个函数一个主题的方式，欢迎大家跟帖也希望有能力的朋友一起完善。本人将从下载获得的D豆奖励给积极参与的朋友。
2、关于这个函数包一律设置权限，初级会员以上可见（积分50吧，很容易达到的），必要的收豆。请大家理解。


下面转帖下XYP-LISP文档包。

请点击此处下载

查看状态：需购买或无权限

您的用户组是：游客

文件名称:xyp_lisp.rar 
下载次数:474  文件大小:412.44 KB 
下载权限: 不限 以上  [免费赚D豆]

清风明月10

我认为一定要中文注释其功能。最好是第一个部分都注释。而且自定义函数名称最好为中文,这样调用函数一看它的名字就知道了。这是我的一些按此原则写的代码。
;自定义函数的制作方法：1、基本格式为“(DEFUN QFMY-类别-功能())”。2、函数名尽量使用中文，因为这样做，以后调用就方便了。3、由于采用了中文，调用时输入比较麻烦，所以最好想出一个快速省时省力的调用方法
;这种自定义函数相当于VBA中的类模块，可以极大地加快编程速度，加强自己的插件功能，所以这方面工作要加强
;这个插件只能加到启动组中
(DEFUN QFMY-新建图层(图层名)
;判断图层名图层是否存在，不存在则新建
(if (not (tblsearch "LAYER" 图层名))
   (command "layer" "n" 图层名 "")
  )
;使用方法
)

(defun QFMY-将插件信息写入TXT ( 文件简单名 命令 / minlingmincen anniuzongxinxi wenjianmincen wenjianmin)
   ;-将插件信息写入TXT
   ;下面是反复启动本插件的代码。将本套代码放在所有代码的最前面。因为放在后面可能会产生不可预测的问题。而放在前面一点问题也不会有
;;这部分代码是将按钮总信息写入一个文本文件“D:/D盘DXM文件夹/自编软件运行过程中保存的信息/日常使用的插件信息2013年3月28日.txt”中,
;;再用VBA将文本文件中的内容读入数组A中，将数组A倒序分解成两个问题，一个部分为插件名称，一个部分为命令，再以命令为关键词添加到字典中。
;;这样就可以获得没有重复命令的插件信息。再将字典的关键词（即插件名称）放入LISTBOX1，将字典的解释词（即插件命令）放入LISTBOX2。这样
;;只要选中LISTBOX2的其中一项双击就可以启动该插件了。
;;命令只保存100条，容许是300条，超过300条就将文本文件内容删除，将LISTBOX1及LISTBOX2的最后100项内容写入文本文件。
;;对于尾缀为“FAS”或“VLS”的加密的LSP插件，另做一个LISP插件V启动它，再将V的插件名加命令发送到文本文件。由于V插件的命令是我定的，所以不会重复，这样还可以避免原插件命令容易重复的毛病，保证了每个最近使用的插件信息都能得到有效保存。
;;VLX另做一个LISP启动，还可以避免命令重复
;;对于VBA插件，直接写代码将VBA插件名称及启动命令写入文本文件，格式为：VBA插件名称+“-vbarun”+一个空格+启动命令
; (setq 文件简单名 "CJ001命令复制一个实体到当前层无论它在哪个层.lsp")
; (setq minlingmincen "(LOAD \"CJ001命令复制一个实体到当前层无论它在哪个层.lsp\") 复制一个实体到当前层无论它在哪个层")
(setq minlingmincen (strcat  "(LOAD \"" 文件简单名 "\") " 命令) )

(setq anniuzongxinxi (strcat 文件简单名 "芰" minlingmincen))
(setq wenjianmincen "D:/D盘DXM文件夹/自编软件运行过程中保存的信息/日常使用的插件信息2013年3月28日.txt")
  (setq wenjianmin(open wenjianmincen "a"));;如何写作“(setq f(open wenjianmincen "a"))”，则是保存原内容，在最行一行的下行追加

(write-line anniuzongxinxi wenjianmin)
(close wenjianmin)
; 使用实例：( QFMY-将插件信息写入TXT  "CJ019命令对象水平对齐程序.LSP" "对象水平对齐程序" )
)





;************************************************************************************
;namezg2011.12.20
;功能：判断点与直线的位置关系  
;参数：pt1，pt2：直线上的两点
;            pt0：所要判断的点
;返回值：                    
;"On"          点在直线上   
;"UpperRight"  点在直线右上  
;"LowerRight"  点在直线右下  
;"UpperLeft"   点在直线左上  
;"LowerLeft"   点在直线左下  
;"Upper"       点在直线上   
;"Lower"       点在直线下   
;"Right"       点在直线右   
;"Left"        点在直线左   
(defun QFMY-点在直线的方位 (pt1 pt2 pt0 / x1 y1 x2 y2 x0 y0 k b y position)
        ; 来源：[namezg][源码]判断点与直线的位置关系-AutoLISP/Visual LISP 编程技术-CAD论坛-明经CAD社区 - Powered by Discuz!
; http://bbs.mjtd.com/thread-91325-1-1.html
                (setq x1 (car pt1))
        (setq y1 (cadr pt1))
        (setq x2 (car pt2))
        (setq y2 (cadr pt2))
        (setq x0 (car pt0))
        (setq y0 (cadr pt0))
        (if (= x1 x2)
                ;直线垂直
                (cond
                        ((< x0 x1)  ;((< x0 x2)
                                (princ "\n直线垂直，点在直线左。")
                                (setq position "Left")
                        )
                        ((> x0 x1)  ;((> x0 x2)
                                (princ "\n直线垂直，点在直线右。")
                                (setq position "Right")
                        )
                        ((= x0 x1)  ;((= x0 x2)
                                (princ "\n直线垂直，点在直线上。")
                                (setq position "On")
                        )
                )
                ;直线水平或倾斜
                (progn
                        (setq k (/ (- y1 y2) (- x1 x2)))
                        (setq b (- y1 (* k x1)))  ;(setq b (- y2 (* k x2)))
                        (setq y (+ (* k x0) b))
                        (cond
                                ;直线向右倾斜
                                ((> k 0)
                                        (cond
                                                ((< y0 y)
                                                        (princ "\n直线向右倾斜，点在直线右下。")
                                                        (setq position "LowerRight")
                                                )
                                                ((> y0 y)
                                                        (princ "\n直线向右倾斜，点在直线左上。")
                                                        (setq position "UpperLeft")
                                                )
                                                ((= y0 y)
                                                        (princ "\n直线向右倾斜，点在直线上。")
                                                        (setq position "On")
                                                )
                                        )
                                       
                                )
                                ;直线向左倾斜
                                ((< k 0)
                                        (cond
                                                ((< y0 y)
                                                        (princ "\n直线向左倾斜，点在直线左下。")
                                                        (setq position "LowerLeft")
                                                )
                                                ((> y0 y)
                                                        (princ "\n直线向左倾斜，点在直线右上。")
                                                        (setq position "UpperRight")
                                                )
                                                ((= y0 y)
                                                        (princ "\n直线向左倾斜，点在直线上。")
                                                        (setq position "On")
                                                )
                                        )        
                                )
                                ;直线水平
                                ((= k 0)
                                        (cond
                                                ((< y0 y)
                                                        (princ "\n直线水平，点在直线下。")
                                                        (setq position "Lower")
                                                )
                                                ((> y0 y)
                                                        (princ "\n直线水平，点在直线上。")
                                                        (setq position "Upper")
                                                )
                                                ((= y0 y)
                                                        (princ "\n直线水平，点在直线上。")
                                                        (setq position "On")
                                                )
                                        )
                                       
                                )
                        )
                )
        )
        position
)
;测试点自定义函数“在直线的方位”
; (defun c:tt (/ en en_dxf pt1 pt2 pt0 value)
        ; (setq en (car (entsel "\n请选择一条直线：")))
        ; (setq en_dxf (entget en))
        ; (setq pt1 (cdr (assoc 10 en_dxf)))
        ; (setq pt2 (cdr (assoc 11 en_dxf)))
        ; (setq pt0 (getpoint "\n请选择一点："))
        ; (setq value (QFMY-点在直线的方位 pt1 pt2 pt0))
        ; (princ)
; )
;************************************************************************************



;;================{ 自定义的getcorner，实现左虚右实(甚至是全虚线). }===============自定义的getcorner函数画选定框
;;参数:MSG--提示字符串,无则nil  PT1--起始点  
;;     CO--矩形框的颜色  MODE--T则总是虚线，nil则左虚右实.
;;返回值: 表 (PT2 CO) 第一项为得到的点 第二项为颜色正负值 ,如果点右键则返回的pt2为nil
;;根据第二项的正负可决定C 或W  如：(ssget (if (minusp co) "_c" "_w") pt1 pt2 SSPARM)
;;测试: 左虚右实--(YY:getcorner (getpoint) "指定对角点" 1 nil)
;;测试: 全虚线--(YY:getcorner (getpoint) "指定对角点" 1 T)
; 来源：晓东CAD家园-论坛-Auto/VLISP-【函数分享】自定义的getcorner，实现左虚右实(或者是全虚线) - Powered by Discuz!
; http://www.xdcad.net/forum/thread-668446-1-1.html
(DEFUN YY:GETCORNER (PT1 MSG CO MODE / PT2)
  (IF MSG
    (princ MSG)
  )
  ;;(princ "指定对角点: ")
  (setq pt1 (list (car pt1) (cadr pt1)))
  (while (not (member (car (setq pt2 (grread T 12 1))) '(3 11 12 25))
         )
    (IF        (listp (cadr pt2))
      (progn
        (setq pt2 (list (caadr pt2) (cadadr pt2)))
        (redraw)
        (setq co (abs co))
        (if (OR MODE (> (car pt1) (car pt2)))
          (setq co (- co))
        )
        (grvecs        (list co
                      pt1
                      (list (car pt1) (cadr pt2))
                      co
                      pt2
                      (list (car pt1) (cadr pt2))
                      co
                      pt2
                      (list (car pt2) (cadr pt1))
                      co
                      pt1
                      (list (car pt2) (cadr pt1))
                )
        )
      )
    )
  )
  (redraw)
  (if (vl-consp (CADR PT2))
    (LIST (CADR PT2) CO)
    (LIST NIL CO)
  )
)


;;来源：批量匹配替换单行或多行文字（源码）-AutoLISP/Visual LISP 编程技术-CAD论坛-明经CAD社区-源码,替换文字,替换,批量,匹配 - Powered by Discuz!
; http://bbs.mjtd.com/thread-95896-1-1.html
;替换文字
; (QFMY- 不匹配替换 选择集 <要找的文字> <替换成的文字>)
(defun QFMY-不匹配替换(单多行TEXT选择集 旧字符串 新字符串 /  ssl ct0 edata etext txtln subln ct1 ct2 schct newtext)
  (if 单多行TEXT选择集
    (progn
      (setq ssl (sslength 单多行TEXT选择集)
            ct0 0
            ct1 0
            ct2 0
            subln (strlen 旧字符串)
      )
      (while (< ct0 ssl)
        (setq edata (entget (ssname 单多行TEXT选择集 ct0))
              etext (cdr (assoc 1 edata))
              txtln (strlen etext)
              schct 1
              newtext ""
        )
        (while (<= schct txtln)
          (setq newtext
            (strcat newtext
              (if (= (setq readch (substr etext schct subln)) 旧字符串)
                (setq ct1 (1+ ct1)
                  schct (+ schct subln)
                  新字符串 新字符串
                )
                (progn
                  (setq schct (1+ schct))
                  (substr readch 1 1)
                )
              )
            )
          )
        )
        (if (/= etext newtext)
   (progn
            (entmod (subst (cons 1 newtext) (assoc 1 edata) edata))
            (setq ct2 (1+ ct2))
          )
        )
        (setq ct0 (1+ ct0))
      )
    )
  )
)


;批量替换字符
; CHGTEXT command - rudi(单多行TEXT选择集
(defun QFMY-匹配替换 ( 单多行TEXT选择集 替换用旧字符串 替换用新字符串 / anniuzongxinxi as chajianmincen chf chm cont e l minlingmincen n nsl osl  si sl st wenjianmin wenjianmincen  文本内容)
   (if 单多行TEXT选择集 (progn                      ; If any objects selected
      (setq cont t)
      (while cont
         
                 (setq osl (strlen 替换用旧字符串))
         (if (= osl 0)
            (princ "Null input invalid")
            (setq cont nil)
         )
      )
      
          (setq nsl (strlen  替换用新字符串 ))
      (setq l 0 n (sslength 单多行TEXT选择集))
      (while (< l n)                 ; For each selected object...
         (setq e (entget (ssname 单多行TEXT选择集 l)))
               (setq chf nil si 1)
               (setq 文本内容 (cdr (setq as (assoc 1 e))))
              ;;完全匹配的条件
                          (IF (= 文本内容 替换用旧字符串 )
                          (while (= osl (setq sl (strlen
                             (setq st (substr 文本内容 si osl)))))
                  (if (= st 替换用旧字符串)
                      (progn
                        (setq 文本内容 (strcat (substr 文本内容 1 (1- si)) 替换用新字符串
                                        (substr 文本内容 (+ si osl))))
                        (setq chf t)    ; Found old string
                        (setq si (+ si nsl))
                      )
                      (setq si (1+ si))
                  )
               )
                           )
               (if chf (progn        ; Substitute new string for old
                  (setq e (subst (cons 1 文本内容) as e))
                  (entmod e)         ; Modify the TEXT entity
                  
               ))
                    
         (setq l (1+ l))
      )
   ))
   
   (terpri)
)

Lispboy

ll_j 发表于 2013-6-3 16:53
怎么说呢？不太支持，除非xyp默许，换句话说，如果他同意，还需要你写么？

就像你偏要去揭开别人家新娘 ...

怎么说呢，自己原创写一个别人有的功能的，还要争取别人的意见？ 自己写一个增强的SSGET，还要征求AUTODESK的意见？

或许我不应该提名字，我主贴里面提到的都是钦佩和赞扬啊。XYP的工具不会因为我写了什么，就没人用了，他的工具不是免费的吗？我只是希望系统的写个东西并在写的过程中和大家一起提高。

Free-Lancer

支持一个，把论坛里面已有的整合起来也不得了来自: Android客户端

SmartStar

我也来捧个场！支持楼主！

xtdwynij

支持一下Lispboy师兄！经常搞一些这样的活动对于像我这种初学者有相当大的帮助！

dwg001

XYP的确引领了一批人进入lisp领域，功不可没。

eachy

支持一下lz，沉在硬盘那些代码也可以再派上用场了，库很有用，不可否认，但对要求效率的时候，具体应用时也要进行必要的改造，借lz的帖子以后把一些心得和大家分享

sicky111

支持楼主！这是院长的本意吗？

kwok

XYP不错，来支持一下.

taner

这个应该是好早以前的库了！

守仁格竹GM

希望能坚持住

hao3ren

不错，支持楼主

ll_j

怎么说呢？不太支持，除非xyp默许，换句话说，如果他同意，还需要你写么？

就像你偏要去揭开别人家新娘子的盖头，好么？

wowan1314

看了下！ 有800多个函数。。 楼主有的忙了！  呵呵

Lispboy

wowan1314 发表于 2013-6-3 17:01
看了下！ 有800多个函数。。 楼主有的忙了！  呵呵

:o 有那么多吗？ 我感觉就一页翻过去多一点。

wowan1314

Lispboy 发表于 2013-6-3 17:11
有那么多吗？ 我感觉就一页翻过去多一点。

我加载他的函数库看了下！ 有800多个！

估计很多都没写进说明文档中吧！  有500KB。我记的好像有几MB呢！