开发工具:
文件大小: 32kb
下载次数: 0
上传时间: 2014-05-01
详细说明： 抹灰厚度计算 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 Ne xt 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 ...展开收缩
(系统自动生成,下载前可以参看下载内容)
下载文件列表
相关说明
- 本站资源为会员上传分享交流与学习,如有侵犯您的权益,请联系我们删除.
- 本站是交换下载平台，提供交流渠道，下载内容来自于网络，除下载问题外，其它问题请自行百度。
- 本站已设置防盗链，请勿用迅雷、QQ旋风等多线程下载软件下载资源，下载后用WinRAR最新版进行解压.
- 如果您发现内容无法下载，请稍后再次尝试；或者到消费记录里找到下载记录反馈给我们.
- 下载后发现下载的内容跟说明不相乎，请到消费记录里找到下载记录反馈给我们，经确认后退回积分.
- 如下载前有疑问，可以通过点击"提供者"的名字，查看对方的联系方式，联系对方咨询.
