1、 块操作 ........................................................................................................................... 1
1.1、定义块方法： .......................................................................................................... 1 1.2、把选择集加入块中的方法 ...................................................................................... 1 1.3、插入块方法： .......................................................................................................... 1 1.4、画块属性方法 .......................................................................................................... 1 1.5、编程思路： .............................................................................................................. 1 2、画直线 (单段线) ................................................................................................................. 3 3、画多段线 ............................................................................................................................. 4
3.1、修改出线点的位置 .................................................................................................. 4 4、画圆 ..................................................................................................................................... 4 5、获取鼠标指定的坐标点 ..................................................................................................... 4 6、旋转 ..................................................................................................................................... 4 7.插入文字（单选） ................................................................................................................ 5
（1）、左边对齐： ........................................................................................................... 5 （2）、中间对齐： ........................................................................................................... 5 （3）、右边对齐 ............................................................................................................... 5 8.插入文字（多行） ................................................................................................................ 5 9、画圆弧 ................................................................................................................................. 6 10、画图椭圆 ........................................................................................................................... 6 11、CAD打开读取数据 ......................................................................................................... 6 12、绘制圆弧 ........................................................................................................................... 6 二、CAD VBA程序答 .................................................................................................................... 7
1. VBA写的宏，可否编译成象ARX一样的程序，经加载后，在命令行打入命令后就可运行........................................................................................................................................... 7 2. VB中可以生成可执行文件，而在VBA中却不行 .......................................................... 7 5.有时文字是从别的图中复制-粘贴的,如果不打破的话,能否直接得到文字内容. ............ 8 GetSubEntity 方法 ................................................................................................................... 8 6. 想必河伯对Excel/ActiveX有研究, 能否请教如何获得Excel文件最后一行的信息? . 8 可以用CurrentRegion属性计算最后一行 ............................................................................. 8 7. 如何调用vba命令对多义线进行fit(拟合)处理 ............................................................... 9 8. 块属性值编辑 ...................................................................................................................... 9 9.如何用程序控制对象捕捉 .................................................................................................. 10 10. 如何从VBA到VB？ ..................................................................................................... 10 11.IntersectWith 方法 ............................................................................................................ 10 12.绘制多边形并显示多边形顶点坐标 ................................................................................ 10 13.Private Sub AcadDocument_BeginDoubleClick(ByVal pPoint As Variant) ...................... 11 14. 现有Handpoint = acadApp.ActiveDocument.Utility.GetPoint(, \"请输入套料的插入点\") ................................................................................................................................................ 12 希望用户在捕捉点或输入点坐标动作时，如何避免用户因其他操作如缩放、PAN引起的系统报错 ............................................................................................................................. 12 15.在VBA中如何传送一个参数给Vlisp? .......................................................................... 12 17.我想知道vb中的那个函数或者对象的方法可以代替在cad中按esc键取消命令 .... 12 18点击菜单项就在该菜单上打对号是怎么实现的? .......................................................... 13
第1页
20请问版主，如何实时获得当前光标的X，y，z坐标值，如同状态栏上显示坐标值 13 21可以设置图块中的块属性值，如内 ................................................................................ 13 22我的选择集中有Block和PLine,我想能使用该函数 ..................................................... 14 23我的机器里装有cad14和cad2000,用vb写了一个程序调用cad,如何让程序每次都调用cad2000呢? ....................................................................................................................... 14 24我只是想判断一下 ............................................................................................................ 14 25SendCommand \"_line\" 没有返回值,怎么知道是否添加了line ...................................... 15 26为什么修改文 字的对方正式后辩证文字会移回到零点？ .......................................... 15 27删除块前，应先删除块的引用，怎样查找块的引用？（VBA） ................................ 15 28使用ADO的方法如何存取ACCESS数据库? .............................................................. 15 30如何将类似 \".5\"数值改为\"0.5\"显示 ............................................................................... 16 31请问，如何将图上所有的数字（成千上万个数值）减去同一个常数？ .................... 17 34 把选择的对象放大几倍，VBA怎么实现？ ................................................................. 20 35怎样提取图形的视图左下角、右上角和图形左下角，右上角的坐标？ .................... 20 1. 怎么查找某一个group是否存在？- ............................................................................. 21 3. 在编程中，我遇到以下问题： ........................................................................................ 21 5. Sheets(\"检测报告\").Select .................................................................................................. 22 6. 请问如何让form.hide后form.show时能保持form先前移动后的位置？.................. 22 9怎样计算一个多边形的中心点? ........................................................................................ 23 10如何返回在命令行中输入的字符,是指在没有按下回车和空格下 ............................... 24 11当我插入块时，鼠标的click_point为两个图块的公共插入点，即同时插入两个块 24 12如何把168.235642度分解成度，分，秒？我没有办法判别小数点？ ....................... 24 13. 请问在VBA中怎么使一个选择集只选中模型空间中可见图元？ ............................ 25 14. windows安装了几个打印机，如何用vb指定打印机。谢谢 ...................................... 26 16请教，VBA中的下拉列表控件的数据是怎么和数据库内的数据邦定的？我查了好些东东都不能搞定，那位仁兄可以相告，谢谢。 ................................................................. 26 17请问高手，在VB中如何将如0.00000053的数字，变成形如5.3E-7字样的科学记数法 ............................................................................................................................................ 27 18.在vba中有 IsNumberic()函数检测变量是不是数值,但我需要一个能检验 所输的变量是不是 字符charactor的函数,或能实现此功能的办法. ................................................ 27 19在ADDMTEXT中，换行符\\p怎么使用啊？ ............................................................... 27 20请大家帮我解一个数学问题 ............................................................................................ 27 22. 如何得到objectDBX及其帮助？ .................................................................................. 28 24. 哪位大侠知道，怎么取得任意图形的中心点坐标！ .................................................. 28 25测量坐标与屏幕坐标的转换 ............................................................................................ 28 26VBA回车响应的问题 ....................................................................................................... 29 27.是根据VBA教材的代码改的批量裁剪程序 ................................................................. 29 28. 我用sendcommand的_trim命令，经常剪不断，怎么办？ ....................................... 31 29关于split()函数的问题 ..................................................................................................... 32 31如何在VB中开关非当前层？ ........................................................................................ 34
第2页
CAD VBA代码 峰
一、基本操作
变量可以不填可不填，在前面加入optional 如optional A as string
1、 块操作
1.1、定义块方法：
Set blocksobj=ThisDrawing.Blocks.Add(基点, 块名) 1.2、把选择集加入块中的方法 ThisDrawing.CopyObjects(选择集,块) 1.3、插入块方法：
ThisDrawing.ModelSpace.InsertBlock(插入点,块名, X轴比例,Y轴比例,Z轴比例, 旋转角度) 1.4、画块属性方法
ThisDrawing.ModelSpace.AddAttribute(文字高度,模式,提示字符, 插入点, 显示字符,默认值) 一共有五种模式，在输入时会有提示，其中最常用的是“acAttributeModeNormal”普通模式 1.5、编程思路：
1．定义一个空块
2．在块中画一段弧（球服衣领） 3．画多段线，镜像画出球衣
4．画块属性，由于块属性默认的对齐方式是左对齐，而球员号码应该居中，所以必须把块的对齐属性改为居中。但是当这个属性更改时块属性对齐点会自动归零，所以不得不再次更改对齐点属性
5．把多段线和属性复制到块中 6．提示用户点选球员位置和姓名
7．插入块，修改球衣号码属性、球员姓名属性 Sub team()
Dim playerlay As AcadLayer '定义球员图层 Dim playerblock As AcadBlock '定义块变量 Dim arcc(0 To 2) As Double '圆弧圆心 Dim linep1(0 To 2) As Double '线条端点1
第1页
CAD VBA代码 峰
Dim linep2(0 To 2) As Double '线条端点2
Dim pline(0 To 20) As Double '定义队服右侧多段线7个顶点 Dim basep(0 To 2) As Double '块基点
Dim playernumberpoint(0 To 2) As Double '块属性插入点 Dim mytxt As AcadTextStyle '定义mytxt变量为文本样式 Dim blockRef As AcadBlockReference '定义块属性变量 Dim Attr3 As Variant '插入块属性变量
Set playerblock = ThisDrawing.Blocks.Add(basep, \"球员\") '定义一个\"球员\"的块 arcc(0) = 0 arcc(1) = 430
Call playerblock.AddArc(arcc, 50, ThisDrawing.Utility.AngleToReal(180, 0), 0) '画弧并加入块中
pline(0) = 0 pline(1) = 20 pline(3) = 100 pline(4) = 20 pline(6) = 100 pline(7) = 250 pline(9) = 125 pline(10) = 207 pline(12) = 212 pline(13) = 257 pline(15) = 112 pline(16) = 430 pline(18) = 50 pline(19) = 430
Set line1 = ThisDrawing.ModelSpace.AddPolyline(pline) '画队服右侧多段线 linep2(1) = 1 '镜像轴第二点位于Y轴上任一点
Set line2 = line1.Mirror(linep1, linep2) '镜像获得另一半多段线 Dim p(0 To 2) As Double '定义坐标变量
Set mytxt = ThisDrawing.TextStyles.Add(\"mytxt\") '添加mytxt样式 mytxt.fontFile = \"c:\\windows\\fonts\\simfang.ttf\" '设置字体文件为仿宋体 ThisDrawing.ActiveTextStyle = mytxt '将当前文字样式设置为mytxt playernumberpoint(0) = 0 '块属性位置 playernumberpoint(1) = 200
Set attr1 = ThisDrawing.ModelSpace.AddAttribute(100, acAttributeModeNormal, \"号码\playernumberpoint, \"X\画块属性 attr1.Alignment = 7 '居中
attr1.TextAlignmentPoint = playernumberpoint '重定义对齐点
Set attr2 = ThisDrawing.ModelSpace.AddAttribute(100, acAttributeModeNormal, \"姓名\playernumberpoint, \"\画块属性 attr2.Alignment = 7 '居中
Dim objCollection(0 To 3) As Object '创建选择集 Set objCollection(0) = line1 '线条1加入选择集
第2页
CAD VBA代码 峰
Set objCollection(1) = line2 '线条2加入选择集 Set objCollection(2) = attr1 '属性1加入选择集 Set objCollection(3) = attr2 '属性2加入选择集
Call ThisDrawing.CopyObjects(objCollection, playerblock) '把选择集加入块中 For Each element In objCollection '在选择集中进行循环
element.Delete '删除线条和属性(此操作并不影响已创建的块) Next
Set playerlay = ThisDrawing.Layers.Add(\"球员\") '新建图层 playerlay.color = 2 '为黄色
ThisDrawing.ActiveLayer = playerlay '将当前图层设置为球员图层; Dim p1 As Variant '块插入点位置 For i = 1 To 11 '插入块
pstring = CStr(i) & \"号球员位置：
p1 = ThisDrawing.Utility.GetPoint(, pstring) '点选球员位置坐标 nstring = ThisDrawing.Utility.GetString(30, \"球员姓名：\")
Set blockRef = ThisDrawing.ModelSpace.InsertBlock(p1, \"球员\插入块
Attr3 = blockRef.GetAttributes '获取块属性 Attr3(0).TextString = CStr(i) '赋值球员号码 Attr3(1).TextString = nstring '赋值球员姓名 Next- End Sub
Set mBlock = ThisDrawing.Blocks.Add(insertPt, tmpName)，其中mBlock是AcadBlock对象，insertPt是插入点的坐标（相对与块），tmpName是块的名称。 块和块的实例是两个概念。块只能有一个，但是这个块的实例却可以有很多个。
使用上述方法得到的是块，而不是块的实例。你能够在CAD菜单栏“插入-块”所打开的对话框中看到名字为tmpName的块，但是CAD图形中并没有块的图形。 Call ThisDrawing.ModelSpace.InsertBlock(Text_P, \"图框B\'(座标，X轴扩，Y轴扩，Z轴扩，旋转） 插入块。
2、画直线 (单段线)
Set ln = ThisDrawing.ModelSpace.AddLine(startPt(), EndPt())
第3页
CAD VBA代码 峰
3、画多段线
Dim p(0 To 49) As Double '定义点坐标
Set myl = ThisDrawing.ModelSpace.AddLightWeightPolyline(p) '画多段线
myl.Color = co '设置颜色属性
myl.ConstantWidth=2'设置多段线宽度属性 3.1、修改出线点的位置
Set Line2 = Line1.Mirror(CC_XYZ, CC_Mir_XYZ) '交叉线2镜像 '修改出线点的位置 a = Line2.Coordinates
a(1) = a(1) - (Phase_Number - 1 - i) * Spacing Line2.Coordinates = a
4、画圆
拓展程序（将上述画圆的程序拓展为每画一个圆设定为一种颜色） Sub c100()
Dim cc(0 To 2) As Double '声明坐标变量 cc(0) = 1000 '定义圆心座标 cc(1) = 1000 cc(2) = 0
Dim myl As Object '定义引用曲线对象变量 co = 15 '定义颜色
For i = 1 To 1000 Step 10 '开始循环
Set myl = ThisDrawing.ModelSpace.AddCircle(cc, i * 10) '画圆,cc数组为圆心X、Y、Z值
myl.color = co '设置颜色属性
co = co + 1 '改变颜色，供下次定义曲线颜色 Next i End Sub
5、获取鼠标指定的坐标点
ThisDrawing.Utility.GetPoint(, \"输入点:\") '获取点坐标
6、旋转
NewFilterEnt.Rotate PT, JiaoDu '更新对象 PT (基点)对你 JiaoDu 孤度 NewFilterEnt.Update
第4页
CAD VBA代码 峰
文字旋转
Set My_Text = ThisDrawing.ModelSpace.AddText(Text, Text_XYZ, Text_Hegin)
My_Text.Alignment = acAlignmentCenter '中心对齐文字 acAlignmentMiddleCenter
My_Text.ScaleFactor = 0.7 '文字横竖比例 My_Text.Rotation = Pi * 90 / 180# '文字旋转角图 My_Text.TextAlignmentPoint = Text_XYZ
My_Text.color = 10 '设置颜色属性 My_Text.Rotate XYZ, Radian My_Text.Update
Str_Number = Str_Number + 1 '下级数组
7.插入文字（单选）
Set Textobj = ThisDrawing.ModelSpace.AddText(Text, Text_P, H)
Textobj.Alignment = Text_Alignment '中心对齐文字 acAlignmentMiddleCenter 'Textobj.Alignment =acAlignmentLeft
Textobj.ScaleFactor = 0.7 '文字横竖比例
Textobj.Rotation = Pi * (Rotate) / 180# '文字旋转角图 （1）、左边对齐：
左上: acAlignmentTopLeft 左中:acAlignmentMiddleLeft 左下: acAlignmentBottomLeft （2）、中间对齐：
中上: acAlignmentTopCenter 正中:acAlignmentMiddleCenter 中下: acAlignmentBottomCenter （3）、右边对齐
右上: acAlignmentTopRight 右中:acAlignmentMiddleRight 右下: acAlignmentBottomRight
8.插入文字（多行）
Set txtobj = ThisDrawing.ModelSpace.AddMText(p, 1400, \"{做到老，学到老}\\P\" & \"此心自光明正大，过人远矣\")
txtobj.LineSpacingFactor = 2 '指定行间距
txtobj.AttachmentPoint = 3 '右对齐（1为左对齐，2为居中）
第5页
CAD VBA代码 峰
9、画圆弧
ThisDrawing.ModelSpace.AddArc(Center, Radius, StartAngle, EndAngle)
startangle:可以根据圆心坐标和起点坐标计算出startangle endangle:可以根据startangle和圆弧角度算出endangle
10、画图椭圆
Dim pEllipse As AcadEllipse ‘椭圆线 Dim center(0 To 2) As Double '中心点坐标 Dim p(0 To 2) As Double '相对座标以圆心为参照 Dim maj As Double, min As Double, angle As Double Dim ratio As Double
Set pEllipse = ThisDrawing.ModelSpace.AddEllipse(center, p, min / maj)
pEllipse.Rotate center, (360 - angle) * 3.1415 / 180#
#1的数据 分别表示椭圆长轴，短轴，方位角，中心点坐标X，中心点坐标Y 格式如下：
11、CAD打开读取数据
Dim La As AcadLayerExcelApp.Workbooks.Open \"D:\\TK\\龙岗索引.xls\"'CASS通过VBA打开EXCEL索引文档
With ExcelApp.ActiveWorkbook.Worksheets(\"龙岗索引\")
For i = 2 To [A65536].End(xlUp).Row '从第二行遍历EXCEL记录 th = .Range(\"B\" & i)
If Dir(\"D:\\DWG\\\" & Right(th, 5) & \".DWG\") <> \"\" Then '判断EXCEL中图幅号对应的DWG文档是否存在，如果存在就打开
Set AcadDocTk = ThisDrawing.Application.Documents.Open(\"D:\\TK\\图框.DWG\")'打开TK模板
tm = .Range(\"A\" & i)
chdw = .Range(\"C\" & i) '变量赋值 jd = .Range(\"R\" & i) sm = .Range(\"S\" & i) X = .Range(\"V\" & i) Y = .Range(\"U\" & i)
12、绘制圆弧
R = 100（半径）
stangle = 45 * 3.14 / 180(起始位) edangle = 135 * 3.14 / 180（结束位）
Set arcobj = ThisDrawing.ModelSpace.AddArc(center, r, stangle, edangle)
第6页
CAD VBA代码
峰
二、CAD VBA程序答
1. VBA写的宏，可否编译成象ARX一样的程序，经加载后，在命令行打入命令后就可运行
不行，必须自己写LISP加载和运行
2. VB中可以生成可执行文件，而在VBA中却不行
如果在VBA中能生成可执行文件，请问是怎样做的，不胜感激！！
VBA是不行，它只能内嵌于Autocad中运行，你可以将代码改在VB下用 3.自动加载执行VBA程序
你可以试试以下LSP函数。它与autoload的LSP函数功能一样，只要你按照它的要求写入你的执行命令名、DVB文件名及宏名就可以自动加载执行，再也不用专门写LSP程序了。 (defun AutoVBALoad (cmdname project macro) (eval
(list 'defun
(read (strcat \"C:\" cmdname)) nil (list
'vl-vbarun (strcat
project \"!\"
(if macro macro cmdname) ) )
(princ) ) ) )
你把函数复制到acad2000doc.lsp文件中，以后每写一个VBA程序，就可以通过写入一行： (AutoVBALoad <命令名> <工程文件> <宏>) 来自动调用，示例如下：
命令名为update，工程文件为myproject.dvb，模块为Foo，宏为Bar，则写为： (AutoVBALoad \"UPDATE\" \"MyProject.dvb\" \"Foo.Bar\") 如果宏的位置在ThisDrawing中，则写为：
(AutoVBALoad \"UPDATE\" \"MyProject.dvb\" \"Bar\") 是不是很方便。
第7页
CAD VBA代码 峰
4. 当我想添加commondialog控件时，总是无法添加，并提示：没有正确授权。
（是不是我用的D版AutoCad2000的原因）。
经过重装vb6,已经可以添加commondialog控件了。
5.有时文字是从别的图中复制-粘贴的,如果不打破的话,能否直接得到文字内容. GetSubEntity 方法
它可以直接取得图元或嵌套图元的信息，取得后你就可以随便对其进行读取或更改。 语法：
object.GetSubEntity Object, PickedPoint, TransMatrix, ContextData[, Prompt] 样例：
Sub Example_GetSubEntity()
' This example prompts the user to select on object on the screen with a mouse click, ' and returns some information about the selected object. Dim Object As Object
Dim PickedPoint As Variant, TransMatrix As Variant, ContextData As Variant Dim HasContextData As String
On Error GoTo NOT_ENTITY TRYAGAIN:
MsgBox \"Use the mouse to click on an entity in the current drawing after dismissing this dialog box.\"
' Get information about selected object
ThisDrawing.Utility.GetSubEntity Object, PickedPoint, TransMatrix, ContextData ' Process and display selected object properties
HasContextData = IIf(VarType(ContextData) = vbEmpty, \" does not \ MsgBox \"The object you chose was an: \" & TypeName(Object) & vbCrLf & _ \"Your point of selection was: \" & PickedPoint(0) & \
PickedPoint(1) & \ PickedPoint(2) & vbCrLf & _ \"This object\" & HasContextData & \"have nested objects.\" Exit Sub
6. 想必河伯对Excel/ActiveX有研究, 能否请教如何获得Excel文件最后一行的信息?
可以用CurrentRegion属性计算最后一行
CurrentSheet.Range(\"A1\").Activate
SheetRows = ExcelApp.ActiveCell.CurrentRegion.Rows.Count '有效数据行数
第8页
CAD VBA代码 峰
7. 如何调用vba命令对多义线进行fit(拟合)处理
直接用SendCommand方法，调用命令进行编辑
8. 块属性值编辑
Public Sub GetAttribute()
'本段代码从选中的图块中获取属性值，并对其修改 Dim entObj As AcadEntity Dim pickPnt As Variant
Dim blkRefObj As AcadBlockReference '选择图元
ThisDrawing.Utility.GetEntity entObj, pickPnt '判断是否为块引用
If StrComp(entObj.ObjectName, \"AcDbBlockReference\ MsgBox \"你选择的不是一个图块，程序将退出！\" '如果选择的不是一个块引用则程序退出运行 Exit Sub End If
'如果选择的是块引用，将其赋给块引用对象 Set blkRefObj = entObj
'判断该块引用是否含有属性值 If Not blkRefObj.HasAttributes Then
MsgBox \"你选择的图块没有块属性，程序将退出！\" '如果不含由属性值退出 Exit Sub End If
Dim attVars As Variant Dim I As Integer
'获取块引用中的块属性对象 attVars = blkRefObj.GetAttributes '对块属性对象进行遍历 For I = 0 To UBound(attVars)
MsgBox \"第\" & I + 1 & \"属性对象的属性值分别如下：\" & Chr(13) & Chr(13) & _ \"属性标签为：\" & attVars(I).TagString & Chr(13) & _ \"属性值为 ：\" & attVars(I).TextString Next
'将块属性的标签和值进行修改 attVars(0).TagString = \"New Tag\" attVars(0).TextString = \"New Value\" ThisDrawing.Regen True
第9页
CAD VBA代码 峰
End Sub
9.如何用程序控制对象捕捉
通过设置系统变量“osmode”来控制
10. 如何从VBA到VB？
在VB里，首先要获得Application对象，再获取Document对象，把VBA中的ThisDrawing对象设置成该Document对象即可，这样，你开发出来的程序就可以融入VB的强大功能了。
11.IntersectWith 方法
获取图中一个对象与另一对象的交点 语法
RetVal = object.IntersectWith(IntersectObject, ExtendOption) 参数
Object 该方法适用于所有图形对象 (除了Pviewport和PolygonMesh)
IntersectObject 对象，为输入项; 该对象可以是所有图形对象中的任一个。 ExtendOption AcExtendOption 枚举数; 为输入项
该选项指定两个对象是否通过延伸一个或两个或没有延伸来取得相交点。 acExtendNone 均无延伸。
acExtendThisEntity 延伸源对象。
acExtendOtherEntity 延伸作为参数传递的对象。 acExtendBoth 两个对象均延伸。
RetVal(返回值) 变体或双精度数组，返回图形中一个对象和另一对象相交的点的数组。 490
12.绘制多边形并显示多边形顶点坐标
Sub polygon()
'以下语句绘制正多边形 Dim num As Integer Dim pnt As Variant Dim lpnt As Variant
num = ThisDrawing.Utility.GetInteger(\"请选择正多边形的边数：\") Dim fpnt As Variant
fpnt = ThisDrawing.Utility.GetPoint(, \"请选择正多边形的起点：\") Dim leng As Double
leng = ThisDrawing.Utility.GetDistance(fpnt, \"请选择正多边形的边长：\") ReDim lpnt(0 To num * 2 - 1) As Double pnt = fpnt
lpnt(0) = pnt(0)
第10页
CAD VBA代码 峰
lpnt(1) = pnt(1) Dim st As Integer For st = 1 To num - 1
pnt = ThisDrawing.Utility.PolarPoint(pnt, (3.14159265 * 2 / num) * (st - 1), leng) lpnt(st * 2) = pnt(0) lpnt(st * 2 + 1) = pnt(1) Next st
Dim pgon As AcadLWPolyline
Set pgon = ThisDrawing.ModelSpace.AddLightWeightPolyline(lpnt) pgon.Closed = True
ThisDrawing.Regen (True) '以下语句获取多边形的顶点 Dim gpnt As Variant gpnt = pgon.Coordinates Dim pntcnt As Integer pntcnt = UBound(gpnt) Dim disptxt As String
disptxt = \"多边形共有\" & (pntcnt + 1) / 2 & \"个顶点\" & vbCrLf Dim i As Integer
For i = 0 To pntcnt - 1 Step 2
disptxt = disptxt & \"第\" & i / 2 + 1 & \"个顶点的坐标为:\" & _ gpnt(i) & \ Next i
disptxt = disptxt & \"明经通道VBA示例 http://www.mjtd.com\" MsgBox disptxt, , \"多边形的坐标显示\" End Sub
13.Private Sub AcadDocument_BeginDoubleClick(ByVal pPoint As Variant)
MsgBox \"图上双击坐标位置\" & vbCrLf & pPoint(0) & vbCrLf & _ pPoint(1) & vbCrLf & pPoint(2)
Open \"MyTest.txt\" For Output Access Write As #1
Print #1, Format(pPoint(0), \"0.000\"), Format(pPoint(1), \"0.000\"),_ Format(pPoint(2), \"0.000\") Close #1 End Sub
上面的程序只能实现将坐标输出一次，而第二次双击时，会将第一次的坐标值覆盖，有什么办法可以实现连续点选输出而不覆盖吗 Open 语句的Output改为Append即可
第11页
CAD VBA代码 峰
14. 现有Handpoint = acadApp.ActiveDocument.Utility.GetPoint(, \"请输入套料的插入点\")
希望用户在捕捉点或输入点坐标动作时，如何避免用户因其他操作如缩放、PAN引起的系统报错
可以加一段以下语句： on error goto errHandle
Handpoint = acadApp.ActiveDocument.Utility.GetPoint(, \"请输入套料的插入点：\") errhandle:
if Err.Number=-2147352567 then Err.Clear resume end if
15.在VBA中如何传送一个参数给Vlisp?
如:在VBA中A = \"123\" , 要把VBA中A的值赋给Vlisp中的B。 用sendcommand可以做到 如:
Sub valuetolisp() Dim a As Integer a = 123
ThisDrawing.SendCommand \"(setq b \" & a & \") \" End Sub
如果不想命令行回显，则可以用VLAX控制。
16.请问在VBA中如何修改属性块中属性的textstring的对齐方式，谢了。
与Text一样，属性块也有HorizontalAlignment属性 P487
17.我想知道vb中的那个函数或者对象的方法可以代替在cad中按esc键取消命令
谢谢
SendCommand(\"\")或SendCommand(Chr(27))
第12页
CAD VBA代码 峰
18点击菜单项就在该菜单上打对号是怎么实现的?
菜单项标签中可包括叹号和句号 (!.)，从而在菜单项前打上复选标记。虽然打标记的项可以被禁用，但标记一个菜单项不会使用户不能选择该项。 在下例中，Line 菜单项被打上标记。 [!.Line]
用 DIESEL 来标记标签
菜单项标签中可以包含 DIESEL 字符串表达式，用于判断在每次显示时，是否标记该标签。在下例中，如果与菜单标签相关的系统变量当前可用，则在该标签左边打上复选标记。 [$(if,$(getvar,orthomode),!.)Ortho]^O [$(if,$(getvar,snapmode),!.)Snap]^B [$(if,$(getvar,gridmode),!.)Grid]^G
19图层间图形实体的移动？请问各位高手：在AutoCAD VBA中怎样通过程序实现
将一图层中的图形实体移到另一图形的图层上去 文档之间复制对象
CopyObjects方法是一个非常有用的工具。这里我们看看它是怎样在图形间复制对象。首先准备两个文档。在一个文档中，创建一些对象。如果另一个文档的名称不是Drawing1.dwg，可修改以下程序中的文档名称为你的图形名称。最后，确定激活包含有要复制对象的图形并运行以下宏，这样可以将本文档中的对象复制到名称为Drawing1.dwg的另一个文档中。 Dim ss As AcadSelectionSet, doc As AcadDocument
Set doc = ThisDrawing.Application.Documents(\"Drawing1.dwg\") Set ss = CreateSelectionSet ss.SelectOnScreen
ThisDrawing.CopyObjects ssArray(ss), doc.ModelSpace
20请问版主，如何实时获得当前光标的X，y，z坐标值，如同状态栏上显示坐标值
我只会在autolisp中用(grread)函数, objectarx俺不懂。
21可以设置图块中的块属性值，如内
Public Sub SetAttribute() Dim pickPnt As Variant
Dim blkRefObj As AcadBlockReference
'选择图元,此段你可以直接将blkRefObj设为你刚插入的块 ThisDrawing.Utility.GetEntity blkRefObj, pickPnt
'判断该块引用是否含有属性值 If Not blkRefObj.HasAttributes Then
第13页
CAD VBA代码 峰
MsgBox \"你选择的图块没有块属性，程序将退出！\" '如果不含由属性值退出 Exit Sub End If
Dim attVars As Variant Dim I As Integer
'获取块引用中的块属性对象 attVars = blkRefObj.GetAttributes '对块属性对象进行遍历 For I = 0 To UBound(attVars) '将块属性的值进行修改 If attVars(I)=\"mccad\" Then
attVars(I).TextString = \"明经通道\" End If Next
ThisDrawing.Regen True End Sub
22我的选择集中有Block和PLine,我想能使用该函数
ThisDrawing.Application.ZoomCenter Center, Magnify
Center这个点取Block的中心点或者Pline的中心点,但是不知道该怎么取这个值,高手帮帮忙吧
Dim minExt As Variant
Dim maxExt As Variant
If ssetobj.Item(Me.MSHFlexGrid1.Row - 1).ObjectName = \"AcDbBlockReference\" Then ThisDrawing.Application.ZoomCenter ssetobj.Item(Me.MSHFlexGrid1.Row - 1).InsertionPoint, 40 Else
ssetobj.Item(Me.MSHFlexGrid1.Row - 1).GetBoundingBox minExt, maxExt ThisDrawing.Application.ZoomWindow minExt, maxExt
ThisDrawing.Application.ZoomScaled 0.5, acZoomScaledRelative End If
23我的机器里装有cad14和cad2000,用vb写了一个程序调用cad,如何让程序每次都调用cad2000呢?
Set acadApp = GetObject(, \"AutoCAD.Application.15\")
24我只是想判断一下
因为我想画一条多段线，就要用到多个Getpoint，但是我不知道具体要话多少段，只是联系
第14页
CAD VBA代码 峰
两点的线，我觉得如果可以象autocad里面画线那样就可以了阿 我现在是在画地理图上面的电线，是折线嘛！ 然后捕捉错误来退出while。
对于取得的点可以通过数组来保存，而数组也可以用redim来重新定义
25SendCommand \"_line\" 没有返回值,怎么知道是否添加了line
在使用该方法前及后看看数据库中最后一个对象是否相同
26为什么修改文 字的对方正式后辩证文字会移回到零点？
在设置了文字的对齐方式（Alignment）后，应该用文本对齐位置（TextAlignmentPoint）重新指定对齐点,否则缺省（即默认）的对齐点为原点。
因为不同的文字方式文字的插入点会有所不同,所以必须计算文字插入点后,一同修改.
27删除块前，应先删除块的引用，怎样查找块的引用？（VBA）
函数如下： '删除块引用
Public Sub DeleteBlockRef(ByVal Name As String) Dim EntObj As AcadEntity
On Error GoTo ErrTrap If Name = \"\" Then Exit Sub
For Each EntObj In ThisDrawing.ModelSpace
If StrComp(EntObj.ObjectName, \"AcDbBlockReference\ If StrComp(EntObj.Name, Name, vbTextCompare) = 0 Then EntObj.Delete End If End If Next
Set EntObj = Nothing Exit Sub ErrTrap:
If Not (EntObj Is Nothing) Then Set EntObj = Nothing On Error GoTo 0 End Sub
28使用ADO的方法如何存取ACCESS数据库?
ADO数据库读取有很多办法，在这告诉你一个比较简单的。
第15页
CAD VBA代码 峰
Dim db As Database '在ACAD VBA中，ACAD图形数据库也用Database类，你须在工程中引用Microsoft DAO 3.51 Object Library库，并将其优先级提高到仅次于AutoCAD类型库。 Dim rst As Recordset 'rst为数据库记录集对象
Set db=DBEngine.Workspaces(0).OpenDatabase(FileName) 'FileName为你的*.mdb数据库文件名(全路径)。
Set rst = db.OpenRecordset(\"SELECT * FROM Table1;\") 'Table1为数据库的表名。
此后，你可以用rst.MoveFirst,rst.MoveNext,rst.MoveLast等方法移动记录指针，用rst.Fields(FieldsName).Value获取FieldsName字段的内容。 不知道是否已明白你的意图，ADO连接方法： Dim cn As Connection Set cn = New Connection
cn.CursorLocation = adUseClient
cn.Open \"PROVIDER=Microsoft.Jet.OLEDB.3.51;Data Source=\" &_ YourMdbPathName
Dim cmd As New ADODB.Command Set cmd.ActiveConnection = cn
cmd.CommandText = YourSQLString Dim rst As New ADODB.Recordset rst.CursorLocation = adUseClient
rst.Open cmd,adOpenStatic,adLockBatchOptimistic
29在Mtext的文字內容中，原始數據的1項為文字內容，但有時會包含一些格式：如(1 . \"\\\\A1;Here),(1 . \"\\\\C2;There).....等等，我知道，\\\\p是換行，\\\\c是表顏色，但\\\\a
就不知道，哪位可提供詳細的全部資料，或以從哪里可得到？先謝了 格式化多行文字
\\O...\\o 打开或关闭上划线 \\L...\\l 打开或关闭下划线 \\~ 插入不断开空格 \\\\ 插入反斜杠
\\{...\\} 插入开始或结束大括号 \\F文件名 更改为指定的字体文件 \\H值; 按图形单位更改文字高度
\\H值x; 更改文字高度为当前文字高度的倍数 \\S...^...; 堆叠在\ረ9、#或^符号后的文字 \\T值; 从0.75到4倍之间调整字符的间隔 \\Q角度; 更改倾斜角度
\\W值; 更改宽度因子以产生较宽的文字
\\A值; 设置对齐值；有效值如下： 0(底对齐)、1(中间对齐)、2(顶对齐) \\P 换行
30如何将类似 \".5\"数值改为\"0.5\"显示
在VB中可直接用Format函数。
如：保存小数点后两位，可以用Format(1.23456,\".00\")=1.23， 如果点号之前补零的话，只要Format(0.23456,\"0.00\")=0.23。
第16页
CAD VBA代码 峰
31请问，如何将图上所有的数字（成千上万个数值）减去同一个常数？
这段程序提示你选择文本，然后指定增量，正的就是加，负的就是减了。如果选中的文本是数字的，那么就对它进行加或减处理。 Sub Test()
Dim SSetObj As AcadSelectionSet Dim bFound As Boolean
Dim IncreaseValue As Double Dim i As Integer
On Error GoTo ErrTrap
For Each SSetObj In ThisDrawing.SelectionSets If SSetObj.Name = \"ChangeText\" Then bFound = True Exit For End If Next
If bFound = False Then
Set SSetObj = ThisDrawing.SelectionSets.Add(\"ChangeText\") Else
Set SSetObj = ThisDrawing.SelectionSets(\"ChangeText\") SSetObj.Clear End If
SSetObj.SelectOnScreen
If SSetObj.Count = 0 Then Exit Sub
IncreaseValue = ThisDrawing.Utility.GetReal(\"指定数值增量: \") For i = 0 To SSetObj.Count - 1
If TypeOf SSetObj(i) Is AcadText Or TypeOf SSetObj(i) Is AcadMText Then If IsNumeric(SSetObj(i).TextString) Then
SSetObj(i).TextString = SSetObj(i).TextString + IncreaseValue End If End If Next
SSetObj.Delete
Set SSetObj = Nothing Exit Sub ErrTrap:
If Not (SSetObj Is Nothing) Then Set SSetObj = Nothing On Error GoTo 0 End Sub 475
32想写一个批量插入文件的程序，能调用所需用到的电子地图，以简化工作（不需要一幅一幅的进行插入），但不知道从哪里开始着手，请教高人指点！！
第17页
CAD VBA代码 峰
多DWG文件选择及选择整个目录下的DWG文件进行插入的例子如内 首先工程中必须使用“CommonDialog-在VBA中使用的公用对话框模块”，见以下链接： http://www.mjtd.com/mcdown/list.asp?id=83 开始工程前应输入CommonDialog.cls文件及modConstants.bas文件。程序如下： '通过选定多个图形文件插入到图形中的过程 Sub IntBlkBySelectDwg() On Error GoTo Err_Control Dim BlkFile As Variant Dim i As Integer Dim InstPnt As Variant Dim BlkRefObj As AcadBlockReference Dim varCancel As Variant BlkFile = getFileBySelect(\"选择图形：\图形文件(*.dwg)|*.dwg\") If IsArray(BlkFile) Then ThisDrawing.Utility.Prompt vbCrLf & \" 你选定了\" & Str(UBound(BlkFile) + 1) & \"个图形\" For i = 0 To UBound(BlkFile) InstPnt = ThisDrawing.Utility.GetPoint(, vbCrLf & \" 请选择图形 \" & JustFileName(BlkFile(i)) & \" 的插
入点：\") Set BlkRefObj = ThisDrawing.ModelSpace.InsertBlock(InstPnt, _ BlkFile(i), 1#, 1#, 1#, 0#) Next End If Exit_Here: Exit Sub Err_Control: Select Case Err.Number Case -2147352567 varCancel = ThisDrawing.GetVariable(\"LASTPROMPT\") If InStr(1, varCancel, \"*Cancel*\") <> 0 And
InStr(1, varCancel, \"*取消*\") <> 0 Then Err.Clear Resume Exit_Here Else Err.Clear Resume End If Case -2145320928 Err.Clear Resume Exit_Here Case Else Resume Exit_Here End Select End Sub '通过选定整个目录中的图形文件插入到图形中的过程 Sub IntBlkByDirDwg() On Error GoTo Err_Control Dim BlkFile As Variant Dim i As Integer Dim InstPnt As Variant Dim BlkRefObj As AcadBlockReference Dim varCancel As Variant BlkFile = GetDir(\"选择要插入图形所在的目录：\ ThisDrawing.Utility.Prompt vbCrLf &
\" 你选定了\" & Str(UBound(BlkFile) + 1) & \"个图形\" For i = 0 To UBound(BlkFile) InstPnt = ThisDrawing.Utility.GetPoint(, vbCrLf & \" 请选择图形 \" & JustFileName(BlkFile(i))
& \" 的插入点：\") Set BlkRefObj = ThisDrawing.ModelSpace.InsertBlock(InstPnt, _ BlkFile(i), 1#, 1#, 1#, 0#) Next End If Exit_Here: Exit Sub Err_Control: Select Case Err.Number Case -2147352567 varCancel = ThisDrawing.GetVariable(\"LASTPROMPT\") If InStr(1, varCancel, \"*Cancel*\") <> 0 And
InStr(1, varCancel, \"*取消*\") <> 0 Then Err.Clear Resume Exit_Here Else Err.Clear Resume End If Case -2145320928 Err.Clear Resume Exit_Here Case Else Resume Exit_Here End Select End Sub '选定多个文件的函数，使用了CommonDialog类 Public Function getFileBySelect(DialogTitle, DefaultExt, Filter) As Variant Dim dlg As CommonDialog Dim Files As Variant Dim i As Integer Set dlg = New CommonDialog With dlg .DialogTitle = DialogTitle .DefaultExt = DefaultExt .Filter = Filter .Flags = OFN_EXPLORER
Or OFN_HIDEREADONLY Or OFN_ALLOWMULTISELECT If .ShowOpen Then getFileBySelect = .ParseFileNames End If End With End Function '返回指定目录下指定名
称所有文件的函数 Function GetFileListByPath(Path As String, FileName As String) As Variant Dim s As String Dim sFiles() As String Dim i As Integer s = Dir(Path &
FileName) If s <> \"\" Then ReDim sFiles(i) As String sFiles(i) = Path & s i = 1 s = Dir() While s <> \"\" ReDim Preserve sFiles(i) As String sFiles(i) = Path & s i = i + 1 s = Dir() Wend GetFileListByPath = sFiles End If End Function '选定目录的函数，使用了commonDialog类 Public Function GetDir(DialogTitle As String, FileName As String) As Variant Dim dlg As CommonDialog Dim Path As String Dim FileList As Variant Set dlg = New CommonDialog
第18页
CAD VBA代码 峰
dlg.DialogTitle = DialogTitle If dlg.Browse Then Path = dlg.Path If Path <> \"\" Then Path = Left$(Path, InStr(Path, vbNullChar) - 1) If Right$(Path, 1) <> \"\\\" Then Path = Path & \"\\\" FileList = GetFileListByPath(Path, \"*.dwg\") GetDir = FileList End If End If End Function '由文件全路径名称返回文件的函数 Public Function JustFileName(FileName) As String On Error Resume Next Dim count As Integer For count = Len(FileName) - 1 To 1 Step -1 If Mid(FileName, count, 1) = \"\\\" Or Mid(FileName, count, 1) = \"/\" Then JustFileName = Right(FileName, Len(FileName) - count) Exit For End If Next End Function 33AutoCAD中的延长直线的命令需要先制定边界，再延长，用VBA可以编写一个直接用鼠标来确定延长位置的程序，可谓鼠标指到哪儿，直线就延长到哪儿，再也不用事先画边界了。有兴趣的同行可以给我发E－mail要求源程序
Public Declare Function GetAsyncKeyState Lib \"user32\" (ByVal vKey As Long) As Integer Public Function MyHotKey(vKeyCode) As Boolean MyHotKey = (GetAsyncKeyState(vKeyCode) < 0) End Function Public Sub ExtendLineArc() Dim Object1 As AcadObject, Line2 As AcadLine, Line3 As AcadLine Dim FP As Variant, TP As Variant, OutAngle As Double, kk As Integer Dim P1(0 To 2) As Double, P2(0 To 2) As Double, RetP As Variant, SelectBase As Variant Dim ComS As String On Error Resume Next LLL1: ThisDrawing.Utility.GetEntity Object1, SelectBase,
\"选择需要延长的直线或圆弧：\" If Err Then If MyHotKey(vbKeyEscape) Then Err.Clear Exit Sub End If ThisDrawing.Utility.Prompt \"没有选择实体!\" Err.Clear GoTo LLL1 ElseIf Object1.ObjectName = \"AcDbLine\" Then Object1.Highlight True RetP = ThisDrawing.Utility.GetPoint(, \"延长的位置：\") P1(0) = RetP(0) + 50 *
Cos(Object1.Angle + Pt / 2) P1(1) = RetP(1) + 50 * Sin(Object1.Angle + Pt / 2) P2(0) = RetP(0) + 50 * Cos(Object1.Angle - Pt / 2) P2(1) = RetP(1) + 50 *
Sin(Object1.Angle - Pt / 2) FP = Object1.StartPoint: TP = Object1.EndPoint RetP = Per_Inter(P1(0), P1(1), P2(0), P2(1), FP(0), FP(1)) If CalDis(RetP(0), RetP(1), FP(0), FP(1)) > CalDis(RetP(0), RetP(1), TP(0), TP(1)) Then P1(0) = RetP(0): P1(1) = RetP(1) P2(0) = FP(0): P2(1) = FP(1) Set Line2 =
ThisDrawing.ModelSpace.AddLine(P1, P2) Line2.Color = Object1.Color:
Object1.Delete Else P1(0) = RetP(0): P1(1) = RetP(1) P2(0) = TP(0): P2(1) = TP(1) Object1 Set Line2 =
ThisDrawing.ModelSpace.AddLine(P1, P2) Line2.Color = Object1.Color: Object1.Delete End If Object1.Highlight False Err.Clear GoTo LLL1 ElseIf Object1.ObjectName = \"AcDbArc\" Then Dim Line1 As AcadLine Dim SAngle As Double, EAngle As Double, DDAngle As Double, Angle1 As Double, Angle2 As Double Object1.Highlight True RetP = ThisDrawing.Utility.GetPoint(, \"延长的位置:\") Dim Arc1 As AcadArc, arc2 As AcadCircle If Distance(RetP, Object1.StartPoint) < 0.0000001 Or Distance(RetP, Object1.EndPoint) < 0.0000001 Then FP = Object1.center Set arc2 = ThisDrawing.ModelSpace.AddCircle(FP, Object1.radius) arc2.Color = Object1.Color: Object1.Delete ElseIf Distance(RetP, Object1.StartPoint) < Distance(RetP, Object1.EndPoint) Then SAngle = Object1.startAngle: EAngle = Object1.endAngle FP = Object1.center Set Line1 = ThisDrawing.ModelSpace.AddLine(FP, RetP) Angle2 = Line1.Angle:
第19页
CAD VBA代码 峰
Line1.Delete TP = Object1.StartPoint Set Line1 = ThisDrawing.ModelSpace.AddLine(FP, TP) Angle1 = Line1.Angle: Line1.Delete DDAngle = Angle2 - Angle1 SAngle = SAngle + DDAngle Set Arc1 = ThisDrawing.ModelSpace.AddArc(FP, Object1.radius,
SAngle, EAngle) Arc1.Color = Object1.Color: Object1.Delete Else SAngle = Object1.startAngle: EAngle = Object1.endAngle FP = Object1.center Set Line1 = ThisDrawing.ModelSpace.AddLine(FP, RetP) Angle2 = Line1.Angle: Line1.Delete TP = Object1.EndPoint Set Line1 = ThisDrawing.ModelSpace.AddLine(FP, TP) Angle1 = Line1.Angle: Line1.Delete DDAngle = Angle2 - Angle1 EAngle = EAngle + DDAngle Set Arc1 = ThisDrawing.ModelSpace.AddArc(FP, Object1.radius,
SAngle, EAngle) Arc1.Color = Object1.Color: Object1.Delete End If 'Object1.Highlight False Err.Clear GoTo LLL1 Else ThisDrawing.Utility.Prompt \"你选择的实体无法用本工具延长！\" GoTo LLL1 End If End Sub
34 把选择的对象放大几倍，VBA怎么实现？
object.ScaleEntity BasePoint, ScaleFactor 方法： 其中object为所有图形对象及属性参照对象 BasePoint为基点
ScaleFactor为比例因子
注意对选择集的操作必须遍历选择集中的所有对象，对每个对象进行操作，而不能直接对选择集进行操作，这一点与ALISP不同。
35怎样提取图形的视图左下角、右上角和图形左下角，右上角的坐标？
左下角：Viewport.LowerLeftCorner 右上角：Viewport.UpperRightCorner 用系统变量。
对于图形界限，用下面的系统变量：
LIMMAX 存储当前空间的右上方图形界限 LIMMIN 存储当前空间的左下方图形界限 对于当前视口，用下面的系统变量：
SCREENSIZE 以像素为单位存储当前视口的大小（X 和 Y 值） VIEWCTR 存储当前视口中视图的中心点 VIEWSIZE 存储当前视口的视图高度
先从当前视口的X和Y的比值，根据当前视口的视图高度求出当前视口的视图宽度。然后中心点的X坐标减去视图宽度的一半就是视图左下角的X坐标，中心点的Y坐标减去视图高度的一半就是视图左下角的Y坐标，右上角坐标类似。
第20页
CAD VBA代码 峰
1. 怎么查找某一个group是否存在？-
检查图形中是否含有指定名称的组合的函数 Function GetGroup(GName As String) As Boolean Dim objGroup As AcadGroup On Error Resume Next
Set objGroup = ThisDrawing.Groups(GName) If Err Then
GetGroup = False Else
GetGroup = True End If End Function
'GetGroup函数使用示例 Sub GGroup()
Dim GName As String GName = \"liec\"
Dim GroupTip As String If GetGroup(GName) Then GroupTip = \"有\" Else
GroupTip = \"无\" End If
MsgBox \"图形中\" & GroupTip & \"名称为\" & GName & \"的组合存在\明经通道示例\" End Sub
2.在AutoCAD中，如果你的模板没有经过修改的话，则写入中文时会显示“”这样的文字，这时，你必须手动修改文字样式，增加中文字体的支持，如使用
大字体或使用TTF中文字体。
以下程序你可以保存为DVB文件，然后加入到启动组中，这样当你在写文字时系统会自动设置好中文字体，免去手动设置的麻烦。
Private Sub AcadDocument_BeginCommand(ByVal CommandName As String) If (CommandName = \"TEXT\" Or CommandName = \"MTEXT\") And _ ThisDrawing.ActiveTextStyle.BigFontFile = \"\" And _
LCase(Right(ThisDrawing.ActiveTextStyle.fontFile, 4)) <> \".ttf\" Then ThisDrawing.ActiveTextStyle.BigFontFile = \"gbcbig.shx\" End If End Sub
3. 在编程中，我遇到以下问题：
我用DATAGRID与ADODC控键建立起与外部数据库的连接，但是不知道如何提取其中的单个数据，在VB中就不存在这问题，VB中的其他控键可以绑定ADODC控键，而
第21页
CAD VBA代码 峰
VBA的控键就不行，我该怎么办呢 看看数据库的操作
用数据集Recordset的移动操作，等价于DataGrid中定位到某一行。可以有MoveFirst、MovePrevious、MoveNext、MoveLast等操作，也可以有AddNew、Delete等
4. 当我使用VBA的GetPoint方法，点击锁点工具列抓点(如：nea point,endpoint….)，在Command里居然出现了 *Cancel* 而无法抓点，不知有哪位前
辈知道如何解决呢 解决方法如下： Sub Test()
On Error GoTo ErrTrap
Pt = acadDoc.Utility.GetPoint(Point, Prompt) Exit Sub ErrTrap:
If Err.Number = -2147352567 Then '运行命令，如透明命令等。 Err.Clear Resume
ElseIf Err.Number = -2147467259 Then '右键单击结束，关于按ESC键结束命令可以参考其它有关资料。 End If
On Error GoTo 0 End Sub
5. Sheets(\"检测报告\").Select
With ActiveSheet.PageSetup .PrintTitleRows = False .PrintTitleColumns = False End With
在有的机器上可以通过，有的就不可以，请问和环境有关吗能帮帮我吗？ 我的原理：定植模班，生成工作表，（通过复制），然后向其中填充数据，最后打印 现在我想实现工作表的打印设置同我的模班打印设置相同，不知道你有好的方法吗？？ 正确的使用方法如下：
.PrintTitleRows = \"$1:$2\" .PrintTitleColumns = \"$A:$B\"
如果不打印标题行及列，可以置为空白，如 .PrintTitleRows = \"\" .PrintTitleColumns = \"\"
6. 请问如何让form.hide后form.show时能保持form先前移动后的位置？
form.startposition=0 ‘(手动)
7. 我想在对文件处理前做一个备份，代码如下(在vb中)： Dim docsObj As AcadDocuments
第22页
CAD VBA代码 峰
Dim docTemp As AcadDocument Dim docObj As AcadDocument Dim spaceObj As AcadBlock Dim returnObj As Acad3DSolid Dim temp3Dsolid As Acad3DSolid ''''''''''''''''''''''''''
'docObj是当前文档对象，returnObj是docObj中的一个3D对象 'set spaceObj = docObj
'对象的赋值对没问题，只是下面的代码不能得到我想要的结果 ''''''''''''''''''''''''''
Set docTemp = docsObj.Add
Set temp3Dsolid = spaceObj.CopyObjects(returnObj, docTemp.ModelSpace) '我想应该在新建的文档里有returnObj对象，可结果什么也没有 '各位高手给我看看，先谢谢了！！！
问题在这一句：Set temp3Dsolid = spaceObj.CopyObjects(returnObj, docTemp.ModelSpace)。 首先CopyObjects应该是文档对象的方法，spaceObj应是AcadDocument对象，然后看看它的传递参数，第一个参数Objects应该是对象的数组，应而returnObj应该声明为Dim returnObj(0) As Acad3DSolid，然后对其赋值。最后，看看返回值RetVal，它也是对象的数组，故应声明为Dim temp3Dsolid As Variant。
8. 我需要在vb程序中实现选择内部点对某一个封闭区域进行填充，好像没有生成封闭区域的函数，如果使用sendcommand调用cad的填充命令，基本上可以实现，但
是当封闭区域没有完全显示在视口内时，就会出错。大家有好的方法吗？ Hatch.AppendOuterLoop '外部区域 Hatch.AppendInnerLoop '内部区域 方法不行吗？
如果选择点的话，要把选择到的点生成 Polyline 当内部区域即可!
9怎样计算一个多边形的中心点?
如果你想知道的仅仅是正多边形的中心点位置，这很容易，若边数是奇数，中心点是这样两条线的交点：它们是多边形顶点到相对边垂线。若边数是偶数，两对相对顶点连线的交点就是中心点。
对于一般的多边形，中心点的计算方法有几种，但都比较麻烦。下面介绍的两个算法实际上都可以应用于任何2D图形的中心点计算。 算法1。该算法基于这样两个数学定理：
1、在任意指定的一个方向上，有且仅有一条直线将指定的闭合区域分成两个面积相等的部分。可用极限理论中的“夹逼定理”。具体证明略。 2、在两个不同方向上得到的上述两条直线的交点就是闭合区域的重心位置。要严格证明它，我同样也未找初等方法，要用到比较复杂的微积分知识。不过可以从重心的物理意义出发理解它。
算法1也就是通过尝试找到这样两条直线(或近似值)。这个方法对于不太熟悉微积分的朋友相对容易理解，但实际编程时要多次计算和比较区域的面积，并且在得到将区域分成面积相等的两块的直线过程中，大概要通过递归的方法逐步逼近正确值，运行效率很低。 算法2直接利用数学中重心坐标计算公式，利用微积分方法计算。
第23页
CAD VBA代码 峰
中心点X坐标为：xdxdy在区域上的二重积分/区域面积。 Y坐标为：ydxdy在区域上的二重积分/区域面积。
积分的计算就用矩形逼近求和的方法，或辛普森方法(如果你对精度要求很高的话)。
当然，针对具体的问题可能(应该几乎可以肯定)有更高效的算法。那么就需要你对具体问题准确描述。
10如何返回在命令行中输入的字符,是指在没有按下回车和空格下
用GetInput如何确定返回的是空字串还是按下了Esc键,
我已先指定了一个KeyWord ,当有输入我指定的KeyWord时,再按下Esc时,返回的还是那个KeyWord,怎么办?
如果出错号为：-2147467259
则指的是输入了字符或回车或空格 如果出错号为：-2147352567 则指的是按了取消键
11当我插入块时，鼠标的click_point为两个图块的公共插入点，即同时插入两个块
但我的问题是，如何在插入时将此两块合成一个块?
图块合并可以用CopyObjects方法，但是合并后的图块最好重新起个名字，否则原来的已经插入的图块将会被覆盖更新。
12如何把168.235642度分解成度，分，秒？我没有办法判别小数点？
使用Utility工具AngleToString方法可以实现转换： Document.Utility.AngleToString(Angle,AngUnit,Precision) 其中，Angle参数为你输入的168.235642(Double类型)。 AngUnit是一个枚举类型，其取值及其意义为： acDegrees 度 acDegreeMinuteSeconds 度分秒 acGrads 梯度 acRadians 弧度
Precision为0到8之间的整数，表示返回值精度。 该函数返回转换后的字符串。
另外，在另一个帖子中，你提到要获得小数点后三位数字，乘1000取整除1000是个很好的方法，当然，也可以用VB的FormatNumber函数，详细使用可参考MSDN帮助。
第24页
CAD VBA代码 峰
13. 请问在VBA中怎么使一个选择集只选中模型空间中可见图元？
我隐藏&锁定&冻结了其他,然后使用了 FilterType = 60 FilterData = 0
sset.SelectOnScreen FilterType, FilterData
可是选不中任何图元，也没什么错误提示 烦闷！
你必须通过图层过滤出可见的图层，然后把这些图层做为过滤器的条件 Sub GetEnt()
Dim ss As AcadSelectionSet Set ss = CreateSelectionSet Dim Ly As String Ly = \"\"
Dim Lyer As AcadLayer Dim I As Integer
Debug.Print ThisDrawing.Layers.Count For I = 0 To ThisDrawing.Layers.Count - 1 Set Lyer = ThisDrawing.Layers(I) If Lyer.LayerOn = True Then Ly = Ly & Lyer.Name & \ End If Next
Dim fType As Variant: Dim fData As Variant BuildFilter fType, fData, 8, Ly
ss.Select acSelectionSetAll, , , fType, fData Debug.Print ss.Count End Sub
Public Function CreateSelectionSet(Optional ssName As String = \"ss\") As AcadSelectionSet
Dim ss As AcadSelectionSet
On Error Resume Next
Set ss = ThisDrawing.SelectionSets(ssName)
If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName) ss.Clear
Set CreateSelectionSet = ss
End Function
Public Sub BuildFilter(typeArray, dataArray, ParamArray gCodes()) Dim fType() As Integer, fData() Dim index As Long, I As Long
第25页
CAD VBA代码 峰
index = LBound(gCodes) - 1
For I = LBound(gCodes) To UBound(gCodes) Step 2 index = index + 1
ReDim Preserve fType(0 To index) ReDim Preserve fData(0 To index) fType(index) = CInt(gCodes(I)) fData(index) = gCodes(I + 1) Next
typeArray = fType: dataArray = fData End Sub
14. windows安装了几个打印机，如何用vb指定打印机。谢谢
一般来说，使用
Layout.GetPlotDeviceNames方法之前必须使用
Layout.RefreshPlotDeviceInfo来刷新一下才能得到正确的结果。
得到所有打印机名称后，你就可以使用列表把他们列出来，供用户选择. 15.斑竹能否推荐几个好的国外的CAD二次开发的网站，多谢 http://www.vbcad.com/ http://www.vbdesign.net/
http://ourworld.compuserve.com/h ... ActiveCAD/index.htm http://www.contractcaddgroup.com/ http://www.acadx.com/
http://www.freevbcode.com/ http://www.vbcode.com/
http://www.copypastecode.com/
http://www.vbdesign.net/cgi-bin/ikonboard.cgi
16请教，VBA中的下拉列表控件的数据是怎么和数据库内的数据邦定的？我查了好些东东都不能搞定，那位仁兄可以相告，谢谢。
你可以循环表中的记录来添加到列表中 如：
MatTbl.MoveFirst
For I = 1 To MatTbl2.RecordCount
DimTolCl.AddItem (MatTbl2(\"enname\") & \" \" & MatTbl2(\"cnname\")) MatTbl2.MoveNext Next I
第26页
CAD VBA代码 峰
17请问高手，在VB中如何将如0.00000053的数字，变成形如5.3E-7字样的科学记数法
用Utility对象的RealToString方法
比如：RealToString(0.00000053, acScientific, 1)，它的用法就是将一个实数（双精度）按指定的类型转化成字符串。
18.在vba中有 IsNumberic()函数检测变量是不是数值,但我需要一个能检验 所输的变量是不是 字符charactor的函数,或能实现此功能的办法.
写了个函数，只检测位于a-z和A-Z之间的字符。
Function IsCharacter(ByVal Expression As String) As Boolean I sCharacter = False Dim i As Integer Dim c As Long On Error GoTo ErrTrap If Expression = \"\" Then Exit Function
IsCharacter = True
For i = 1 To Len(Expression) c = Asc(Mid(Expression, i, 1))
If Not ((c >= 65 And c <= 90) Or (c >= 97 And c <= 122)) Then IsCharacter = False Exit For End If Next
Exit Function ErrTrap: On Error GoTo 0 End Function
19在ADDMTEXT中，换行符\\p怎么使用啊？
直接插入到字符串中，不过要用大写的表示，\\P
20请大家帮我解一个数学问题
已知a b c的坐标分别为:(x1,y1) (x2,y2) (x3,y3)，求过c做直线ab的垂足点的坐标(x,y)。
第27页
CAD VBA代码 峰
呵呵，不知道有没有现成的公式呢？用直角三角形三边关系列那个二元二次方程实在太令人头痛了
斜率k=(y2-y1)/(x2-x1) y-y1=k*(x-x1) y-y3=-1/k*(x-x3)
21我设了一选择集，内就一个对象（样条曲线），想求出该样条曲线和另一直线的交点，却无法引用该样条曲线。请高手指点！急！！
If sset(0).EntityType = acLine Then Set lineObj = sset(0) MsgBox lineObj.Length End If
lineObj是一个直线对象，引用其它对象使用相同的方法
22. 如何得到objectDBX及其帮助？
23请教CAD屏幕选取一个块后,怎样获得它的属性,并存放在一个数组里. 必须先定义一个二维数组 如：
Dim AttArray(1, UBound(vaattributes)) As Variant
然后在下面的循环中把属性填充到数组中：
For J = 0 To UBound(vaattributes)
AttArray(0,J)=vaattributes(J).TagString AttArray(1,J) = attvars(J).TextString Next
24. 哪位大侠知道，怎么取得任意图形的中心点坐标！
如果是指质心的话，你可以先将图形做成面域（region） 然后再找这个面域的centroid属性即可。
但要说明的是，这个centroid是个二维点，你只能得到centroid（0）和centroid（1）两个量。其余的应该好办了吧。
如果不是质心，可以用getboundary方法来找图形的几何中心
25测量坐标与屏幕坐标的转换
us1 = ThisDrawing.GetVariable(\"userr1\") us2 = ThisDrawing.GetVariable(\"userr2\")
第28页
CAD VBA代码 峰
us3 = ThisDrawing.GetVariable(\"userr3\") ThisDrawing.GetVariable(\"useri5\") = 666
请教：userr1，userr2，userr3，userri5这几个系统变量有什么用？ userr1，userr2，userr3，userri5
按顺序排：比例尺，左下角x坐标，左下角y坐标，高程比例尺
26VBA回车响应的问题
我想在对话框显示的时候，按回车就立即响应COMMAND1的CLICK事件。 我写的程序为：
Private Sub UserForm_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) If KeyAscii = 13 Then UserForm1.Hide End If End Sub
运行时，按回车无响应。
怎样才能按回车就立即响应COMMAND1的CLICK事件？ 请各位多多指教。
将Command1的Default属性更改为True。这样，只要是你在编辑框中按了回车，就可以默认Command1中的点击事件。
27.是根据VBA教材的代码改的批量裁剪程序
Sub Trim()
Dim acadapp As AcadApplication Dim acaddoc As AcadDocument
Set acadapp = connectcad(acadapp) Set acaddoc = acadapp.ActiveDocument
AppActivate acadapp.Caption '让CAD得到焦点 Dim Pnt1 As Variant
Dim entObj1 As AcadEntity
acaddoc.Utility.GetEntity entObj1, Pnt1, \"选择修剪边界：\" Dim det1 As String
det1 = axEnt2lspEnt(entObj1) Dim Pnt2 As Variant
Dim entObj2 As AcadEntity Dim sle1 As AcadSelectionSet On Error Resume Next
Set sle1 = acaddoc.SelectionSets.Item(\"sle1\") sle1.Clear If Err Then
第29页
CAD VBA代码 峰
Err.Clear
Set sle1 = acaddoc.SelectionSets.Add(\"sle1\") End If
acaddoc.Utility.Prompt \"选择需要修剪的对象\" & Chr(13) sle1.SelectOnScreen
Pnt2 = acaddoc.Utility.GetPoint(, \"选择修剪方向\") Dim det2 As String
For Each entObj2 In sle1
det2 = GetDoubleEntTable(entObj2, Pnt2
acaddoc.SendCommand \"_trim\" & vbCr & det1 & vbCr & vbCr & det2 & vbCr & vbCr Next
Dim command_str As String command_str = Chr(3) & Chr(3)
acaddoc.SendCommand command_str acaddoc.Utility.Prompt \"修剪完成!\" acaddoc.SendCommand command_str Set acadapp = Nothing End End Sub
'转换双元表的函数
Public Function GetDoubleEntTable(entObj As AcadEntity, Pnt As Variant) As String Dim entHandle As String entHandle = entObj.Handle
GetDoubleEntTable = \"(list(handent \" & Chr(34) & entHandle & Chr(34) & _ \")(list \" & Str(Pnt(0)) & Str(Pnt(1)) & Str(Pnt(2)) & \"))\" End Function '转换点的函数
Public Function axPoint2lspPoint(Pnt As Variant) As String axPoint2lspPoint = Pnt(0) & \End Function '转换图元函数
Public Function axEnt2lspEnt(entObj As AcadEntity) As String Dim entHandle As String entHandle = entObj.Handle
axEnt2lspEnt = \"(handent \" & Chr(34) & entHandle & Chr(34) & \")\" End Function
Function connectcad(acadapp As AcadApplication) As AcadApplication '连接AUTOCAD On Error Resume Next '与autocad通信
Set acadapp = GetObject(, \"AutoCAD.Application\") If Err Then Err.Clear
Set acadapp = CreateObject(\"AutoCAD.Application\")
第30页
CAD VBA代码 峰
If Err Then
MsgBox Err.Description Exit Function End If End If
Set connectcad = acadapp End Function
Private Sub Form_Initialize() Trim End Sub
你的程序本身有问题：
在选择修剪方向时，其实你只认定了一个点Pnt2，然后你就使用该点组成了修剪的双元表，这样的话，对于被修剪对象来说，可能会产生点取的点在外部的问题，因为系统认定的点取的位置是Pnt2到被修剪对象上的垂直点的位置。 要达到效果，应该是：
点取一个点Pnt2后，把多段线向内偏移一小段距离，然后逐条遍历被修剪对象的选择集，求选择集中的对象与偏移的对象的交点，再通过交点来组成双元表，这样的话，应该可以解决。
双元表也就是指在进行一些对象操作时对位置有要求时使用数据格式
28. 我用sendcommand的_trim命令，经常剪不断，怎么办？
是从“实用函数”里学到的方法，做了一些修改：
Public Sub Trim(ByVal cutLine1 As AcadLine, ByVal cutLine2 As AcadLine, _ ByVal entSP As AcadSpline, ByVal optCode As String) 'cutLine1 cutLine2是_trim的两个边界线，endSP是要剪的样条曲线。
Dim det1, det2 As String
det1 = axEnt2lspEnt(cutLine1) det2 = axEnt2lspEnt(cutLine2)
Dim det3, det4 As String
det3 = GetDoubleEntTable(entSP, entSP.GetControlPoint(0))
det4 = GetDoubleEntTable(entSP, entSP.GetControlPoint(entSP.NumberOfControlPoints - 1))
If optCode = \"first\" Then
ThisDrawing.SendCommand \"_trim\" & vbCr & det2 & vbCr & _ vbCr & det4 & vbCr & vbCr GoTo rtn End If
If optCode = \"last\" Then
第31页
CAD VBA代码 峰
ThisDrawing.SendCommand \"_trim\" & vbCr & det1 & vbCr & _ vbCr & det3 & vbCr & vbCr GoTo rtn End If
ThisDrawing.SendCommand \"_trim\" & vbCr & det1 & vbCr & det2 & _ vbCr & vbCr & det3 & vbCr & det4 & vbCr & vbCr rtn:
End Sub
'转换双元表的函数
Private Function GetDoubleEntTable(entObj As AcadEntity, Pnt As Variant) As String Dim entHandle As String entHandle = entObj.Handle
GetDoubleEntTable = \"(list(handent \" & Chr(34) & entHandle & Chr(34) & _ \")(list \" & Str(Pnt(0)) & Str(Pnt(1)) & Str(Pnt(2)) & \"))\" End Function
'转换点的函数
Private Function axPoint2lspPoint(Pnt As Variant) As String axPoint2lspPoint = Pnt(0) & \End Function
'转换图元函数
Private Function axEnt2lspEnt(entObj As AcadEntity) As String Dim entHandle As String entHandle = entObj.Handle
axEnt2lspEnt = \"(handent \" & Chr(34) & entHandle & Chr(34) & \")\" End Function
作用主要是把样条曲线其中两个拟合点之间的一段剪出来，但在弯比较急的地方经常剪不断，造成出错。请问怎么办？
29关于split()函数的问题
我在尝试用CommonDialog打开多个文件时，为分离各个文件名，用了split()函数，但结果却怎么也不对。具体代码如下： Dim NewFileName() As String
CommonDialog1.filter = \"Drawing Files(*.dwg)|*.dwg|\" & \"All Files(*.*)|*.*|\" CommonDialog1.flags = cdlOFNAllowMultiselect Or cdlOFNExplorer CommonDialog1.FilterIndex = 1
CommonDialog1.DialogTitle = \"选择文件...\" CommonDialog1.InitDir = \"e:\\\" CommonDialog1.ShowOpen
第32页
CAD VBA代码 峰
NewFileName() = Split(CommonDialog1.FileName, \"\")
'因为用监视窗口察看CommonDialog1.FileName各文件之间用间隔，但此时的NewFileName(0) =CommonDialog1.FileName，即split()函数没起作用，但若我 定义CommonDialog1.FileName=\"E:\\pb02009083.dwgpb02009082\则split()函数则 起作用，此时NewFileName() 为正确结果。 不知大家能否帮我解决这一难题，不胜感激。
NewFileName() = Split(CommonDialog1.FileName, Chr(0))
30我有一个问题,就是\"在AUTOCAD中用VBA或Visual LISP中写一个程式,能在AUTOCAD中选中一个封闭的多义线(在封闭的多义线中有直线,倒圆角,圆弧,角度)按
逆时针找出每一个2D坐标,写在一个文本文件里!
我在网上坛子里问了三个月了,十几个人说来说去,都没搞定. Sub oef()
Dim pnt As Variant
Dim ent1 As AcadLWPolyline Dim ent2 As AcadLWPolyline Dim ents As Variant Dim pnts As Variant Dim cnt As Integer Dim cor() As Double Dim i As Integer Dim txt As String
ThisDrawing.Utility.GetEntity ent1, pnt pnts = ent1.Coordinates cnt = (UBound(pnts) + 1) / 2 Debug.Print cnt
ReDim cor(1, cnt) As Double For i = 0 To UBound(pnts) Step 2 cor(0, i / 2) = ent1.Coordinates(i) cor(1, i / 2) = ent1.Coordinates(i + 1) Next
ents = ent1.Offset(10) Set ent2 = ents(0)
If ent2.Area > ent1.Area Then
txt = \"逆时针方向，其逆时针坐标如下：\" For i = 0 To UBound(cor, 2) - 1
txt = txt & vbCr & cor(0, i) & \Next Else
txt = \"线为顺时针方向，已经转换为逆时针的坐标如下：\" For i = UBound(cor, 2) - 1 To 0 Step -1
txt = txt & vbCr & cor(0, i) & \Next End If
For i = 0 To UBound(ents)
第33页
CAD VBA代码 峰
ents(i).Delete Next
MsgBox txt
End Sub
31如何在VB中开关非当前层？
Sub SetLayerOff()
Dim LayerName As String LayerName = \"1\"
On Error Resume Next Err.Number = 0
Dim MyLayer As AcadLayer
Set MyLayer = ThisDrawing.Layers(LayerName) If Err.Number = 0 Then
ThisDrawing.Layers(LayerName).LayerOn = False
ThisDrawing.Utility.Prompt vbCrLf & \" 图层“\" & LayerName & \"”已经被关闭。\" Else
ThisDrawing.Utility.Prompt vbCrLf & \" 图层“\" & LayerName & \"”不存在。\" End If End Sub
第34页
因篇幅问题不能全部显示，请点此查看更多更全内容