CAD VBA代码Word文档格式.docx
- 文档编号:6099082
- 上传时间:2023-05-06
- 格式:DOCX
- 页数:51
- 大小:44.24KB
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.如何用程序控制对象捕捉
通过设置系
- 配套讲稿:
如PPT文件的首页显示word图标,表示该PPT已包含配套word讲稿。双击word图标可打开word文档。
- 特殊限制:
部分文档作品中含有的国旗、国徽等图片,仅作为作品整体效果示例展示,禁止商用。设计者仅对作品中独创性部分享有著作权。
- 关 键 词:
- CAD VBA代码 VBA 代码