对于CAD自身的DCL，总是无法做的很合心意。
OPENDCL有其特殊之处所在，因而利用其DOCK控件，制作了一些工具栏，自我使用方便一些。主要特点是为了按需加载，就是所有的程序，分为几个级别，第一种是常用的，随系统启动，用lisp或者autohook定义为左手键。第二种是这类DOCK工具，按需要进行加载。第三种是机器里成千上万个lisp程序，按类别分后，用lisplink的ctrl+a来调用。基本足矣。
[autolisp] 增加Autolisp相关网站链接
November 6, 2007
autolisp, 网站记录 Leave a comment
1. http://www.cadesigner.com/Downloads.htm
2. http://paracadd.com/lisp.htm
http://paracadd.com/lisp/lisp_lst.htm
有一个叫http://paracadd.com/lisp/lsplst.lsp的程序挺好的，自动生成html页面
http://paracadd.com/lisp/
3.一个韩国的网站，收集了大量不错的lisp程序，可以发现，其不少程序是来自于theswamp。
http://www.acadvba.com/zero/zboard.php?id=codelisp
4. MP- Michael Puckett -一个国际知名autolisp高手的主页，有好些精彩的函数。他的主页做的非常精致，层次结构很好。
http://tiddlyspot.com/cadlabs/
[autolisp] 将圆内的文字移动到圆中心处
November 4, 2007
autocad, autolisp Leave a comment
[autolisp] 将圆内的文字移动到圆中心处
;;; —————————————————————–;
;;; Purpose: move the text inside circle to the center of the circle ;
;;; write by qjchen ;
;;; http://qjchen.yo2.cn ;
;;; http://chenqj.blogspot.com ;
;;; —————————————————————–;
(defun c:test (/ std-sslist movetocenter)
(command “_undo” “_be”)
(setting)
(defun std-sslist (ss / n lst)
(if (eq ‘pickset (type ss))
(repeat (setq n (fix (sslength ss))) ; fixed
(setq lst (cons (ssname ss (setq n (1- n))) lst))
)
)
)
(defun movetocenter (/ a x txtobj center_circle outline b bobject objss
res midpoint
)
(setq a (ssget ‘((0 . “circle”))))
(setq a (std-sslist a))
(foreach x a
(setq txtobj nil)
(setq pub x)
(setq center_circle (assoc 10 (entget x)))
(setq outline (objectpoint (entget x)))
(setq b (ssget “_cp” outline ‘((0 . “TEXT”))))
(setq bobject (ssname b 0))
(setq objss (vlax-ename->vla-object bobject))
(setq res (xyval1 objss))
(setq midpoint (midp (list (nth 0 res) (nth 1 res)) (list
(nth 2 res)
(nth 3 res)
)
)
)
(command “move” bobject “” midpoint (cdr center_circle))
)
)
(movetocenter)
(resetting)
(command “_undo” “_e”)
)
;;; the subrountine is write by qjchen to get selection by circle
;;; and lwpolyline
(defun objectpoint (obj / name ori i r w_pl_lst wlist)
(setq name (cdr (assoc 0 obj)))
(cond
((= name “CIRCLE”)
(setq ori (cdr (assoc 10 obj)))
(setq r (cdr (assoc 40 obj)))
(setq i 0)
(repeat 30
(setq wlist (append
wlist
(list (polar ori (* 2 pi (/ i 30.0)) r))
)
)
(setq i (1+ i))
)
)
((= name “LWPOLYLINE”)
(defun w_pl_lst (ent / pt_list)
(foreach x ent
(if (= (car x) 10)
(setq pt_list (append
(list (cdr x))
pt_list
)
)
)
)
pt_list
)
(setq wlist (w_pl_lst obj))
)
)
wlist
)
;;; _ end of xyval
;;; —The following codes are copy from Tony Hotchkiss at cadalyst
;;; Get the boundingbox of one object
(defun xyval1 (obj / minpt maxpt topy bottmy leftx rightx)
(vla-GetBoundingBox obj ‘minpt ‘maxpt)
(setq pt1 (vlax-safearray->list minpt)
pt2 (vlax-safearray->list maxpt)
topy (cadr pt2)
bottmy (cadr pt1)
leftx (car pt1)
rightx (car pt2)
) ; _ end of setq
(list leftx bottmy rightx topy)
)
;;; The error function
(defun err (s)
(if (= s “Function cancelled”)
(princ “\nALIGNIT – cancelled: “)
(progn
(princ “\nALIGNIT – Error: “)
(princ s)
(terpri)
) ; _ end of progn
) ; _ end of if
(resetting)
(princ “SYSTEM VARIABLES have been reset\n”)
(princ)
)
;;; err
;;; setting and resetting the system variables
(defun setv (systvar newval / x)
(setq x (read (strcat systvar “1″)))
(set x (getvar systvar))
(setvar systvar newval)
)
;;; setv
(defun setting ()
(setq oerr *error*)
(setq *error* err)
(setv “BLIPMODE” 0)
(setv “CMDECHO” 0)
(setv “OSMODE” 0)
)
;;; setting
(defun rsetv (systvar)
(setq x (read (strcat systvar “1″)))
(setvar systvar (eval x))
)
;;; rsetv
(defun resetting ()
(rsetv “BLIPMODE”)
(rsetv “CMDECHO”)
(rsetv “OSMODE”)
(setq *error* oerr)
)
;;; ——————————————————-
(defun midp (p1 p2)
(mapcar
‘(lambda (x)
(/ x 2.)
)
(mapcar
‘+
p1
p2
)
)
)
;;; The following code taken from Mr.Tony Hotchkiss at Cadalyst
(defun err (s)
(if (= s “Function cancelled”)
(princ “\nregion clean – cancelled: “)
(progn
(princ “\nregion clean – Error: “)
(princ s)
(terpri)
) ; _ end of progn
) ; _ end of if
(resetting)
(princ “SYSTEM VARIABLES have been reset\n”)
(princ)
)
;;; err
;;; setting and resetting the system variables
(defun setv (systvar newval / x)
(setq x (read (strcat systvar “1″)))
(set x (getvar systvar))
(setvar systvar newval)
)
;;; setv
(defun setting ()
(setq oerr *error*)
(setq *error* err)
(setv “BLIPMODE” 0)
(setv “CMDECHO” 0)
(setv “OSMODE” 0)
)
;;; setting
(defun rsetv (systvar)
(setq x (read (strcat systvar “1″)))
(setvar systvar (eval x))
)
;;; rsetv
(defun resetting ()
(rsetv “BLIPMODE”)
(rsetv “CMDECHO”)
(rsetv “OSMODE”)
(setq *error* oerr)
)
opendcl的博客和论坛和highflybird兄的应用
July 12, 2007
autocad, autolisp, objectdcl, opendcl Leave a comment
在jtbworld里面看到的
http://www.opendcl.com/
http://www.opendcl.com/forum/
它的论坛和theswamp用的是同个架构软件，个人挺喜欢。
highflybird兄最近写了一个很高级的物体跟随反应器
发起时间 ：2007年07月08日17点53分”>[原创]：十年磨一剑–openDCL和反应器
http://www.xdcad.net/forum/showthread.php?s=&threadid=637122
写的很好，佩服佩服
19. Jimmy Bergmark的一些Vlisp函数功能简介
April 3, 2007
autocad, autolisp, 网站记录 Leave a comment
19. Jimmy Bergmark的一些Vlisp函数功能简介
AutoLisp和Vlisp的资料现在越来越多了，不像10年前一样只有可怜巴巴的几本书，互联网也不发达的时候了。慢慢的上网会发现很多自己的想法早就有高手解决了，这里面有国外的Bill Krammer, Tony Tanzillo, Evgeniy，Menzi，John Uhden等等，也有国内的xdsoft，eachy，aeo，狂刀，Lucas等等高手。Lisp是一个很有趣的语言， 有时候同一个函数有着7，8种不同的写法，有时候却几乎一模一样。高手们的程序一般而言都很有特色。有时候看到了一个好程序，就很喜欢google一下，去看看他们还有一些什么作品，感受一下他们的风格。
Jimmy Bergmark创建的www.jtbworld.com网站很早的时候就存在互联网了，他现在的博客地址是http://jtbworld.blogspot.com/，在网上也很有名，经常会发布一些Autocad和Lisp相关的新闻，技巧和代码。下面翻译的是他主页上的一些公开的源代码的简单解释。有简单有复杂，：）可以看出高手也是一步步走过来的呀。不好意思，还没有一个个测试，假如其功能翻译有误，请告知。也希望能对其中几个进行抓图演示。
——
积累求总距离
ADT 2004相关程序
ADT 2004相关程序
选择物体求总面积
选择物体的面积
不少关于块的程序
用Lisp创建Viewport 视窗
用ActiveX法在模型空间建块
改变背景颜色
把块变成Xref
线求总长
用CAO的方法在autocad 2002中创建和删除链接
把不能打印的层移到defpoints层
选dim标注中的线改动到其他图层，可以是其他线形
多个显示颜色特性的子程序
一些关于显示特性的子程序
获取打印设备
获取视窗的显示比例
移动hatch的起始点位置
hatch边界线重建
改变一个或多个hatch的基准点
改变命令行的高度
两个用ActiveX方法插入块
改变Autocad的标题栏，注意，需要下载一个vb的dvb文件
把图层的名称和状态存到某文件中
图形的图层和线宽列表
删除所有冻结和关闭图层上的所有物体
按照给定的状态对图层进行列表（是否冻结，关闭，可打印）
切换图层的freezen冻结状态，并只对这些图层regen
把某个布局layout存为dwg，对存r14及以下版本有用
选择物体的周长
几个关于线形的程序
两点的中点，三分点和四分点，三点的中点
一些关于页面设置（page setup）的子程序
在Mtext的右键菜单中添加一些个人的Mtext符号
通过误差连接直线、弧和多义线
一些关于打印设置的子程序
打印
一些关于配置Profile的子程序
保存图形文件的配置路径，以便在其他机子上使用
一个purge 点的程序，Autocad与POINT 5交流时用
purge相关程序，避免出现命令行讨厌的提示
通过配置注册表，移除icons Buzzsaw, RedSpark, Point A and FTP 等不大必要的选项的显示
把一个文件打开，激活，并设为只读
把支持路径保存到一个文件中，或从一个文件中加载
把所有物体中的Text或Mtext改变为指定文字style
把所有Text旋转到指定路径
得到视窗中心
输出或导入View视图
保存、导入或者恢复Viewport中的图层
在模型空间中创建一个包含选择视窗的外轮廓线
选择Viewport视窗中所有可见物体
所有Viewport视窗最大化
AutoCAD 2008的一些新特性及与以往Lisp之小联系
March 6, 2007
autocad, autolisp Leave a comment
AutoCAD 2008的一些新特性及与以往Lisp之小联系
qjchen
1）加了一种Annotaion的概念，可以在缩放详图的时候自动调整尺寸，这点对详图设计应该比较有用。所以必须学习一下annotation scale。而annotative object包含了好些实体，比如dimension，text等。2008把它当成第一个新特性，肯定认为是很重要的吧。
Lisp相关：以前有一个叫Detail的程序。
2）Dimension的一些增强，包括公差的对齐等等，还有给标注加截断线，加了一种叫Inspection Dimension的。给线性标注添加一种叫Jog line来表示尺寸和实际不符的情况（还没有想明白具体的作用）。
Lisp相关：以前有一个弧线长度标注的程序，不过在最近版本的cad中已经自己支持了。
3）自动调整标注之间的间距，使之不重叠，这点倒是比较神奇，莫非有点人工智能的能力了（效果其实还不错，要先选基准线）。multileader会自动增加编号，可以自己定义格式，不过还不够智能的样子。不过它的对齐调整倒是比较有趣。
Lisp相关：探索者有一个多线标注的程序，但是作用不是很类似。
4）可以动态和Excel交换数据，内容包括sheet，range和cell，这个对各种表格软件的打击还是不小的。表格风格也得到了增强。表格中可以象excel一样拖曳来递增数据。可以把一个表格通过简单的点击变成两个（这个功能挺有趣的，以前还没有见过）。可以对图形对象进行数据导出，比如块，属性等。可以导出到excel。这个功能应该也挺不错。比如导出polyline围住的面积等。
Lisp相关：有不少关于Excel和Acad之间互通的程序，包括mmmm的程序和truetable，还有国外一些。
5）layer的属性得到了一些增强，在不同的viewport中有不同的设置。
6）一种将选择图层不关闭，但锁住变灰可捕捉的reduce visual complexity的做法。这个Layeriso的命令非常好用，是这个版本的一个亮点了。地位可以和最近几个版本中出现的join和scaletext等小命令相媲美。
Lisp相关：记得xdcad几个版主曾经讨论过这个功能，是不是给了autodesk灵感啊。
7）可以对附加的xref的图层进行更好的控制。Xclip有了新的选项。
Lisp相关：Aeo版主写过自动剪切判断内外的程序。
8）Visual fidelity 的功能用于对新的annotation性质进行控制。Mtext可以写多列文字了。多行块属性。
9）可以导入和导出Microstation的DGN文件。
10）aeo版主提过的substr问题仍然没有改进。
所以个人感觉，2008的变化没有2007来的多。更多的细节，应该是小号版本的升级吧。
AutoCAD 2008的一些新特性及与以往Lisp之小联系
March 6, 2007
autocad, autolisp Leave a comment
AutoCAD 2008的一些新特性及与以往Lisp之小联系
qjchen
1）加了一种Annotaion的概念，可以在缩放详图的时候自动调整尺寸，这点对详图设计应该比较有用。所以必须学习一下annotation scale。而annotative object包含了好些实体，比如dimension，text等。2008把它当成第一个新特性，肯定认为是很重要的吧。
Lisp相关：以前有一个叫Detail的程序。
2）Dimension的一些增强，包括公差的对齐等等，还有给标注加截断线，加了一种叫Inspection Dimension的。给线性标注添加一种叫Jog line来表示尺寸和实际不符的情况（还没有想明白具体的作用）。
Lisp相关：以前有一个弧线长度标注的程序，不过在最近版本的cad中已经自己支持了。
3）自动调整标注之间的间距，使之不重叠，这点倒是比较神奇，莫非有点人工智能的能力了（效果其实还不错，要先选基准线）。multileader会自动增加编号，可以自己定义格式，不过还不够智能的样子。不过它的对齐调整倒是比较有趣。
Lisp相关：探索者有一个多线标注的程序，但是作用不是很类似。
4）可以动态和Excel交换数据，内容包括sheet，range和cell，这个对各种表格软件的打击还是不小的。表格风格也得到了增强。表格中可以象excel一样拖曳来递增数据。可以把一个表格通过简单的点击变成两个（这个功能挺有趣的，以前还没有见过）。可以对图形对象进行数据导出，比如块，属性等。可以导出到excel。这个功能应该也挺不错。比如导出polyline围住的面积等。
Lisp相关：有不少关于Excel和Acad之间互通的程序，包括mmmm的程序和truetable，还有国外一些。
5）layer的属性得到了一些增强，在不同的viewport中有不同的设置。
6）一种将选择图层不关闭，但锁住变灰可捕捉的reduce visual complexity的做法。这个Layeriso的命令非常好用，是这个版本的一个亮点了。地位可以和最近几个版本中出现的join和scaletext等小命令相媲美。
Lisp相关：记得xdcad几个版主曾经讨论过这个功能，是不是给了autodesk灵感啊。
7）可以对附加的xref的图层进行更好的控制。Xclip有了新的选项。
Lisp相关：Aeo版主写过自动剪切判断内外的程序。
8）Visual fidelity 的功能用于对新的annotation性质进行控制。Mtext可以写多列文字了。多行块属性。
9）可以导入和导出Microstation的DGN文件。
10）aeo版主提过的substr问题仍然没有改进。
所以个人感觉，2008的变化没有2007来的多。更多的细节，应该是小号版本的升级吧。
一些lisp和emacs的博客或站点
March 5, 2007
一个网络课程
http://wlkc.lnnu.edu.cn/rgzn/content/index.htm
一个博客，关于emacs的
http://ann77.stu.cdut.edu.cn/
一篇关于emacs的文章
http://www.newsmth.net/pc/pccon.php?id=6147&nid=152423&order=&tid=13200
一篇关于lisp，python和ruby（一个日本人弄的语言，水木清华有专版）的对比
http://blog.csdn.net/jq0123/archive/2006/08/31/1147758.aspx
近日在好好写论文，就不勤力更新了。
tecplot不支持中文的问题是挺讨厌的，好在假如中文不多的话，倒是可以用coreldraw或者illustrator或者autocad或者acrobat来编辑一下。sigmaplot的图也是非常漂亮，但同样也存在着中文字体间距不等的问题。
一些lisp和emacs的博客或站点
March 5, 2007
一个网络课程
http://wlkc.lnnu.edu.cn/rgzn/content/index.htm
一个博客，关于emacs的
http://ann77.stu.cdut.edu.cn/
一篇关于emacs的文章
http://www.newsmth.net/pc/pccon.php?id=6147&nid=152423&order=&tid=13200
一篇关于lisp，python和ruby（一个日本人弄的语言，水木清华有专版）的对比
http://blog.csdn.net/jq0123/archive/2006/08/31/1147758.aspx
近日在好好写论文，就不勤力更新了。
tecplot不支持中文的问题是挺讨厌的，好在假如中文不多的话，倒是可以用coreldraw或者illustrator或者autocad或者acrobat来编辑一下。sigmaplot的图也是非常漂亮，但同样也存在着中文字体间距不等的问题。
添加目录到autocad的支持路径
March 3, 2007
学习一下vlisp中的add supporting path
刚好xd论坛有这个问题，秋枫版主也做了回答，为了好好学习，也在网上找了一下其他资料，好像大概都是两种写法，setenv和vla-put-supportpath，其实记得有一个专门讨论preference里面操作的，现在不明确的是否所有的vba都能被lisp支持。
Lisp是一个很奇怪的语言，好像不同人会写出各式各样的代码，但是有时候高手的代码又会几乎一模一样。好奇怪。
学习作笔记～
秋枫兄代码:
;;; 解析字符串为表（函数来自明经通道转载）
;;; ---------------------------------------------------------------------------------
(defun strParse (Str Delimiter / SearchStr StringLen return n char)
(setq SearchStr Str)
(setq StringLen (strlen SearchStr))
(setq return '())
(while (> StringLen 0)
(setq n 1)
(setq char (substr SearchStr 1 1))
(while (and (/= char Delimiter) (/= char ""))
(setq n (1+ n))
(setq char (substr SearchStr n 1))
) ;_ end of while
(setq return (cons (substr SearchStr 1 (1- n)) return))
(setq SearchStr (substr SearchStr (1+ n) StringLen))
(setq StringLen (strlen SearchStr))
) ;_ end of while
(reverse return)
) ;_ end of defun
;;; 反解析表为字符串（函数来自明经通道转载）
;;; ---------------------------------------------------------------------------------
(defun StrUnParse (Lst Delimiter / return)
(setq return "")
(foreach str Lst
(setq return (strcat return Delimiter str))
) ;_ end of foreach
(substr return 2)
) ;_ end of defun
;;; 添加支持文件搜索路径
;;; ---------------------------------------------------------------------------------
;;; note: 第二个参数如果为真, 插最前，否则插最后
;;;
(defun AddSupportPath (PathToAdd isFirst / supportlist)
(if (not
(vl-string-search
(strcase (strcat pathToAdd ";"))
(strcase (strcat (getenv "ACAD") ";"))
)
) ; 保证不重复添加
(progn
(setq supportlist (strparse (getenv "ACAD") ";"))
(setq supportlist
(vl-remove-if-not
'vl-file-directory-p
supportlist
)
) ; 移除不存在的文件夹
(if isFirst
(setq supportlist (cons PathToAdd supportlist))
(setq supportlist (append supportlist (list PathToAdd)))
)
(setenv "ACAD" (strUnParse supportlist ";"))
)
)
)
[AcadX.com]的代码，可能年代也挺久的，和秋枫版主的类似
代码:
(defun addSP (dir pos / tmp c lst)
(setq tmp ""
c -1
)
(if (not (member (strcase dir) (setq lst (mapcar
'strcase
(parse (getenv "ACAD") ";")
)
)
)
)
(progn
(if (not pos)
(setq tmp (strcat (getenv "ACAD") ";" dir))
(mapcar
'(lambda (x)
(setq tmp (if (= (setq c (1+ c))
pos
)
(strcat tmp ";" dir ";" x)
(strcat tmp ";" x)
)
)
)
lst
)
)
(setenv "ACAD" tmp)
)
)
(princ)
)
(defun parse (str delim / lst pos)
(setq pos (vl-string-search delim str))
(while pos
(setq lst (cons (substr str 1 pos) lst)
str (substr str (+ pos 2))
pos (vl-string-search delim str)
)
)
(if (> (strlen str) 0)
(setq lst (cons str lst))
)
(reverse lst)
)
; Arguments : A folder path and the position at which to insert it. (0 based.)
; Here's an example to add a support folder :
(addSP "c:\\afralisp" 3)
John Laidler ，也用setenv函数，没有选择位置项
代码:
;;; John Laidler
;;; http://groups.google.com/group/auto...72d257e2d2174/4
b0851cbad83d142?lnk=gst&q=add+support+path&rnum=4#4b0851cbad83d142
(defun CS:AddSupportPath (dir / tmp Cpath)
(vl-load-com)
(setq Cpath (getenv "ACAD")
tmp (strcat ";" dir ";")
)
(if (not (vl-string-search dir cpath))
(setenv "ACAD" (strcat Cpath ";" dir))
)
(princ)
)
(CS:ADDSUPPORTPATH "c:\\b")
下面三个是theswamp找到的函数
MP，只用一句话，是vla函数
代码:
;;;[MP]
(defun _AddSupportPath ( path / files )
(vla-put-supportpath
(setq files
(vla-get-files
(vla-get-preferences
(vlax-get-acad-object)
)
)
)
(strcat
(vla-get-supportpath files) ";"
path
)
)
)
(_addsupportpath "c:\\3")
Jeff_M和kerry Brown都是为了一个问题写的，希望一次加多个子目录
代码:
(defun c:ldp (/ FilePrefs addEnviron EnvironBase acadEnviron)
(setq FilePrefs (vla-get-files (vla-get-preferences
(vlax-get-acad-object)
)
)
)
(setq acadEnviron (vla-get-supportpath FilePrefs))
(setq EnvironBase "M:\\_Cad Support\\AutoCAD 2004\\2004dannyCAD\\MENU\\")
(setq addEnviron '("Area" "Blocks"
"Dimensions" "Layers"
"Linetypes" "Plotting"
"Settings" "Shortcuts"
"Text"
);;;add any others you want to this list
)
(if (not (vl-string-search (strcat EnvironBase (car addEnviron))
acadEnviron
);;;make sure we haven't already done this
)
(progn
(mapcar
'(lambda (x)
(setq acadEnviron (strcat acadEnviron ";" EnvironBase x))
)
addEnviron
)
(vla-put-supportpath FilePrefs acadEnviron)
(princ "\n....Support Paths updated!")
);progn
(princ "\n....Support Paths were previously updated...nothing done.")
);if
(princ)
)
Kerry Brown
代码:
(VL-LOAD-COM)
(prompt "\n Load Dependant Support Paths to profile [V0.01]")
(defun c:LDP (/ fileprefs addenviron environbase acadenviron)
(setq fileprefs (vla-get-files (vla-get-preferences
(vlax-get-acad-object)
)
)
)
(setq acadenviron (vla-get-supportpath fileprefs))
(setq environbase "M:\\_Cad Support\\AutoCAD 2004\\2004dannyCAD\\MENU\\")
(setq addenviron '("Area" "Blocks"
"Dimensions" "Layers"
"Linetypes" "Plotting"
"Settings" "Shortcuts"
"Text"
)
)
(mapcar
'(lambda (x)
(setq acadenviron (strcat acadenviron ";" environbase x))
)
addenviron
)
(vla-put-supportpath fileprefs acadenviron)
(PRINC)
)
