CAD VBA代码.docx
《CAD VBA代码.docx》由会员分享，可在线阅读，更多相关《CAD VBA代码.docx（51页珍藏版）》请在冰豆网上搜索。
CADVBA代码
一、基本操作
变量可以不填可不填，在前面加入optional如optionalAasstring
1、块操作
1.1、定义块方法：
Setblocksobj=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．插入块，修改球衣号码属性、球员姓名属性
Subteam（）
DimplayerlayAsAcadLayer'定义球员图层
DimplayerblockAsAcadBlock'定义块变量
Dimarcc（0To2）AsDouble'圆弧圆心
Dimlinep1（0To2）AsDouble'线条端点1
Dimlinep2（0To2）AsDouble'线条端点2
Dimpline（0To20）AsDouble'定义队服右侧多段线7个顶点
Dimbasep（0To2）AsDouble'块基点
Dimplayernumberpoint（0To2）AsDouble'块属性插入点
DimmytxtAsAcadTextStyle'定义mytxt变量为文本样式
DimblockRefAsAcadBlockReference'定义块属性变量
DimAttr3AsVariant'插入块属性变量
Setplayerblock=ThisDrawing.Blocks.Add（basep,"球员"）'定义一个"球员"的块
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,"姓名",playernumberpoint,"",0）'画块属性
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
EndSub
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'中心对齐文字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.插入文字（多行）
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‘椭圆线
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打开读取数据
DimLaAsAcadLayerExcelApp.Workbooks.Open"D:
\TK\龙岗索引.xls"'CASS通过VBA打开EXCEL索引文档
WithExcelApp.ActiveWorkbook.Worksheets（"龙岗索引"）
Fori=2To[A65536].End（xlUp）.Row'从第二行遍历EXCEL记录
th=.Range（"B"&i）
IfDir（"D:
\DWG\"&Right（th,5）&".DWG"）<>""Then '判断EXCEL中图幅号对应的DWG文档是否存在，如果存在就打开
SetAcadDocTk=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（结束位）
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中，则写为：
（AutoVBALoad"UPDATE""MyProject.dvb""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"）
MsgBox"Theobjectyouchosewasan:
"&TypeName（Object）&vbCrLf&_
"Yourpointofselectionwas:
"&PickedPoint（0）&","&_
PickedPoint
（1）&","&_
PickedPoint
（2）&vbCrLf&_
"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
MsgBox"你选择的不是一个图块，程序将退出！
"
'如果选择的不是一个块引用则程序退出运行
ExitSub
EndIf
'如果选择的是块引用，将其赋给块引用对象
SetblkRefObj=entObj
'判断该块引用是否含有属性值
IfNotblkRefObj.HasAttributesThen
MsgBox"你选择的图块没有块属性，程序将退出！
"
'如果不含由属性值退出
ExitSub
EndIf
DimattVarsAsVariant
DimIAsInteger
'获取块引用中的块属性对象
attVars=blkRefObj.GetAttributes
'对块属性对象进行遍历
ForI=0ToUBound（attVars）
MsgBox"第"&I+1&"属性对象的属性值分别如下：
"&Chr（13）&Chr（13）&_
"属性标签为：
"&attVars（I）.TagString&Chr（13）&_
"属性值为：
"&attVars（I）.TextString
Next
'将块属性的标签和值进行修改
attVars（0）.TagString="NewTag"
attVars（0）.TextString="NewValue"
ThisDrawing.RegenTrue
EndSub
9.如何用程序控制对象捕捉
通过设置系
升级会员 