三维建模VB程序

1、Public I As Single Public i0 As Single Public i1 As Single Public i2 As Single Public i3 As Single Public h As Single Public b As Single Public r As Single Public r0 As Single Pub1ic rr As Single Public w As Single Public d As Single Public d0 As Single Public dl As Single Public l As Single Public

2、al As SinglePublic e As Single Public intStru As Integer 选择哪种凸轮机构形式 Public intCreate As Integer 选择哪种轮廓生成模式 Public intUPFunc As Integer 选择哪种升程 Public intDownFunc As Integer 选择哪种回程 Public Const Pi As Single = Public strStruFunc() As String 机构形式公式 Public objEXP As New ClsFunExp 公式对象 Public sngS(359) As

3、 Single 距离 Public sngV(359) As Single 速度 Public sngA(359) As Single 加速度 Public sngPreDat() As Single 批量计算得到的结果 Public sngXY() As Single 坐标Public sngPoint() As Single 离散点Public Sub Init() 初始化,数组及公式 Erase sngS Erase sngV Erase sngA ReDim sngXY(359，l) 默认为360个点 ReDim strStruFunc(3，l) 机构形式公式偏置尖顶直动从动件strs

4、truFunc(0，0)=”e*Cos(i*pi/180)+(Sqr(r*r-e*e)+s)*Sin(i*pi/180)”strstruFunc(0，1)=”-e*Sin(i*pi/180)+(Sqr(r*r-e*e)+s)*Cos(i*pi/180)”偏置滚子直动从动件对心平底直动从动件摆动滚子从动件对心平底直动从动件摆动滚子从动件EndSub升程等速运动规律Public Functtion Nomal_UP_EQ(ByVal w As Single,ByVal h As Single, ByVal i0 As Single ) As Boolean Dim i As Integer Dim

5、 i As Integert=Int(i0) On Error Resume NextFor i= 0 To tsngS(i)=i*h/10sngV(i)=w*h/10sngA(i)=0 If Err ThenErr.ClearsngS(i)=0sngV(i)=0 End IfNextIf Err ThenErr.ClearNomal_UP_EQ =FalseElseNormal_UP_EQ=TrueEnd IfEnd Function升程等加速等减速运动规律升程余弦加速运动规律升程正弦加速运动规律远休程Public Function Far_NoMove (ByVal h As Single

6、,ByVal i0 As Single, ByVal i1 As Single ) As Boolean Dim i As Integer Dim t As Integert=Int(i0+i1)For i=Int(i0) To tsngS(i)=hNextEnd Function回程等速运动规律回程等加速等减速运动规律回程余弦加速运动规律回程正弦加速运动规律近休程Public Function Near_NoMove(ByVal h As Single,ByVal i0 As Single, ByVal i1 As Single,ByVal i2 As Single ) As Boolean

7、 Dim I As Integer Dim t As Integert=Int(i0+i1+i2)-lFor i=t To 359sngS(i)=0NextIf Err ThenErr.Clear Near_NoMove=FalseElse Near_NoMove=True End IfEnd Function公式化输入 升程Public Function Custom_Up(ByVal strFunc As String, ByVal w As Single， ByVal h As Single, ByVal i0 As Single ) As BooleanDim objTExp As N

8、ew ClsFunExpobjTExp.Express=strFuncIf Not objTExp.Translate ThenCustom_Up=False Exit Function End If Dim strKey As String 检查变量是否正确strKey=”i，h，i0” If objTExp.VariantList.Count 3 ThenCustom_Up=False Exit Function End IfobjTExp.SetValue”h”, hobjTExp.SetValue”10”,i0 Dim i As IntegerDim t As Integert=Int

9、(i0) on Error Resume NextFor i=0 To tobjTExp.SetValue”i”,isngS(i)=objTExp.Computer(0)sngV(i)=0sngA(i)=0 If Err ThenErr.ClearsngS(i)=0sngV(i)=0sngA(i)=0 End IfNextIf Err ThenErr.ClearCustom_Up=FalseElseCustom_Up=TrueEnd IfEnd Function公式化输入 回程只允许输入数字，使用时放在keypress事件中/允许退格及回车,小数点,负数Public Function Filt

10、erNumber (obj As TextBox, iValue As Integer ) As Integer允许数字和退格If ( iValue 57 ) And iValue 8 Then允许输入负数 If iValue= Ase (“-”) And Left (obj.Text, 1 )“-And obj.Selstart= 0 ThenElse允许输入小数 If iValue=Asc(“.”) And InStr(obj.Text,”.”)= 0 ThenElseiValue=0 End If EndIfEndIfFilterNumber=iValueEnd Function将所有数

11、据显示到列表中Public Function LvAddLine( ByRef objList As ListView,ByVal intI As Integer， ByVal S As Single, ByVal v As Single,ByVal A As Single ,ByVal X As Single,ByVal Y As Single) As BooleanDim i As Integer Dim objItem As ListItemi=objList.ListItems.Count+l On Error Resume Next Set objItem=objList.ListI

12、tem.Add(“Key”&i,CStr(intI)objltem.SubItems(1)=CStr(S)objltem.SubItems(2)=CStr(v)objltem.SubItems(3)=CStr(A)objltem.SubItems(4)=CStr(X)objltem.SubItems(5)=CStr(Y) If Err ThenErr.ClearLvAddLine=FalseElseLvAddLine=True End If End Function添加离散点到ListView列表中 Public Function PointList_Add(ByRef objList As

13、ListView, ByVal sngX As Single，ByVal sngS As Single) As Boolean Dim i As Integer Dim iCount As Integer Dim objItem As ListItem On Error Resume Next判断数据不重复，重复则修改原数据 For i=1 To objList.ListItems.Count If objList.ListItems(i).Text = CStr(sngX) ThenobjList.ListItems(i).SubItems(1)=CStr(sngS) PointList_A

14、dd=True Exit Function End IfNext在这里要寻找合适的点I=objList.ListItems.Count+lSet objItem=objList.ListItems.Add(,”Key_”&i,CStr(sngX)objItem.SubItems(1)=CStr(sngS)If Err ThenErr.Clear PointList_Add=Fa1seEisePointList_Add=TrueEnd IfEnd Function读离散点数据到数组Public Function PointList2Arr (ByRef objUpList As ListView

15、, objDownList As ListView) As BooleanDim i As Integer Dim iCount Up As Integer Dim iCountDown As Integer Dim intX As Integer读取数据 Erase sngPoint()iCountDown= If iCountUp + iCountDown=0 thenPointList2Arr= False Exit FunctionEnd If定义大小，加上远休和近休 ReDim sngPoint ( iCountUp + CountDown + i1+i3-l, l )添加升程数据i

16、ntX=0 For i=1 To iCountUp sngPoint(i-1,0)=CSng ( objUpList.ListItems(i).Text)sngPoint(i-1,1)=CSng ( objUpList.ListItems(i).SubItems(1)/1000Next远休int X = iCountUpFor i = To i1 -1sngPoint(i+iCountUp,0)= i +i0sngPoint(i+iCountUp,I) = hNext添加回程数据For i=1 To iCountDownsngPoint (i+iCountUp+i1-1,0)=CSng(obj

17、DownList.ListItems(i).Text)+i0+i1sngPoint(i+iCountUp+i1-1, 1)=CSng(objDownList.ListItems(i)=Subltems(1)/1000 Next 近休数据 For i = 0 To i3-1 sngPoint(i+iCountUp+i1+iCountDown,0)=I + i0 + i1 + i2sngPoint(i+iCountUp+i1+iCountDown,1)=0Next If Err ThenErr.ClearPointList2Arr=FalseElsePointList2Arr=True End I

18、fEnd Function机构形式公式计算 Public Function StructComputer(ByVal intStru As Integer) As Boolean Dim i As Integer Dim objFuncX As ClsFunExp Dim objFuncY As ClsFunExp Dim intPointCount As Integer 离散点个数根据选择创建坐标 Select Case intCreateCase 0,2 公式计算，360个点 ReDim sngXY(359，1)Case l 离散点intPointCount=UBound(sngPoint

19、)离散点数据出错 If Err ThenErr.ClearStructComPuter=False Exit Function End If ReDim sngXY(intPointCount,1) End Select套用X坐标公式进行计算 Set objFuncX=New ClsFunExpobjFuncX.Express=strStruFunc(intStru,0)解析数据 If Not objFuncX.Translate ThenStructComPuter=False Exit Function End If套用Y坐标公式进行计算 Set objFuncY=New ClsFunEx

20、pobjFuncY.Express=strStruFunc(intStru,1)解析 If Not objFuncY.Translate ThenStructComPuter=False Exit Function End If代入各机构机构模型所需的参数objFuncX.SetValue”e”,eobjFuncX.SetValue”r”, r Dim u As Single Dim uu As Single Select Case intCreate 计算值Case 0,2 常用规律和公式For i= 0 To 359 计算objFuncX.SetValue”v”,sngV(i)objFun

21、cX.SetValue”s”,sngS(i)objFuncX.SetValue”a”,sngA(i)sngXY(i,0)= objFuncX.Computer(CSng(i),”i”)objFuncY.SetValue”i”,iobjFuncY.SetValue”s”,sngS(i)objFuncY.SetValue”v”,sngV(i)objFuncY.SetValue”a”,sngA(i)sngXY(i，1)=objFuncY.Computer(CSng(i)，”I”)NextCase l 离散点输入 For i=0 To intPointCountobjFuncX.SetValue”I”

22、,sngPoint(i,0)objFuncX.SetValue”s”,sngPoint(i,1)sngXY(i,0)=objFuncX.Computer(0)objFuncY.SetValue”i”,sngPoint(i,0)objFuneY.SetValue”s”,sngPoint(i,l)sngXY(i,l)=objFuncY.Computer(0)Next End Select If Err Then Err.ClearStructComputer=FalseElseStructComPuter=TrueEnd IfEnd Function根据生成的sngxY()坐标，输出到SW系统中传

23、递的参数必须是XY(n,l)二维数组Public Function ModelOut(iXY() As Single) As Boolean Dim i As Integer Dim i Count Dim swApp As Object Dim Part As Object Dim SelMgr As Object Dim boolstatus As Boolean Dim longstatus As Long, longwarnings As Long Dim Feature As Object Dim Annotation As Object On Error Resume Next I

24、f UBound(iXY,2)1 Then 判断数据大小是否正确ModelOut=False Exit Function End If If Err ThenErr.ClearModelOut=False Exit Function End IfiCount=UBound(iXY,l) 计算点的个数Set swApp = Application.SldworkS 创建Sw对象If Err ThenErr.ClearMsgBox”无法创建Sldworks对象!”,vbOKOnly + vbInformationModelOut = False Exit Function End IfswApp.Visible = True Set Part=swApp.NewDocument(“D:Solidworks 2006langchinese-simplifiedTutorialpart.prtdot”,0,0#,0#) If