CADVBA例子文档格式.docx
《CADVBA例子文档格式.docx》由会员分享，可在线阅读，更多相关《CADVBA例子文档格式.docx（29页珍藏版）》请在冰点文库上搜索。
图纸空间（PaperSpace）集合
包含在活动图纸空间布局中的所有图形对象（图元）。
图块（Block）对象
包含在指定图块定义中的所有图元。
图块（Blocks）集合
包含在图形中的所有图块。
字典（Dictionaries）集合
包含在图形中的所有字典。
标注样式（DimStyles）集合
包含在图形中的所有标注样式。
组合（Groups）集合
包含在图形中的所有组合。
超级链接（Hyperlinks）集合
包含提供图元的所有超级链接。
图层（Layers）集合
包含在图形中的所有图层。
布局（Layouts）集合
包含在图形中的所有布局。
线型（Linetypes）集合
包含在图形中的所有线型。
菜单条（MenuBar）集合
包含当前显示于AutoCAD的所有菜单。
菜单组（MenuGroups）集合
包含当前装载到AutoCAD中的所有菜单和工具栏。
注册应用程序（RegisteredApplications）集合
包含在图形中的所有注册的应用程序。
选择集（SelectionSets）集合
包含在图形中所有的选择集。
字型（TextStyles）集合
包含在图形中所有的文字样式。
UCSs集合
包含在图形中所有的用户坐标系统（UCS）。
视图（Views）集合
包含在图形中所有的视图。
视口（Viewports）集合
包含在图形中所有的视口。
三、理解对象的属性和方法
每一对象都关联着属性和方法。
属性描述着单个对象的外观，而方法是一种可在单个对象上执行的行为。
当对象创建后，你就可通过属性和方法查询和编辑对象。
例如，一个圆对象有圆心属性。
该属性以三维世界坐标系统的坐标描述了圆的圆心。
更改圆的圆心，你只要简单地将该属性设定为新的坐标。
圆对象也有称为偏移（Offset）的方法。
该方法可在相对于现存圆的指定偏移距离创建一个新的对象。
关于圆对象所有属性和方法的列表，请参考AutoCADActiveX和VBA参考中的圆对象。
四、开发实例
1、程序和文档窗口设置
'
*****************************************************************************
SubMyWindow（）
MsgBoxThisDrawing.WindowTitle'
="
杨彪绘图01"
ThisDrawing.WindowState=acMin'
acMax'
acNorm
EndSub
SubSetMyAcadTitle（）
Dimhw&
hw=GetParent（GetParent（ThisDrawing.hwnd））
SetWindowTexthw,"
杨彪地质编录出图子系统"
CallInitialDZBL'
初始化
ThisDrawing.WindowState=acMax
SubSetMyAcadWindow（）
ThisDrawing.Application.WindowState=acNorm
ThisDrawing.Application.WindowLeft=100
ThisDrawing.Application.Width=600
ThisDrawing.Application.Height=600
2、视图
**************************************************************************
SubMyZoomView1（）
ThisDrawing.Application.ZoomExtents
ZoomAll
SubMyZoomView2（）
DimVPn1AsVariant,VPn2AsVariant
VPn1=ThisDrawing.Utility.getpoint（,"
缩放窗口左下点：
"
）
VPn2=ThisDrawing.Utility.getpoint（,"
缩放窗口右上点：
ThisDrawing.Application.ZoomWindowVPn1,VPn2
3、二维图形绘制
‘addline
SubMyaddline（）
DimlnAsAcadLine
DimstartPt
（2）AsDouble,EndPt
（2）AsDouble
startPt（0）=0
startPt
（1）=0
startPt（0）=100
startPt
（1）=50
Setln=ThisDrawing.ModelSpace.AddLine（startPt（）,EndPt（））
ln.color=acRed
‘LightWeightPolyline
SubMyLightWeightPolyline（）
DimMyPlnAsAcadLWPolyline
DimPnts（9）AsDouble
ForI=0To9
Pnts（I）=Rnd*100
Next
Pnts（0）=PntMin（0）:
Pnts
（1）=PntMin
（1）
Pnts
（2）=PntMin（0）+DWidth:
Pnts（3）=PntMin
（1）
Pnts（4）=PntMin（0）+DWidth:
Pnts（5）=PntMin
（1）+DHeight
Pnts（6）=PntMin（0）:
Pnts（7）=PntMin
（1）+DHeight
Pnts（8）=PntMin（0）:
Pnts（9）=PntMin
（1）
SetMyPln=ThisDrawing.ModelSpace.AddLightWeightPolyline（Pnts）
DimnAsInteger
n=UBound（Pnts）
ForK=0To（n/2-1）'
宽度设定
MyPln.SetWidthK,K/5,Rnd*10
MyPln.color=acYellow
‘Polyline
SubMyPolyline（）
DimMyPlnAsAcadPolyline
DimPnts（8）AsDouble'
必须是3*N的数组
ForI=0To8
SetMyPln=ThisDrawing.ModelSpace.AddPolyline（Pnts）
ForK=0To（n/3-1）'
‘LightCircleandHatch
SubMyCircle（）
DimCir（0）AsAcadCircle
输入插入点：
SetCir（0）=ThisDrawing.ModelSpace.AddCircle（VPn1,10#）
SetMyHatchObj=ThisDrawing.ModelSpace.AddHatch（0,"
Solid"
True）
MyHatchObj.AppendOuterLoop（Cir）
MyHatchObj.color=1
MyHatchObj.Evaluate
SubMytext（）
DimMyTxtAsAcadText
DimStrTxtAsString
DimVPnts
（2）AsDouble
StrTxt="
HoHaiUniverSity河海大学土木工程学院测绘工程系"
SetMyTxt=ThisDrawing.ModelSpace.AddText（StrTxt,VPnts,100）
MyTxt.color=acRed
SubMyPoint（）
DimPnts（0To2）AsDouble
DimIAsInteger,JAsInteger
DimMyPointAsAcadPoint
Pnts（I）=50
Pnts（I）=60
SetMyPoint=ThisDrawing.ModelSpace.AddPoint（Pnts）
4、图层
SubGetlayerName（）
DimMyLayAsAcadLayer
DimBLExistAsBoolean
BLExist=False
DimLayExitAsBoolean
LayExit=False
ForEachMyLayInThisDrawing.Layers
IfMyLay.Name="
ybNewLayer"
ThenLayExit=True
MsgBoxMyLay.Name,vbInformation
IfLayExitThen
MsgBox"
图层：
ybNewLayer'
已经存在!
vbCritical
Else
ThisDrawing.Layers.Add"
EndIf
ThisDrawing.Layers（"
）.LayerOn=True
）.Lock=False
ThisDrawing.ActiveLayer=ThisDrawing.Layers（"
'
obj.Layer="
ThisDrawing.Layers（"
）.color=1
EndSub
SubCh2_IterateLayer（）
'
在图层集合中循环
OnErrorResumeNext
DimIAsInteger
DimmsgAsString
msg="
ForI=0ToThisDrawing.Layers.count-1
msg=msg+ThisDrawing.Layers.Item（I）.Name+vbCrLf
MsgBoxmsg
5、用户输入
***********************************************************************
SubGetInput（）
DimVPn1AsVariant,StrTFAsString,KwordListAsString,Str1AsString
DimObj1AsAcadObject
Str1=ThisDrawing.Utility.GetString（1,"
请输入点号：
KwordList="
YN"
ThisDrawing.Utility.InitializeUserInput1,KwordList
StrTF=ThisDrawing.Utility.GetKeyword（"
是否显示选点的坐标？
（是Y）/（否N）：
IfUCase（StrTF）="
Y"
Then
点"
&
Str1&
"
：
X="
VPn1（0）&
;
Y="
VPn1
（1）&
:
Z="
VPn1
（2）,vbInformation
ThisDrawing.Utility.GetEntityObj1,Pnt1,"
选择一个对象：
Obj1.color=1
SubMyZoomView3（）
请按回车键：
ThisDrawing.Application.ZoomScaled0.7,acZoomScaledRelative
6、选择集合'
****SelectionSets***************************
SubMySelectionSets（）
DimKAsInteger
DimssetObjAsAcadSelectionSet
DimobjCollectionAsAcadEntity
DimobAsAcadEntity
ForI=ThisDrawing.SelectionSets.count-1To0Step-1
ThisDrawing.SelectionSets（I）.Delete
NextI
ThisDrawing.Utility.GetEntityobjCollection,Pnt1,"
objCollection.color=1
SetssetObj=ThisDrawing.SelectionSets.Add（"
ybssa"
SetssetObj=ThisDrawing.ActiveSelectionSet
ssetObj.SelectacSelectionSetAll
IfssetObj.count>
0Then
选择集中对象数目:
ssetObj.count
ForEachobInssetObj
ob.color=acMagenta
7、栅格图像Raster
SubInsertRaster（）
DimaAsAcadRasterImage
Dimb
（2）AsDouble
DimlyAsAcadLayer
DimPicFileNameAsString
DimfactorAsDouble
factor=2#
Setly=ThisDrawing.Application.ActiveDocument.Layers.Add（"
底图"
PicFileName="
E:
\图片\Bliss.jpg"
b（0）=100
b
（1）=100
b
（2）=0
Seta=ThisDrawing.Application.ActiveDocument.ModelSpace.AddRaster（PicFileName,b,factor,45）
a.Transparency=True
a.Layer="
ThisDrawing.SaveAs"
\yangbiao.dwg"
8、计算面积
************************计算面积**************************************
SubCh3_CalculateDefinedArea（）
Dimp1AsVariant
Dimp2AsVariant
Dimp3AsVariant
Dimp4AsVariant
Dimp5AsVariant
从用户处取得点
p1=ThisDrawing.Utility.getpoint（,vbCrLf&
第一个点:
p2=ThisDrawing.Utility.getpoint（p1,vbCrLf&
第二个点:
p3=ThisDrawing.Utility.getpoint（p2,vbCrLf&
第三个点:
p4=ThisDrawing.Utility.getpoint（p3,vbCrLf&
第四个点:
p5=ThisDrawing.Utility.getpoint（p4,vbCrLf&
第五个点:
由这些点创建二维多段线
DimpolyObjAsAcadLWPolyline
Dimvertices（0To9）AsDouble
vertices（0）=p1（0）:
vertices
（1）=p1
（1）
vertices
（2）=p2（0）:
vertices（3）=p2
（1）
vertices（4）=p3（0）:
vertices（5）=p3
（1）
vertices（6）=p4（0）:
vertices（7）=p4
（1）
vertices（8）=p5（0）:
vertices（9）=p5
（1）
SetpolyObj=ThisDrawing.ModelSpace.AddLightWeightPolyline_
（vertices）
polyObj.Closed=True
ThisDrawing.Application.ZoomAll
显示多段线的面积
通过定义的点形成的面积为"
_
polyObj.Area,,"
计算定义的面积"
9、加载菜单
‘加载菜单
SubMenuAutocad（）
DimacMenuGroupAsAcadMenuGroup
ForEachacMenuGroupInThisDrawing.Application.MenuGroups
acMenuGroup.Unload
Next
SetacMenuGroup=ThisDrawing.Application.MenuGroups.Load（"
acad.mnc"
10、‘增加菜单按钮和创建菜单按钮
SubCreateMenuFirst2（）
SetacApp=ThisDrawing.Application
DimacMenuAsAcadPopupMenu
DimacMenuItemAsAcadPopupMenuItem
DimNewacMenuAsAcadPopupMenuItem
SetacMenu=acApp.MenuGroups（0）.Menus（"
文件（&
F）"
SetacMenuItem=acMenu.AddMenuItem（0,"
杨彪"
"
._OPEN"
杨彪4"
-vbarunshowpic2"
SetacMenu=ThisDrawing.Application.MenuGroups（0）.Menus.Add（"
杨彪111"
放大"
.Z1.5XP"
SetacMenuItem=acMenu.AddMenuItem（1,"
缩小"
.Z0.7XP"
SetacMenuItem=acMenu.AddMenuItem（2,"
全景显示"
.ZA"
SetacMenuItem=acMenu.AddMenuItem（3,"
最大显示"
.ZE"
SetacMenuItem=acMenu.AddMenuItem（4,"
鸟瞰"
._DISVIEWER"
SetacMenuItem=acMenu.AddMenuItem（5,"
移动"
.PAN"
acMenu.InsertInMenuBar10
acApp.MenuGroups（0）.SaveAs"
d:
\MyMenu.mnu"
1
‘增加工具栏按钮和创建工具栏
SubCreateToolFirst（）
DimacToolbarAsAcadT
升级会员 