抹灰厚度计算
Option Explicit
Dim xlExcel As New Excel.Application
Dim xlBook As New Excel.Workbook
Dim xlSheet As New Excel.Worksheet
Dim iRow As Long, jCol As Long, maxf As Long
Dim a() As Double
Dim maxfe As Integer
Dim maxfg As Integer
'Dim AppExcel As Object
Private Sub isButton1_Click()
CommonDialog1.ShowOpen
If Right(CommonDialog1.FileName, 3) <> "xls" Then
MsgBox ("非xls有效格式文件")
Exit Sub
End If
Text5.Text = CommonDialog1.FileName
List1.Clear
ProgressBar1.Max = 1
'读取excel
On Error Resume Next
xlExcel.Workbooks.Open Text5.Text
Set xlBook = xlExcel.Workbooks(1)
xlBook.Sheets(1).Select
maxf = xlExcel.ActiveSheet.UsedRange.Rows.Count
ReDim a(maxf) As Double
For iRow = 1 To maxf
a(iRow) = xlBook.Worksheets(1).Cells(iRow, 1)
ProgressBar1.Value = iRow / maxf
DoEvents
Next
xlBook.Close
xlExcel.Quit
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlExcel = Nothing
End Sub
Private Sub isButton2_Click()
If Text2.Text = "" Then
MsgBox ("请输入抹灰设计厚度")
Exit Sub
End If
If Text3.Text = "" Then
MsgBox ("请输入实际抹灰厚度超过设计厚度的期望百分比")
Exit Sub
End If
If Text5.Text = "" Then
MsgBox ("请指定EXCEL数据路径")
Exit Sub
End If
List1.Clear
'排序
Dim i As Integer
Dim j As Integer
Dim temp As Double
For i = LBound(a()) To UBound(a()) - 1
For j = LBound(a()) To UBound(a()) - 1
If a(j) > a(j + 1) Then
temp = a(j)
a(j) = a(j + 1)
a(j + 1) = temp
End If
Next
Next
'按照期望百分比分割
maxfe = (1 - Text3.Text / 100) * maxf
maxfg = Text3.Text / 100 * maxf
'前n个
Dim ae() As Double
ReDim ae(maxfe) As Double
'减掉后的前n个
Dim aej() As Double
ReDim aej(maxfe) As Double
'后n个
Dim af() As Double
ReDim af(maxfg) As Double
'得到前n个
For iRow = 1 To maxfe
ae(iRow) = a(iRow)
Next
'得到容许值
Dim zzz As Double
zzz = ae(maxfe) - Text2.Text
Text4.Text = zzz
'第一个数组相减
Dim T As Integer
For iRow = 1 To maxfe
aej(iRow) = ae(iRow) - zzz
'形成正数数组
If aej(iRow) < 0 Then
T = iRow
End If
Next
For iRow = 1 To T
List1.AddItem (ae(iRow))
Next
Dim ttt As Double
ttt = T / maxf
Text1.Text = Format(ttt, "0.000")
End Sub
Private Sub Text2_keypress(KeyAscii As Integer)
If KeyAscii = 46 And Not CBool(InStr(Text2, ".")) Then Exit Sub
If KeyAscii = 8 Then Exit Sub
If KeyAscii < 48 Or KeyAscii > 57 Then KeyAscii = 0
If Text2.Text = "0" And Text2.SelStart = 1 And Chr(KeyAscii) <> "." And KeyAscii <> 8 Then KeyAscii = 0
End Sub
Private Sub Text3_keypress(KeyAscii As Integer)
If KeyAscii = 46 And Not CBool(InStr(Text2, ".")) Then Exit Sub
If KeyAscii = 8 Then Exit Sub
If KeyAscii < 48 Or KeyAscii > 57 Then KeyAscii = 0
If Text3.Text = "0" And Text3.SelStart = 1 And Chr(KeyAscii) <> "." And KeyAscii <> 8 Then KeyAscii = 0
End Sub
