frmtest.frm

采用面向负荷控制技术

    Else
        mrs_r("rpartname") = rs1(0)
    End If
    rs1.Close
    'mrs_r("rpartname") = mrs_r("referencepartno")
    mrs_r.Update
    mrs_r.MoveNext
    i = i + 1
    Debug.Print i
Wend
mrs_r.Close
MsgBox "total record: " & i
End Sub

Sub update_bom()
Dim rs0 As New ADODB.Recordset
Dim rs1 As New ADODB.Recordset
Dim sql As String, i As Integer
i = 0
sql = "select * from t_spbillofmaterial where locomotivetype='东风4D型客运内燃机车'"
rs0.CursorLocation = adUseClient
rs0.Open sql, conn2, adOpenKeyset, adLockPessimistic
sql = "select * from t_bom "
rs1.CursorLocation = adUseClient
rs1.Open sql, conn2, adOpenKeyset, adLockPessimistic
rs0.MoveFirst
While Not rs0.EOF
    rs1.AddNew
    rs1("workcode") = "007-1"
    rs1("father") = rs0("prodrawingnumber")
    rs1("fname") = rs0("productname")
    rs1("son") = rs0("pardrawingnumber")
    rs1("sname") = rs0("partname")
    rs1("parroutine") = rs0("parroutine")
    rs1("pargroupamount") = rs0("pargroupamount")
    rs1("parmaterial") = rs0("parmaterial")
    rs1("ptype") = rs0("productiontype")
    rs1.Update
    rs0.MoveNext
    i = i + 1
    Debug.Print i
Wend
rs1.Close
rs0.Close
MsgBox "total record:" & i
End Sub

Private Sub Frame2_DragDrop(Source As Control, X As Single, Y As Single)

End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Key
    
    Case "a"
        Toolbar1.Buttons(4).Enabled = False
        'Button.Enabled = False
    Case "b"
        Toolbar1.Buttons(4).Enabled = True
        Toolbar1.Buttons(6).Enabled = False
    Case "c"
        'Toolbar1.Buttons(6).Enabled = False
        Call readdata
        Call SimpleForm
End Select
End Sub

Sub update_machine()
Dim sql As String, rs0 As New ADODB.Recordset, rs1 As New ADODB.Recordset, rs2 As New ADODB.Recordset
Dim sql0 As String, i As Integer
sql = "select * from t_submachine"
rs0.CursorLocation = adUseClient
rs0.Open sql, conn, adOpenKeyset, adLockPessimistic
rs0.MoveFirst
While Not rs0.EOF
    sql = "select * from deviceclass where model='" & rs0("machinename") & "'"
    rs1.CursorLocation = adUseClient
    rs1.Open sql, conn, adOpenKeyset, adLockPessimistic
    If rs1.RecordCount = 0 Then
        rs1.AddNew
        rs1("model") = rs0("machinename")
        rs1("name") = rs0("machinename")
        rs1("limit") = 8
        rs1("amount") = 1
        rs1("note") = rs0("note")
        rs1.Update
    End If
    rs1.Close
    sql = "select * from device where deviceno='" & rs0("machinenumber") & "'"
    rs1.Open sql, conn, adOpenKeyset, adLockPessimistic
    If rs1.RecordCount = 0 Then
        rs1.AddNew
        rs1("deviceno") = rs0("machinenumber")
        rs1("devicename") = rs0("machinename")
        rs1("model") = rs0("machinename")
        rs1("orderdate") = "1999-05-30"
        rs1("status") = 8
        rs1("operatorstatus") = 8
        rs1("qualitystatus") = 8
        sql = rs0("note")
        rs1("note") = sql
        rs1.Update
    
    End If
    rs1.Close
    rs0.MoveNext
    i = i + 1
    Debug.Print i
Wend
rs0.Close
End Sub

Sub upd_subpmreference()
Dim sql As String, rs0 As New ADODB.Recordset, rs1 As New ADODB.Recordset
Dim i As Integer, j As Integer
sql = "select * from t_subpmreference"
rs0.CursorLocation = adUseClient
rs0.Open sql, conn, adOpenKeyset, adLockPessimistic
rs0.MoveFirst
sql = "select * from device"
rs1.Open sql, conn, adOpenKeyset, adLockPessimistic

While Not rs0.EOF
        Dim MyValue
    MyValue = Int((100 * Rnd) + 1)
    rs1.MoveFirst
    For i = 0 To MyValue
        rs1.MoveNext
    Next i
    rs0("machinenumber") = rs1("deviceno")
    rs0.Update
    rs0.MoveNext
    j = j + 1
    Debug.Print j
Wend
rs0.Close
rs1.Close
End Sub

Sub readdata()
 Dim fs, wfs, str0
 Dim txtfile, wfile, StrLine
 Dim ForReading As Integer, forwriting As Integer, i As Integer, j As Integer
 
    ForReading = 1
    forwriting = 2
    On Error GoTo errhandler
    CommonDialog1.CancelError = True
    CommonDialog1.DialogTitle = "查找文档"
    CommonDialog1.Filter = "Text Files" & "(*.txt)|*.txt|All Files (*.*)|*.*"

    CommonDialog1.ShowOpen
    Set fs = CreateObject("scripting.filesystemobject")
    Set txtfile = fs.OpenTextFile(CommonDialog1.FileName, ForReading, False)
    'wfname = fs.GetParentFolderName(CommonDialog1.FileName)
    Me.MousePointer = ccHourglass 'ccDefault
    'wfname = App.Path & "\pdmerr.txt"
    'Set wfs = CreateObject("scripting.filesystemobject")
    'Set wfile = wfs.OpenTextFile(wfname, forwriting, True)
        StrLine = txtfile.ReadLine
        str0 = Split(StrLine, ",")
        n = str0(0)
        m = str0(1)
        StrLine = txtfile.ReadLine
        str0 = Split(StrLine, ",")
        For i = 0 To m - 1
            ji(i) = str0(i)
        Next i
        StrLine = txtfile.ReadLine
        str0 = Split(StrLine, ",")
        For i = 0 To n - m - 1
            nonji(i) = str0(i)
        Next i
        For i = 0 To m - 1
            StrLine = txtfile.ReadLine
            str0 = Split(StrLine, ",")
            For j = 0 To n - 1
                a(i, j) = str0(j)
            Next j
        Next i
        StrLine = txtfile.ReadLine
        str0 = Split(StrLine, ",")
        For i = 0 To n - 1
            c(i) = str0(i)
        Next i
        StrLine = txtfile.ReadLine
        str0 = Split(StrLine, ",")
        For i = 0 To m - 1
            b(i) = str0(i)
        Next i
        
    txtfile.Close
    Me.MousePointer = ccDefault
    'test
    rtxt = "a:" & vbCrLf
    For j = 0 To n - 1
        rtxt = rtxt & j + 1 & "    "
    Next j
    rtxt = rtxt & vbCrLf
    For i = 0 To m - 1
        rtxt = rtxt & i + 1 & " "
        For j = 0 To n - 1
            rtxt = rtxt & a(i, j) & " "
        Next j
        rtxt = rtxt & vbCrLf
    Next i
    rtxt = rtxt & vbCrLf
    rtxt = rtxt & "c:   "
    For i = 0 To n - 1
        rtxt = rtxt & c(i)
    Next i
    rtxt = rtxt & vbCrLf & "b:   " & vbCrLf
    For i = 0 To m - 1
        rtxt = rtxt & b(i)
    Next i
    'Call SimpleForm
Exit Sub
errhandler:
        If Err.number <> 32755 Then
            MsgBox Err.Description, vbOKOnly
        End If
Exit Sub

End Sub

'根据传入的?号返回对应的?号
'按此方式调用
'i=contrast(index)
Function contrast(param As Integer) As Integer
Dim ForReading As Integer
Dim txtfile, fs, str0
Dim s0 As String, StrLine As String, FName As String
    ForReading = 1
    FName = "d:\hfwang\mp2188.ini"      '系统配置文件名
    s0 = "SLOT" & param
    Set fs = CreateObject("scripting.filesystemobject")
    Set txtfile = fs.OpenTextFile(FName, ForReading, False)
     '跳过第一行
    StrLine = txtfile.ReadLine
     Do While Not txtfile.AtEndOfStream
          '读一行
        StrLine = txtfile.ReadLine
        str0 = Split(StrLine, "=")      '分割后，str(0)为'='前部分，str(1)为'='后部分
        If str0(0) = s0 Then
            contrast = str0(1)
            txtfile.Close
            Exit Function
        End If
        
     Loop
    txtfile.Close
    MsgBox "未找到" & s0 & "所对应的路号", vbOKOnly

End Function




Sub senddevicedata()
Dim sql1 As String, sql2 As String, str0
'Dim conn1 As New ADODB.Connection, conn2 As New ADODB.Connection
Dim connstr1 As String, connstr2 As String
Dim rs1 As New ADODB.Recordset, rs2 As New ADODB.Recordset
'connstr1 = "大机车": connstr2 = "dlrwdb"
sql1 = "select * from t_submachine"
sql2 = "select * from device"
rs1.Open sql1, conn1, adOpenKeyset, adLockPessimistic
rs2.Open sql2, conn2, adOpenKeyset, adLockPessimistic
rs1.MoveFirst
While Not rs1.EOF

    rs2.AddNew
    rs2(0) = rs1(0)
    rs2(1) = rs1(1)
    str0 = Split(rs1(0), "-")
    rs2(2) = str0(0)
    rs2(3) = rs1("type")
    rs2(4) = "1998-09-08"
    rs2(5) = 8
    rs2(6) = 1
    rs2(7) = 2
    rs2(8) = rs1("location")
    rs2(9) = rs1("note")
    rs2.Update
    rs1.MoveNext
Wend
rs1.Close
rs2.Close
End Sub

Sub getdeviceclass()
Dim sql1 As String, sql2 As String, str0
'Dim conn1 As New ADODB.Connection, conn2 As New ADODB.Connection
Dim connstr1 As String, connstr2 As String
Dim rs1 As New ADODB.Recordset, rs2 As New ADODB.Recordset, rs0 As New ADODB.Recordset
'connstr1 = "大机车": connstr2 = "dlrwdb"
sql1 = "select * from device"
rs1.Open sql1, conn2, adOpenKeyset, adLockPessimistic
rs1.MoveFirst
While Not rs1.EOF
    sql2 = "select * from deviceclass where model='" & rs1("model") & "'"
    rs2.Open sql2, conn2, adOpenKeyset, adLockPessimistic
    If rs2.RecordCount = 0 Then
        rs2.AddNew
        rs2(0) = rs1("model")
        rs2(1) = rs1(1)
        rs2(2) = 20
        rs2(3) = 1
        rs2(4) = " "
    Else
        rs2(3) = rs2(3) + 1
    End If
    rs2.Update
    rs2.Close
    rs1.MoveNext
Wend
rs1.Close
End Sub

Sub getproduct1()
Dim sql1 As String, sql2 As String, str0
'Dim conn1 As New ADODB.Connection, conn2 As New ADODB.Connection
Dim connstr1 As String, connstr2 As String
Dim rs1 As New ADODB.Recordset, rs2 As New ADODB.Recordset
'connstr1 = "大机车": connstr2 = "dlrwdb"
sql2 = "select * from t_bom"
rs2.Open sql2, conn2, adOpenKeyset, adLockPessimistic
rs2.MoveFirst
While Not rs2.EOF
    sql1 = "select * from t_spbillofmaterial where prodrawingnumber='" & rs2("father")
    sql1 = sql1 & "' and pardrawingnumber='" & rs2("son") & "' and locomotivetype='"
    sql1 = sql1 & "东风4D型客运内燃机车" & "'"
    rs1.Open sql1, conn1, adOpenKeyset, adLockPessimistic
    If rs1.RecordCount > 0 Then
        rs2("pargroupamount") = rs1("pargroupamount")
        rs2("parmaterial") = rs1("parmaterial")
        rs2("ptype") = rs1("productiontype")
        rs2("note2") = rs1("note")
        rs2.Update
    Else
        MsgBox "", vbOKOnly
    End If
    rs1.Close
    rs2.MoveNext
Wend
rs2.Close
End Sub

Sub getprocessplan()
Dim sql1 As String, sql2 As String, str0
'Dim conn1 As New ADODB.Connection, conn2 As New ADODB.Connection
Dim connstr1 As String, connstr2 As String
Dim rs1 As New ADODB.Recordset, rs2 As New ADODB.Recordset
Dim i As Integer
i = 0
'connstr1 = "大机车": connstr2 = "dlrwdb"
sql1 = "select * from t_subprocessplan"
sql2 = "select * from t_subpmreference"
rs1.Open sql1, conn1, adOpenKeyset, adLockPessimistic
rs2.Open sql2, conn2, adOpenKeyset, adLockPessimistic
rs1.MoveFirst
While Not rs1.EOF

    rs2.AddNew
    rs2("drawingnumber") = rs1("drawingnumber")
    rs2("partname") = rs1("partname")
    rs2("processnumber") = rs1("processnumber")
    rs2("processname") = rs1("processname")
    rs2("elapsetime") = rs1("processquota")
    rs2("locationname") = rs1("groupname")
    rs2("referencepartno") = rs1("addpartdrawingno")
    rs2("rpartname") = rs1("addpartname")
    rs2("workeramount") = 10
    rs2("note") = " "
    rs2.Update
    rs1.MoveNext
    i = i + 1
    Label2.Caption = "第" & i & "条记录"
Wend
rs1.Close
rs2.Close

End Sub