[LISP程序]：老外寫的修改圓半徑程序

taner

[php]; =============================================================================
; Filename    :   ChgRad.lsp
; Datum       :   07.11.01
; Author      :   jme
; Copyright   :   MENZI ENGINEERING GmbH
; Revision  1 :   18.01.05 jme - Selection mode added
; Revision  2 :   __.__.__ ___ -
; -----------------------------------------------------------------------------
; Description:
; Function to change the radius of circles.
; -----------------------------------------------------------------------------
; Known bugs:
; - None
; -----------------------------------------------------------------------------
; Global variables:
; Me:Err  Me:Nra  Me:Ora  Me:Smd  Me:Svr
; -----------------------------------------------------------------------------
; Internal LISP-functions:
; MeEndFunction  MeGetAssoc  MeGetRadius  MeStartFunction  MeUserError
; -----------------------------------------------------------------------------
; External LISP-functions:
;
; -----------------------------------------------------------------------------
; Version notes:
; AutoCAD:        Version:        Language:        AddIns:
; 14+                1.01                English                ...
; -----------------------------------------------------------------------------
;
; -- Message on loading -------------------------------------------------------
;
(princ "\nChgRad v1.01")
;
; == Main =====================================================================
;
(defun c:chgrad( / CurEnt CurSet EntLst FltLst TmpStr)
(MeStartFunction '("APERTURE" "AUTOSNAP" "CURSORSIZE" "OSMODE"))
(initget "Match Select")
(setq Me:Ora (cond
               (Me:Ora)
               ((> (getvar "CIRCLERAD") 0) (getvar "CIRCLERAD"))
               (1.0)
              )
       Me:Nra (cond
               (Me:Nra)
               ((> (getvar "CIRCLERAD") 0) (getvar "CIRCLERAD"))
               (1.0)
              )
       Me:Smd (cond (Me:Smd) ("Select"))
       TmpStr (strcat "\nSelection mode [Match/Select] <" Me:Smd ">: ")
       Me:Smd (cond ((getkword TmpStr)) (Me:Smd))
)
(if (eq Me:Smd "Select")
  (progn
   (princ "\nSelect circle(s)...")
   (setq CurSet (ssget '((0 . "CIRCLE"))))
  )
  (setq Me:Ora (MeGetRadius "\nSelect Circle or enter radius to match" Me:Ora)
        FltLst (list
               '(0 . "CIRCLE")
               '(-4 . ">=") (cons 40 (- Me:Ora 1E-6))
               '(-4 . "<=") (cons 40 (+ Me:Ora 1E-6))
               )
        CurSet (ssget "X" FltLst)
  )
)
(if CurSet
  (progn
   (setq Me:Nra (MeGetRadius "\nSelect Circle or enter new radius" Me:Nra))
   (while (setq CurEnt (ssname CurSet 0))
    (setq EntLst (entget CurEnt)
          EntLst (subst (cons 40 Me:Nra) (assoc 40 EntLst) EntLst)
    )
    (entmod EntLst)
    (ssdel CurEnt CurSet)
   )
  )
  (if (eq Me:Smd "Match") (alert "No matching circle(s) found..."))
)
(MeEndFunction)
)
;
; == Subs =====================================================================
;
; -- Function MeGetRadius
; Get the default radius by object or number.
; Arguments [Typ]:
;   Pmt = Prompt [STR]
;   Rad = Default radius [REAL]
; Return [Typ]:
;   > New radius [REAL]
; Notes:
;   None
;
(defun MeGetRadius (Pmt Rad / EntLst GoLoop RetVal TmpStr TmpVal)
(setq GoLoop T)
(while GoLoop
  (setvar "OSMODE" 512)
  (setvar "APERTURE" (getvar "PICKBOX"))
  (setvar "AUTOSNAP" 0)
  (setvar "CURSORSIZE" 1)
  (initget 128)
  (setq RetVal (getpoint (strcat Pmt " <" (rtos Rad) ">: ")))
  (setvar "OSMODE" 0)
  (setvar "APERTURE" (MeGetAssoc "APERTURE" Me:Svr))
  (setvar "AUTOSNAP" (MeGetAssoc "AUTOSNAP" Me:Svr))
  (setvar "CURSORSIZE" (MeGetAssoc "CURSORSIZE" Me:Svr))
  (cond
   ((= (type RetVal) 'LIST)
    (if (= (type (setq TmpVal (car (nentselp RetVal)))) 'ENAME)
     (progn
      (setq EntLst (entget TmpVal))
      (if (= (MeGetAssoc 0 EntLst) "CIRCLE")
       (setq RetVal (MeGetAssoc 40 EntLst)
             GoLoop nil
       )
       (prompt "selected object is not a Circle. ")
      )
     )
     (prompt "1 selected, 0 found. ")
    )
   )
   ((= (type RetVal) 'STR)
    (cond
     ((wcmatch RetVal "*[~0-9.-]*")
      (prompt "requires a decimal number. ")
     )
     ((minusp (atof RetVal))
      (prompt "number must be positive. ")
     )
     ((zerop (atof RetVal))
      (prompt "requires a number >0. ")
     )
     (T
      (setq RetVal (atof RetVal)
            GoLoop nil
      )
     )
    )
   )
   (T
    (setq GoLoop nil
          RetVal Rad
    )
   )
  )
)
RetVal
)
;
; -- Function MeGetAssoc
; Returns the assoc value of a DottedPair list.
; Arguments [Typ]:
;   Key = Key name [ALL]
; Return [Typ]:
;   > Associated value from list [ALL]
; Notes:
;   None
;
(defun MeGetAssoc (Key Lst) (cdr (assoc Key Lst)))
;
; -- User Error
;
(defun MeUserError (Msg)
(command) (command)
(if (not
      (member Msg
      '("Function cancelled" "console break" "quit / exit abort")
      )
     )
  (princ (strcat "\nError: " Msg))
)
(MeEndFunction)
(princ)
)
;
; -- Start function
;
(defun MeStartFunction (Lst)
(setvar "CMDECHO" 0)
(if (= (logand (getvar "UNDOCTL") 4) 4) (command "_.UNDO" "_GROUP"))
(setq Me:Err  *error*
       *error* MeUserError
       Me:Svr  (mapcar '(lambda (l) (cons l (getvar l))) Lst)
)
(princ)
)
;
; -- End function
;
(defun MeEndFunction ()
(if Me:Svr (mapcar '(lambda (l) (setvar (car l) (cdr l))) Me:Svr))
(setq Me:Svr  nil
       *error* Me:Err
)
(if (= (logand (getvar "UNDOCTL") 4) 4) (command "_.UNDO" "_END"))
(princ)
)
;
; == Copyright - Note (May be never deleted) ==================================
;
(princ "\n------------------------------------------------")
(princ "\n ?001-2005 MENZI ENGINEERING GmbH, Switzerland ")
(princ "\n------------------------------------------------")
(princ "\nType ChgRad in the command line to start the programm...")
(princ)
;
; == End ChgCircRad ===========================================================[/php]

狂刀

改多个用ｃｔｒｌ＋１特性管理工具就挺好用
改单个也可用夹点直接改

hhzcfx

感谢楼主精彩贡献

happyliubin

16个隐藏在Windows XP系统背后的小窍门

--------------------------------------------------------------------------------

http://www.sina.com.cn 2006年12月07日 09:44 eNet硅谷动力

　　这些Windows XP的窍门你也许不知道，但有可能很有用：　　

　　安装音乐：

　　开始 > 运行 > “C:\Windows\system32\oobe\images\title.wma” > 确定

　　让机器休眠(Hibernate)：

　　开始 > 关闭电脑… > 按Shift键”待机”就会变成”休眠”。

　　隐藏的设备

　　控制面板> 系统 > 硬件 > 设备管理器 > 选择菜单”查看”中”的显示隐藏的设备”。

　　字符映射表

　　开始 > 运行 > “charmap.exe” > 确定

　　剪贴板查看器

　　开始 > 运行 > “clipbrd.exe” &


   



gt; 确定

　　Dr Watson

　　开始 > 运行 > “drwtsn32.exe” > 确定

　　IExpress Wizard(一个自解压包制作工具)

　　开始 > 运行 > “iexpress.exe” > 确定

　　老的Windows 媒体播放器 5.1

　　开始 > 运行 > “mplay32.exe” > 确定

　　ODBC 数据源管理器

　　开始 > 运行 > “odbcad32.exe” > 确定

　　对象包装程序

　　开始 > 运行 > “packager.exe” > 确定

　　系统性能监视器

　　开始 > 运行 > “perfmon.exe” > 确定

　　创建共享文件夹向导

　　开始 > 运行 > “shrpubw.exe” > 确定

　　文件签名验证工具

　　开始 > 运行 > “sigverif.exe” > 确定

　　系统配制编辑器

　　开始 > 运行 > “sysedit.exe” > 确定

　　驱动程序验证管理器

　　开始 > 运行 > “verifier.exe” > 确定

　　工作组聊天软件

　　开始 > 运行 > “winchat.exe” > 确定

killer9806

谢楼主提供，思路值得学习哦

jin123l

感谢楼主

zdc51858

感谢楼主，受益哦！

176489156

看不懂

xxywxtk

感谢楼主，太神奇了!