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

xshrimp

Lispboy 发表于 2013-6-4 09:42
CHM里面是波兰语？，虾米版主，能给翻译下做个CHM不。

我也不懂啊,你猜猜啊:D,,google翻译一下:lol基本差不多了.

Lispboy

xshrimp 发表于 2013-6-4 09:46
我也不懂啊,你猜猜啊,,google翻译一下基本差不多了.

我现在还在用你的LISP宝典呢，翻译的好啊。

你做这个擅长啊，我都不会做CHM，有劳虾米版主用翻译器翻译下，给大家造福下，做个CHM的帮助呗，也给你的资料库添砖加瓦了。

让我死，也不让你活，哈哈:lol

pengfei2010

pengfei2010 发表于 2013-6-3 20:12
我觉得  自定义函数还是自己写比较好，用别人的的确方便 省事，但是每个人写函数的习惯不同，虽然有源码。 ...

您是前辈，都是在模仿您，我只想弱弱的说一句，您一直被模仿，从未被超越

QiaoCheng

哇！这句话院长脸蛋肯定开了朵花

Lisphk

pengfei2010 发表于 2013-6-4 12:27
您是前辈，都是在模仿您，我只想弱弱的说一句，您一直被模仿，从未被超越

wow!!!! 哪位美眉对我说这么一句。:$

13808843088

继续支持，建议楼主将大家的建议整合一下，制定一个命名及注释规则，对不满足规则的在点评中提出，

1. 
   
2. ;;;功能：选择集转表
   
3. ;;;ss选择集
   
4. ;;;vla 是否返回vla对象表，t为是
   
5. ;;;返回值图元名表或vla对象表
   
6. (defun xd_SS->List (ss vla / i lst)
   
7.   (if (eq (type ss) 'PICKSET)
   
8.     (if vla
   
9.       (repeat (setq i (sslength ss))
   
10. (setq
    
11.    lst
    
12.     (cons (vlax-ename->vla-object (ssname ss (setq i (1- i))))
    
13.    lst
    
14.     )
    
15. )
    
16.       )
    
17.       (repeat (setq i (sslength ss))
    
18. (setq lst (cons (ssname ss (setq i (1- i))) lst))
    
19.       )
    
20.     )
    
21.     (princ "您输入的ss不是选择集")
    
22.   )
    
23. )
    
24. ;;;功能：修改图元特定组码
    
25. ;;;ss选择集、图元名、vla对象
    
26. ;;;mode需修改的组码，组码表
    
27. ;;;ch与组码表对应的修改值，修改值表
    
28. ;;;返回值输入的ss
    
29. (defun xd_dxf_ch (ss mode ch / ssl en ent new_num old_num x y)
    
30.   (cond
    
31.     ((eq (type ss) 'PICKSET) (setq ssl (xd_SS->List ss nil)))
    
32.     ((eq (type ss) 'ENAME) (setq ssl (list ss)))
    
33.     ((eq (type ss) 'VLA-OBJECT)
    
34.      (setq ssl (list (vlax-vla-object->ename ss)))
    
35.     )
    
36.   )
    
37.   (cond
    
38.     ((eq (type mode ) 'INT) (setq mode (list mode )))
    
39.   )
    
40.   (cond
    
41.     ((null (eq (type ch) 'LIST)) (setq ch (list ch)))
    
42.   )
    
43.   (if (/= (length mode ) (length ch))
    
44.     (princ "组码表与修改表数目不等")
    
45.     (foreach en ssl
    
46.       (mapcar '(lambda (x y)
    
47.    (setq ent     (entget en)
    
48.          new_num (cons x y)
    
49.          old_num (assoc x ent)
    
50.    )
    
51.    (if old_num
    
52.      (entmod (subst new_num old_num ent))
    
53.      (entmod (reverse (cons new_num (reverse ent))))
    
54.    )
    
55.         )
    
56.        mode
    
57.        ch
    
58.       )
    
59.     )
    
60.   )
    
61.   ss
    
62. )
    

<br /> ;;;功能：选择集转表<br /> ;;;ss选择集<br /> ;;;vla 是否返回vla对象表，t为是<br /> ;;;返回值图元名表或vla对象表<br /> (defun xd_SS->List (ss vla / i lst)<br />   (if (eq (type ss) 'PICKSET)<br />     (if vla<br />       (repeat (setq i (sslength ss))<br /> (setq<br />    lst<br />     (cons (vlax-ename->vla-object (ssname ss (setq i (1- i))))<br />    lst<br />     )<br /> )<br />       )<br />       (repeat (setq i (sslength ss))<br /> (setq lst (cons (ssname ss (setq i (1- i))) lst))<br />       )<br />     )<br />     (princ "您输入的ss不是选择集")<br />   )<br /> )<br /> ;;;功能：修改图元特定组码<br /> ;;;ss选择集、图元名、vla对象<br /> ;;;mode需修改的组码，组码表<br /> ;;;ch与组码表对应的修改值，修改值表<br /> ;;;返回值输入的ss<br /> (defun xd_dxf_ch (ss mode ch / ssl en ent new_num old_num x y)<br />   (cond<br />     ((eq (type ss) 'PICKSET) (setq ssl (xd_SS->List ss nil)))<br />     ((eq (type ss) 'ENAME) (setq ssl (list ss)))<br />     ((eq (type ss) 'VLA-OBJECT)<br />      (setq ssl (list (vlax-vla-object->ename ss)))<br />     )<br />   )<br />   (cond<br />     ((eq (type mode ) 'INT) (setq mode (list mode )))<br />   )<br />   (cond<br />     ((null (eq (type ch) 'LIST)) (setq ch (list ch)))<br />   )<br />   (if (/= (length mode ) (length ch))<br />     (princ "组码表与修改表数目不等")<br />     (foreach en ssl<br />       (mapcar '(lambda (x y)<br />    (setq ent     (entget en)<br />          new_num (cons x y)<br />          old_num (assoc x ent)<br />    )<br />    (if old_num<br />      (entmod (subst new_num old_num ent))<br />      (entmod (reverse (cons new_num (reverse ent))))<br />    )<br />         )<br />        mode <br />        ch<br />       )<br />     )<br />   )<br />   ss<br /> )<br />

XDSoft

13808843088 发表于 2013-6-5 17:28
继续支持，建议楼主将大家的建议整合一下，制定一个命名及注释规则，对不满足规则的在点评中提出，

建议下，函数里面就不要有PRINC等提示语句了，就靠返回值说话。提示在外面引用函数的主程序里面根据返回结果提示用户。

QiaoCheng

呵呵，这一句(repeat (setq i (sslength ss))
如LISPbOY见到又要说了

Lispboy

QiaoCheng 发表于 2013-6-5 18:02
呵呵，这一句(repeat (setq i (sslength ss))
如LISPbOY见到又要说了

呵呵，又提到我了，经过G版的说明，现在我不会说了，不过我觉得还是放到repeat外面好，repeat这个地方用个常量，看着舒服。:P

清风明月10

期待楼主写好，菜鸟可以跟着学习

Lispboy

清风明月10 发表于 2013-6-5 19:30
期待楼主写好，菜鸟可以跟着学习

已经开始写了，大家多鼓励啊，真压力挺大的，大家都参与啊。不过现在写的和XYP还没有关系。现在写一个函数，就想到还有更基础的需要先写。很折磨人的，我争取写的东西能让大家用最少的LISP代码实现具体要求。现在感觉要重写XDRX_API用LISP实现了，老大不要拍我。:lol

13808843088

Lispboy 发表于 2013-6-5 19:59
已经开始写了，大家多鼓励啊，真压力挺大的，大家都参与啊。不过现在写的和XYP还没有关系。现在写一个函 ...

可分阶段贴出来，大家讨论，定稿后再由后写的函数调用，以免修改了先编写的函数，影响后编写的函数

eachy

Lispboy 发表于 2013-6-5 19:59
已经开始写了，大家多鼓励啊，真压力挺大的，大家都参与啊。不过现在写的和XYP还没有关系。现在写一个函 ...

曾经写过一些 XDAPI 的 aLisp 实现，大概还能搜到一些帖子。开始是为了函数而写函数，到后来就不拘泥于形式了，根据具体应用来组织，不过重写的过程对Alisp、Vlisp的认识和提高却是有了非常大的帮助

zxq0220

山寨，又见山寨……

清风明月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)
)