CAD VBA代码Word文档格式.docx
《CAD VBA代码Word文档格式.docx》由会员分享，可在线阅读，更多相关《CAD VBA代码Word文档格式.docx（51页珍藏版）》请在冰点文库上搜索。
）'
定义一个"
的块
arcc（0）=0
arcc
（1）=430
Callplayerblock.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
Setline1=ThisDrawing.ModelSpace.AddPolyline（pline）'
画队服右侧多段线
linep2
（1）=1'
镜像轴第二点位于Y轴上任一点
Setline2=line1.Mirror（linep1,linep2）'
镜像获得另一半多段线
Dimp（0To2）AsDouble'
定义坐标变量
Setmytxt=ThisDrawing.TextStyles.Add（"
mytxt"
添加mytxt样式
mytxt.fontFile="
c:
\windows\fonts\simfang.ttf"
'
设置字体文件为仿宋体
ThisDrawing.ActiveTextStyle=mytxt'
将当前文字样式设置为mytxt
playernumberpoint（0）=0'
块属性位置
playernumberpoint
（1）=200
Setattr1=ThisDrawing.ModelSpace.AddAttribute（100,acAttributeModeNormal,"
号码"
playernumberpoint,"
X"
0）'
画块属性
attr1.Alignment=7'
居中
attr1.TextAlignmentPoint=playernumberpoint'
重定义对齐点
Setattr2=ThisDrawing.ModelSpace.AddAttribute（100,acAttributeModeNormal,"
姓名"
"
attr2.Alignment=7'
DimobjCollection（0To3）AsObject'
创建选择集
SetobjCollection（0）=line1'
线条1加入选择集
SetobjCollection
（1）=line2'
线条2加入选择集
SetobjCollection
（2）=attr1'
属性1加入选择集
SetobjCollection（3）=attr2'
属性2加入选择集
CallThisDrawing.CopyObjects（objCollection,playerblock）'
把选择集加入块中
ForEachelementInobjCollection'
在选择集中进行循环
element.Delete'
删除线条和属性（此操作并不影响已创建的块）
Next
Setplayerlay=ThisDrawing.Layers.Add（"
新建图层
playerlay.color=2'
为黄色
ThisDrawing.ActiveLayer=playerlay'
将当前图层设置为球员图层;
Dimp1AsVariant'
块插入点位置
Fori=1To11'
插入块
pstring=CStr（i）&
"
号球员位置：
p1=ThisDrawing.Utility.GetPoint（,pstring）'
点选球员位置坐标
nstring=ThisDrawing.Utility.GetString（30,"
球员姓名：
）
SetblockRef=ThisDrawing.ModelSpace.InsertBlock（p1,"
1,1,1,0）'
Attr3=blockRef.GetAttributes'
获取块属性
Attr3（0）.TextString=CStr（i）'
赋值球员号码
Attr3
（1）.TextString=nstring'
赋值球员姓名
Next-
EndSub
SetmBlock=ThisDrawing.Blocks.Add（insertPt,tmpName），其中mBlock是AcadBlock对象，insertPt是插入点的坐标（相对与块），tmpName是块的名称。
块和块的实例是两个概念。
块只能有一个，但是这个块的实例却可以有很多个。
使用上述方法得到的是块，而不是块的实例。
你能够在CAD菜单栏“插入-块”所打开的对话框中看到名字为tmpName的块，但是CAD图形中并没有块的图形。
CallThisDrawing.ModelSpace.InsertBlock（Text_P,"
图框B"
1,1,1,0）
'
（座标，X轴扩，Y轴扩，Z轴扩，旋转）
插入块。
2、画直线
（单段线）
Set
ln
=
ThisDrawing.ModelSpace.AddLine（startPt（）,
EndPt（））
3、画多段线
Dimp（0To49）AsDouble'
定义点坐标
Setmyl=ThisDrawing.ModelSpace.AddLightWeightPolyline（p）'
画多段线
myl.Color=co'
设置颜色属性
myl.ConstantWidth=2'
设置多段线宽度属性
3.1、修改出线点的位置
SetLine2=Line1.Mirror（CC_XYZ,CC_Mir_XYZ）'
交叉线2镜像
修改出线点的位置
a=Line2.Coordinates
a
（1）=a
（1）-（Phase_Number-1-i）*Spacing
Line2.Coordinates=a
4、画圆
拓展程序（将上述画圆的程序拓展为每画一个圆设定为一种颜色）
Subc100（）
Dimcc（0To2）AsDouble'
声明坐标变量
cc（0）=1000'
定义圆心座标
cc
（1）=1000
cc
（2）=0
DimmylAsObject'
定义引用曲线对象变量
co=15'
定义颜色
Fori=1To1000Step10'
开始循环
Setmyl=ThisDrawing.ModelSpace.AddCircle（cc,i*10）'
画圆,cc数组为圆心X、Y、Z值
myl.color=co'
co=co+1'
改变颜色，供下次定义曲线颜色
Nexti
5、获取鼠标指定的坐标点
ThisDrawing.Utility.GetPoint（,"
输入点:
获取点坐标
6、旋转
NewFilterEnt.Rotate
PT,
JiaoDu
更新对象
PT（基点）对你JiaoDu孤度
NewFilterEnt.Update
文字旋转
SetMy_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.RotateXYZ,Radian
My_Text.Update
Str_Number=Str_Number+1'
下级数组
7.插入文字（单选）
SetTextobj=ThisDrawing.ModelSpace.AddText（Text,Text_P,H）
Textobj.Alignment=Text_Alignment'
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.插入文字（多行）
Settxtobj=ThisDrawing.ModelSpace.AddMText（p,1400,"
{做到老，学到老}\P"
&
此心自光明正大，过人远矣"
txtobj.LineSpacingFactor=2'
指定行间距
txtobj.AttachmentPoint=3'
右对齐（1为左对齐，2为居中）
9、画圆弧
ThisDrawing.ModelSpace.AddArc（Center,Radius,StartAngle,EndAngle）
startangle:
可以根据圆心坐标和起点坐标计算出startangle
endangle:
可以根据startangle和圆弧角度算出endangle
10、画图椭圆
Dim
pEllipse
As
AcadEllipse‘椭圆线
center（0
To
2）
Double
中心点坐标
p（0
相对座标以圆心为参照
maj
Double,
min
angle
Double
ratio
ThisDrawing.ModelSpace.AddEllipse（center,
p,
/
maj）
pEllipse.Rotate
center,
（360
-
angle）
*
3.1415
180#
#1的数据
分别表示椭圆长轴，短轴，方位角，中心点坐标X，中心点坐标Y
格式如下：
11、CAD打开读取数据
DimLaAsAcadLayerExcelApp.Workbooks.Open"
D:
\TK\龙岗索引.xls"
CASS通过VBA打开EXCEL索引文档
WithExcelApp.ActiveWorkbook.Worksheets（"
龙岗索引"
Fori=2To[A65536].End（xlUp）.Row'
从第二行遍历EXCEL记录
th=.Range（"
B"
i）
IfDir（"
\DWG\"
Right（th,5）&
.DWG"
）<
>
Then
判断EXCEL中图幅号对应的DWG文档是否存在，如果存在就打开
SetAcadDocTk=ThisDrawing.Application.Documents.Open（"
\TK\图框.DWG"
）'
打开TK模板
tm=.Range（"
A"
chdw=.Range（"
C"
i）'
变量赋值
jd=.Range（"
R"
sm=.Range（"
S"
X=.Range（"
V"
Y=.Range（"
U"
12、绘制圆弧
R=100（半径）
stangle=45*3.14/180（起始位）
edangle=135*3.14/180（结束位）
Setarcobj=ThisDrawing.ModelSpace.AddArc（center,r,stangle,edangle）
二、CADVBA程序答
1.VBA写的宏，可否编译成象ARX一样的程序，经加载后，在命令行打入命令后就可运行
不行，必须自己写LISP加载和运行
2.VB中可以生成可执行文件，而在VBA中却不行
如果在VBA中能生成可执行文件，请问是怎样做的，不胜感激！
！
VBA是不行，它只能内嵌于Autocad中运行，你可以将代码改在VB下用
3.自动加载执行VBA程序
你可以试试以下LSP函数。
它与autoload的LSP函数功能一样，只要你按照它的要求写入你的执行命令名、DVB文件名及宏名就可以自动加载执行，再也不用专门写LSP程序了。
（defunAutoVBALoad（cmdnameprojectmacro）
（eval
（list'
defun
（read（strcat"
C:
cmdname））
nil
（list
vl-vbarun
（strcat
project"
!
（ifmacromacrocmdname）
）
（princ）
）
你把函数复制到acad2000doc.lsp文件中，以后每写一个VBA程序，就可以通过写入一行：
（AutoVBALoad<
命令名>
<
工程文件>
宏>
来自动调用，示例如下：
命令名为update，工程文件为myproject.dvb，模块为Foo，宏为Bar，则写为：
（AutoVBALoad"
UPDATE"
MyProject.dvb"
Foo.Bar"
如果宏的位置在ThisDrawing中，则写为：
Bar"
是不是很方便。
4.当我想添加commondialog控件时，总是无法添加，并提示：
没有正确授权。
（是不是我用的D版AutoCad2000的原因）。
经过重装vb6,已经可以添加commondialog控件了。
5.有时文字是从别的图中复制-粘贴的,如果不打破的话,能否直接得到文字内容.
GetSubEntity方法
它可以直接取得图元或嵌套图元的信息，取得后你就可以随便对其进行读取或更改。
语法：
object.GetSubEntityObject,PickedPoint,TransMatrix,ContextData[,Prompt]
样例：
SubExample_GetSubEntity（）
Thisexamplepromptstheusertoselectonobjectonthescreenwithamouseclick,
andreturnssomeinformationabouttheselectedobject.
DimObjectAsObject
DimPickedPointAsVariant,TransMatrixAsVariant,ContextDataAsVariant
DimHasContextDataAsString
OnErrorGoToNOT_ENTITY
TRYAGAIN:
MsgBox"
Usethemousetoclickonanentityinthecurrentdrawingafterdismissingthisdialogbox."
Getinformationaboutselectedobject
ThisDrawing.Utility.GetSubEntityObject,PickedPoint,TransMatrix,ContextData
Processanddisplayselectedobjectproperties
HasContextData=IIf（VarType（ContextData）=vbEmpty,"
doesnot"
"
does"
Theobjectyouchosewasan:
TypeName（Object）&
vbCrLf&
_
Yourpointofselectionwas:
PickedPoint（0）&
PickedPoint
（1）&
PickedPoint
（2）&
Thisobject"
HasContextData&
havenestedobjects."
ExitSub
6.想必河伯对Excel/ActiveX有研究,能否请教如何获得Excel文件最后一行的信息?
可以用CurrentRegion属性计算最后一行
CurrentSheet.Range（"
A1"
）.Activate
SheetRows=ExcelApp.ActiveCell.CurrentRegion.Rows.Count'
有效数据行数
7.如何调用vba命令对多义线进行fit（拟合）处理
直接用SendCommand方法，调用命令进行编辑
8.块属性值编辑
PublicSubGetAttribute（）
本段代码从选中的图块中获取属性值，并对其修改
DimentObjAsAcadEntity
DimpickPntAsVariant
DimblkRefObjAsAcadBlockReference
选择图元
ThisDrawing.Utility.GetEntityentObj,pickPnt
判断是否为块引用
IfStrComp（entObj.ObjectName,"
AcDbBlockReference"
1）<
0Then
你选择的不是一个图块，程序将退出！
如果选择的不是一个块引用则程序退出运行
EndIf
如果选择的是块引用，将其赋给块引用对象
SetblkRefObj=entObj
判断该块引用是否含有属性值
IfNotblkRefObj.HasAttributesThen
你选择的图块没有块属性，程序将退出！
如果不含由属性值退出
DimattVarsAsVariant
DimIAsInteger
获取块引用中的块属性对象
attVars=blkRefObj.GetAttributes
对块属性对象进行遍历
ForI=0ToUBound（attVars）
第"
I+1&
属性对象的属性值分别如下：
Chr（13）&
属性标签为：
attVars（I）.TagString&
属性值为：
attVars（I）.TextString
Next
将块属性的标签和值进行修改
attVars（0）.TagString="
NewTag"
attVars（0）.TextString="
NewValue"
ThisDrawing.RegenTrue
9.如何用程序控制对象捕捉
通过设置系
升级会员 