eachy

Eachy Lisp/Vlisp Library 使用说明

本函数库收集了本人几年来编程中所积累的一些函数，所提供的函数以实用为主，不求大而全。其中所封装的函数均经过了测试，理论上应该可以应用在 R2000 以上版本。某些有使用条件的的函数会单独说明。

函数命名规则纯Autolisp部分前缀为 ybl- , 使用 Vlisp 部分的前缀为 ybvl-，函数名称的第二部分为分类，如 str、lst ...

本函数库所包含的函数均为本人原创或者对现有的一些函数进行了优化和重写。

详情请查看 http://eachy.ys168.com


下载地址: http://eachy.ys168.com

声明：

本函数库为共享软件，而且永久免费，但有作者信息提示

Adodb.Stream是ADO的Stream对象,提供存取二进制数据或者文本流,从而实现对流的读、写和管理等操作.

有下列方法：
Cancel 方法
使用方法如下
Object.Cancel
说明：取消执行挂起的异步 Execute 或 Open 方法的调用。
Close 方法
使用方法如下
Object.Close
：关闭对像
CopyTo 方法
使用方法如下
Object.CopyTo(destStream,[CharNumber])
说明：将对像的数据复制，destStream指向要复制的对像，CharNumber为可选参数，指要复制的字节数，不选为全部复制。
Flush 方法
使用方法如下
Object.Flush
说明：
LoadFromFile 方法
使用方法如下
Object.LoadFromFile(FileName)
说明:将FileName指定的文件装入对像中,参数FileName为指定的用户名。
Open 方法
使用方法如下
Object.Open(Source,[Mode],[Options],[UserName],[Password])
说明：打开对像，
参数说明：Sourece 对像源，可不指定
Mode 指定打开模式，可不指定，可选参数如下：
adModeRead =1
adModeReadWrite =3
adModeRecursive =4194304
adModeShareDenyNone =16
adModeShareDenyRead =4
adModeShareDenyWrite =8
adModeShareExclusive =12
adModeUnknown =0
adModeWrite =2

adModeUnknown:缺省。当前的许可权未设置

adModeRead:只读

adModeWrite:只写

adModeReadWrite:可以读写

adModeShareDenyRead:阻止其它Connection对象以读权限打开连接

adModeShareDenyWrite:阻止其它Connection对象以写权限打开连接

adModeShareExclusive:阻止其它Connection对象以读写权限打开连接

adModeShareDenyNone:阻止其它Connection对象以任何权限打开连接   

Options 指定打开的选项，可不指定，可选参数如下：
adOpenStreamAsync =1
adOpenStreamFromRecord =4
adOpenStreamUnspecified=-1
UserName 指定用户名，可不指定。
Password 指定用户名的密码

Read 方法
使用方法如下：
Object.Read(Numbytes)
说明：读取指定长度的二进制内容。
参数说明：Numbytes指定的要读取的找度，不指定则读取全部。

ReadText 方法
使用方法如下：
Object.ReadText(NumChars)
说明：读取指定长度的文本
参数说明：NumChars指定的要读取的找度，不指定则读取全部。

SaveToFile 方法
使用方法如下：
Object.SaveToFile(FileName,[Options])
说明：将对像的内容写到FileName指定的文件中
参数说明：FileName指定的文件

Options 存取的选项，可不指定，可选参数如下：
adSaveCreateNotExist =1 指定文件不存在则创建
adSaveCreateOverWrite =2 覆盖

SetEOS 方法
使用方法如下：
Object.setEOS()
说明：返回对像内数据是否为空

SkipLine 方法
使用方法如下：
Object.SkipLine()
说明：在读取textstream文件时跳过下一行

Write 方法
使用方法如下：
Object.Write(Buffer)
说明：将指定的数据装入对像中。
参数说明：Buffer 为指定的要写入的内容。

WriteText 方法
使用方法如下：
Object.Write(Data,[Options])
说明：将指定的文本数据装入对像中。
参数说明：Data 为指定的要写入的内容。

Options 写入的选项
，可不指定，可选参数如下：
adWriteChar =0
adWriteLine =1


有下列属性：
Charset
EOS 返回对像内数据是否为空。

LineSeparator 指定换行格式，可选参数有
adCR =13
adCRLF =-1
adLF =10

Mode 指定或返加模式。

Position 指定或返加对像内数据的当前指针。

Size 返回对像内数据的大小。

State 返加对像状态是否打开。

Type 指定或返回的数据类型，可选参数为：
adTypeBinary =1
adTypeText =2

例子：

adodb.stream 的使用地方很多 这里ME只讲一讲使用 adodb.stream 组 替代 FSO 实现读取文件的方法 --- 网上流行的一些无组件上传程序全部基于这个写成的 哈哈
因为直接讲可能会使一大半人头脑发晕 所以ME们在这里先写一个例子 看不明白不要紧 后面后一条一条的进行解释
1 On Error Resume Next
2 Set stream=Server.CreateObject("Adodb.Stream")
3 If Err.Number=-2147221005 Then
4 Response.Write "<div align='center'>非常遗憾,您的主机不支持ADODB.Stream,不能使用本程序</div>"
5 Err.Clear
6 Response.End
7 End If
8 stream.type=2
9 stream.mode=3
10 stream.open
11 dim filepath
12 filepath="a.txt"
13 stream.LoadFromFile Server.Mappath(filepath)
14 If Err.Number<>0 Then
15 Response.Write "<div align='center'>文件<font color='#ff0000'>"&Filepath&"</font>无法被打开，请检查是否存在!< /font></div>"
16 Err.Clear
17 Response.End
18 End If
19 stream.Charset="gb_2312"
20 stream.position=2
21 dim loadfile
22 loadfile=steam.readtext
23 stream.close
24 set stream=nothing
到这里读出的工作就完成了
下面来一句一句的解释
第一句不要解释了吧 会点英语的光看意思就知道了 就是 在遇到错误的时候假定到下一行 也就是如果错误不中断程序从下一句继续执行了
第二句 为 创建 stream 对象 3-7为进行错误判断 可以不写
8,9分别设置stream对象 返回 数据的类型和打开的模式
type属性 设置 stream 对象返回的数据类型 有两个值 1 返回二进制 2 返回文本
mode属性 为打开模式 1.只读 2.只写 3.读写 还有一些其它的 这里就不写了
10 句 是打开对象 只有打开后 以后的方法如 loadFromFile才能使用
11,12,13是使用loadFromFile 将文件 a.txt 里的内容 读入 stream对象里(注意是读入这个对象中，并没有另开一个变量空间)
14-18 一样是错误判断啊
19 Charset设置返回数据类型的编码格式 这里设的是 简体中文
20 Position 设置文件读取的当前指针位 也就是当前指向的是第几个字符了
21,22使用readtext的方法将对象里的内容(就是先前用LOADFROMFILE读进来的内容)写入loadfile变量
后面两句是 关闭 和 销毁 对象
当然这只是读取
要想将其内容写入一文件 可以使用 savetofile(filename,[adsavecreatenotexist|adsavecreateoverwrite])
要想往其内容里写入内容 可以使用 write(buffer) 和writetext(data,[adwritechar|adwriteline])
将一个对象的内容复制到另一个对象里
Object.CopyTo(destStream,[CharNumber])
其中destStream为另一对象 charnumber 为要复制文件的大小 不设为全部 这个在上传里必须用到 啊 哈哈
好了 就写到这里了 希望给看到的人 并需要使用他的人 有点 帮助



///////////////////////////////////////////////////////////////////////////

目前有很多无组件上传类，我大概看了一下，大多写的相当复杂，有的居然还只能传文本
最关键的是没有10行代码以下的 ：）
我花了一个晚上时间研究了一下ADODB.Stream，并且用了6行代码实现了无组件上传：

strFileName = Request.QueryString("file1")
Set objStream = Server.CreateObject("ADODB.Stream")
objStream.Type = 1 ' adTypeBinary
objStream.Open
objStream.LoadFromFile strFileName
objStream.SaveToFile Server."123_onweb.gif",2

使用方法：

把上面的代码写成upload.asp
在浏览器里面输入：
http://XXX/upload.asp?file1=c:\上传文件\123.gif
XXX为你的主机地址
执行完后你会看到你的目录下面多了一个123_onweb.gif
他就是你要文件拉！！！！

根据原理我们可以扩展以下代码：
upload.asp文件
<%
Function GetFileName(ByVal strFile)
If strFile <> "" Then
GetFileName = mid(strFile,InStrRev(strFile, "\")+1)
Else
GetFileName = ""
End If
End function

strFileName = Request.Form("file1")
Set objStream = Server.CreateObject("ADODB.Stream")
objStream.Type = 1 ' adTypeBinary
objStream.Open
objStream.LoadFromFile strFileName
objStream.SaveToFile Server.MapPath(GetFileName(strFileName)),2
objStream.Close
%>

upload.htm文件
<form name="FORM" action="upload.asp" method="post">
<input type="submit" name="submit" value="OK">
<input type="file" name="file1" style="width:400" value="">
</form>

前几天要写一个东西里面有用到读文件的。

可是我不想用FSO，我怕有的空间不支持。
可是网络上找了半天没有找到一个不是用FSO写的。

还是自己做了一个。

我记得以前在做无组件上传，并保存文件的时候有用到stream
我发现有一个LoadFromFile的方法。可以读取文件。
下面是我的代码。

function readfile(URL,chartype)
set srmObj = server.CreateObject("adodb.stream")
srmObj.type=1
srmObj.mode=3
srmObj.open
srmObj.Position=0
srmObj.LoadFromFile URL

srmObj.Position = 0
srmObj.type=2
srmObj.charset=chartype
readfile=srmObj.readtext()

end function

两个参数。URL是文件的路径，好像只能绝对路径。chartype是文件以什么编码存放的。

返回一个字符串，存放文件的内容。

这个函数只能读文本文件。读二进制文件也差不多。要用的人可以自己改

;;总结：Autocad 与 Excel 通讯的一般步骤

;;1 建立连接

(if
  (not
    (setq excel (vlax-get-or-create-object "Excel.Application")) ;_ Excel ActiveX
  )
   (progn
     (princ "\nExcel not Install!")
     (exit) ;_无法建立时程序退出
   )
)

;;2 获得 Workbooks
(setq wks (vlax-get excel 'workbooks))

;;3 用 Workbooks 的 Open 或者 Add 方法打开或者建立新的Workbook
(setq shts (vlax-invoke wks 'open fl))

;;4 获取 excel 的 Sheets (工作簿)
(setq sht (vlax-get excel 'sheets))

;;5 依次处理 Sheet
(vlax-for sh sht ...)

;;6 获取 Sheet 中的 Cells (单元格集合)
(vlax-get sh 'Cells)

;;7 用 item 属性就可以得到指定的单元格了
(vlax-get-property cells 'item 1 2)

;;8 后面就是根据需要对 Cell 进行各种操作

;;Author: eachy 2010.06.25
(defun c:tt (/ fl excel fn fp wks shts sht na uc nfl cells i j lst
      maxrows nfp)
  (if (setq fl (getfiled "Please Select Excel files" "" "xlsx;xls" 8)) ;_excel Filename
    (progn
      (if
 (not
   (setq excel (vlax-get-or-create-object "Excel.Application")) ;_ Excel ActiveX
 )
  (progn
    (princ "\nExcel not Install!")
    (exit)
  )
      )
      (setq fn (vl-filename-base fl) ;_ Excel FileName
     fp (vl-filename-directory fl) ;_ Excel File Directory
      )
      (setq wks  (vlax-get excel 'workbooks) ;_ Workbooks
     shts (vlax-invoke wks 'open fl) ;_ Open Excel file , also can use Excel Findfile property
      )
      (setq sht (vlax-get excel 'sheets)) ;_Get Sheets
      (vlax-for sh sht ;_ Foreach all sheet
 (setq na      (vlax-get sh 'name) ;_ Sheet Name
       uc      (vlax-get sh 'usedrange) ;_UsedRange
       maxRows (vlax-get (vlax-get uc 'Rows) 'Count) ;_Number of Bottom Row in Used
       cells   (vlax-get sh 'Cells) ;_ActiveSheet Cells
       i       7
 )
 (while (<= i maxrows) ;_Get Needed Rangs
   (setq lst (cons (list
       (vlax-get (variant-value
     (vlax-get-property cells 'item i 2)
          )
          'text
       )
       (vlax-get (variant-value
     (vlax-get-property cells 'item i 3)
          )
          'text
       )
       (vlax-get (variant-value
     (vlax-get-property cells 'item i 4)
          )
          'text
       )
     )
     lst
      )
  i   (1+ i)
   )

  (setq lst nil)
 )
 (setq lst
        (vl-remove
   nil
   (reverse
     (mapcar
       '(lambda (x)
   (setq
     x
      (mapcar '(lambda (a) (vl-string-trim " " a))
       x
      )
   )
   (if (vl-every '(lambda (x) (= x "")) x)
     nil
     (if (= (last x) "")
       (list (car x) (cadr x))
       x
     )
   )
        )
       lst
     )
   )
        )
 ) ;_Prosss Space
 ;;Follow to write hdm files
 (setq nfl (strcat fp "\\" fn "_" na ".hdm"))
 (setq nfp (open nfl "w"))
 (write-line "zgh" nfp)
 (write-line "BEGIN,坝中1.00:1" nfp)
 (foreach x lst
   (if (= 3 (length x))
     (write-line
       (strcat (car x) "," (cadr x) "(" (last x) ")")
       nfp
     )
     (write-line (strcat (car x) "," (cadr x)) nfp)
   )
 )
 (close nfp)
      )
      (vlax-invoke-method excel "quit") ;_closed excel
      (if (vlax-object-released-p excel)
 (vlax-release-object excel) ;_this can not close excel
      )
    )
  )
  (princ)
)

原文地址：http://www.alchemy3d.cn/blog/post/4.html

透视投影是3D固定流水线的重要组成部分，是将相机空间中的点从视锥体(frustum)变换到规则观察体(Canonical View Volume)中，待裁剪完毕后进行透视除法的行为。在算法中它是通过透视矩阵乘法和透视除法两步完成的。

透视投影变换是令很多刚刚进入3D图形领域的开发人员感到迷惑乃至神秘的一个图形技术。其中的理解困难在于步骤繁琐，对一些基础知识过分依赖，一旦对它们中的任何地方感到陌生，立刻导致理解停止不前。

没错，主流的3D APIs如OpenGL、D3D的确把具体的透视投影细节封装起来，比如

gluPerspective(…)就可以根据输入生成一个透视投影矩阵。而且在大多数情况下不需要了解具体的内幕算法也可以完成任务。但是你不觉得，如果想要成为一个职业的图形程序员或游戏开发者，就应该真正降伏透视投影这个家伙么？我们先从必需的基础知识着手，一步一步深入下去（这些知识在很多地方可以单独找到，但我从来没有在同一个地方全部找到，但是你现在找到了）。

我们首先介绍两个必须掌握的知识。有了它们，我们才不至于在理解透视投影变换的过程中迷失方向（这里会使用到向量几何、矩阵的部分知识，如果你对此不是很熟悉，可以参考

可以找到一组坐标(v1,v2,v3)，使得

v = v1 a + v2 b + v3 c （1）

而对于一个点p，则可以找到一组坐标（p1,p2,p3），使得

p - o = p1 a + p2 b + p3 c （2）

从上面对向量和点的表达，我们可以看出为了在坐标系中表示一个点（如p），我们把点的位置看作是对这个基的原点o所进行的一个位移，即一个向量 --p - o（有的书中把这样的向量叫做位置向量--起始于坐标原点的特殊向量），我们在表达这个向量的同时用等价的方式表达出了点p:

p = o + p1 a + p2 b + p3 c (3)

(1)(3)是坐标系下表达一个向量和点的不同表达方式。这里可以看出，虽然都是用代数分量的形式表达向量和点，但表达一个点比一个向量需要额外的信息。如果我写出一个代数分量表达(1, 4, 7)，谁知道它是个向量还是个点！

我们现在把（1）（3）写成矩阵的形式：

这里(a,b,c,o)是坐标基矩阵，右边的列向量分别是向量v和点p在基下的坐标。这样，向量和点在同一个基下就有了不同的表达：3D向量的第4个代数分量是0，而3D点的第4个代数分量是1。像这种这种用4个代数分量表示3D几何概念的方式是一种齐次坐标表示。

"齐次坐标表示是计算机图形学的重要手段之一，它既能够用来明确区分向量和点，同时也更易用于进行仿射（线性）几何变换。"-- F.S. Hill, JR

这样，上面的(1, 4, 7)如果写成（1,4,7,0），它就是个向量；如果是(1,4,7,1)，它就是个点。

下面是如何在普通坐标(Ordinary Coordinate)和齐次坐标(Homogeneous Coordinate)之间进行转换：

从普通坐标转换成齐次坐标时，

如果(x,y,z)是个点，则变为(x,y,z,1);

如果(x,y,z)是个向量，则变为(x,y,z,0)

从齐次坐标转换成普通坐标时，

如果是(x,y,z,1)，则知道它是个点，变成(x,y,z);

如果是(x,y,z,0)，则知道它是个向量，仍然变成(x,y,z)

以上是通过齐次坐标来区分向量和点的方式。从中可以思考得知，对于平移T、旋转R、缩放S这3个最常见的仿射变换，平移变换只对于点才有意义，因为普通向量没有位置概念，只有大小和方向，这可以通过下面的式子清楚地看出：

而旋转和缩放对于向量和点都有意义，你可以用类似上面齐次表示来检测。从中可以看出，齐次坐标用于仿射变换非常方便。

此外，对于一个普通坐标的点P=(Px, Py, Pz)，有对应的一族齐次坐标(wPx, wPy, wPz, w)，其中w不等于零。比如，P(1, 4, 7)的齐次坐标有(1, 4, 7, 1)、（2, 8, 14, 2）、（-0.1, -0.4, -0.7, -0.1）等等。因此，如果把一个点从普通坐标变成齐次坐标，给x,y,z乘上同一个非零数w，然后增加第4个分量w；如果把一个齐次坐标转换成普通坐标，把前三个坐标同时除以第4个坐标，然后去掉第4个分量。

由于齐次坐标使用了4个分量来表达3D概念，使得平移变换可以使用矩阵进行，从而如F.S. Hill, JR所说，仿射（线性）变换的进行更加方便。由于图形硬件已经普遍地支持齐次坐标与矩阵乘法，因此更加促进了齐次坐标使用，使得它似乎成为图形学中的一个标准。

简单的线性插值

这是在图形学中普遍使用的基本技巧，我们在很多地方都会用到，比如2D位图的放大、缩小，Tweening变换，以及我们即将看到的透视投影变换等等。基本思想是：给一个x属于[a, b]，找到y属于[c, d]，使得x与a的距离比上ab长度所得到的比例，等于y与c的距离比上cd长度所得到的比例，用数学表达式描述很容易理解：

这样，从a到b的每一个点都与c到d上的唯一一个点对应。有一个x，就可以求得一个y。

此外，如果x不在[a, b]内，比如x < a或者x > b，则得到的y也是符合y < c或者y > d，比例仍然不变，插值同样适用。

透视投影变换

好，有了上面两个理论知识，我们开始分析这次的主角--透视投影变换。这里我们选择OpenGL的透视投影变换进行分析，其他的APIs会存在一些差异，但主体思想是相似的，可以类似地推导。经过相机矩阵的变换，顶点被变换到了相机空间。这个时候的多边形也许会被视锥体裁剪，但在这个不规则的体中进行裁剪并非那么容易的事情，所以经过图形学前辈们的精心分析，裁剪被安排到规则观察体(Canonical View Volume, CVV)中进行，CVV是一个正方体，x, y, z的范围都是[-1，1]，多边形裁剪就是用这个规则体完成的。所以，事实上是

透视投影变换由两步组成：

1） 用透视变换矩阵把顶点从视锥体中变换到裁剪空间的CVV中。

2） CVV裁剪完成后进行透视除法（一会进行解释）。

我们一步一步来，我们先从一个方向考察投影关系。

上图是右手坐标系中顶点在相机空间中的情形。设P(x,z)是经过相机变换之后的点，视锥体由eye--眼睛位置，np--近裁剪平面，fp--远裁剪平面组成。N是眼睛到近裁剪平面的距离，F是眼睛到远裁剪平面的距离。投影面可以选择任何平行于近裁剪平面的平面，这里我们选择近裁剪平面作为投影平面。设P'(x',z')是投影之后的点，则有z' = -N。通过相似三角形性质，我们有关系：

同理，有

这样，我们便得到了P投影后的点P'

从上面可以看出，投影的结果z'始终等于-N，在投影面上。实际上，z'对于投影后的P'已经没有意义了，这个信息点已经没用了。但对于3D图形管线来说，为了便于进行后面的片元操作，例如z缓冲消隐算法，有必要把投影之前的z保存下来，方便后面使用。因此，我们利用这个没用的信息点存储z，处理成：

这个形式最大化地使用了3个信息点，达到了最原始的投影变换的目的，但是它太直白了，有一点蛮干的意味，我感觉我们最终的结果不应该是它，你说呢？我们开始结合CVV进行思考，把它写得在数学上更优雅一致，更易于程序处理。假设能够把上面写成这个形式：

那么我们就可以非常方便的用矩阵以及齐次坐标理论来表达投影变换：

其中

哈，看到了齐次坐标的使用，这对于你来说已经不陌生了吧？这个新的形式不仅达到了上面原始投影变换的目的，而且使用了齐次坐标理论，使得处理更加规范化。注意在把变成的一步我们是使用齐次坐标变普通坐标的规则完成的。这一步在透视投影过程中称为透视除法（Perspective Division），这是透视投影变换的第2步，经过这一步，就丢弃了原始的z值（得到了CVV中对应的z值，后面解释），顶点才算完成了投影。而在这两步之间的就是CVV裁剪过程，所以裁剪空间使用的是齐次坐标，主要原因在于透视除法会损失一些必要的信息（如原始z，第4个-z保留的）从而使裁剪变得更加难以处理，这里我们不讨论CVV裁剪的细节，只关注透视投影变换的两步。

矩阵

就是我们投影矩阵的第一个版本。你一定会问为什么要把z写成

有两个原因：

1） P'的3个代数分量统一地除以分母-z，易于使用齐次坐标变为普通坐标来完成，使得处理更加一致、高效。

2） 后面的CVV是一个x,y,z的范围都为[-1，1]的规则体，便于进行多边形裁剪。而我们可以适当的选择系数a和b，使得这个式子在z = -N的时候值为-1，而在z = -F的时候值为1，从而在z方向上构建CVV。

接下来我们就求出a和b：

这样我们就得到了透视投影矩阵的第一个版本：

使用这个版本的透视投影矩阵可以从z方向上构建CVV，但是x和y方向仍然没有限制在[-1,1]中，我们的透视投影矩阵的下一个版本就要解决这个问题。

为了能在x和y方向把顶点从Frustum情形变成CVV情形，我们开始对x和y进行处理。先来观察我们目前得到的最终变换结果：

我们知道-Nx / z的有效范围是投影平面的左边界值（记为left）和右边界值（记为right），即[left, right]，-Ny / z则为[bottom, top]。而现在我们想把-Nx / z属于[left, right]映射到x属于[-1, 1]中，-Ny / z属于[bottom, top]映射到y属于[-1, 1]中。你想到了什么？哈，就是我们简单的线性插值，你都已经掌握了！我们解决掉它：

则我们得到了最终的投影点：

下面要做的就是从这个新形式出发反推出下一个版本的透视投影矩阵。注意到是经过透视除法的形式，而P'只变化了x和y分量的形式，az+b和-z是不变的，则我们做透视除法的逆处理--给P'每个分量乘上-z，得到

而这个结果又是这么来的：

则我们最终得到：

M就是最终的透视变换矩阵。相机空间中的顶点，如果在视锥体中，则变换后就在CVV中。如果在视锥体外，变换后就在CVV外。而CVV本身的规则性对于多边形的裁剪很有利。OpenGL在构建透视投影矩阵的时候就使用了M 的形式。注意到M的最后一行不是(0 0 0 1)而是(0 0 -1 0)，因此可以看出透视变换不是一种仿射变换，它是非线性的。另外一点你可能已经想到，对于投影面来说，它的宽和高大多数情况下不同，即宽高比不为1，比如640/480。而CVV的宽高是相同的，即宽高比永远是1。这就造成了多边形的失真现象，比如一个投影面上的正方形在CVV的面上可能变成了一个长方形。解决这个问题的方法就是在对多变形进行透视变换、裁剪、透视除法之后，在归一化的设备坐标(Normalized Device Coordinates)上进行的视口(viewport)变换中进行校正，它会把归一化的顶点之间按照和投影面上相同的比例变换到视口中，从而解除透视投影变换带来的失真现象。进行校正前提就是要使投影平面的宽高比和视口的宽高比相同。

便利的投影矩阵生成函数

3D APIs都提供了诸如gluPerspective(fov, aspect, near, far)或者D3DXMatrixPerspectiveFovLH(pOut, fovY, Aspect, zn, zf)这样的函数为用户提供快捷的透视矩阵生成方法。我们还是用OpenGL的相应方法来分析它是如何运作的。

gluPerspective(fov, aspect, near, far)

fov即视野，是视锥体在xz平面或者yz平面的开角角度，具体哪个平面都可以。OpenGL和D3D都使用yz平面。

aspect即投影平面的宽高比。

near是近裁剪平面的距离

far是远裁剪平面的距离。

上图中左边是在xz平面计算视锥体，右边是在yz平面计算视锥体。可以看到左边的第3步top = right / aspect使用了除法（图形程序员讨厌的东西），而右边第3步right = top x aspect使用了乘法，这也许就是为什么图形APIs采用yz平面的原因吧！

下篇

原文地址：http://www.alchemy3d.cn/blog/post/5.html

在上一篇文章中我们讨论了透视投影变换的原理，分析了OpenGL所使用的透视投影矩阵的生成方法。正如我们所说，不同的图形API因为左右手坐标系、行向量列向量矩阵以及变换范围等等的不同导致了矩阵的差异，可以有几十个不同的透视投影矩阵，但它们的原理大同小异。这次我们准备讨论一下 Direct3D（以下简称D3D）以及J2ME平台上的JSR184（M3G）（以下简称M3G）的透视投影矩阵，主要出于以下几个目的：

（1） 我们在写图形引擎的时候需要采用不同的图形API实现，当前主要是OpenGL和D3D。虽然二者的推导极为相似，但D3D的自身特点导致了一些地方仍然需要澄清。

（2） DirectX SDK的手册中有关于透视投影矩阵的一些说明，但并不详细，甚至有一些错误，从而使初学者理解起来变得困难，而这正是本文写作的目的。

（3） M3G是J2ME平台上的3D开发包，采用了OpenGL作为底层标准进行封装。它的透视投影矩阵使用OpenGL的环境但又进行了简化，值得一提。

本文努力让读者清楚地了解D3D与M3G透视投影矩阵的原理，从而能够知道它与OpenGL的一些差别，为构建跨API的图形引擎打好基础。需要指出的一点是为了完全理解本文的内容，请读者先理解上一篇文章《深入探索透视投影变换》的内容，因为OpenGL和它们的透视投影矩阵的原理非常相似，因此这里不会像上一篇文章从基础知识讲起，而是对比它们的差异来推导变换矩阵。我们开始！

OpenGL 与D3D的基本差异

前面提到，不同API的基本差异导致了最终变换矩阵的不同，而导致OpenGL和D3D的透视投影矩阵不同的原因有以下几个：

（1） OpenGL默认使用右手坐标系，而D3D 默认使用左手坐标系。

（2） OpenGL使用列向量矩阵乘法而D3D使用行向量矩阵乘法。

（3） OpenGL的CVV的Z范围是[-1, 1]，D3D的CVV的Z范围是[0, 1]。

以上这些差异导致了最终OpenGL和D3D的透视投影矩阵的不同。

D3D的透视投影矩阵推导

我们先来看最最基本的透视关系图（上一篇文章开始的时候使用的图）：

这里我们考察的是xz平面上的关系，yz平面上的关系同理。这里o是相机位置。np是近裁剪平面，也是投影平面，N是它到相机的距离。fp是远裁剪平面，F是它到相机的位置。p是需要投影的点，p'是投影之后的点。根据相似三角形定理，我们有

则有

注意到OpenGL使用右手坐标系，因此应该使用-N（请参考上一篇文章的这一步），而D3D使用左手坐标系，因此使用N，这是二者的不同点之一。这样，我们得到投影之后的点

第三个信息点是变换之后的z在投影平面上的位置，也就是N，它已经没用了，我们把p'写成

从而用第三个没用信息点它来存储z（如果读者对这一点不太了解，请参考上一篇文章）。接下来我们求出a和b，从而在z方向上构建CVV。请注意这里是OpenGL和D3D的另一个不同点，OpenGL的CVV的z范围是[-1, 1]，而D3D的CVV的z范围是[0, 1]。也就是说，D3D 中在近裁剪平面上的点投影之后的点会处于CVV的z=0平面上，而在远裁剪平面上的点投影之后的点会在CVV的z=1平面上。这样我们的计算方程就是

从而我们得到了透视投影矩阵的第一个版本

即

这个时候第三个分量变换到CVV情形了，CVV的z范围是[0,1]。接下来根据上一篇文章所讲到的，我们要把前两个分量变成CVV情形，CVV的 x和y范围是[-1, 1]，如下图所示：

使用线性插值，我们有：

这里left和right是投影平面的左右范围，top和bottom是投影平面的上下范围。xcvv和ycvv是我们需要算出的在CVV情形中的 x和y，也就是我们要计算出的结果。但在算出它们之前，我们先把上面的式子写成：

这里有一个需要注意的地方，如果投影平面在x方向上居中，则

那么第一个式子就可以销掉等号两边的1/2，写成

同理，如果投影平面在y方向上居中，则第二个式子可以写成

则我们现在分两种情况讨论：

（1） 投影平面的中心和x-y平面的中心重合（在x和y方向上都居中）

（2） 一般情况

我们分别讨论：

（1）特殊情况方程

这组是特殊情况，方程比较简单，但也是使用频率最高的方式（这是D3DXMatrixPerspectiveLH、 D3DXMatrixPerspectiveRH、D3DXMatrixPerspectiveFovLH、 D3DXMatrixPerspectiveFovRH四个方法所使用的情况）。我们导出它：

则我们反推出透视投影矩阵：

其中

而r-l和t-b可以分别看作是投影平面的宽w和高h。最后那个矩阵就是D3D的透视投影矩阵之一。另外呢，如果我们不知道right、left、 top以及bottom这几个参量，也可以根据视野（FOV - Field Of View）参量来求得。下面是两个平面的视野关系图：

其中，两个fov分别是在x-z以及y-z平面上的视野。如果只给了一个视野，也可以通过投影平面的宽高比计算出来：

用一个视野算出w或者h，然后用宽高比算出h或者w。

（2）一般情况的方程

这组方程比较繁琐，但更具一般性（和OpenGL一般矩阵的推导一致，这也是D3DXMatrixPerspectiveOffCenterLH和 D3DXMatrixPerspectiveOffCenterRH两个方法所使用的情况）。我们导出它：

我们继续反推出透视投影矩阵：

其中

最后那个矩阵就是D3D的一般透视投影矩阵。

好了，目前为止，我们已经导出了D3D的两个透视投影矩阵。下面我把上一篇导出的OpenGL的透视投影矩阵写出来，大家可以拿它和刚刚导出的 D3D的一般性透视投影矩阵做一个对比。

如果仔细观察，可以发现二者在元素的布局上是一个转置的关系，这个就是由它们使用的左右手坐标系以及使用的行列矩阵的差异造成的。而另外在一些元素的细节上也存在着差异，这是由于D3D的CVV的z范围不同造成的。可见在原理相同的情况下，细微的环境差异可以造成非常大的变化，而这就是透视投影矩阵存在诸多不同版本的原因。一般情况的透视投影矩阵也可以使用视野方式来定义，方法和特殊情况相同。

M3G 的透视投影矩阵

M3G是对OpenGL进行的一个封装，它的透视投影变换矩阵被放到了类Camera里面。因为它封装了OpenGL，因此环境和OpenGL相同：右手坐标系、列向量乘法、CVV范围[-1， 1]。它唯一和OpenGL有些差异的地方就在于它只使用投影平面的中心和x-y平面的中心重合（在x和y方向上都居中）的情况（就是我们上面D3D的第一种特殊情况）。我们用OpenGL透视投影矩阵最终版本来说明（再次提醒，如果读者对此感到迷惑，请参考第一篇文章）：

上面是OpenGL透视投影矩阵的最终版本，也是一般性版本，我们要把它变成特殊性，版本，非常简单，和上面D3D的特殊情况一样，我们从对x和y 进行插值的那一步来看：

和D3D的第一种情况一样，销掉两边的1/2，得到：

则我们反推出透视投影矩阵：

最右边那个矩阵就是M3G的透视投影矩阵。仍然可以通过视野参数来设置透视投影矩阵，这里请读者自行推导，方法与上面D3D的完全相同。

二维图形的几何变换

    正如我们在附录中提到的那样，用齐次坐标表示点的变换将非常方便，因此在本节中所有的几何变换都将采用齐次坐标进行运算。二维齐次坐标变换的矩阵的形式是：
                
这个矩阵每一个元素都是有特殊含义的。
形进行平移变换；[g h]是对图形作投影变换；[i]则是对图形整体进行缩放变换。
1）平移变换


2）缩放变换


3）旋转变换



4）对称变换

对称变换其实只是a、b、d、e取0、1等特殊值产生的一些特殊效果。例如：

1. 当b=d=0，a=-1，e=1 时有x^´=-x，y^´=y，产生与y轴对称的图形。

2. 当b=d=0，a=-1，e=-1时有x^´=x，y^´=-y，产生与x轴对称的图形。

3. 当b=d=0，a=e=-1时有x^´=-x，y^´=-y，产生与原点对称的图形。

4. 当b=d=1，a=e=0时有x^´=y，y^´=x，产生与直线y=x对称的图形。

5. 当b=d=-1，a=e=0时有x^´=-y，y^´=-x，产生与直线y=-x对称的图形。

5）错切变换

1. 当d=0时，x^´=x+by，y^´=y，此时，图形的y坐标不变，x坐标随初值  （x，y）及变换系数b作线性变化。

2. 当b=0时，x^´=x，y^´=dx+y，此时，图形的x坐标不变，y坐标随初值  （x，y）及变换系数d作线性变化。

6）复合变换

如果图形要做一次以上的几何变换，那么可以将各个变换矩阵综合起来进行一步到位的变换。复合变换有如下的性质：

1. 复合平移

   对同一图形做两次平移相当于将两次的平移两加起来：
   

2. 复合缩放

   两次连续的缩放相当于将缩放操作相乘：

   

3. 复合旋转

   两次连续的旋转相当于将两次的旋转角度相加： 缩放、旋转变换都与参考点有关，上面进行的各种变换都是以原点为参考点的。如果相对某个一般的参考点（x_f，y_f）作缩放、旋转变换，相当于将该点移到坐标原点处，然后进行缩放、旋转变换，最后将（x_f，y_f）点移回原来的位置。切记复合变换时，先作用的变换矩阵在右端，后作用的变换矩阵在左端。

4. 关于（x_f，y_f）点的缩放变换

   

   

5. 绕（x_f，y_f）点的旋转变换

   

Qleader 设置中有个“默认提示文字宽度”选项，默认是勾选的，当去除后保持图形，下次打开设置中会保持，这说明该选项是随图保存的，翻遍了Help也没有找到变量控制。经过一番研究，终于找到了存储位置:)

1 打开一个新图，什么都不做，直接另存为 dxf

2 另开一个新图，运行 Qleader -〉设置-〉去掉“默认提示文字宽度”选项，确认退出，不要标注，另存为 dxf

3 用 Uedit 或者其他软件比较两个 dxf，找出不同点

经过查找，排除一些无关的差异（比如编辑时间等等），会找到一个 68 的位置由 1 变为 0，初步判断应该是这里（Acad 中 1 和 0 很多地方表示开关），往前翻，看到 Xrecord 字样，再找到前面最近的 5 （5 是句柄标志），打开该 dxf，用 handent 查找这个句柄，会看到是 AcadDim 词典，再次试验 Qleader 命令，

勾选时状态：

_$ (dictsearch (namedobjdict) "AcadDim")
((-1 . <图元名: 7eb1e4b8>) (0 . "XRECORD") (5 . "2FF7") (102 . "{ACAD_REACTORS") (330 . <图元名: 7efc0c60>) (102 . "}") (330 . <图元名: 7efc0c60>) (100 . "AcDbXrecord") (280 . 1) (90 . 990106) (3 . "") (60 . 0) (61 . 0) (62 . 1) (63 . 3) (64 . 0) (65 . 0) (66 . 0) (67 . 3) (68 . 1) (69 . 0) (70 . 0) (71 . 0) (72 . 0) (40 . 0.0) (170 . 0))
_$

关闭默认：

_$ (dictsearch (namedobjdict) "AcadDim")
((-1 . <图元名: 7eb1e9e0>) (0 . "XRECORD") (5 . "3094") (102 . "{ACAD_REACTORS") (330 . <图元名: 7efc0c60>) (102 . "}") (330 . <图元名: 7efc0c60>) (100 . "AcDbXrecord") (280 . 1) (90 . 990106) (3 . "") (60 . 0) (61 . 0) (62 . 1) (63 . 3) (64 . 0) (65 . 0) (66 . 0) (67 . 3) (68 . 0) (69 . 0) (70 . 0) (71 . 0) (72 . 0) (40 . 0.0) (170 . 0))
_$

其他的没有操作命令没有，可以看到只有 68 发生了变化，可以断定就是这个值了，下面用 Lisp 试试

(vl-catch-all-apply
  (function
    (lambda (/ acdim)
      (setq acdim (dictsearch (namedobjdict) "Acaddim"))
      (if (assoc 68 acdim)
 (entmod (subst '(68 . 0)
         '(68 . 1)
         acdim
  )
 )
      )
    )
  )
  nil
)

用 entmod 测试成功。

通过这个可以看到 Cad 中的有些命令的默认值是保存在词典中，只是没有相关资料，要自己动手试验。而且这个 AcadDim 词典要在用过 Dim 类命令后就会自动生成，打开cad不做任何操作是没有这个词典的。其他的参数暂时没有试验是控制哪些选项的，有兴趣了再试！

(defun c:tt (/ ss ssl i e el ll d hi p vh vx vy str)
  (if (setq ss (ssget '((0 . "text"))))
    (progn
      (setq ssl    (sslength ss)
        i    -1
      )
      (repeat ssl
    (setq e     (ssname ss (setq i (1+ i)))
          el (entget e)
    )
    (if ll
      (setq ll (cons el ll))
      (setq ll (list el))
    )
      )
      (setq
    ll (vl-sort ll
            '(lambda (e1 e2)
               (> (caddr (assoc 10 e1)) (caddr (assoc 10 e2)))
             )
       )
      )
      (setq p  (cdr (assoc 10 (car ll)))
        vx (car p)
        vy (cadr p)
        i  1
      )
      (setq d (getdist p "\n行距: "))
      (setq hi (getdist    p
            (strcat    "\n字高<"
                (rtos (cdr (assoc 40 (car ll)))
                      2
                      2
                )
                ">: "
            )
           )
      )
      (if hi
    (setq vh (cons 40 hi))
      )
      (foreach x ll
    (if vh
      (entmod (subst vh (assoc 40 x) x))
    )
    (setq str (vl-string-left-trim " " (cdr (assoc 1 x))))
    (if (wcmatch str "[0-9]*")
      (setq    str (vl-string-left-trim "1234567890" str)
        el  (subst (cons 1 (strcat (itoa i) str)) (assoc 1 x) x)
        i   (1+ i)
      )
      (setq el x)
    )
    (setq el (subst (list 10 vx vy 0.) (assoc 10 x) el))
    (entmod el)
    (if d
      (setq vy (- vy d))
    )
   )
   )
  )
  (princ)
)

利用以前写的代码，写了几个排序设置函数

1 ea:Num->hz
调用格式：(Ea:num->hz string mod)
参    数：String - 数字字符串
          Mod    - T 中文数字，nil 大写中文

2 ybl-ent-sort
调用格式：(ybl-ent-sort lst mode key vx)
参数说明:
        1 mode 0 按行 1 按列
        2 key
             (mod = 0)    (mod = 1)
          1  Y降X升       X升Y降   (左上至右下)
          2  Y降X降       X降Y降   (右上至左下)
          3  Y升X降       X降Y升   (右下至左上)
          4  Y升X升       X升Y升   (左下至右上)
        3 vx 行(列)允许误差，为 nil 实取 0
        4 lst 表, 格式如下
          ((pt1 ent1) (pt2 ent2) ... (ptn entn))
          a pt 为 ent 的特征点， ent 可以为 entity 或 vla-object
            比如对文字排序，pt 可以使用文字的插入点
            
          b 当 pt 为实数时，vx 为行列最大及最小值的差值，此时 mode key 为任意值
            如一组数 (1 3 56 89 56 45 6 8 45 91 45 69 78 15 12 11) vx 取 10
            排序后为 ((1 3 6 8 11) (12 15) (45 45 45) (56 56) (69 78) (89 91))
            总表及子表均为由小到大排列
        
返 回 值: 表，子表为按要求排列的 行/列
说    明: 因为是 lisp 函数，本函数内部并不对数据的合法性进行检查，以提高程序的效率
          使用前确保各参数的的正确性
|;
3 Ea:SortList
调用格式：(ea:sortlist pl row smod num spa vx cn)
参数说明：
;; pl 排序表((pt1 obj1) (pt2 obj2) ... )
;; row  0 按行 1 按列
;; smod 排序方式
;;      1  Y降X升       X升Y降   (左上至右下)
;;      2  Y降X降       X降Y降   (右上至左下)
;;      3  Y升X降       X降Y升   (右下至左上)
;;      4  Y升X升       X升Y升   (左下至右上)
;; num  string 起始序号
;; spa  string 步距
;; vx   行精度
;; cn   0 数字 1 大写中文  2 中文
;; 返回值： (((num1 pt1 obj1) (num2 pt2 obj2) ..) (...))
4 Ea:SortInit
调用格式：(ea:sortinit pl key)
参数说明：pl - 实体表，((pt1 obj1) (pt2 obj2) ....)
          key - "s" or nil
                "s" 时显示排序对话框
          当 pl = nil key = nil 时返回表 (row smod num spa vx cn)
          当 pl = nil key = "s" 时调用对话框设置并返回表 (row smod num spa vx cn)
          当 pl 不为空，key = nil 时调用 (ea:SortList pl row smod num spa vx cn)

http://eachy.bokee.com/inc/sortent.VLX

;;;************************************************************************ 
;;;一个求点集合的凸包的lisp程序-------------------------------------------- 
;;;------采用的算法为礼品包扎法-------------------------------------------- 
;;;方法为最右端的点开始处理，将该点作为凸包边界的第一个点P1，从最初的垂直线 
;;;方向绕P1顺时针旋转，直到碰到另一个P2这就是凸包边界的第二个点P2，依此类推 
;;;p2求得p3......直到又重新回到p1，已经考虑了各种退化情况和浮点运算，其算法 
;;;时间不超过O(n.h),其中h是凸包的复杂度，时间还是很快的。大家不妨验证。     
;;;参考文献<<计算几何-算法及其应用>>(第二版),以及参考了其他网站的一些源代码 
;;;------------------------------------------------------------------------ 
;;;其中程序主段是核心算法，其他的附加程序为取得点集，画凸包边界线，测试大量 
;;;点集函数处理所花费的时间。---------------------------------------------- 
;;;用法: 加载lisp运行test选取点，直线段，或多义线(全是直线段组成)即可。---- 
;;;************************************************************************ 
(defun C:test (/ sel t0 ptlist pp 2Pi) 
  (setq 2Pi (* 2 pi)) 
  ;;(setq	sel (ssget (list '(0 . "POINT"))))                  ;选择点集 
  (setq sel (ssget)) 
  (if (setq ptlist (getpt sel))                             ;构造点集 
    (progn 
      (setq t1 (getvar "CDATE"))                            ;计时开始 
      ;;(setq t0 (getvar "TDUSRTIMER"))                       ;开始计时 
      (setq p1 (hull ptlist))                               ;求凸包 
      (setq t2 (getvar "CDATE"))                            ;计时结束 
      (setq pp (Max-distance p1)) 
      (setq t3 (getvar "CDATE"))  
      (princ "\n求点集的凸包用时:") 
      (princ (* (- t2 t1) 1e6)) 
      (princ "秒") 
      (princ "\n凸包共有") 
      (princ (length p1)) 
      (princ "个顶点") 
      (princ "\n求凸包的直径用时:") 
      (princ (* (- t3 t2) 1e6)) 
      (princ "秒") 
      (princ "\n总用时=最大距离点对用时:") 
      (princ (* (- t3 t1) 1e6)) 
      (princ "秒")       
      ;;(princ (* (- (getvar "TDUSRTIMER") t0) 86400))        ;结束计时 
    ) 
  ) 
  (if (null pp) 
    (alert "点的有效数目太小，请重新输入!") 
    (entmake                                                ;画凸包 
      (append 
       '( (0 . "LWPOLYLINE") 
	  (100 . "AcDbEntity") 
	  (100 . "AcDbPolyline") 
	) 
	(list (cons 90 (length pp)))                        ;顶点个数 
	(mapcar '(lambda (x) (cons 10 x)) pp)               ;多段线顶点 
	(list (cons 70 0))                                  ;闭合的 
	(list (cons 62 1))                                  ;红色的 
      ) 
    ) 
  ) 
  (princ) 
) 
;;;========================== 
;;;程序主段，可以单独成为函数 
;;;========================== 
 
;;;右半部的凸包 
(defun hull1 (pts MaxPt MinPt / nextPt hullPt) 
  (if (< (length pts) 3) 
    pts 
    (progn 
      (setq nextPt (Max-angle1 pts MaxPt))                  ;从最上面的点开始 
      (setq hullPt (cons nextPt (cons MaxPt hullPt)))       ;顺时针求得第一点 
      (while (not (equal nextPt MinPt 1e-8))                ;到最下面的点为止 
        (setq nextPt (Max-angle pts nextPt))                ;循环求凸包每一点 
	(setq hullPt (cons nextPt hullPt))                  ;把每点加入凸包集 
      ) 
    ) 
  ) 
) 
;;;左半部的凸包 
(defun hull (ptlist / revPts 2ndPts maxYp1 minYp1 maxYp2 minYp2 
	              ptlst1 ptlst2 +ptlst -ptlst hullp1 hullp2) 
  (setq revPts (mapcar 'reverse ptlist))                    ;点表的X和Y交换 
  (setq 2ndPts (mapcar 'cadr ptlist))                       ;点表的Y值的表 
  (setq maxYp1 (reverse (assoc (apply 'max 2ndPts) revPts)));最上面的点 
  (setq minYp1 (reverse (assoc (apply 'min 2ndPts) revPts)));最下面的点 
  (setq maxYp2 (list (- (car maxYp1)) (cadr maxYp1)))       ;镜像后最上面的点 
  (setq minYp2 (list (- (car minYp1)) (cadr minYp1)))       ;镜像后最下面的点 
  (foreach n ptlist                                         ;把点表分成两部分 
    (if (> (det minYp1 n maxYp1) 0)                         ;如果左转 
      (setq ptlst1 (cons n ptlst1))                         ;加入右半部分 
      (setq ptlst2 (cons n ptlst2))                         ;否则左半部分 
    ) 
  ) 
  (setq +ptlst (cons minYp1 (cons maxYp1 ptlst1)))          ;右半部分 
  (setq -ptlst (Mirror-list-X ptlst2))                      ;左半部分以Y轴镜像 
  (setq hullp1 (hull1 +ptlst maxYp1 minYp1))                ;右半部分的凸包 
  (setq hullp2 (hull1 -ptlst maxYp2 minYp2))                ;左半部分镜像的凸包 
  (setq hullp2 (cdr (reverse (cdr hullp2)))) 
  (setq hullp2 (Mirror-list-X hullp2))                      ;左半部分的凸包 
  (append hullp1 hullp2)                                    ;把凸包左右相加 
) 
;;;镜像左半部分 
(defun Mirror-list-X (ptlist) 
  (mapcar (function (lambda (x)(list (- (car x))(cadr x)))) ptlist) 
) 
;;;求点集中夹角的最大值的点 
(defun Max-angle (ptlist pt / An) 
  (setq An (mapcar (function (lambda (x) (angle pt x))) ptlist)) 
  (nth (- (length An) (length (member (apply 'max An) An))) ptlist) 
) 
(defun Max-angle1 (ptlist pt / An) 
  (setq An 
    (mapcar 
      (function 
        (lambda (x) 
	  (if 
	    (and 
	      (equal (cadr x) (cadr pt) 1e-8) 
	      (> (car x) (car pt)) 
	    ) 
	    (+ 2Pi (- (car x) (car pt))) 
	    (angle pt x) 
	  )	    
	) 
      ) 
      ptlist 
    ) 
  ) 
  (nth (- (length An) (length (member (apply 'max An) An))) ptlist) 
) 
;;定义三点的行列式,即三点之倍面积 
(defun det (p1 p2 p3 / dx1 dy1 dx2 dy2) 
  (setq	dx1 (- (car  p2) (car  p1)) 
	dy1 (- (cadr p2) (cadr p1)) 
	dx2 (- (car  p3) (car  p1)) 
	dy2 (- (cadr p3) (cadr p1)) 
  ) 
  (- (* dx1 dy2) (* dx2 dy1)) 
) 
(defun Max-distance (ptlist / maxD halfPi HullP1 l HullP2 midPts 
		              i j Pi+1 Qi+1 Ai+1 D-i PairPt) 
  (setq MaxD nil) 
  (setq 2Pi  (* 2 pi)) 
  (setq halfPi (/ Pi 2)) 
  (setq HullP1 (Hull ptlist)) 
  (setq l      (1- (length HullP1))) 
  (setq HullP2 (append (cdr HullP1) (list (car HullP1)))) 
  (setq midPts (mapcar 'mid-pt HullP1 HullP2)) 
  (setq i 1) 
  (foreach pt (reverse (cdr (reverse HullP1))) 
    (setq j i) 
    (setq Pi+1 (nth i HullP1)) 
    (setq Qi+1 (nth i midPts)) 
    (setq Ai+1 (ang Qi+1 pt Pi+1)) 
    (while (and (< Ai+1 halfPi) (< j l)) 
      (setq j (1+ j)) 
      (setq Ai+1 (ang (nth j midPts) Pt (nth j HullP1)))   
    ) 
    (setq D-i  (distance pt (nth j HullP1))) 
    (setq MAXD (cons (list D-i (1- i) j) MAXD)) 	   
    (setq i (1+ i))   
  ) 
  (setq PairPt (assoc (apply 'Max (mapcar 'car MaxD)) MaxD)) 
  (list 
    (nth (cadr  PairPt) HullP1) 
    (nth (caddr PairPt) HullP1) 
  ) 
) 
(defun mid-pt (p1 p2) 
  (list 
    (* (+ (car  p1) (car  p2)) 0.5) 
    (* (+ (cadr p1) (cadr p2)) 0.5) 
  ) 
) 
;;;============ 
;;;程序主段结束 
;;;============ 
 
;;;依据晓东网站的代码改写而成的取点函数 
(defun getpt1 (ss / a b c d i p) 
  (setq	i 0) 
  (if ss 
    (repeat (sslength ss) 
      (setq a (ssname ss i)) 
      (setq b (entget a)) 
      (setq c (cdr (assoc 10 b))) 
      (setq c (list (car c) (cadr c))) 
      (setq p (cons c p)) 
      (setq i (1+ i)) 
    ) 
  ) 
  p 
) 
;;定义三点的夹角函数 
(defun ang (p1 p2 p3 / x) 
  (setq x (abs (- (angle p1 p3) (angle p1 p2)))) 
  (if (< x Pi) x (- 2Pi x))  
) 
(defun C:tt (/ p1 p2 p3) 
  (initget 1) 
  (setq p1 (getpoint "\n输入第一点:")) 
  (setq p2 (getpoint "\n输入第二点:")) 
  (setq p3 (getpoint "\n输入第三点:")) 
  (ang p1 p2 p3) 
)   
;;;取点函数2 
(defun getpt (ss / i listpp a b c d) 
  (setq	i 0) 
  (if ss 
    (repeat (sslength ss) 
      (setq a (ssname ss i)) 
      (setq b (entget a)) 
      (setq ename (cdr (assoc 0 b))) 
      (cond 
	( (= ename "LWPOLYLINE") 
	  (setq c (get-LWpolyline-vertexs b)) 
	  (setq listpp (append c listpp)) 
	) 
	( (= ename "LINE") 
	  (setq c (cdr (assoc 10 b))) 
	  (setq d (cdr (assoc 11 b))) 
	  (setq c (list (car c) (cadr c))) 
	  (setq d (list (car d) (cadr d))) 
	  (setq listpp (cons c listpp)) 
	  (setq listpp (cons d listpp)) 
	) 
	( (= ename "POINT") 
	  (setq c (cdr (assoc 10 b))) 
	  (setq c (list (car c) (cadr c))) 
	  (setq listpp (cons c listpp)) 
	) 
      ) 
      (setq i (1+ i)) 
    ) 
  ) 
  listpp 
) 
;;取得多边形顶点 
(defun get-LWpolyline-vertexs (entlst / n lst) 
  (foreach n entlst 
    (if (= (car n) 10) 
      (setq lst (cons (cdr n) lst)) 
    ) 
  ) 
  lst 
) 

问题：

如果知道AutoCAD 2000启动时各个文件加载的顺序，可能就会明白一个文件对另一个文件的影响。例如，已经在从acad.lsp文件加载的LISP程序中定义了一个函数，但是在启动AutoCAD 2000后，这个函数却不工作。这是因为acaddoc.lsp是在acad.lsp文件之后加载，此函数已经被acaddoc.lsp文件重新定义了。

解决方法：

以下是第一次启动AutoCAD 2000时，AutoCAD、Express Tools和自定义文件的加载顺序。

文件	使用者
acad2000.lsp	AutoCAD
acad.rx	User
acad.lsp	User
acad2000doc.lsp	AutoCAD
acetutil.fas	Express Tools
acaddoc.lsp	User
mymenu.mnc	User
mymenu.mnl	User
acad.mnc	AutoCAD
acad.mnl	AutoCAD
acetmain.mnc	Express Tools
acetmain.mnl	Express Tools
s::startup	User

注意： 如果acad.lsp、acaddoc.lsp或MNL文件中包含自定义函数S::STARTUP，那么，创建新图形或打开现有图形时就会调用这个函数。因此，在 LISP启动文件中添加S::STARTUP函数定义，就可以执行全部所需的安装操作。如果需要关于“S::STARTUP”函数的详细信息，请参阅“AutoCAD 2000 Customization Guide”的第六章。

原文地址
http://www.xdcad.net/forum/showthread.php?s=&postid=176897#post176897

1 彻底修改（不推荐使用）
用自己编辑好的屏幕菜单替换掉ACAD.MNU中的SCREEN菜单部分，然后重新加载。

2 参考晓东工具箱部分（推荐），不修改系统MNU，按需加载。但是如果要一直显示需关闭屏幕菜单的响应，但对象天正3.0中要用到屏幕菜单写墙柱参数的时候会麻烦些。

 ;|两个矢量的叉积 	2003年02月11日
　　　　| i 　j 　k　|
v1xv2 = | x1　y1　z1 |= (y1z2-y2z1, z1x2-z2x1, x1y2-x2y1)
　　　　| x2　y2　z2 |
　　　　　　
|;
;;向量的差积;
(defun ea:vector_CrossProduct
			      (ve1 ve2 / x1 y1 z1 x2 y2 z2)
  (setq	x1 (car ve1)
	y1 (cadr ve1)
	z1 (last ve1)
	x2 (car ve2)
	y2 (cadr ve2)
	z2 (last ve2)
  )
  (list	(- (* y1 z2) (* y2 z1))
	(- (* z1 x2) (* z2 x1))
	(- (* x1 y2) (* x2 y1))
  )
)

。

代码 2003年02月11日: ;;获取指定UCS的转换矩阵 (defun ea:getucsMatrix (ucsname / code10 code11 code12 _z) (if (= ucsname "") (progn (setq code10 (getvar "ucsorg") code11 (getvar "ucsxdir") code12 (getvar "ucsydir") ) ) (progn (setq code10 (cdr (assoc 10 (tblsearch "ucs" ucsname))) code11 (cdr (assoc 11 (tblsearch "ucs" ucsname))) code12 (cdr (assoc 12 (tblsearch "ucs" ucsname))) ) ) ) (setq _z (EA:VECTOR_CROSSPRODUCT code11 code12)) (list (list (car code11) (car code12) (car _z) (car code10)) (list (cadr code11) (cadr code12) (cadr _z) (cadr code10)) (list (nth 2 code11) (nth 2 code12) (nth 2 _z) (nth 2 code10) ) '(0.0 0.0 0.0 1.0) ) )

"Mechanical 2000" has QAFLAGS always set to 16 and I cannot change it.
在autocad 2000(含)以上, qaflags已不能设为1
指令: qaflags
输入 QAFLAGS 的新值<16>: 1
指令: qaflags
输入 QAFLAGS 的新值<17>:

利用AutoCAD几何计算器实现快速定位

常州市规划设计院　王汉洲

　　

　　提到AutoCAD的定位，很多人会自然而然地会想到AutoCAD的Osnap捕捉模式。运用捕捉模式进行定位不是非常方便吗？的确，每一位 AutoCAD的使用者，都懂得充分利用捕捉模式来提高工作效率。然而，捕捉模式有其局限性，仅利用它进行定位有时无法满足我们的需求。这里介绍另外一种 方法——应用AutoCAD几何计算器实现快速定位。

　　几何计算器是AutoCAD提供的一个十分有用的工具。和普通的计算器一样，几何计算器可以完成加、减、乘、除的运算以及三角函数的运算，这使得用户 在使用AutoCAD绘图过程中，可以在不中断命令的情况下进行算术运算，计算的结果可直接作为命令的参数使用。和一般计算器不同的是，AutoCAD几 何计算器还可以做几何运算。它既可直接对各坐标点的坐标值进行运算，也可以使用AutoCAD的Osnap模式捕捉屏幕上的坐标点来参与运算，还可以自动 计算几何坐标点。当然，AutoCAD几何计算器还有其它的功能，这里且不作讨论。

　　在使用AutoCAD绘图中，常常需要确定一些无法直接给出坐标的点。例如，任意两点间的中点，直线上任意分点等。这就是CAD绘图的定位问题。实际 上，在许多计算机绘图场合，定位是否方便和精确往往直接影响作图的效率和速度。因此，应该充分利用AutoCAD几何计算器的几何运算功能，来实现 AutoCAD绘图中的快速定位。

　　在命令提示Command：下键入CAL，即可启动AutoCAD几何计算器。CAL也是一个透明命令，可以在其它的命令下随时启动几何计算器。此外，还可以在AutoLISP程序中使用CAL命令。

　　下面是利用AutoCAD几何计算器的几何运算功能实现在AutoCAD绘图中，经常遇到的几个快速定位的实例。

　　1.用相对坐标来确定点

　　在绘图中，经常要根据某一实体的位置画出另一实体。如画一直线，该直线的起点为另一直线的端点，位移(3，4)后的点，操作过程如下：

　　Command: Line；

　　From Point: 'Cal（启动几何计算器）；

　　>>Expression: End+[3,4]（输入表达式，这里计算器把Osnap的End模式作为表达式参数来参与运算，作点和点的相加运算）；

　　>>Select Entity For END Snap:（捕捉端点）；

　　To Point:……。

　　其它的目标捕捉模式，如Int、Cen、Ins 、Tan等等均可在几何计算表达式中使用。如果将Cur作为表达式参数，则可以在计算机要求输入点时，再设定Osnap方式来捕捉所需的点。

　　2.确定数个点间的中心点

　　将各点坐标相加再除以点的个数，商即为它们的中心点坐标。操作过程如下：

　　Command: Line；

　　From Point: 'Cal；

　　>>Expression: (Int+ Int+ Int)/3 （输入表达式，这里求三个点间的中心点）；

　　>>Select Entity For Int Snap:（捕捉交点）；

　　>>Select Entity For Int Snap:（捕捉交点）；

　　>>Select Entity For Int Snap:（捕捉交点）；

　　To Point:……。

　　如果点的个数为2，则上述操作过程所得结果为两点间的中点。

　　3.确定一条直线上的任意分点和与直线端点定长的点

　　使用几何计算器提供的Plt和Pld函数可以完成这个操作。函数格式如下：

　　Plt(p1,p2,t)（求出p1p2直线上的分点。t=0时，该点为p1；t=0.5时，该点为p1p2的中点； t=1时该点为p2）；

　　Pld(p1,p2,dist)（求出p1p2直线上距离p1点长度为dist的点）。

　　假设我们需要画一条直线，起点为直线ab上分线段ab为1:2的点，终点为直线cd上距离c点长度为5的点。操作过程如下：

　　Command: Line；

　　From Point: 'Cal；

　　>> Expression: Plt(End,End,1/3)；

　　>> Select Entity For End Snap:（捕捉端点a）；

　　>> Select Entity For End Snap:（捕捉端点b后即得到距a点为1/3线段长的点）；

　　To Point: 'Cal；

　　>> Expression: Pld(End,End,5)；

　　>> Select Entity For End Snap:（捕捉端点c）；

　　>> Select Entity For End Snap:（捕捉端点d后即得到距c点长度为5的点）；

　　To Point:……。

　　参数t和dist可以为负数，这里不加赘述。

　　4.作与一斜线相切的圆以及过圆上一点作圆的切线

　　（1）利用AutoCAD正交模式可容易地画出和垂直线或水平线相切的圆。画一个和斜线相切的圆则需要准确地确定圆心。操作过程如下：

　　Command: Circle；

　　3P/2P/TTR/

: 'Cal；

　　>> Expression: Nea+3*Nee（Nea表示在直线上捕捉一个点作为圆和直线的切点，Nee函数用来计算两端点矢量的法线，3是圆的半径）；

　　>> Select Entity For NEA Snap: （在直线上捕捉一个点作为圆和直线的切点）；

　　>> Select One Endpoint For NEE:（捕捉直线的一个端点）；

　　>> Select Another Endpoint For NEE:（捕捉直线上的另一个端点）；

　　Diameter/: 3(给出圆的半径后即可画出这个圆)。

　　改变光标捕捉直线两个端点的顺序，则可在直线的另一侧画圆。

　　（2）假设过圆和一直线的交点作圆的切线，操作过程如下：

　　Command: Line；

　　From Point: Int(捕捉交点)；

　　Of

　　To Point: 'Cal；

　　>> Expression: Int+3*Nor(Cen,Int)；

　　>> Select Entity For INT Snap:（捕捉交点）；

　　>> Select Entity For CEN Snap:（捕捉圆心）；

　　>> Select Entity For INT Snap:（再次捕捉交点即画出从交点出发长度为3的已知圆的切线）；

　　To Point:……。

　　总之，在使用AutoCAD绘图的过程中，充分利用AutoCAD几何计算器工具，可以完成许多用一般方法难以实现的作图定位，从而使我们作图的效率和速度得以提高。

AutoCAD中非图形特征的存取方法及应用

四川大学制造学院 李学坤 姚进

　　

　　一、引言

　　在进行产品设计时，很多时候只是设计出了产品的几何特征和属性，在图纸中很少涉及到其它非图形特征属性，如零件的材料、生产数量、拓扑关系等。这些非 图形特征往往通过标注来实现，但在图纸本身的数据库中并没有保存这些有用的非图形特征信息。随着计算机技术的发展，尤其是网络和数据库的发展和成熟，图纸 数据库中若不包含必要的非图形特征信息，就很难实现零件之间的关联及信息的相互利用，很难充分实现信息的共享。

　　AutoCAD 2000 以其强大的功能及对二次开发的支持和开放性，成为众多设计人员采用的工作平台和二次开发平台。它不仅能存储所生成图形的几何信息和其它相关信息，而且还允 许用户建立自己的“非图形特征信息”，以便在图形文件中提供必要的较完整的产品数据，实现零件信息的自动统计，不同零部件的关联设计，自动提取所需零件及 图纸的相关特征参数等，为后续开发和生产提供保障。

　　二、 非图形特征的存储和提取方法

　　在AutoCAD中，图形是指存储在数据库中的对象的集合。基本的数据库对象包括实体、符号表和字典。实体是一种指定类型的数据库对象，它在 AutoCAD中有图形表示，如直线、圆、曲线和文字等；符号表和字典是用来存储数据库对象的容器对象。ObjectARX 使用户的应用程序能够访问这些数据库对象，另外，用户也可以为指定的应用程序创建新的数据库对象。

　　在通常的设计中，图纸中只包含了各种图形实体及实体的基本属性，如线型、图层和可见性等，一般都不包括基本属性以外的非图形特征属性，如实体的材料、 加工方法等。我们可以利用扩展数据(Xdata)和扩展记录对象(Xrecord)来存储其非图形特征参数，为关联设计和CAPP等提供必要的信息。

　　1.扩展实体数据(Xdata)

　　ObjectARX、Visual Lisp等应用程序都可以创建扩展实体数据(Xdata)，扩展实体数据可以附在任何对象上，AutoCAD 只负责维护这些信息，但并不使用这些信息。一个实体的扩展数据由应用程序所建立，跟随在该实体的正常定义数据之后，包含一个或多个1001组。每一组均以 一个互不相同的应用程序名开头，扩展数据的组码在1000至1071之间，不同组码对应不同类型的信息。可用以下方法为指定对象附加扩展实体数据，获取指 定对象的扩展实体数据。

　　(1)为指定对象附加扩展实体数据

　　Acad::ErrorStatus AcDbObject::setXData(const resbuf* xdata);

　　其中，xdata 为结果缓冲区链表，包含要添加的信息。

　　(2)获取指定对象的扩展实体数据

　　Acad::ErrorStatus AcDbObject::XData(const char* regappName);

　　其中，regappName 欲获取信息所属的应用程序名。

　　2.扩展实体词典和扩展实体记录

　　词典用以存储用户自己定义的各类符号表及其他大量数据。扩展实体记录就是一个Resbuf链表。该链表是一个数据组的列表，链表中每一节点都包含一个 DXF组码及相关数据。扩展实体记录的DXF组码的范围是1～369，其中的数据没有任何限制，可以被任何其它对象所拥有。我们可以通过以下方法来实现对 非图形特征信息的存储和提取。

　　(1)创建词典对象

　　Acad::ErrorStatus createExtensionDictionary();

　　(2)添加对象到扩展数据词典

　　Acad::ErrorStatus；

　　setAt(char* Key,AcDbObject* obj,AcDbObjectId& retobjId);

　　其中，Key为加入到词典的新对象的索引关键字；

　　obj为加入到词典的新对象指针;

　　retobjId为加入到词典的新对象Id。

　　(3)检索指定关键字的扩展数据词典记录

　　Acad::ErrorStatus getAt(const char* entryName,AcDbObject*&entryObj,AcDb::OpenMode mode) const;

　　其中，entryName为指定检索的关键字；

　　entryObj为返回的检索到的对象指针；

　　mode为对象打开的方式。

　　(4)添加数据到扩展数据记录

　　Acad::ErrorStatusAcDbXrecord::setFromRb

　　Chain(resbuf& pRb,AcDbDatabase*pDb=NULL);

　　其中,pRb为包含特征信息的结果缓冲区链表。

　　(5)获取扩展实体记录的内容

　　Acad::ErrorStatusAcDbXrecord::rbChain(resbuf**ppRb,AcDbDatabase*pAuxDb=NULL);

　　其中，ppRb为结果缓冲区结构指针。

　　三、非图形特征存储提取方法的应用

　　以上介绍了通过扩展实体数据和扩展实体记录对象来存储和提取非图形特征的方法。下面通过3个实例来介绍其应用。

　　1.利用扩展实体数据保存和提取实体非图形特征

　　在工厂电气布线中，需要对电缆设定代号、名称、产地等非几何特征，以便于对电缆等材料进行自动统计等后续工作。

　　(1)为电缆实体设定非图形特征

　　char appName[40];//应用程序名

　　char daihao[40];//电缆代号

　　char mingcheng[40];//电缆名称

　　ads_real length;//电缆长度

　　struct resbuf *pRb,*pTemp;

　　……//通过对话框等方式对daihao,mingcheng,length赋初值

　　strcpy(appName,“diqibuxian”);

　　acdbRegApp(appName);//以appName登记图形中一个应用程序名

　　pRb = acutNewRb(AcDb::kDxfRegAppName);//分配结果缓冲器

　　pTemp = pRb;

　　pTemp->resval.rstring= (char*)malloc(strlen(appName)+1);

　　strcpy(pTemp->resval.rstring, appName);//将数据存入结果缓冲器链表

　　pTemp->rbnext=acutNewRb(AcDb::kDxfXdAsciiString);

　　pTemp=pTemp->rbnext;

　　pTemp->resval.rstring= (char*)malloc(strlen(daihao)+1);

　　strcpy(pTemp->resval.rstring, daihao); //将代号存入结果缓冲器链表

　　……

　　pTemp->rbnext=acutNewRb(AcDb::kDxfxdLong);

　　pTemp=pTemp->rbnext;

　　pTemp->resval.rreal=length;

　　AcdbObject *pObj;//通过一定的方式获取需要添加数据的对象

　　pObj->SetXData(pRb);//为对象添加扩展实体数据

　　pObj->close();

　　acutRelRb(pRb);

　　(2)获取指定对象的扩展实体数据

　　AcDbObject* pObj;

　　char appName[40];//应用程序名

　　char daihao[40];//电缆代号

　　char mingcheng[40];//电缆名称

　　ads_real length;//电缆长度

　　struct resbuf *pRb;

　　strcpy(appName,“dianqibuxian”);

　　pRb=pObj->xData(appName);//获取应用名appName指定的扩展数据

　　if(pRb!=NULL)

　　{ int n=0;

　　for(;pRb!=NULL;pRb=pRb->rbnext)

　　{　if(pRb->restype==1000)

　　{　n++;

　　if(n==1)

　　strcpy(daihao,pRb->resval.rstring);//得到电缆代号

　　if(n==2)

　　strcpy(mingcheng,pRb->resval.rstring);//得到电缆名称

　　}

　　if(pRb->restype==1040)

　　length=pRb->resval.rreal;

　　}

　　}

　　acutRelRb(pRb);

　　2.利用扩展记录对象实现关联设计

　　在参数化设计过程中，零件甲中的某些参数与零件乙的设计有关联。我们设计零件乙时就需要从零件甲的图纸数据库中获取所需的参数，实现关联设计。

　　(1) 在零件甲的图纸空间中保存关联参数

　　ads_real bl,fl;//零件甲与零件乙相关联的参数

　　AcDbDictionary *pNamedobj, *pDict;

　　acdbHostApplicationServices()->workingDatabase()

　　->getNamedObjectsDictionary(pNamedobj, AcDb::kForWrite);

　　//获取当前数据库中的命名对象字典

　　pNamedobj->setAt("Guanliansheji", pDict, DictId);

　　pNamedobj->close();

　　AcDbXrecord *pXrec = new AcDbXrecord;

　　AcDbObjectId xrecObjId;

　　pDict->setAt("XREC1", pXrec, xrecObjId);

　　pDict->close();

　　struct resbuf *pHead;

　　pHead = acutBuildList(AcDb::kDxfReal, bl,AcDb::kDxfReal,fl,0);

　　//设置包含参数bl,fl的结果缓冲器链表

　　pXrec->setFromRbChain(*pHead);//给扩展记录对象附加信息

　　acutRelRb(pHead);

　　pXrec->close();

　　(2) 在设计零件乙的过程中，从零件甲的图形文件中获取所需的相关参数

　　AcDbDatabase* pDb = new AcDbDatabase(false, true);

　　　　pDb->readDwgFile(fname);//fname为零件甲的图形文件名

　　　　AcDbDictionary *pNamedobj;

　　pDb->getNamedObjectsDictionary(pNamedobj, AcDb::kForRead);

　　AcDbDictionary *pDict;

　　pNamedobj->getAt("Guanliansheji", (AcDbObject*&)pDict,

　　AcDb::kForRead);//获取名为Guanliansheji的数据词典

　　　　 pNamedobj->close();

　　AcDbXrecord *pXrec;

　　pDict->getAt("XREC1", (AcDbObject*&) pXrec,AcDb::kForRead);

　　//获取关键字为XREC1的扩展记录对象

　　pDict->close();

　　struct resbuf *pRbList;

　　pXrec->rbChain(&pRbList);//获取包含特征信息的结果缓冲器链表

　　　　 pXrec->close();

　　bl=pRbList->resval.rreal;//获取关联参数bl

　　　　 pRbList=pRbList->rbnext;

　　　　fl=pRbList->resval.rreal; //获取关联参数fl

　　acutRelRb(pRbList);

　　3. 其他应用

　　前面介绍了如何利用扩展实体数据和扩展记录对象来存储和提取非图形特征，除此以外，还有更多的应用。例如，在CAPP中自动提取零件的一些特征参数供工艺设计用，可减少重复的工作，提高整个设计过程的效率。

　　四、结束语

　　本文介绍了在AutoCAD中通过二次开发程序来实现非图形特征信息的存储和提取，这些方法可以大大提高图纸数据库中的信息含量，从而为后续的产品设计和开发工作提供基础，大大提高设计效率。

在Dimension 的DXF组码中一些特性不能直接得到，下面的程序是为了获取字体高度，测试中觉得有意思，发上来给初学Lisp者在编程方面作为解决问题的一种思考方式。 第一个是ActiveX方法，是为了检验能否获取Dim的子实体，在块内实体以及选择集遍历方面，VLa方法更简单易用，第二个是在ActiveX方法测 试成功后用纯Lisp 方式来实现，在测试中也看到了Dimension内部各个子实体的规律，先是线然后是两侧的斜，接着写文字，最后是几个Point。 PHP代码:　　　　　　　　　　　　　　　　　　　　　　　　　　　　[拷贝到剪切板] (defun c:test (/ e obj blk hi)   (if (setq e (car (entsel)))     (progn       (setq obj    (vlax-ename->vla-object e);;转换Entity 为 Object         blk    (vla-item (vla-get-blocks                 (vla-get-activedocument (vlax-get-acad-object))               )               (cdr (assoc 2 (entget e)))         );;获取Dim的块定义本身，不是Reference       )       (vlax-for    i blk;;遍历块定义     ;;(setq elst (cons (vla-get-objectname i) elst));;第一次测试为检验Dim内实体组成     (if (= (vla-get-objectname i) "AcDbMText");;看到6个实体后增加获取高度       (setq hi (vla-get-height i))     )       )     )   )   hi ) (defun c:test1 (/ e blk lst hi)   (if (setq e (car (entsel "\nSelect Dimension: ")))     (progn       (setq     bn  (cdr (assoc 2 (entget e)));;块名     blk (tblobjname "block" bn);;获取块定义本身       )       (while;;检索块内实体，出现文字停止     (/= (cdr           (assoc 0              (setq lst (entget (setq blk (entnext blk))))           )         )         "MTEXT"     )       )     )   )   (cdr (assoc 40 (entget blk))) ) 说明：测试仅检验了简单的垂直标注，不含公差等等其他形式，以上测试仅提供一种方法 2004年02月18日

;|                             
                                                                                  2006对Hatch的支持使得以前的很多程序得以简化，成功率也有了很大的提高，一切都源于   
Hatch 命令的增强。                                                                
                                                                                  
[非关联(DI)/样式(S)/特性(P)/绘图顺序(DR)/添加边界(AD)/删除边界(R)/重新创建边界(B  
)/关联(AS)/独立图案(H)/原点(O)] <特性>:                                           
                                                                                  
上面是基于命令行模式的各个选项，对话框模式的编辑和填充命令实际是一个，包括了所有的
填充选项。                                                                        
                                                                                  
下面的程序就是用Hatchedit实现批处理,其中的 getkword 用法和以前的版本也略有变化    
                                                                                  
                eachy [www.xdcad.net] Email: eachy@21cn.com 2005.5.9              
|;
;;(if (>= (atof (getvar "acadver")) 16.2)
(defun c:tt (/ ss e kw ssl _$area)
  (vl-load-com)
  (if (setq ss (ssget '((0 . "Hatch"))))
    (progn
      (setvar "cmdecho" 0)
      (setq ssl (sslength ss))
      (if (= ssl 1)
	(progn
	  (initget "B H O A S")
	  (setq	kw
		 (getkword
		   "\n模式选择\n[重建边界(B)/独立图案(H)/原点(O)/统计面积(A)/实心填充(S)]: "
		 )
	  )
	)
	(progn
	  (initget "B H A S")
	  (setq	kw
		 (getkword
		   "\n模式选择\n[重建边界(B)/独立图案(H)/统计面积(A)/实心填充(S)]: "
		 )
	  )
	)
      )
      (cond
	((= kw "B") ;_重建边界
	 (while	(> ssl 0)
	   (setq e (ssname ss (setq ssl (1- ssl))))
	   (if (= (cdr (assoc 450 el)) 1)
	     (progn
	       (initdia)
	       (command "hatchedit" e)
	     )
	     (command ".-hatchedit" e "B" "p" "y")
	   )
	 )
	)
	((= kw "H") ;_ 分解为独立填充
	 (while	(> ssl 0)
	   (setq e (ssname ss (setq ssl (1- ssl))))
	   (command ".-hatchedit" e "h")
	 )
	)
	((= kw "O") ;_指定原点
	 (vl-cmdf ".-hatchedit"
		  (ssname ss 0)
		  "o"
		  "s"
		  (getpoint "\n新原点: ")
		  "y"
	 )
	)
	((= kw "S") ;_ 变实心填充
	 (while	(> ssl 0)
	   (setq e (ssname ss (setq ssl (1- ssl))))
	   (command ".-hatchedit" e "p" "s")
	 )
	)
	(t ;_求面积
	 (setq _$area 0.)
	 (while	(> ssl 0)
	   (setq e (ssname ss (setq ssl (1- ssl))))
	   (setq _$area
		  (+ _$area
		     (vla-get-area (vlax-ename->vla-object e))
		  )
	   )
	 )
	 (princ "\n填充总面积: ")
	 (princ _$area)
	)
      )
    )
  )
  (princ)
)
;;(princ "\n仅适用AutoCAD 2006以上版本!")
;;)
;;对填充合并可以先利用生成Region边界，然后用Hatch命令重新填充，有兴趣的可以自己
;;添加这部分。

地形图上的标高都是属性块，第一次遇到 2005年06月02日

;;使用时可以用 vl-load-all 加载,格式如
;; (vl-load-all "c:\\cleardwg.vlx") 	2005年06月22日
(vl-load-com)
(defun c:cleardwg (/ thisdrawing ss lyrlst olderr myerr)
  (defun myerr (msg)
    (if	(/= msg "取消")
      (princ "\*取消*")
    )
    (vla-endundomark thisdrawing)
    (setq *error* olderr
	  myerr	  nil
    )
    (princ)
  )
  (setvar "cmdecho" 0)
  (setq	thisdrawing
	 (vlax-get-property
	   (vlax-get-acad-object)
	   'activedocument
	 )
  )
  (vla-startundomark thisdrawing)
  (setq	olderr	*error*
	*error*	myerr
  )
  (vlax-map-collection
    (vlax-get-property thisdrawing 'layers)
    '(lambda (lyr / name s tf)
       (setq name (vla-get-name lyr))
       (if (or (setq tf (= (vla-get-freeze lyr) :vlax-true))
	       (= (vla-get-layeron lyr) :vlax-false)
	   )
	 (progn
	   (if (= (vla-get-lock lyr) :vlax-true)
	     (vla-put-lock lyr :vlax-false)
	   )
	   (if tf
	     (setq lyrlst (cons name lyrlst))
	   )
	   (vla-put-freeze lyr :vlax-false)
	   (if (setq s (ssget "X" (list (cons 8 name))))
	     (vl-cmdf ".erase" s "")
	   )
	 )
       )
     )
  )
  ;|(if lyrlst
    (vlax-map-collection
      (vlax-get-property thisdrawing 'blocks)
      '(lambda (b / bn)
	 (setq bn (vla-get-name b))
	 (if (and (/= bn "*MODEL_SPACE")
		  (/= bn "*PAPER_SPACE")
		  (not (wcmatch bn "`*PAPER_SPACE?"))
	     )
	   (vlax-map-collection
	     b
	     '(lambda (x)
		(if (vl-position (vla-get-layer x) lyrlst)
		  (vla-delete x)
		)
	      )
	   )
	 )
       )
    )
  )|;
  (if (setq ss (ssget "x" '((2 . "*网易*,*土木在线*,*园林站图块*"))))
    (vl-cmdf ".erase" ss "")
  )
  (vla-purgeall thisdrawing)
  (vla-purgeall thisdrawing)
  (vla-purgeall thisdrawing)
  (vla-zoomextents (vla-get-application thisdrawing))
  (vla-save thisdrawing)
  (vla-endundomark thisdrawing)
  (setq	*error*	olderr
	myerr	nil
  )
  (princ)
)
(princ "\n清理图层, 命令: ClearDwg, eachy[www.xdcad.net]")
(princ)