实用型函数《三》

zynyjp · 发表于 2013-8-10 23:42:41

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

本帖最后由牢固于 2013-8-11 09:15 编辑

;|
---------------------- XYP_LIB.lsp -------------------------
本程序由xyp@bsedi.com编写或搜集整理，对原作者表示敬意和感谢
加载方式：利用以下任何一种方式即可运行该程序内所有子程序
1.在每个程序内增加(load"xyp_lib.lsp")
2.在acad.lsp中增加(load"xyp_lib.lsp")
3.在command下输入(load"xyp_lib.lsp")
------------------------------------------------------------
|;
;;CMDLA0 保存用户系统变量
;;CMDLA1 恢复用户系统变量
;;UREAL 实型数输入格式化
;;USTR 字符串输入格式化
;;UDIST 距离输入格式化
;;UKWORD 关键字输入格式化
;;UINT 整型数输入格式化
;;UPOINT 点输入格式化
;;UANGLE 角度输入格式化并返回以弧度表示的角度
;;MKLA 图层颜色格式化输入
;;DXF DXF代码
;;DXF-S1 DXF代码
;;DDXF DXF代码
;;OBJ AutoLISP 类型(entsel)的对象名转换为 VLA 对象
;;_MIDP 两点之中点
;;_MIDPUP 垂直平分线上定点-波峰
;;_MIDPDN 垂直平分线上定点-波谷
;;SSUNION ss1 + ss2 选择集之和
;;SSDIFF ss1 + ss2 选择集之差
;;SSINTER ss1 + ss2 选择集之交集
;;ss-ac a+b和b+c,求a+c
;;JZHZ 加载汉字－宋体
;;SETBL 设置出图比例
;;SETNIL 清空变量
;;RAD2ANG 弧度转角度
;;ANG2RAD 角度转弧度
;;XYP_SZX 在确定点画矢量十字线
;;X_STARTP 线起点
;;X_ENDP 线终点
;;XYP_LX 亮显选集
;;SHOW-JT 显示光标箭头
;;SUB_UPD 更换图元
;;JZXX 加载线型
;;;zxd 封闭域中心点
;;PXYP 显示程序命令及作者信息
;;X_ZB 在某点标注坐标
;;cosh sinh 双曲余弦函数、双曲正弦函数
(vl-load-com);将 Visual LISP 扩展功能加载到 AutoLISP。
(setq bl 100 sc 1)
;;;通用子程序
;;;------------------------ CMDLA0 -------------------------
;;; 保存用户系统变量
;;;方式 : (CMDLA0)
(defun CMDLA0 ()
(setq cmdech (getvar "CMDECHO")
oom (getvar "orthomode")
osm (getvar "osmode")
LA (getvar "clayer")
rmode (getvar "regenmode")
pw (getvar "plinewid")
)
(if (null sc)
(SETBL)
) ;确认SC存在
(command "ucs" "") ;恢复世界坐标系统
(setvar "plinewid" 0) ;多义线宽→0
(setvar "regenmode" 0)
(setvar "CMDECHO" 0)
(princ)
)
;;;------------------------ CMDLA1 -------------------------
;;; 恢复用户系统变量
;;;方式 : (CMDLA1)
(defun CMDLA1 ()
(setvar "CMDECHO" cmdech)
(setvar "orthomode" oom)
(setvar "osmode" osm)
(setvar "clayer" LA)
(setvar "regenmode" rmode)
(setvar "plinewid" pw)
(princ)
)
;;;---------------------- UREAL ----------------------------
;;; 实型数输入格式化
;;;方式 : (setq no1 (ureal 1 "" "\n\t实数" no1))
(defun ureal (bit kwd msg def / inp)
(if def
(setq msg (strcat "\n" msg "<" (rtos def 2) ">: ")
bit (* 2 (fix (/ bit 2)))
)
(setq msg (strcat "\n" msg ": "))
)
(initget bit kwd)
(setq inp (getreal msg))
(if inp inp def)
)
;;;---------------------- USTR -----------------------------
;;; 字符串输入格式化
;;;方式 : (setq txt1 (ustr 1 "\n\t字符串" txt1 nil))
(defun ustr (bit msg def spflag / inp nval)
(if (and def (/= def ""))
(setq msg (strcat "\n" msg "<" def ">:")
inp (getstring msg spflag)
inp (if (= inp "") def inp)
)
(progn
(setq msg (strcat "\n" msg ": "))
(if (= bit 1)
(while (= "" (setq inp (getstring msg spflag))))
(setq inp (getstring msg spflag))
)))
(if inp inp def)
)
;;;---------------------- UDIST ---------------------------
;;; 距离输入格式化
;;;方式 : (setq dist1 (udist 1 "" "\n\t距离" dist1 (list 0 0)))
(defun udist (bit kwd msg def bpt / inp)
(if def
(setq msg (strcat "\n" msg "<" (rtos def) ">:")
bit (* 2 (fix (/ bit 2)))
)
(setq msg (strcat "\n" msg ":"))
)
(initget bit kwd)
(setq inp
(if bpt
(getdist msg bpt)
(getdist msg)
))
(if inp inp def)
)
;;;---------------------- UKWORD ---------------------------
;;; 关键字输入格式化
;;;方式 : (setq tx1 (ukword 1 "1 2" "\n\t1-任意点/2-中心点" tx1))
(defun ukword (bit kwd msg def / inp)
(if (and def (/= def ""))
(setq msg (strcat "\n" msg "<" def ">:")
bit (* 2 (fix (/ bit 2)))
)
(setq msg (strcat "\n" msg ":"))
)
(initget bit kwd)
(setq inp (getkword msg))
(if inp inp def)
)
;;;---------------------- UINT -----------------------------
;;; 整型数输入格式化
;;;方式 : (setq no1 (uint 1 "" "\n\t整数" no1))
(defun uint (bit kwd msg def / inp)
(if def
(setq msg (strcat "\n" msg "<" (itoa def) ">: ")
bit (* 2 (fix (/ bit 2)))
)
(setq msg (strcat "\n" msg ": "))
)
(initget bit kwd)
(setq inp (getint msg))
(if inp inp def)
)
; ----------------------- UPOINT ---------------------------
; 输入点格式化
;;;方式 : (setq pt (upoint 1 "" "\n\t点" pt (list 0 0)))
(defun upoint (bit kwd msg def bpt / inp)
(if def
(setq pts (strcat
(rtos (car def)) ", " (rtos (cadr def))
(if (and (caddr def) (= 0 (getvar "flatland")))
(strcat ", " (rtos (caddr def)))
""
))
msg (strcat "\n" msg "<" pts ">: ")
bit (* (fix (/ bit 2)))
)
(setq msg (strcat "\n" msg ": "))
)
(initget bit kwd)
(setq inp
(if bpt
(getpoint msg bpt)
(getpoint msg)
))
(if inp inp def)
)
; ----------------------- UANGLE ---------------------------
; 格式化输入角度然后返回以弧度表示的角度
;;;方式 : (setq ang (uangle 1 "" "\n\t角度" ang (list 0 0)))
(defun uangle (bit kwd msg def bpt / inp)
(if def
(setq msg (strcat "\n" msg "<" (angtos def) ">: ")
bit (* (fix (/ bit 2))))
(setq msg (strcat "\n" msg ": ")))
(initget bit kwd)
(setq inp
(if bpt
(getangle msg bpt)
(getangle msg)))
(if inp inp def)
)
;;; ----------------------- MKLA ---------------------------
;;; 图层颜色格式化输入
;;;方式 : (mkla "层名" 颜色号)
(defun mkla (name color)
(If (= (Tblsearch "layer" name) nil)
(Command "layer" "m" name "c" color name "")
(Command "layer" "t" name "s" name "c" color name "")
)
)
;;; ----------------------- DXF ----------------------------
;;; DXF代码
;;;方式 : (setq etype (dxf 0 s1))
(defun dxf (code elist) (cdr (assoc code elist)))
(defun dxf-s1 (code elist) (dxf code (entget elist)))
(defun ddxf (code elist) (dxf code (entget (car elist))))
;;; ----------------------- OBJ ----------------------------
;;;将 AutoLISP 类型(entsel)的对象名转换为 VLA 对象
;;;ename为实体名称 = (car(entsel))
(defun OBJ (ename)(vlax-ename->vla-object ename))
;;; ----------------------- _midp --------------------------
;;; 两点之中点
;;;方式 : (setq pt3 (_midp pt1 pt2))
(defun _midp (p1 p2)
(list (/ (+ (car p1) (car p2)) 2)
(/ (+ (cadr p1) (cadr p2)) 2)
(/ (+ (caddr p1) (caddr p2)) 2)
)
)
;;; ----------------------_midpup --------------------------
;;; 垂直平分线上定点-波峰
;;;方式 : (setq pt3 (_midpup pt1 pt2))
(defun _midPUP (pta ptb fb)
(polar (_midP pta ptb) (+ (angle pta ptb) (/ pi 2.0)) fb)
)
;;; ----------------------_midpdn --------------------------
;;; 垂直平分线上定点波谷
;;;方式 : (setq pt3 (_midpdn pt1 pt2))
(defun _midPDN (pta ptb fb)
(polar (_midP pta ptb) (- (angle pta ptb) (/ pi 2.0)) fb)
)
;;; -------------------- 选择集操作 ------------------------
;;;ss1 + ss2 选择集之和
;;;方式 : (ssunion ss1 ss2)
(defun ssunion (ss1 ss2 / hilite ss3)
;(setq hilite (getvar"highlight"))
;(setvar"highlight" 0)
(command "_.select" ss1 ss2 "")
(setq ss3 (ssget "p"))
;(setvar "highlight" hilite)
ss3
)
;;;ss1 - ss2 选择集之差
;;;方式 : (setq ss3 (ssdiff ss1 ss2))
(defun ssdiff (ss1 ss2 / hilite ss3)
;(setq hilite (getvar"highlight"))
;(setvar"highlight" 0)
(command "_.select" ss1 "_r" ss2 "")
(setq ss3 (ssget "p"))
;(setvar "highlight" hilite)
ss3
)
;;;ss1 与 ss2 选择集之交集 a+b和b+c,求b
;;;方式 : (setq ss3 (ssinter ss1 ss2))
(defun ssinter (ss1 ss2 / ss3)
;(setq hilite (getvar"highlight"))
;(setvar"highlight" 0)
(command".select" ss1 "r" ss2 "") ; a
(command".select" ss1 "r" "p" "") ; b
(setq ss3 (ssget "p"))
;(setvar "highlight" hilite)
ss3
)
;;;SxS
;a+b和b+c,求a+c
;;;方式 : (setq ss3 (ss-ac ss1 ss2))
(defun ss-ac (ss1 ss2 / ss3)
(command".select" ss1 "R" ss2 "") ;a
(command".select" ss2 "R" ss1" a" "p" "") ;c+a
(setq ss3 (ssget "p"))
ss3
)
;;; ---------------------- jzhz ----------------------------
;;; 加载汉字－宋体
;;;方式 : (jzhz)
(defun jzhz ()
(setq chksty (tblsearch "style" "汉字"))
(if (null chksty)
(command "_style" "汉字" "宋体" "0" "0.7" "0" "" "")
)
(setvar "textstyle" "汉字")
)
;;; ---------------------- setbl ---------------------------
;;; 设置出图比例
;;;方式 : (setbl)
(defun setbl ()
(setq bl (ureal 1 "" "\n输入出图比例1 : " bl))
(setq SC (/ bl 100.0))
(command "modemacro"
(strcat "XCAD BY XYP." " 当前出图比例 1:"
(rtos bl 2 1))
))
;;; ---------------------- setnil --------------------------
;;; 清空变量
;;;方式 : (setnil)
(defun setnil ()
(setq no1 nil no2 nil no3 nil no4 nil no5 nil no6 nil
no7 nil no8 nil no9 nil no10 nil
txt nil txt1 nil txt2 nil txt3 nil txt4 nil txt5 nil
txt6 nil txt7 nil txt8 nil
)
)
;;; --------------------------------------------------------
;;;弧度转角度
(defun rad2ang (rad)(* (/ rad pi) 180.0))
;;;角度转弧度
(defun ang2rad (ang)(* (/ ang 180.0) pi))
;;; --------------------------------------------------------
;;;十字线
;;;方式 : (xyp_szx (pt1 200));在pt1点画ll长十字线
(defun xyp_szx (pt1 ll)
(command "line" (POLAR PT1 0 ll) (POLAR PT1 PI ll) "")
(command "line"(POLAR PT1 (/ PI 2.0) ll)
(POLAR PT1 (* PI 1.5) ll)"")
)
;;; --------------------------------------------------------
;;;线起点和终点
(defun x_startP (e)
(vlax-curve-getstartPoint e)
)
(defun x_endP (e)
(vlax-curve-getEndPoint e)
)
;;; --------------------------------------------------------
;;;亮显选集
;;;方式 : (xyp_lx ss1)
(defun xyp_LX (ss)
(setq i -1)
(repeat (sslength ss)
(setq i (+ 1 i))
(redraw (ssname ss i) 3)
)
;(princ)
)
;;; --------------------------------------------------------
;;;显示光标箭头
;;;pt1、pt2、pt3分别为连续三点的坐标
(defun show-jt (pt1 pt2 pt3 / ang1 ang2 po3 po4 po3_3 po4_3 po3_1 po4_1 po3_2 po4_2)
(setq ang1 (angle pt1 pt2)
ang2 (angle pt2 pt3)
)
(setq
po3 (polar pt1 (+ ang1 (* 1.5 pi) ang2) (* 4000 sc))
po4 (polar pt2 (+ ang1 (* 1.5 pi) ang2) (* 4000 sc))
po3_3 (polar pt1 (+ ang1 (* 1.5 pi) ang2) (* 2000 sc))
po4_3 (polar pt2 (+ ang1 (* 1.5 pi) ang2) (* 2000 sc))
po3_1 (polar po3_3 (+ ang1 (* 1.0 pi)) (* 560 sc))
po4_1 (polar po4_3 (+ ang1 (* 1.0 pi)) (* 560 sc))
po3_2 (polar po3_3 ang1 (* 560 sc))
po4_2 (polar po4_3 ang1 (* 560 sc))
)
(grvecs (list 256 pt1 po3 256 pt2 po4 256 po3
po3_1 256 po3 po3_2 256 po3_1 po3_2 256
po4 po4_1 256 po4 po4_2 256 po4_1 po4_2
1 pt1 pt2
)
)
)
;;; --------------------------------------------------------
;;;更换图元。
;;;方式 : 改圆半径(sub_upd s1 40 300)
(defun sub_upd (ename code #new)
(setq cc (subst (cons code #new) (assoc code (entget ename)) (entget ename)))
(entmod cc)
(entupd ename)
)
;;; --------------------------------------------------------
;;;jzxx 加载线型
;;; 程序搜寻线型ltname，如果没有找到，则会由acadiso.lin 文件添加
;;;方式 : (jzxx"车库1")
(defun jzxx (ltname)
(if (not (tblsearch "ltype" ltname))
(vl-catch-all-apply
'vla-load
(list (vla-get-Linetypes
(vla-get-activedocument (vlax-get-acad-object))
)
ltname
"acadiso.lin"
)
)
)
(setvar "celtype" ltname)
;(command"-linetype""s" ltname "")
(princ)
)
;;; --------------------------------------------------------
;;;中心点
(defun zxd ()
(setq #pt (getpoint "\n\t选择区域内一点<退出> : "))
(command "-boundary" "a" "o" "r" "" #pt "")
(setq #pt (vlax-safearray->list
(vlax-variant-value
(vla-get-centroid (vlax-ename->vla-object (entlast)))
)
)
)
(entdel (entlast))
#pt
)
;;; ---------------------- X_ZB ----------------------------
;;; 在某点标注坐标
;;;方式 : (X_ZB #upt)
(defun X_ZB (#upt)
(setvar "LUPREC" 4) ;小数位位数
(setvar "UNITMODE" 1) ;控制单位的显示格式
(setq p2 (polar #upt (/ pi 4) (* sc 1000))
h (* SC 300)
a (strcat "X=" (rtos (cadr #upt) 2 4))
b (strcat "Y=" (rtos (car #upt) 2 4))
c (max (strlen a) (strlen b))
p3 (list (+ (car p2) (* c h 0.8)) (cadr p2))
rp1 (list (+ (car p2) (/ (* c h 0.8) 2))
(+ (cadr p2) (+ (/ h 2) (/ bl 1)))
)
rp2 (list (+ (car p2) (/ (* c h 0.8) 2))
(- (cadr p2) (+ (/ h 2) (/ bl 1)))
)
)
(setvar "osmode" 0)
(command "pline" #upt p2 p3 "")
(command "text" "j" "mc" rp1 h "0" a)
(command "text" "j" "mc" rp2 h "0" b)
)
;;; --------------------------------------------------------
;;;双曲余弦函数、双曲正弦函数
(defun cosh (dx) (* 0.5 (+ (exp dx) (exp (- 0 dx)))))
(defun sinh (dx) (* 0.5 (- (exp dx) (exp (- 0 dx)))))
(defun tanh (dx) (/ (sinh dx) (cosh dx)))
(defun sec (dx) (/ 1 (cos dx)))
;;; ---------------------- PXYP ----------------------------
;;; 显示程序命令及作者信息
;;;方式 : (pxyp"pdpc (坡度坡长)")
(DEFUN PXYP (TXT1)
(SETQ TXT1 (STRCAT "\n\r 程序命令: "TXT1
" -- xyp@bsedi.com"))
(PRINC TXT1)
(Princ))
;;;---------------------------------------------------------
(princ)
;;;---------------------------------------------------------
;;;END
;|
;;;选择ssget “和”即“and”的用法
(setq SS (ssget '((0 . "CIRCLE,ELLIPSE,LINE,*POLYLINE,SPLINE,ARC"))))
(ssget '((0 . "line") (8 . "1,0")))
;;;undo类型
;;;回退开始
(vl-cmdf ".undo" "BE")
(command ".undo" "BE")
;;;回退结束
(vl-cmdf ".undo" "E")
(command ".undo" "E")

;|                                                          
---------------------- XYP_LIB.lsp ------------------------- 
本程序由<a href=\"mailto:xyp@bsedi.com\" target=\"_blank\">xyp@bsedi.com</a>编写或搜集整理，对原作者表示敬意和感谢 
加载方式：利用以下任何一种方式即可运行该程序内所有子程序    
1.在每个程序内增加(load"xyp_lib.lsp")                        
2.在acad.lsp中增加(load"xyp_lib.lsp")                        
3.在command下输入(load"xyp_lib.lsp")                         
------------------------------------------------------------ 
|; 
;;CMDLA0 保存用户系统变量 
;;CMDLA1 恢复用户系统变量 
;;UREAL 实型数输入格式化 
;;USTR 字符串输入格式化 
;;UDIST 距离输入格式化 
;;UKWORD 关键字输入格式化 
;;UINT 整型数输入格式化 
;;UPOINT 点输入格式化 
;;UANGLE 角度输入格式化并返回以弧度表示的角度 
;;MKLA 图层颜色格式化输入 
;;DXF DXF代码 
;;DXF-S1 DXF代码 
;;DDXF DXF代码 
;;OBJ  AutoLISP 类型(entsel)的对象名转换为 VLA 对象 
;;_MIDP 两点之中点 
;;_MIDPUP 垂直平分线上定点-波峰 
;;_MIDPDN 垂直平分线上定点-波谷 
;;SSUNION ss1 + ss2 选择集之和 
;;SSDIFF ss1 + ss2 选择集之差 
;;SSINTER ss1 + ss2 选择集之交集 
;;ss-ac a+b和b+c,求a+c 
;;JZHZ 加载汉字－宋体 
;;SETBL 设置出图比例 
;;SETNIL 清空变量 
;;RAD2ANG 弧度转角度 
;;ANG2RAD 角度转弧度 
;;XYP_SZX 在确定点画矢量十字线 
;;X_STARTP 线起点 
;;X_ENDP 线终点 
;;XYP_LX 亮显选集 
;;SHOW-JT 显示光标箭头 
;;SUB_UPD 更换图元 
;;JZXX 加载线型 
;;;zxd 封闭域中心点 
;;PXYP 显示程序命令及作者信息 
;;X_ZB 在某点标注坐标 
;;cosh sinh 双曲余弦函数、双曲正弦函数 
(vl-load-com);将 Visual LISP 扩展功能加载到 AutoLISP。 
(setq bl 100 sc 1) 
;;;通用子程序                                                
;;;------------------------ CMDLA0 ------------------------- 
;;;                    保存用户系统变量                      
;;;方式 : (CMDLA0)                                           
(defun CMDLA0 () 
  (setq cmdech (getvar "CMDECHO") 
 oom    (getvar "orthomode") 
 osm    (getvar "osmode") 
 LA     (getvar "clayer") 
 rmode  (getvar "regenmode") 
 pw     (getvar "plinewid") 
  ) 
  (if (null sc) 
    (SETBL) 
  )     ;确认SC存在 
  (command "ucs" "")   ;恢复世界坐标系统 
  (setvar "plinewid" 0)   ;多义线宽→0 
  (setvar "regenmode" 0) 
  (setvar "CMDECHO" 0) 
  (princ) 
) 
;;;------------------------ CMDLA1 ------------------------- 
;;;                     恢复用户系统变量                     
;;;方式 : (CMDLA1)                                           
(defun CMDLA1 () 
  (setvar "CMDECHO" cmdech) 
  (setvar "orthomode" oom) 
  (setvar "osmode" osm) 
  (setvar "clayer" LA) 
  (setvar "regenmode" rmode) 
  (setvar "plinewid" pw) 
  (princ) 
) 
;;;---------------------- UREAL ---------------------------- 
;;;                  实型数输入格式化                        
;;;方式 : (setq no1 (ureal 1 "" "\n\t实数" no1))             
(defun ureal (bit kwd msg def / inp) 
  (if def 
    (setq msg (strcat "\n" msg "<" (rtos def 2) ">: ") 
          bit (* 2 (fix (/ bit 2))) 
    ) 
    (setq msg (strcat "\n" msg ": ")) 
  ) 
  (initget bit kwd) 
  (setq inp (getreal msg)) 
  (if inp inp def) 
) 
;;;---------------------- USTR ----------------------------- 
;;;                  字符串输入格式化                        
;;;方式 : (setq txt1 (ustr 1 "\n\t字符串" txt1 nil))         
(defun ustr (bit msg def spflag / inp nval) 
   (if (and def (/= def "")) 
       (setq msg (strcat "\n" msg "<" def ">:") 
             inp (getstring msg spflag) 
             inp (if (= inp "") def inp) 
       ) 
       (progn 
         (setq msg (strcat "\n" msg ": ")) 
         (if (= bit 1) 
             (while (= "" (setq inp (getstring msg spflag)))) 
             (setq inp (getstring msg spflag)) 
         ))) 
   (if inp inp def) 
) 
;;;---------------------- UDIST --------------------------- 
;;;                  距离输入格式化                         
;;;方式 : (setq dist1 (udist 1 "" "\n\t距离" dist1 (list 0 0))) 
(defun udist (bit kwd msg def bpt / inp) 
  (if def 
    (setq msg (strcat "\n" msg "<" (rtos def) ">:") 
          bit (* 2 (fix (/ bit 2))) 
    ) 
    (setq msg (strcat "\n" msg ":")) 
  ) 
  (initget bit kwd) 
  (setq inp 
    (if bpt 
      (getdist msg bpt) 
      (getdist msg) 
    )) 
  (if inp inp def) 
) 
;;;---------------------- UKWORD --------------------------- 
;;;                   关键字输入格式化                      
;;;方式 : (setq tx1 (ukword 1 "1 2" "\n\t1-任意点/2-中心点" tx1)) 
(defun ukword (bit kwd msg def / inp) 
  (if (and def (/= def "")) 
      (setq msg (strcat "\n" msg "<" def ">:") 
            bit (* 2 (fix (/ bit 2))) 
      ) 
      (setq msg (strcat "\n" msg ":")) 
  ) 
  (initget bit kwd) 
  (setq inp (getkword msg)) 
  (if inp inp def) 
) 
;;;---------------------- UINT ----------------------------- 
;;;                    整型数输入格式化                      
;;;方式 : (setq no1 (uint 1 "" "\n\t整数" no1))             
(defun uint (bit kwd msg def / inp) 
  (if def 
    (setq msg (strcat "\n" msg "<" (itoa def) ">: ") 
          bit (* 2 (fix (/ bit 2))) 
    ) 
    (setq msg (strcat "\n" msg ": ")) 
  ) 
  (initget bit kwd) 
  (setq inp (getint msg)) 
  (if inp inp def) 
) 
; ----------------------- UPOINT --------------------------- 
;                       输入点格式化                         
;;;方式 : (setq pt (upoint 1 "" "\n\t点" pt (list 0 0)))    
(defun upoint (bit kwd msg def bpt / inp) 
  (if def 
    (setq pts (strcat 
                  (rtos (car def)) ", " (rtos (cadr def)) 
                  (if (and (caddr def) (= 0 (getvar "flatland"))) 
                           (strcat ", " (rtos (caddr def))) 
                           "" 
                  )) 
          msg (strcat "\n" msg "<" pts ">: ") 
          bit (* (fix (/ bit 2))) 
    ) 
    (setq msg (strcat "\n" msg ": ")) 
  ) 
  (initget bit kwd) 
  (setq inp 
       (if bpt 
           (getpoint msg bpt) 
           (getpoint msg) 
       )) 
  (if inp inp def) 
) 
; ----------------------- UANGLE --------------------------- 
;          格式化输入角度然后返回以弧度表示的角度            
;;;方式 : (setq ang (uangle 1 "" "\n\t角度" ang (list 0 0))) 
(defun uangle (bit kwd msg def bpt / inp) 
  (if def 
      (setq msg (strcat "\n" msg "<" (angtos def) ">: ") 
            bit (* (fix (/ bit 2)))) 
      (setq msg (strcat "\n" msg ": "))) 
  (initget bit kwd) 
  (setq inp 
       (if bpt 
           (getangle msg bpt) 
           (getangle msg))) 
  (if inp inp def) 
) 
;;; ----------------------- MKLA --------------------------- 
;;;                   图层颜色格式化输入                     
;;;方式 : (mkla "层名" 颜色号)                               
(defun mkla (name color) 
  (If (= (Tblsearch "layer" name) nil) 
    (Command "layer" "m" name "c" color name "") 
    (Command "layer" "t" name "s" name "c" color name "") 
  ) 
) 
;;; ----------------------- DXF ---------------------------- 
;;;                       DXF代码                            
;;;方式 : (setq etype (dxf 0 s1))                            
(defun dxf (code elist) (cdr (assoc code elist))) 
(defun dxf-s1 (code elist) (dxf code (entget elist))) 
(defun ddxf (code elist) (dxf code (entget (car elist)))) 
;;; ----------------------- OBJ ---------------------------- 
;;;将 AutoLISP 类型(entsel)的对象名转换为 VLA 对象          
;;;ename为实体名称 = (car(entsel))                           
(defun OBJ (ename)(vlax-ename->vla-object ename)) 
;;; ----------------------- _midp -------------------------- 
;;;                       两点之中点                         
;;;方式 : (setq pt3 (_midp pt1 pt2))                         
(defun _midp (p1 p2) 
  (list (/ (+ (car p1) (car p2)) 2) 
 (/ (+ (cadr p1) (cadr p2)) 2) 
 (/ (+ (caddr p1) (caddr p2)) 2) 
  ) 
  ) 
;;; ----------------------_midpup -------------------------- 
;;;                 垂直平分线上定点-波峰                   
;;;方式 : (setq pt3 (_midpup pt1 pt2))                      
(defun _midPUP (pta ptb fb) 
  (polar (_midP pta ptb) (+ (angle pta ptb) (/ pi 2.0)) fb) 
) 
;;; ----------------------_midpdn -------------------------- 
;;;                 垂直平分线上定点波谷                     
;;;方式 : (setq pt3 (_midpdn pt1 pt2))                      
(defun _midPDN (pta ptb fb) 
  (polar (_midP pta ptb) (- (angle pta ptb) (/ pi 2.0)) fb) 
) 
;;; -------------------- 选择集操作 ------------------------ 
;;;ss1 + ss2 选择集之和 
;;;方式 : (ssunion ss1 ss2) 
(defun ssunion (ss1 ss2 / hilite ss3) 
       ;(setq hilite (getvar"highlight")) 
       ;(setvar"highlight" 0) 
       (command "_.select" ss1 ss2 "") 
       (setq ss3 (ssget "p")) 
       ;(setvar "highlight" hilite) 
       ss3 
       ) 
;;;ss1 - ss2 选择集之差 
;;;方式 : (setq ss3 (ssdiff ss1 ss2))                        
(defun ssdiff (ss1 ss2 / hilite ss3) 
       ;(setq hilite (getvar"highlight")) 
       ;(setvar"highlight" 0) 
       (command "_.select" ss1 "_r" ss2 "") 
       (setq ss3 (ssget "p")) 
       ;(setvar "highlight" hilite) 
       ss3 
       ) 
;;;ss1 与 ss2 选择集之交集  a+b和b+c,求b 
;;;方式 : (setq ss3 (ssinter ss1 ss2)) 
(defun ssinter (ss1 ss2 / ss3) 
       ;(setq hilite (getvar"highlight")) 
       ;(setvar"highlight" 0) 
       (command".select" ss1 "r" ss2 "") ; a 
       (command".select" ss1 "r" "p" "") ; b 
       (setq ss3 (ssget "p")) 
       ;(setvar "highlight" hilite) 
       ss3 
       ) 
;;;SxS 
;a+b和b+c,求a+c 
;;;方式 : (setq ss3 (ss-ac ss1 ss2)) 
(defun ss-ac (ss1 ss2 / ss3) 
  (command".select" ss1 "R" ss2 "") ;a 
  (command".select" ss2 "R" ss1" a" "p" "") ;c+a 
  (setq ss3 (ssget "p")) 
  ss3 
) 
;;; ---------------------- jzhz ---------------------------- 
;;;                    加载汉字－宋体                        
;;;方式 : (jzhz)                                             
(defun jzhz () 
  (setq chksty (tblsearch "style" "汉字")) 
  (if (null chksty) 
    (command "_style" "汉字" "宋体" "0" "0.7" "0" "" "") 
  ) 
  (setvar "textstyle" "汉字") 
) 
;;; ---------------------- setbl --------------------------- 
;;;                    设置出图比例                         
;;;方式 : (setbl)                                           
(defun setbl () 
  (setq bl (ureal 1 "" "\n输入出图比例1 : " bl)) 
  (setq SC (/ bl 100.0)) 
  (command "modemacro" 
    (strcat "XCAD BY XYP." " 当前出图比例 1:" 
     (rtos bl 2 1)) 
  )) 
;;; ---------------------- setnil -------------------------- 
;;;                       清空变量                           
;;;方式 : (setnil)                                           
(defun setnil () 
  (setq no1 nil no2 nil no3 nil no4 nil no5 nil no6 nil 
 no7 nil no8 nil no9 nil no10 nil 
 txt nil txt1 nil txt2 nil txt3 nil txt4 nil txt5 nil 
 txt6 nil txt7 nil txt8 nil 
 ) 
  ) 
;;; -------------------------------------------------------- 
;;;弧度转角度 
(defun rad2ang (rad)(* (/ rad pi) 180.0)) 
;;;角度转弧度 
(defun ang2rad (ang)(* (/ ang 180.0) pi)) 
;;; -------------------------------------------------------- 
;;;十字线 
;;;方式 : (xyp_szx (pt1 200));在pt1点画ll长十字线          
(defun xyp_szx (pt1 ll) 
  (command "line" (POLAR PT1 0 ll) (POLAR PT1 PI ll) "") 
  (command "line"(POLAR PT1 (/ PI 2.0) ll) 
    (POLAR PT1 (* PI 1.5) ll)"") 
) 
;;; -------------------------------------------------------- 
;;;线起点和终点                                              
(defun x_startP (e) 
  (vlax-curve-getstartPoint e) 
) 
(defun x_endP (e) 
  (vlax-curve-getEndPoint e) 
) 
;;; -------------------------------------------------------- 
;;;亮显选集 
;;;方式 : (xyp_lx ss1)                                     
(defun xyp_LX (ss) 
  (setq i -1) 
  (repeat (sslength ss) 
    (setq i (+ 1 i)) 
    (redraw (ssname ss i) 3) 
  ) 
  ;(princ) 
  ) 
;;; -------------------------------------------------------- 
;;;显示光标箭头 
;;;pt1、pt2、pt3分别为连续三点的坐标 
(defun show-jt (pt1 pt2 pt3 / ang1 ang2 po3 po4 po3_3 po4_3 po3_1 po4_1 po3_2 po4_2) 
  (setq ang1 (angle pt1 pt2) 
 ang2 (angle pt2 pt3) 
 ) 
  (setq 
    po3   (polar pt1 (+ ang1 (* 1.5 pi) ang2) (* 4000 sc)) 
    po4   (polar pt2 (+ ang1 (* 1.5 pi) ang2) (* 4000 sc)) 
    po3_3 (polar pt1 (+ ang1 (* 1.5 pi) ang2) (* 2000 sc)) 
    po4_3 (polar pt2 (+ ang1 (* 1.5 pi) ang2) (* 2000 sc)) 
    po3_1 (polar po3_3 (+ ang1 (* 1.0 pi)) (* 560 sc)) 
    po4_1 (polar po4_3 (+ ang1 (* 1.0 pi)) (* 560 sc)) 
    po3_2 (polar po3_3 ang1 (* 560 sc)) 
    po4_2 (polar po4_3 ang1 (* 560 sc)) 
  ) 
  (grvecs (list 256    pt1    po3    256    pt2    po4   256  po3 
  po3_1  256    po3    po3_2  256    po3_1  po3_2  256 
  po4    po4_1  256    po4    po4_2  256   po4_1  po4_2 
  1 pt1 pt2 
        ) 
  ) 
) 
;;; -------------------------------------------------------- 
;;;更换图元。 
;;;方式 :  改圆半径(sub_upd s1 40 300) 
(defun sub_upd (ename code #new)   
  (setq cc (subst (cons code #new) (assoc code (entget ename)) (entget ename))) 
  (entmod cc) 
  (entupd ename) 
) 
;;; -------------------------------------------------------- 
;;;jzxx 加载线型 
;;; 程序搜寻线型ltname，如果没有找到，则会由acadiso.lin 文件添加 
;;;方式 :  (jzxx"车库1") 
(defun jzxx (ltname) 
  (if (not (tblsearch "ltype" ltname)) 
    (vl-catch-all-apply 
      'vla-load 
      (list (vla-get-Linetypes 
       (vla-get-activedocument (vlax-get-acad-object)) 
     ) 
     ltname 
     "acadiso.lin" 
      ) 
    ) 
  ) 
  (setvar "celtype" ltname) 
  ;(command"-linetype""s" ltname "") 
  (princ) 
) 
;;; -------------------------------------------------------- 
;;;中心点 
(defun zxd () 
  (setq #pt (getpoint "\n\t选择区域内一点<退出> : ")) 
  (command "-boundary" "a" "o" "r" "" #pt "") 
  (setq #pt (vlax-safearray->list 
       (vlax-variant-value 
  (vla-get-centroid (vlax-ename->vla-object (entlast))) 
       ) 
     ) 
  ) 
  (entdel (entlast)) 
  #pt 
) 
;;; ---------------------- X_ZB ---------------------------- 
;;;                在某点标注坐标                            
;;;方式 : (X_ZB #upt)                                        
(defun X_ZB (#upt) 
  (setvar "LUPREC" 4)   ;小数位位数 
  (setvar "UNITMODE" 1)   ;控制单位的显示格式 
  (setq p2  (polar #upt (/ pi 4) (* sc 1000)) 
 h   (* SC 300) 
 a   (strcat "X=" (rtos (cadr #upt) 2 4)) 
 b   (strcat "Y=" (rtos (car #upt) 2 4)) 
 c   (max (strlen a) (strlen b)) 
 p3  (list (+ (car p2) (* c h 0.8)) (cadr p2)) 
 rp1 (list (+ (car p2) (/ (* c h 0.8) 2)) 
    (+ (cadr p2) (+ (/ h 2) (/ bl 1))) 
     ) 
 rp2 (list (+ (car p2) (/ (* c h 0.8) 2)) 
    (- (cadr p2) (+ (/ h 2) (/ bl 1))) 
     ) 
  ) 
  (setvar "osmode" 0) 
  (command "pline" #upt p2 p3 "") 
  (command "text" "j" "mc" rp1 h "0" a) 
  (command "text" "j" "mc" rp2 h "0" b) 
) 
;;; -------------------------------------------------------- 
;;;双曲余弦函数、双曲正弦函数 
(defun cosh (dx) (* 0.5 (+ (exp dx) (exp (- 0 dx))))) 
(defun sinh (dx) (* 0.5 (- (exp dx) (exp (- 0 dx))))) 
(defun tanh (dx) (/ (sinh dx) (cosh dx))) 
(defun sec (dx) (/ 1 (cos dx))) 
;;; ---------------------- PXYP ---------------------------- 
;;;                显示程序命令及作者信息                   
;;;方式 : (pxyp"pdpc      (坡度坡长)")                      
(DEFUN PXYP (TXT1) 
  (SETQ TXT1 (STRCAT "\n\r      程序命令: "TXT1 
       "      -- <a href=\"mailto:xyp@bsedi.com\" target=\"_blank\">xyp@bsedi.com</a>")) 
  (PRINC TXT1) 
  (Princ)) 
;;;--------------------------------------------------------- 
(princ) 
;;;--------------------------------------------------------- 
;;;END 
;| 
;;;选择ssget “和”即“and”的用法 
(setq SS (ssget '((0 . "CIRCLE,ELLIPSE,LINE,*POLYLINE,SPLINE,ARC")))) 
(ssget '((0 . "line") (8 . "1,0"))) 
;;;undo类型 
;;;回退开始 
(vl-cmdf ".undo" "BE") 
(command ".undo" "BE") 
;;;回退结束 
(vl-cmdf ".undo" "E") 
(command ".undo" "E")

haibinpro · 发表于 2013-8-11 08:15:38

内容不错。只是发帖时不能选择渲染为lsp显示么。应该有这个的。

caoliu023 · 发表于 2013-8-12 09:07:25

复制好像有问题，没有换行

cooolsee · 发表于 2014-5-8 22:16:01

高手往往都显得那么低调

totorojdm · 发表于 2014-5-9 22:14:39

很好的资料~
对编写程序很有帮助~

modman · 发表于 2014-6-17 16:07:02

很给力啊！:lol

dzgsfjw · 发表于 2014-6-17 16:21:51

给力，正能量

账号		自动登录	找回密码
密码			立即注册

[他山之石] 实用型函数《三》

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

评分

相关帖子