frmts.frm

采用面向负荷控制技术

VERSION 5.00
Begin VB.Form frmTS 
   Caption         =   "禁忌搜索算法"
   ClientHeight    =   6885
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   10065
   LinkTopic       =   "Form1"
   MDIChild        =   -1  'True
   ScaleHeight     =   6885
   ScaleWidth      =   10065
   Begin VB.TextBox Text2 
      Height          =   5295
      Left            =   6120
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   3
      Text            =   "frmTS.frx":0000
      Top             =   360
      Width           =   3975
   End
   Begin VB.CommandButton Command2 
      Caption         =   "Command2"
      Height          =   375
      Left            =   3480
      TabIndex        =   2
      Top             =   6120
      Width           =   855
   End
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   495
      Left            =   960
      TabIndex        =   1
      Top             =   6000
      Width           =   975
   End
   Begin VB.TextBox Text1 
      Height          =   5295
      Left            =   120
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   0
      Text            =   "frmTS.frx":0006
      Top             =   360
      Width           =   5775
   End
End
Attribute VB_Name = "frmTS"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim conn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim DBProcess(1000, 1000) As Integer, DBProcessTime(1000, 1000) As Double
Dim Part() As String, Gx() As String, Dev() As String
Dim PCount As Integer, GCount As Integer, DCount As Integer



Sub RecordToMatrix()
Dim j As Integer, k As Integer, m As Integer
Dim sql As String, str0, pstime As Double
'得到零件数及零件对照表Part(),为矩阵中的编号与零件图号对照表
sql = "select distinct drawingno from t_myplantask "
rs.Open sql, conn, adOpenKeyset, adLockPessimistic
If rs.RecordCount = 0 Then
    MsgBox "no record in _myplantask when generate DBProcess", vbOKOnly
    rs.Close
    Exit Sub
End If
rs.MoveFirst
PCount = 0

While Not rs.EOF
    ReDim Preserve Part(PCount + 1)
    Part(PCount) = rs(0)
    rs.MoveNext
    PCount = PCount + 1
Wend
rs.Close
Text2 = "Part:" & vbCrLf
For j = 0 To PCount - 1
    Text2 = Text2 & j & ":" & Part(j) & vbCrLf
Next j
'得到工序数及工序对照表Gx(),为矩阵中的编号与工序号对照表
sql = "select max(processno) from t_myplantask"
rs.Open sql, conn, adOpenKeyset, adLockPessimistic
If rs.RecordCount = 0 Then
    MsgBox "no record in _myplantask when generate DBProcess", vbOKOnly
    rs.Close
    Exit Sub
End If
rs.MoveFirst
GCount = rs(0) / 5
rs.Close
ReDim Gx(GCount + 1)
For k = 0 To GCount
    Gx(k) = k * 5
Next k

'得到设备数及设备对照表Dev(),为矩阵中的编号与设备编号对照表,得到加工时间阵
'矩阵元素数为PCount*(GCount+1)
ReDim Dev(1)
Dev(0) = "备注"      '0表示无此设备，在矩阵中设备号为0表示该工件的该道工序不存在或不加工
DCount = 1
For j = 0 To PCount - 1
    For k = 0 To GCount
        sql = "select locationname,elapsetime from t_subpmreference where drawingnumber='" & Part(j)
        sql = sql & "' and processnumber='" & Gx(k) & "'"
        rs.Open sql, conn, adOpenKeyset, adLockPessimistic
        If rs.RecordCount = 0 Then
            DBProcess(j, k) = 0
            DBProcessTime(j, k) = 0
            rs.Close
        Else
            '先在DEV（）数组中查找该设备是否已加入数组，若未加入则加入，否则只填写编号
            For m = 0 To DCount - 1
                If Dev(m) = rs(0) Then
                    Exit For
                End If
            Next m
            If m < DCount Then
                DBProcess(j, k) = m
            Else
                ReDim Preserve Dev(DCount + 1)
                Dev(DCount) = rs(0)
                DBProcess(j, k) = DCount
                DCount = DCount + 1
            End If
            '加工时间
            If InStr(1, rs(1), "+") Then
                str0 = Split(rs(1), "+")
                For m = 0 To UBound(str0)
                    DBProcessTime(j, k) = DBProcessTime(j, k) + str0(m)
                Next m
            ElseIf InStr(1, rs(1), "*") Then
                    str0 = Split(rs(1), "*")
                    pstime = 1
                    For m = 0 To UBound(str0)
                        pstime = pstime * str0(m)
                    Next m
                    DBProcessTime(j, k) = DBProcessTime(j, k) + pstime
                Else
                        DBProcessTime(j, k) = rs(1) '获得单位加工时间，
            End If
            rs.Close
            sql = "select planquantity from t_myplantask where drawingno='" & Part(j) & "'"
            rs.Open sql, conn, adOpenKeyset, adLockPessimistic
            If rs.RecordCount = 0 Then
                DBProcessTime(j, k) = 0
                rs.Close
            Else
                rs.MoveFirst
                DBProcessTime(j, k) = DBProcessTime(j, k) * rs(0)   '计划数量*单位工时=实际用工时间
                rs.Close
            End If
        End If
        
    Next k
Next j
'for debug
Text2 = Text2 & vbCrLf & "quota" & vbCrLf
For j = 0 To GCount
    sql = "select processname from t_subpmreference where processnumber='" & Gx(j) & "'"
    rs.Open sql, conn, adOpenKeyset, adLockPessimistic
    rs.MoveFirst
    Text2 = Text2 & j & ":" & Gx(j) & "," & rs(0) & vbCrLf
    rs.Close
Next j
Text2 = Text2 & vbCrLf & "Device" & vbCrLf
For j = 0 To DCount - 1
    Text2 = Text2 & j & ":" & Dev(j) & vbCrLf
Next j

Text1 = ""
For j = 0 To PCount - 1
    For k = 0 To GCount - 1
        Text1 = Text1 & "(" & DBProcess(j, k) & "," & DBProcessTime(j, k) & "),"
    Next k
    Text1 = Text1 & vbCrLf
Next j
End Sub

Private Sub Command1_Click()
Call RecordToMatrix

End Sub

Private Sub Command2_Click()
Call myexit
End Sub

Private Sub Form_Load()
Dim connstr As String
connstr = "dlrwdb"
conn.Open connstr

End Sub

Sub myexit()
Set conn = Nothing
Set rs = Nothing
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Call myexit

End Sub

Private Sub Form_Unload(Cancel As Integer)
'Call myexit

End Sub