tfdp1.bas

此程序是完成的土方调配

Attribute VB_Name = "Module1"
Option Explicit

Public filename As String, ldmc As String, bg As String, filename1 As String
Public qt1_3 As Double, qt4 As Double, qt5 As Double, qt6 As Double
Public ys1 As Integer, ys As Integer
Public qdzh As Double, zdzh As Double
Public xlbook As Excel.Workbook
Public xlsheet1 As Excel.Worksheet
Public xlsheet2 As Excel.Worksheet
Public xlsheet3 As Excel.Worksheet
Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
'保存Text文本框的内容到“sjsv.ini”文件中。
Public Function WriteOneString(ByVal Section As String, ByVal Key As String, ByVal value As String) As Boolean
    Dim X As Long, buff As String * 128, i As Integer
    buff = value + Chr(0)
    X = WritePrivateProfileString(Section, Key, buff, "sjsv.ini")
    WriteOneString = X
End Function
'将保存的文本框的内容从“sjsv.ini”中读出来，再显示在文本框中。
Public Function ReadOneString(ByVal Section As String, ByVal Key As String) As String
    Dim X As Long, buff As String * 128, i As Integer
    X = GetPrivateProfileString(Section, Key, "", buff, 128, "sjsv.ini")
    i = InStr(buff, Chr(0))
    ReadOneString = Trim(Left(buff, i - 1))
End Function
'从ljtsfslbsj.dat中读出数据，并输出到表格中。
Sub tfb()
    Form1.Command1.Enabled = False
    Dim zh1() As Double, zh2() As String, tmj() As Double, wmj() As Double
    Dim wfs() As Double, wss As Double, tfs() As Double, jl() As Double
    Dim wffl1() As Single, wffl2() As Single, wffl3() As Single, wffl4() As Single, wffl5() As Single, wffl6() As Single
    Dim wfsl1() As Double, wfsl2() As Double, wfsl3() As Double, wfsl4() As Double, wfsl5() As Double, wfsl6() As Double
    Dim filename As String, i As Integer, n As Integer
    Dim zz As Integer, glys As Integer
    Dim wts As Double, glhj As String
    filename1 = filename1 & "\ljtsfbsj.dat"
    On Error GoTo ErrorTrap
    Open filename1 For Input As #1
    i = 1
    Do While Not EOF(1)
        ReDim Preserve zh1(i) As Double
        ReDim Preserve zh2(i) As String
        ReDim Preserve tmj(i) As Double
        ReDim Preserve wmj(i) As Double
        ReDim Preserve jl(i) As Double
        ReDim Preserve wfs(i) As Double
        ReDim Preserve tfs(i) As Double
        ReDim Preserve wffl1(i) As Single
        ReDim Preserve wffl2(i) As Single
        ReDim Preserve wffl3(i) As Single
        ReDim Preserve wffl4(i) As Single
        ReDim Preserve wffl5(i) As Single
        ReDim Preserve wffl6(i) As Single
        ReDim Preserve wfsl1(i) As Double
        ReDim Preserve wfsl2(i) As Double
        ReDim Preserve wfsl3(i) As Double
        ReDim Preserve wfsl4(i) As Double
        ReDim Preserve wfsl5(i) As Double
        ReDim Preserve wfsl6(i) As Double
        Input #1, zh1(i), zh2(i), tmj(i), wmj(i), jl(i), tfs(i), wfs(i), wffl1(i), wfsl1(i), wffl2(i), wfsl2(i), wffl3(i), wfsl3(i), wffl4(i), wfsl4(i), wffl5(i), wfsl5(i), wffl6(i), wfsl6(i)
        i = i + 1
        If zh1(i - 1) > zdzh Then
            Exit Do
        End If
    Loop
    Close (1)
    n = i - 1
    zz = 1
    ys = 1
    ys1 = 1
    glys = 1
    For i = 1 To n
    If zh1(i) >= qdzh And zh1(i) <= zdzh Then
        If zh1(i) <> qdzh Then
        If zh1(i) / 1000 = Int(zh1(i) / 1000) And zh1(i) <> 0 Then
            If zh1(i) < zdzh Then
                ys1 = ys1 + 1
                zz = 2
            End If
        End If
        End If
        If zz > 27 Then
            ys1 = ys1 + 1
            zz = 2
        End If
        zz = zz + 1
    End If
    Next i
    zz = 1
    For i = 1 To n
    If zh1(i) >= qdzh And zh1(i) <= zdzh Then
        If zh1(i) = qdzh Then
            xlsheet3.Cells((ys - 1) * 64 + 6 + zz * 2, "A") = zh2(i)
            If wmj(i) <> 0 Then
                xlsheet3.Cells((ys - 1) * 64 + 6 + zz * 2, "B") = wmj(i)
            End If
            If tmj(i) <> 0 Then
                xlsheet3.Cells((ys - 1) * 64 + 6 + zz * 2, "C") = tmj(i)
            End If
        Else
            xlsheet3.Cells((ys - 1) * 64 + 2, "AC") = "第 " & ys & " 页 共 " & ys1 & " 页"
            xlsheet3.Cells((ys - 1) * 64 + 2, "A") = ldmc
            xlsheet3.Cells((ys - 1) * 64 + 6 + zz * 2, "A") = zh2(i)
            If wmj(i) <> 0 Then
                xlsheet3.Cells((ys - 1) * 64 + 6 + zz * 2, "B") = wmj(i)
            End If
            If tmj(i) <> 0 Then
                xlsheet3.Cells((ys - 1) * 64 + 6 + zz * 2, "C") = tmj(i)
            End If
            If jl(i) <> 0 Then
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "D") = jl(i)
            End If
            If wfs(i) <> 0 Then
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "E") = wfs(i)
            End If
            If wfsl1(i) <> 0 Then
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "F") = wffl1(i) * 100
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "G") = wfsl1(i)
            End If
            If wfsl2(i) <> 0 Then
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "H") = wffl2(i) * 100
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "I") = wfsl2(i)
            End If
            If wfsl3(i) <> 0 Then
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "J") = wffl3(i) * 100
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "K") = wfsl3(i)
            End If
            If wfsl4(i) <> 0 Then
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "L") = wffl4(i) * 100
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "M") = wfsl4(i)
            End If
            If wfsl5(i) <> 0 Then
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "N") = wffl5(i) * 100
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "O") = wfsl5(i)
            End If
            If wfsl6(i) <> 0 Then
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "P") = wffl6(i) * 100
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "Q") = wfsl6(i)
            End If
            If tfs(i) <> 0 Then
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "R") = tfs(i)
            End If
            wts = wfsl1(i) + wfsl2(i) + wfsl3(i)
            wss = wfsl4(i) + wfsl5(i) + wfsl6(i)
                lyfqf wts, wss, tfs(i), zz, wfsl4(i), wfsl5(i), wfsl6(i)    '调用“真弃”的横向调配子程序
        End If
        If zh1(i) = zdzh Then
            mglhj ys, glys
        End If
        zz = zz + 1
        If zz > 27 Then     '分页
            glys = glys + 1
            ys = ys + 1
            copy_bg
            zz = 1
            xlsheet3.Cells((ys - 1) * 64 + 6 + zz * 2, "A") = zh2(i)
            If wmj(i) <> 0 Then
                xlsheet3.Cells((ys - 1) * 64 + 6 + zz * 2, "B") = wmj(i)
            End If
            If tmj(i) <> 0 Then
                xlsheet3.Cells((ys - 1) * 64 + 6 + zz * 2, "C") = tmj(i)
            End If
            zz = 2
        End If
        If zh1(i) / 1000 = Int(zh1(i) / 1000) And zh1(i) <> 0 Then       '整公里分页
            If zh1(i) <> qdzh Then
                If zh1(i) < zdzh Then
                    Call mglhj(ys, glys)
                    glys = 1
                    ys = ys + 1
                    copy_bg
                    zz = 1
                    xlsheet3.Cells((ys - 1) * 64 + 6 + zz * 2, "A") = zh2(i)
                    If wmj(i) <> 0 Then
                        xlsheet3.Cells((ys - 1) * 64 + 6 + zz * 2, "B") = wmj(i)
                    End If
                    If tmj(i) <> 0 Then
                        xlsheet3.Cells((ys - 1) * 64 + 6 + zz * 2, "C") = tmj(i)
                    End If
                    zz = 2
                End If
            End If
        End If
    End If
    Next i
    ymsz
    Form1.Command1.Enabled = True
ErrorTrap:
    Select Case Err.Number
        Case 76         '路径不对
            Dim Response
            Response = MsgBox _
                ("无法在给定的路径找到“Ljtsfbsj.dat”，您是否进行手工查找？" _
                , vbYesNo + vbCritical, "运行错误")
            If Response = vbYes Then
                Form1.cmDialog1.Filter = "数据文件(*.dat)|*.dat|所有文件(*.*)|*.*"
                Form1.cmDialog1.InitDir = "C:\"
                Form1.cmDialog1.ShowOpen
                If Form1.cmDialog1.filename <> "" Then
                    Open Form1.cmDialog1.filename For Input As #1
                Else
                    End
                End If
            Else
                End
            End If
    End Select
End Sub
'拷贝表格到指定的位置
Sub copy_bg()
    Dim r1 As String, r2 As String, r3 As String, rr1 As String, rr2 As String
    xlsheet1.Activate
    xlsheet1.Range("A1", "AQ64").Select
    xlsheet1.Application.Selection.Copy
    xlsheet3.Activate
    rr1 = "A" & (ys - 1) * 64 + 1
    rr2 = "AQ" & (ys - 1) * 64 + 1
    xlsheet3.Range(rr1, rr2).Select
    xlbook.ActiveSheet.Paste
    r1 = (ys - 1) * 64 + 1 & ":" & (ys - 1) * 64 + 7
    r2 = (ys - 1) * 64 + 8 & ":" & (ys - 1) * 64 + 61
    r3 = (ys - 1) * 64 + 62 & ":" & (ys - 1) * 64 + 63
    xlsheet3.Rows(r1).Select