📄 throw.frm
字号:
End
Begin VB.Label Label2
BackColor = &H00C0E0FF&
Caption = "横坐标："
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H000000C0&
Height = 255
Left = 2160
TabIndex = 3
Top = 480
Width = 1095
End
Begin VB.Label Label1
BackColor = &H00C0E0FF&
Caption = "纵坐标："
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H000000C0&
Height = 255
Left = 2160
TabIndex = 2
Top = 960
Width = 1215
End
End
Begin VB.Label Label7
BackStyle = 0 'Transparent
Caption = "在测量前请确保您已经将仪器调平，如未调平请按照说明书进行调平操作"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H000000FF&
Height = 495
Left = 480
TabIndex = 18
Top = 240
Width = 8295
End
Begin VB.Menu File
Caption = "文件"
Begin VB.Menu Quit
Caption = "退出"
End
End
Begin VB.Menu Properties
Caption = "通讯"
Begin VB.Menu ProSetting
Caption = "通讯参数"
End
End
Begin VB.Menu Help
Caption = "帮助"
Begin VB.Menu About
Caption = "关于 北京"
End
End
End
Attribute VB_Name = "frmthrow"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Sub About_Click()
Dim Style, Title, Response As String
Style = vbOKOnly + vbInformation + vbDefaultButton2
Title = "关于 北京飞鹿体育用品有限公司"
Response = MsgBox("北京飞鹿体育用品有限公司 1.0.0" + vbCrLf + "", Style, Title)
End Sub
Private Sub clean_Click()
Startx1.Caption = ""
Starty1.Caption = ""
Endx1.Caption = ""
Endy1.Caption = ""
Text1.Text = ""
Result.Caption = ""
Rs232 = ""
Throwx1 = ""
Throwy1 = ""
'全部数据都清除
End1.Enabled = False
Record.Enabled = False
'按钮去除使能
End Sub
Private Sub end1_Click()
If Starty1.Caption = "" Or Startx1.Caption = "" Then
MsgBox "缺少起点数据" '当数据太小时，会认为数据为0，导致出错
Exit Sub
End If
Dim B2, V2, S2 As Single
Dim Ds2, X2, Y2, X1, Y1, Data As Single
Start1.Enabled = False
End1.Enabled = False
Record.Enabled = False
Endx1.Caption = ""
Endy1.Caption = ""
Result.Caption = ""
Call Separatedata(B2, V2, S2)
Start1.Enabled = True
End1.Enabled = True
If S2 = 0 Then
Exit Sub
End If
Ds2 = S2 * Sin(V2)
X2 = Ds2 * Cos(B2)
Y2 = Ds2 * Sin(B2)
Endx1.Caption = Format(X2, "0.000")
Endy1.Caption = Format(Y2, "0.000")
'读取原点终点数据，计算数据
X1 = CSng(Startx1.Caption)
Y1 = CSng(Starty1.Caption)
X2 = CSng(Endx1.Caption)
Y2 = CSng(Endy1.Caption)
Data = Sqr((X1 - X2) * (X1 - X2) + (Y1 - Y2) * (Y1 - Y2)) '计算成绩
Result.Caption = Format(Data, "0.000")
End Sub
Private Sub Form_Load()
'使窗口整体颜色一致
Frame1.BackColor = Me.BackColor
Frame2.BackColor = Me.BackColor
Frame3.BackColor = Me.BackColor
Frame4.BackColor = Me.BackColor
Label1.BackColor = Me.BackColor
Label2.BackColor = Me.BackColor
Label3.BackColor = Me.BackColor
Label4.BackColor = Me.BackColor
Label5.BackColor = Me.BackColor
Label6.BackColor = Me.BackColor
Label7.BackColor = Me.BackColor
Label8.BackColor = Me.BackColor
Label9.BackColor = Me.BackColor
Label10.BackColor = Me.BackColor
Left = (Screen.Width - Me.Width) \ 2
Top = (Screen.Height - Me.Height) \ 2 '窗口居中
Label8.Caption = "第一步：起点测量" + vbCrLf + "对起点进行测距，点击记录按钮，单击程序上的“起点测量”，完成起点测量"
Label9.Caption = "第二步：落点测量" + vbCrLf + "完成起点测量后，对落点测距，记录后，单击“落点测量”"
Label10.Caption = "第三步：计算成绩" + vbCrLf + "有起点和终点数据之后，点击“成绩计算”按钮可计算成绩，点击“成绩记录”按钮可记录成绩"
Startx1.Caption = Format(Throwx1, "0.000")
Starty1.Caption = Format(Throwy1, "0.000")
Rs232 = "" '进入窗口，数据清零
On Error Resume Next '忽略错误继续执行
If frmmath.MSComm1.PortOpen = False Then frmmath.MSComm1.PortOpen = True
If Err Then '出错的话，弹出错误对话框
MsgBox Error$ + "，请确认线路已连接并设置正确通讯参数", 48
Exit Sub
End If
End Sub
Private Sub close_Click()
frmmath.Text.Text = ""
Unload Me
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label8.Visible = False
Label9.Visible = False
Label10.Visible = False
End Sub
Private Sub Form_Unload(Cancel As Integer)
If frmmath.MSComm1.PortOpen = True Then frmmath.MSComm1.PortOpen = False
End Sub
Private Sub Frame2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label9.Visible = True
Label8.Visible = False
Label10.Visible = False
End Sub
Private Sub Frame1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label8.Visible = True
Label9.Visible = False
Label10.Visible = False
End Sub
Private Sub Frame3_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label10.Visible = True
Label8.Visible = False
Label9.Visible = False
End Sub
Private Sub Frame4_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label8.Visible = True
Label9.Visible = True
Label10.Visible = True
End Sub
Private Sub ProSetting_Click()
frmProperties.Show vbModal
End Sub
Private Sub Quit_Click()
Unload Me
End Sub
Private Sub Record_Click()
Dim Temp As String 'a用于存储数据
If Text1.Text = "" Or Result.Caption = "" Then
MsgBox "缺少数据" '当数据太小时，会认为数据为0，导致出错
Exit Sub
End If
Temp = App.Path + "\" + Trim(Str(Year(Date))) + Trim(Str(Month(Date))) + Trim(Str(Day(Date))) + "投掷成绩.txt"
If Dir(Temp) = "" Then
Temp = App.Path + "\" + Trim(Str(Year(Date))) + Trim(Str(Month(Date))) + Trim(Str(Day(Date))) + "投掷成绩.txt"
Open Trim(Temp) For Append As #1
Print #1, "运动员号" + vbTab + "成绩"
Close
End If
Open Trim(Temp) For Append As #1
Print #1, Text1.Text + vbTab + Result.Caption
Close
FileCopy Temp, App.Path + "\" + Trim(Str(Year(Date))) + Trim(Str(Month(Date))) + Trim(Str(Day(Date))) + "投掷成绩.xls"
Endx1.Caption = ""
Endy1.Caption = ""
Text1.Text = ""
Result.Caption = ""
Rs232 = ""
Record.Enabled = False
End Sub
Private Sub Result_Change()
If Text1.Text <> "" Then Record.Enabled = True
End Sub
Private Sub start1_Click()
Dim B1, V1, S1 As Single '通过SUB调用过程，参数要单独定义。
Dim Ds1, X1, Y1 As Single
Startx1.Caption = ""
Starty1.Caption = ""
Endx1.Caption = ""
Endy1.Caption = ""
Result.Caption = ""
Start1.Enabled = False
End1.Enabled = False
Record.Enabled = False
Call Separatedata(B1, V1, S1) '调用子过程，按地址传递B1，V1，S1然后改变数值
Start1.Enabled = True
If S1 = 0 Then
Exit Sub
End If
Ds1 = S1 * Sin(V1)
X1 = Ds1 * Cos(B1)
Y1 = Ds1 * Sin(B1)
Throwx1 = X1
Throwy1 = Y1
Startx1.Caption = Format(X1, "0.000")
'format用于格式化字符串，0.###用于用于保留3位小数，并在不足1的数字前面加0
Starty1.Caption = Format(Y1, "0.000")
End1.Enabled = True
End Sub
Private Sub Startx1_Change()
End1.Enabled = True
End Sub
Private Sub Text1_Change()
If Result.Caption <> "" Then Record.Enabled = True
If Text1.Text = "" Then Record.Enabled = False
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -