frmbeltdisply.frm

齿轮传动设计计算的开发软件

      TabIndex        =   5
      Top             =   4095
      Width           =   990
   End
   Begin VB.Label Label5 
      Caption         =   "包角系数"
      Height          =   210
      Left            =   3315
      TabIndex        =   4
      Top             =   3315
      Width           =   990
   End
   Begin VB.Label Label4 
      Caption         =   "长度系数"
      Height          =   210
      Left            =   3315
      TabIndex        =   3
      Top             =   2535
      Width           =   990
   End
   Begin VB.Label Label3 
      Caption         =   "包角"
      Height          =   210
      Left            =   3315
      TabIndex        =   2
      Top             =   1755
      Width           =   990
   End
   Begin VB.Label Label2 
      Caption         =   "带速"
      Height          =   210
      Left            =   3315
      TabIndex        =   1
      Top             =   975
      Width           =   990
   End
   Begin VB.Label Label50 
      Caption         =   "实际传动比"
      Height          =   210
      Left            =   3315
      TabIndex        =   0
      Top             =   195
      Width           =   990
   End
End
Attribute VB_Name = "FrmbeltDisply"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Option Base 1
Dim filename As String
Dim lunjiegou(3) As String '带轮结构数组
Dim lunfubanhoudu(3) As Single
Private Declare Function shellexecute Lib "shell.32.dll" Alias "shellexecuteA" (ByVal hwnd As Long, ByVal lpszop As String, _
ByVal lpszFile As String, ByVal lpszParams As String, ByVal lpszDir As String, ByVal FsShowCmd As Long) As String
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Const SW_SHOWNORMAL = -1
Const SE_ERR_FNF = 2&
Const SE_ERR_PNF = 3&
Const SE_ERR_ACCESSDENIED = 5&
Const SE_ERR_OOM = 8&
Const SE_ERR_DLLNOTFOUND = 32&
Const SE_ERR_SHARE = 26&
Const SE_ERR_ASSOCINCOMPLETE = 27&
Const SE_ERR_DDETIMEOUT = 28&
Const SE_ERR_DDEFAIL = 29&
Const SE_ERR_DDEBUSY = 30&
Const SE_ERR_NOASSOC = 31&
Const ERROR_BAD_FORMAT = 11&
Dim iTask As Long, ret As Long, pHandle As Long
Private Sub beltb104(xh As String, d As Single)  '查询轮缘尺寸 xh型号 d 基准直径
Dim x As Integer, j As Integer
Dim wheelxh, wheelhfmin, wheelhamin, wheele, wheelfmin, wheelbd '数组变量
Dim wheeldlt, hfmin, hamin, e As String, fmin, bd, dlt
Dim fai As Single, b
xh = UCase(xh) '将型号转为大写
wheelxh = Array("A", "Z", "A", "B", "C", "D", "E")
wheelhfmin = Array(4.7, 7#, 8.7, 10.8, 14.3, 19.9, 23.4)
wheelhamin = Array(1.6, 2#, 2.75, 3.5, 4.8, 8.1, 9.6)
wheele = Array("8±0.3", "12±0.3", "15±0.3", "19±0.4", "25.5±0.5", "37±0.6", "44.5±0.7")
wheelfmin = Array(6, 7, 9, 11.5, 16, 23, 28)
wheelbd = Array(5.3, 8.5, 11#, 14#, 19#, 27#, 32#)
wheeldlt = Array(5#, 5.5, 6#, 7.5, 10#, 12#, 15#)
For x = 1 To 6
If xh = wheelxh(x) Then Exit For
Next x
hfmin = wheelhfmin(x): hamin = wheelhamin(x)
e = wheele(x): fmin = wheelfmin(x): bd = wheelbd(x): dlt = wheeldlt(x)
b = (z - 1) * Val(Left(e, 4)) + 2 * fmin '计算带轮宽度
Select Case xh
Case "Y"
If d <= 60 Then fai = 32 Else fai = 36
Case "Z"
If d <= 80 Then fai = 34 Else fai = 38
Case "A"
If d <= 118 Then fai = 34 Else fai = 38
Case "B"
If d <= 190 Then fai = 34 Else fai = 38
Case "C"
If d <= 315 Then fai = 34 Else fai = 38
Case "D"
If d <= 475 Then fai = 36 Else fai = 38
Case "E"
If d <= 600 Then fai = 36 Else fai = 38
End Select
Cbosize.AddItem "hfmin" & Str$(hfmin) '将轮缘尺寸列于组合框cbosize
Cbosize.AddItem "hamin" & Str$(hamin)
Cbosize.AddItem "e" & e
Cbosize.AddItem "fmin" & Str$(fmin)
Cbosize.AddItem "bd" & Str$(bd)
Cbosize.AddItem "δ" & Str$(dlt)
Cbosize.AddItem "ψ" & Str$(fai)
Cbosize.AddItem "B" & Str$(b)
Open App.Path + "\vb-acad.txt" For Append As #1 '向app.path+"\vb-acad.txt"中追加数据，供带轮.lsp读取
Print #1, Chr$(40); Chr$(32); d; Chr$(32); hfmin; Chr$(32); hamin; Chr$(32); Val(Left(e, 2)); Chr$(32); fmin; Chr$(32); bd; Chr$(32); _
fai; Chr$(32); z; Chr$(32); Chr$(41)
Close

End Sub
Private Sub xianshi()
Dim r As Long
Dim msg As String
r = opendoc(filename)
If r <= 32 Then
Select Case r

Case SE_ERR_FNF
msg = "文件没有找到"
Case SE_ERR_PNF
msg = "路径没有找到"
Case SE_ERR_ACCESSDENIED
msg = "该文件被拒绝访问"
Case SE_ERR_OOM
msg = "内存溢出"
Case SE_ERR_DLLNOTFOUND
msg = "DLL文件没有找到"
Case SE_ERR_SHARE
msg = "A sharing violation occurred"
Case SE_ERR_ASSOCINCOMPLETE
msg = "无效的文件链接"
Case SE_ERR_DDETIMEOUT
msg = "DDE链接超时"
Case SE_ERR_DDEFAIL
msg = "DDE传递超时"
Case SE_ERR_DDEBUSY
msg = "DEE忙"
Case SE_ERR_NOASSOC
msg = "没有相应的文件链接"
Case ERROR_BAD_FORMAT
msg = "无效的文件格式"
Case Else
msg = "其它未知错误"

End Sub
Private Function opendoc(DocName As String) As Long ' 打开文件
Dim scr_hdc As Long
scr_hdc = GetDesktopWindow()
opendoc = shellexecute(scr_hdc, "open", DocName, "", "C:", SW_SHOWNORMAL)
End Function
Private Sub dailunjiegou(xh As String, jizhundd As Single, jiegou As String, kongjing As Single, fubanhoudu As Single)
Dim jj1 As Integer
Dim jj2 As Integer
Dim dd
Dim xinghao
Dim yiweid0
Dim erweid0(7, 8) As Single
Dim yiweijiegou(1360)
Dim sanweijiegou(7, 8, 41) As String
Dim shuchujiegou As String
Dim shuchuhoudu As Single
Dim shuchucaishu As String
Dim x As Integer
Dim y As Integer
Dim j As Integer
Dim s As Integer
Dim k As Integer
fubanhoudu = 0 '辐板厚度赋初值为零
If jizhundd > 2500 Then
MsgBox ("带轮直径不能超过2500mm，请重新输入")
Exit Sub
End If
If jizhundd < 0 Then
MsgBox ("带轮基准直径必须大于零，请重新输入")
Exit Sub
End If
If kongjing <= 0 Then
MsgBox ("孔径必须大于零，请重新输入")
Exit Sub
End If
xinghao = Array("A", "Z", "A", "B", "C", "D", "E")
yiweid0 = Array(14, 18, 22, 25, 30, 35, 18, 22, 25, 30, 35, 40, 45, 35, 40, 45, 55, 65, 45, 55, 65, 75, 85, 65, 75, 85, 95, 110, 85, 95, 110, 130, 150)
s = 0
For y = 1 To 6
s = s + 1
erweid0(1, y) = yiweid0(s)
Next y
For y = 1 To 7
s = s + 1
erweid0(2, y) = yiweid0(s)
Next y
For x = 3 To UBound(xinghao)
For y = 1 To 5
s = s + 1
 erweid0(x, y) = yiweid0(s)  'sx为实心 fb6 为护板厚度为6mm fb7为辐板厚度为7mm 以此类推
Next y
Next x
dd = Array(63, 71, 75, 80, 90, 95, 100, 106, 112, 118, 125, 132, 140, 150, 160, 170, 180, 200, 212, 224, 236, 250, 265, 280, 300, 315, 355, 375, 400, 425, 450, 475, 500, 530, 560, 600, 630, 710, 2500, 2501)
Open App.Path + "\jiegou.txt" For Input As #1
For x = 1 To 1320
Input #1, yiweijiegou(x)
Next x
Close
s = 0
For y = 1 To 6
For j = 1 To 6
s = s + 1
sanweijiegou(1, y, j) = yiweijiegou(s)
Next j
Next y
For y = 1 To 7
For j = 1 To 40
s = s + 1
sanweijiegou(2, y, j) = yiweijiegou(s)
Next j
Next y
For x = 3 To 6
For y = 1 To 5
For j = 1 To 40
s = s + 1
sanweijiegou(x, y, j) = yiweijiegou(s)
Next j
Next y
Next x
For x = 1 To 6
If xh = xinghao(x) Then Exit For '定位大行
Next x
Select Case x
Case 1
k = 6
Case 2
k = 7
Case Else
k = 5
End Select
For y = 1 To k
If kongjing <= erweid0(x, y) Then Exit For '定位小行
Next y
If y > k Then
k = MsgBox("目前带型号为" + xh1 + "，孔径=" + Str(kongjing) + "太大，没有合适结构，最大不能超过" + Str(erweid0(x, y - 1)) + "," + Chr(13) & Chr(10), vbCritical, "警告")
Exit Sub
End If
If y = 1 Then
jiegou = "0"
Select Case xh1
Case "Z"
If kongjing < 14 Then y = MsgBox("孔径=" + Str(kongjing) + "，太小，没有合适结构。孔径最小不能小于" + Str(14), vbCritical, "警告"): Exit Sub
Case "A"
If kongjing < 18 Then y = MsgBox("孔径=" + Str(kongjing) + "，太小没有合适结构。孔径最小不能小于" + Str(18), vbCritical, "警告"): Exit Sub
Case "B"
If kongjing < 35 Then y = MsgBox("孔径=" + Str(kongjing) + "，太小没有合适结构。孔径最小不能小于" + Str(35), vbCritical, "警告"): Exit Sub
Case "C"
If kongjing < 45 Then y = MsgBox("孔径=" + Str(kongjing) + "，太小没有合适结构。孔径最小不能小于" + Str(45), vbCritical, "警告"): Exit Sub
Case "D"
If kongjing < 65 Then y = MsgBox("孔径=" + Str(kongjing) + "，太小没有合适结构。孔径最小不能小于" + Str(65), vbCritical, "警告"): Exit Sub
Case "E"
If kongjing < 85 Then y = MsgBox("孔径=" + Str(kongjing) + "，太小没有合适结构。孔径最小不能小于" + Str(85), vbCritical, "警告"): Exit Sub
End Select
End If
For j = 1 To 40
If jizhundd <= dd(j) Then Exit For '定位列j
Next j
jiegou = sanweijiegou(x, y, j)
If jiegou = "0" Then  '如果没有结构 查询dd在什么范围内才有结构，以便提示 先查dd的最小值
For jj1 = 1 To 40
If sanweijiegou(x, y, jj1) <> "0" Then Exit For
Next jj1
For jj2 = jj1 To 40
If sanweijiegou(x, y, jj2) = "0" Then Exit For
Next jj2
jj1 = MsgBox("在目前带型为" + xh1 + "，孔径=" + Str(kongjing) + "的情况下，" + "基准直径>" + Str(dd(jj1 - 1)) + "～" + Str(dd(jj2 - 1)) + "才有合适结构" + Chr(13) & Chr(10) + "但目前的基准直径=" + Str(jizhundd), vbCritical, "警告")

Else
If Left(sanweijiegou(x, y, j), 2) = "fb" Or Left(sanweijiegou(x, y, j), 2) = "sk" Or Left(sanweijiegou(x, y, j), 2) = "lk" Then
fubanhoudu = Mid(sanweijiegou(x, y, j), 3, 4)
End If
Select Case Left(sanweijiegou(x, y, j), 2)
Case "sx"
jiegou = "实心轮"
Case "fb"
jiegou = "辐板轮"
Case "sk"
jiegou = "四孔辐板轮"
Case "lk"
jiegou = "六孔辐板轮"
Case "st"
jiegou = "四椭圆辐轮"
Case "lt"
jiegou = " 六椭圆辐轮"
End Select
End If
Open App.Path + "vb_acad.txt" For Append As #1 '向app.path+"vb_acad.txt" 中追加的数据，供带轮.lsp 读取
Print #1, Chr$(40); Chr$(32); jiegou; Chr$(32); fubanhoudu; Chr$(32); kongjing; Chr$(32); Chr$(41)
Close
End Sub
Public Sub Cmddisplysize_Click() '查询带轮轮缘尺寸
Cbosize.Clear
Cbosize.AddItem "小带轮："
Call beltb104(xh1, dd1) '调用beltb104过程，查小带轮轮缘尺寸
Cbosize.AddItem "大带轮："
Call beltb104(xh1, dd2)
End Sub

Private Sub Cmddwg_Click() '绘图
Open App.Path + "\vb-acad.tex" For Output As #1
Close
Call beltb104(xh1, dd1)
Call dailunjiegou(xh1, dd1, lunjiegou(1), dailunkongjing(1), lunfubanhoudu(1)) '查轮辐结构和辐板厚度
If lunjiegou(1) = "0" Then
MsgBox ("无适合带轮结构，请核查！")
Exit Sub
End If
Call beltb104(xh1, dd2)
Call dailunjiegou(xh1, dd2, lunjiegou(2), dailunkongjing(2), lunfubanhoudu(2)) '查轮辐结构和辐板厚度
If lunjiegou(2) = "0" Then
MsgBox ("无适合带轮结构，请核查！")
Exit Sub
End If
iTask = Shell("c:\acad", vbMaximizedFocus)
pHandle = OpenProcess(SYNCHRONIZE, False, iTask)
ret = WaitForSingleObject(pHandle, INFINITE)
ret = CloseHandle(pHandle)
End Sub

Private Sub CmdEnd_Click()
End
End Sub

Private Sub CmdReturn_Click()
FrmOptionxhdla.Visible = True
FrmOptionxhdla.Picdla.Visible = True
FrmbeltDisply.Visible = False
End Sub

Private Sub CmdSave_Click()
Dim lemp As String
Dim inReturn As Integer
Dim shifudakai As Integer
filename: CommonDialog1.filename = "" ' 将对话框的文件名置空，并将变量filename的值置空
CommonDialog1.Filter = "*.txt|*.txt|*.dat|*.dat" '为通用对话框的过滤器属性filter赋值
CommonDialog1.ShowSave '将通用对话框置为save对话框（保存文件对话框）
filename = CommonDialog1.filename 'filename是通用对话框的文件名属性
If filename <> "" Then
lemp = Dir(filename, vbNormal) 'dir（）函数是查询文件的函数，返回结果赋给变量lemp
If lemp <> "" Then '如果lemp不为空，说明有重名文件；否则，说明没有重名文件
inReturn = MsgBox("文件已经存在，要覆盖吗？", vbYesNo)
If inReturn = 7 Then GoTo filename
End If
Call dailunjiegou(xh1, dd1, lunjiegou(1), dailunkongjing(1), lunfubanhoudu(1))
Call dailunjiegou(xh1, dd2, lunjiegou(2), dailunkongjing(2), lunfubanhoudu(2))
Open filename For Output As #1
Print #1, "带型号："; xh1
Print #1, "带根数："; z
Print #1, "带长度："; Ld; "mm"
Print #1, "小带轮直径："; dd1; "mm"
Print #1, "大带轮直径:"; dd2; "mm"
Print #1, "中心距:"; a; "mm"
Print #1, "实际传动比:"; sis
Print #1, "带速:"; v1; "m/s"
Print #1, "小带轮包角:"; x1; "度"
Print #1, "长度系数:"; kL
Print #1, "包角系数:"; kalf
Print #1, "工作情况系数:"; ka
Print #1, "初拉力:"; f0; "N"
Print #1, "轴压力:"; fz; "N"
Print #1, "单根带功率:"; p1; "KW"
Print #1, "功率增量:"; dp1; "KW"
Print #1, "带质量:"; q; "kg/m"
Print #1, "传动比误差："; dlti
Print #1, "小带轮孔径："; dailunkongjing(1)
Print #1, "小带轮结构："; lunjiegou(1)
Print #1, "小带轮辐板厚度："; lunfubanhoudu(1)
Print #1, "大带轮孔径："; dailunkongjing(2)
Print #1, "大带轮结构："; lunjiegou(2)
Print #1, "大带轮辐板厚度："; lunfubanhoudu(2)
Close
shifudakai = MsgBox("是否打开结果文件？", vbYesNo, "是否打开结果文件")
If shifudakai = 6 Then
Call xianshi
End If
Else
Exit Sub
End If
End Sub