VBA二次开发.docx
《VBA二次开发.docx》由会员分享，可在线阅读，更多相关《VBA二次开发.docx（14页珍藏版）》请在冰豆网上搜索。
VBA二次开发
TheReportofParametricDesign
Name:
StudentNo.:
ExpectingScore:
90
1.TheObjectofDesign:
Mydesignisaprogram,whichiswritedbyVBA,todrawingascrewbolt.
Inmydesign,userscancreatascrewboltjustbytypingtheparametersofthebolt.
So,Idesignaform,whichdisplaytheparameterstheusershouldtypingin.andthen,userscanspecifyapointasthefirstpointP0,thenclick“OK”;ascrewboltisceated.
2.Theoriginalpicture:
Theparametersofthescrewboltislikethepictureasfollow:
3.Program:
ØFirstly,designingtheform:
ØSecondly，designingfunctionsoftheformabove-mentioned:
DimPXAsDouble'定义存储点的变量
DimPYAsDouble
DimP2AsVariant
SubCommandButton1_Click（）
'将控制权交给AutoCAD
UserForm1.Hide
'获取点的位置
P2=ThisDrawing.Utility.GetPoint（,"指定点:
"）
PX=P2（0）
PY=P2
（1）
TextBox13=P2（0）
TextBox14=P2
（1）
'返回对话框
UserForm1.Show
EndSub
PrivateSubquxiao_Click（）
ZoomExtents
End
EndSub
Subyes_Click（）
'定义所需要的变量
DimdkAsDouble
DimnAsDouble
DimkAsDouble
DimtAsDouble
DimLAsDouble
DimL1AsDouble
DimdAsDouble
DimplineObj（0To9,0To2）AsAcadLine'定义一个二维数组，存储所画的直线
DimiAsInteger'定义循环控制变量
DimjAsInteger
DimP0（0To2）AsDouble
DimP1（0To2）AsDouble
'初始化
dk=TextBox1
n=TextBox2
k=TextBox12
t=TextBox9
L=TextBox8
L1=TextBox11
d=TextBox10
P0（0）=PX
P0
（1）=PY
P1（0）=PX
P1
（1）=PY
'开始计算绘图
'画中心线
OnErrorResumeNext
ThisDrawing.Linetypes.Load"CENTER","acad.lin"
ThisDrawing.ActiveLinetype=ThisDrawing.Linetypes.Item（"CENTER"）
SetplineObj（0,0）=AddLineReXY（P0,1.3*L,0）
SetplineObj（0,1）=AddLineReXY（P0,-0.2*L,0）
'
（1）
OnErrorResumeNext
ThisDrawing.Linetypes.Load"CONTINUOUS","acad.lin"
ThisDrawing.ActiveLinetype=ThisDrawing.Linetypes.Item（"CONTINUOUS"）
SetplineObj（1,0）=AddLineReXY（P0,0,n/2）
SetplineObj（1,1）=AddLineReXY（P1,0,-n/2）
P0
（1）=P0
（1）+n/2
P1
（1）=P1
（1）-n/2
'
（2）
SetplineObj（2,0）=AddLineReXY（P0,-k,0）
P0（0）=P0（0）-k
SetplineObj（2,1）=AddLineReXY（P1,-k,0）
P1（0）=P1（0）-k
'（3）
SetplineObj（3,0）=AddLineReXY（P0,0,（dk/2-n/2））
P0
（1）=P0
（1）+（dk/2-n/2）
SetplineObj（3,1）=AddLineReXY（P1,0,-（dk/2-n/2））
P1
（1）=P1
（1）-（dk/2-n/2）
'（4）
SetplineObj（4,0）=AddLineReXY（P0,t,0）
P0（0）=P0（0）+t
SetplineObj（4,1）=AddLineReXY（P1,t,0）
P1（0）=P1（0）+t
'（5）
SetplineObj（5,0）=AddLineReXY（P0,0,-dk/2）
P0
（1）=P0
（1）+（d/2-dk/2）
SetplineObj（5,1）=AddLineReXY（P1,0,dk/2）
P1
（1）=P1
（1）-（d/2-dk/2）
'（6）
SetplineObj（6,0）=AddLineReXY（P0,L,0）
P0（0）=P0（0）+L
SetplineObj（6,1）=AddLineReXY（P1,L,0）
P1（0）=P1（0）+L
'（7）
SetplineObj（7,0）=AddLineReXY（P0,0,-d/2）
P0
（1）=P0
（1）-d/2
P0（0）=P0（0）-L1
SetplineObj（7,1）=AddLineReXY（P1,0,d/2）
P1
（1）=P1
（1）+d/2
P1（0）=P1（0）-L1
'（8）
SetplineObj（8,0）=AddLineReXY（P0,0,d/2）
P0
（1）=P0
（1）+d/2-1
SetplineObj（8,1）=AddLineReXY（P0,L1,0）
SetplineObj（9,0）=AddLineReXY（P1,0,-d/2）
P1
（1）=P1
（1）-d/2+1
SetplineObj（9,1）=AddLineReXY（P1,L1,0）
plineObj（0,0）.Lineweight=acLnWt009
plineObj（0,1）.Lineweight=acLnWt009
plineObj（0,0）.ScaleEntityP2,suofang
plineObj（0,0）.Update
plineObj（0,1）.ScaleEntityP2,suofang
plineObj（0,1）.Update
plineObj（0,1）.color=zs'指定中心线的颜色zs代表中心线颜色
plineObj（0,0）.color=zs'指定中心线的颜色
Fori=1To10Step1'循环对螺钉直线进行操作，两层循环
Forj=0To1Step1
plineObj（i,j）.Lineweight=acLnWt030'指定螺钉线宽
plineObj（i,j）.color=ls'指定螺钉线的颜色ls代表螺钉线颜色
plineObj（i,j）.ScaleEntityP2,suofang'指定螺钉缩放比例
plineObj（i,j）.Update
Nextj
Nexti
ZoomExtents
EndSub
ØFinally，designingamodule，thismodulecontainsrequiredfunction.
OptionExplicit
PublicSubAlternation（）'创建显示窗口和隐藏窗口的函数
UserForm1.Hind
UserForm1.Show
EndSub
'创建直线的基准函数
PublicFunctionAddLine（ByValptStAsVariant,ByValptEnAsVariant）AsAcadLine
SetAddLine=ThisDrawing.ModelSpace.AddLine（ptSt,ptEn）
EndFunction
'根据另一点的相对直角坐标创建直线
PublicFunctionAddLineReXY（ByValptStAsVariant,ByValxAsDouble,ByValyAsDouble）AsAcadLine
'定义终点
DimptEnAsVariant
ptEn=GetPoint（ptSt,x,y）
SetAddLineReXY=AddLine（ptSt,ptEn）
EndFunction
'获得相对已经点偏移一定距离的点
PublicFunctionGetPoint（ptAsVariant,xAsDouble,yAsDouble）AsVariant
DimptTarget（0To2）AsDouble
ptTarget（0）=pt（0）+x
ptTarget
（1）=pt
（1）+y
ptTarget
（2）=0
GetPoint=ptTarget
EndFunction
4.Runningresults:
ØLoadtheproject
ØRunthisproject，typingtheParametersoftheboltasfollow
ØPickapointasthefirstpoint
ØClick"确定"
ØClick"取消"退出程序
ØDifferenttypingsleadtodifferentresult
升级会员 