压实度厚度.frm

饮羽公路测设（glcs） 由20多个公路测量、设计、试验和施工组织设计等小软件组成。如《中桩大地坐标》可以计算不等长缓和曲线的中桩和边桩的大地坐标；《缓和曲线反算》可以根据切线长、外距长或缓和曲线长求

      Caption         =   "计算"
      Height          =   375
      Left            =   4920
      TabIndex        =   0
      Top             =   4800
      Width           =   975
   End
   Begin VB.Label Label10 
      Caption         =   "必需安装Excel；出现保存等问题时，点击是即可。"
      Height          =   255
      Left            =   120
      TabIndex        =   23
      Top             =   4860
      Width           =   4455
   End
End
Attribute VB_Name = "frmysdhd"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim Result As Double
Dim shj() As Double


Private Sub Combo1_Change()
'选定的保证率数据

    On Error GoTo handlerror
    
    Call Combo1_Click
    
    Exit Sub
handlerror:

End Sub

Private Sub Combo1_Click()
'选定的保证率数据

    Dim bzl As Double

    On Error GoTo handlerror
    
    If Combo1.Text = "高速公路、一级公路基层" Then bzl = 99
    If Combo1.Text = "高速公路、一级公路底基层" Then bzl = 99
    If Combo1.Text = "高速公路、一级公路路基" Then bzl = 95
    If Combo1.Text = "高速公路、一级公路面层" Then bzl = 95
    If Combo1.Text = "其他公路基层、底基层" Then bzl = 95
    If Combo1.Text = "其他公路路基、面层" Then bzl = 90
    
    Text2.Text = Trim(Str(bzl)) + "%"
    Text3.Text = Trim(Str((1 - bzl / 100) * 2))
    
    
    
    Exit Sub
handlerror:

End Sub

Private Sub Command1_Click()
'计算
    
    Dim i As Integer, k As Integer
    Dim sum As Double, n As Integer
    Dim kp As Double, sumjf As Double
    Dim tcn As Double
    Dim ta As Double, kbz As Double
    
    On Error GoTo handlerror
    
    '计算ta值
    Call funtfb(Val(Text3.Text), Val(Text1.Text))
    ta = Result
    Text4.Text = Trim(Str(Int(Result * 1000 + 0.5) / 1000))
    
    k = VSFlexGrid1.Rows - 1
    
    ReDim shj(k) As Double
    
    '个数
    n = Val(Text1.Text)
    
    '数值tα/sqrt(n)
    If n > 0 Then
        Text6.Text = Trim(Str(Int(ta / Sqr(n) * 10000 + 0.5) / 10000))
    End If
    
    '计算平均值
    sum = 0
    For i = 1 To n
        shj(i) = Val(VSFlexGrid1.TextMatrix(i, 1))
        sum = sum + Val(VSFlexGrid1.TextMatrix(i, 1))
    Next i
    
    '平均值
    If n <> 0 Then
        kp = sum / n
        Text5.Text = Trim(Str(Int(kp * 1000 + 0.5) / 1000))
    End If
    
    '计算均方差
    sumjf = 0
    For i = 1 To n
        sumjf = sumjf + (kp - shj(i)) * (kp - shj(i))
    Next i
    jfc = Sqr(sumjf / (n - 1))
    
    Text7.Text = Trim(Str(Int(jfc * 10000 + 0.5) / 10000))
    
    If n > 1 Then kbz = kp - ta * jfc / Sqr(n)
    
    Text8.Text = Trim(Str(Int(kbz * 1000 + 0.5) / 1000))
    
    
    
    Exit Sub
handlerror:
    xiansh = MsgBox("在计算代表值时出错，请再试试。", vbInformation, "问题提示")
    
End Sub



Private Sub Command2_Click()
'关闭

    Dim i As Integer

    On Error GoTo handlerror
    
    '计算结果
    If Text8.Text <> "" And rjsfzc = 88 Then
        frmMain.Text1 = frmMain.Text1 & vbCrLf & ""
        frmMain.Text1 = frmMain.Text1 & vbCrLf & "    压实度和厚度计算："
        
        frmMain.Text1 = frmMain.Text1 & vbCrLf & ""
        frmMain.Text1 = frmMain.Text1 & vbCrLf & "    －－－－－－计算结果－－－－－－"
        frmMain.Text1 = frmMain.Text1 & vbCrLf & "    " + Label1.Caption + "     ＝" + Combo1.Text
        frmMain.Text1 = frmMain.Text1 & vbCrLf & "    " + Label2.Caption + "         ＝" + Text1.Text
        frmMain.Text1 = frmMain.Text1 & vbCrLf & "    " + Label3.Caption + Text2.Text
        frmMain.Text1 = frmMain.Text1 & vbCrLf & "    " + Label4.Caption + Text3.Text
        frmMain.Text1 = frmMain.Text1 & vbCrLf & "    " + Label5.Caption + Text4.Text
        frmMain.Text1 = frmMain.Text1 & vbCrLf & "    " + Label6.Caption + Text5.Text
        frmMain.Text1 = frmMain.Text1 & vbCrLf & "    " + Label7.Caption + Text6.Text
        frmMain.Text1 = frmMain.Text1 & vbCrLf & "    " + Label9.Caption + Text7.Text
        frmMain.Text1 = frmMain.Text1 & vbCrLf & "    " + Label8.Caption + Text8.Text
        frmMain.Text1 = frmMain.Text1 & vbCrLf & ""
        frmMain.Text1 = frmMain.Text1 & vbCrLf & "    －－－－－－原始数据－－－－－－"
        
        For i = 0 To VSFlexGrid1.Rows - 1
            If i = 0 Then frmMain.Text1 = frmMain.Text1 & vbCrLf & "    " + Trim(VSFlexGrid1.TextMatrix(i, 0)) + "      " + Trim(VSFlexGrid1.TextMatrix(i, 1))
            If i <> 0 Then frmMain.Text1 = frmMain.Text1 & vbCrLf & "    " + Trim(Str(Val(VSFlexGrid1.TextMatrix(i, 0)))) + "          " + Trim(Str(Val(VSFlexGrid1.TextMatrix(i, 1))))
        Next i
        
        frmMain.Text1 = frmMain.Text1 & vbCrLf & "    --------------------------------------"
    End If
        
        
        
    Unload Me
    
    Exit Sub
handlerror:


End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
'Esc键退出，VbEscape可以用27代替
    On Error GoTo handlerror

    If KeyAscii = 27 Then
        Unload Me
    End If
    
    Exit Sub
handlerror:

End Sub

Private Sub Form_Load()
'启动窗体

    On Error GoTo handlerror
    
    Text1.Text = ""
    Text2.Text = ""
    Text3.Text = ""
    Text4.Text = ""
    Text5.Text = ""
    Text6.Text = ""
    Text7.Text = ""
    Text8.Text = ""
    
    Combo1.Clear
    Combo1.AddItem "高速公路、一级公路基层"
    Combo1.AddItem "高速公路、一级公路底基层"
    Combo1.AddItem "高速公路、一级公路路基"
    Combo1.AddItem "高速公路、一级公路面层"
    Combo1.AddItem "其他公路基层、底基层"
    Combo1.AddItem "其他公路路基、面层"
    Combo1.Text = "高速公路、一级公路面层"
    
    With VSFlexGrid1
        .Rows = 1
        .TextMatrix(0, 0) = "序号"
        .TextMatrix(0, 1) = "实测数据"
        .ColWidth(0) = 900
        .ColWidth(1) = 1800
        .ColWidth(2) = 0
        .RowHeightMin = 260
        .ColAlignment(0) = flexAlignCenterCenter
        .ColAlignment(1) = flexAlignCenterCenter
    End With
    
    
    Exit Sub
handlerror:

End Sub





Public Function funtfb(ByVal n As Double, x As Integer)

    Dim xlApp As Excel.Application

    On Error GoTo handlerror

    Set xlApp = New Excel.Application
        
    Set xlApp = CreateObject("Excel.Application")
    '激活EXCEL应用程序
    xlApp.Visible = False '隐藏EXCEL应用程序窗口
    
    Set xlBook = xlApp.Workbooks.Add
    
    '打开工作簿，strDestination为一个EXCEL报表文件
    Set xlsheet = xlBook.Worksheets(1)
    
    xlsheet.Cells(1, 1).ClearContents
    xlsheet.Cells(1, 1).FormulaR1C1 = "=TINV(" + Trim(Str(n)) + "," + Trim(Str(x)) + ")"
    Result = xlsheet.Cells(1, 1)
    
    xlsheet.Cells(1, 1) = ""
    
    xlBook.Save
    xlApp.Workbooks.Close
    
    xlApp.Quit

    
    Exit Function
handlerror:
    If Err.Number = 1004 Then xlApp.Quit
'    xiansh = MsgBox("在计算tα时出错，可能没有安装Excel，请再试试。", vbInformation, "问题提示")

End Function

Private Sub Text1_Change()
'数据个数
    
    Dim i As Integer
    
    On Error GoTo handlerror
    
    VSFlexGrid1.Rows = Val(Text1.Text) + 1
    For i = 1 To VSFlexGrid1.Rows - 1
        VSFlexGrid1.TextMatrix(i, 0) = i
    Next i
    
    Exit Sub
handlerror:

End Sub