frmsuanfa1.frm

基于vb6.0和sql数据库的车间调度管理系统

    Dim i As Integer, j As Integer, k As Integer, l As Integer, m As Integer
    Dim min, ave As Single
    m = UBound(mach1)
    ReDim C(m)
    For i = 1 To m
      C(i) = 0       '初始化每台设备的任务量为0
    Next i
       
   For i = 1 To quantitys '将n个任务依次分配到m太设备上
      k = 1
      min = mach1(1) + processquatos / mach2(1)
      For j = 2 To m       '找出设备占用时间最小的，并将任务分配给他
         ave = mach1(j) + processquatos / mach2(j)
         If (ave < min) Then
            min = ave
            k = j
         End If
       Next j
       mach1(k) = min
       C(k) = C(k) + 1
     Next i
 
End Sub
Sub AlgBuffFirst()
Dim sql As String, remaint As Integer
Dim finpro() As String
Set mrs = Nothing
sql = "select * from t_spgeneralpartplan order by drawingnumber"
mrs.Open sql, mconn, adOpenKeyset, adLockPessimistic
If mrs.RecordCount > 0 Then
    mrs.MoveFirst
    While Not mrs.EOF
        '获得已完工工序，对finpro()赋值
        ReDim finpro(1)
        finpro(0) = mrs("state")
        remaint = GetRemainTime(finpro, mrs("drawingnumber"))
        sql = mrs("senddate") - Date
        mrs("bufftime") = mrs("senddate") - Date - remaint
        mrs.Update
        mrs.MoveNext
    Wend
End If
mrs.Close
End Sub
Sub ljb()
Dim sql As String, remaint As Integer
Dim finpro() As String
Set mrs = Nothing
sql = "select * from t_spgeneralpartplan order by drawingnumber"
mrs.Open sql, mconn, adOpenKeyset, adLockPessimistic
If mrs.RecordCount > 0 Then
    mrs.MoveFirst
    While Not mrs.EOF
        '获得已完工工序，对finpro()赋值
        ReDim finpro(1)
        finpro(0) = mrs("state")
        remaint = GetRemainTime(finpro, mrs("drawingnumber"))
        sql = mrs("senddate") - Date
        If remaint <> 0 Then
            
        mrs("bufftime") = (mrs("senddate") - Date) / remaint
        End If
        mrs.Update
        mrs.MoveNext
    Wend
End If
mrs.Close
End Sub

Sub ShowResult()
Dim sql As String
Set mrs = Nothing
sql = "select drawingnumber as 图号,state as 下道工序,planquantity as 计划数量,senddate as 交货日期,"
Select Case Me.Tag
    Case "buff"
        sql = sql & " bufftime as 缓冲期 "
    Case "ljb"
        sql = sql & " bufftime as 临界比 "
    
End Select
 sql = sql & " from t_spgeneralpartplan order by bufftime"
mrs.Open sql, mconn, adOpenKeyset, adLockPessimistic
If mrs.RecordCount = 0 Then
    Set dgd_show.DataSource = Nothing
    dgd_show.Refresh
Else
    mrs.MoveFirst
    Set dgd_show.DataSource = mrs
    dgd_show.Refresh
End If
End Sub

'根据已完工工序，获得未完工工序所需时间
Function GetRemainTime(finishedprocess() As String, drawno As String)
Dim sql As String, tt As Integer
Dim rs As New ADODB.Recordset
sql = "select * from t_subpmreference where drawingnumber='" & drawno & "'"
'派工时工序固定从小到大，不能改变顺序
sql = sql & " and processnumber>=" & finishedprocess(0)
'若允许随机排序，须减去数组finishedprocess()中的工序
rs.CursorLocation = adUseClient
rs.Open sql, mconn, adOpenKeyset, adLockPessimistic
If rs.RecordCount = 0 Then
    GetRemainTime = 0
Else
    tt = 0
    rs.MoveFirst
    While Not rs.EOF
        tt = rs("elapsetime") + tt
        rs.MoveNext
    Wend
    GetRemainTime = tt
End If
rs.Close

End Function

Public Function findmachine(machine1 As String) As Integer
    Dim i As Integer
    Dim flag As Boolean
    flag = False
    i = 1
    Do Until i > mm Or flag
      If machine1 = maa(i) Then
          flag = True
      Else
        i = i + 1
      End If
    Loop
   If flag Then
    findmachine = i
   Else
    findmachine = 0
   End If
End Function
'总体初始化
Public Sub initial4()
    Dim i As Integer, j As Integer
    Dim findrs As New ADODB.Recordset
    Dim str As String
'ss = CInt(txtss.Text)
'   pc = CSng(txtpc.Text)
'  pm = CSng(txtpm.Text)
'  dd = CInt(txtdd.Text)
   ss = ss1
   pc = pc1
   pm = pm1
   dd = 4
'   dd = dd1
 
    '查询生产设备数
   Set rs = Nothing
    rs.ActiveConnection = "dsn=dbw;uid=sa"
    rs.CursorLocation = adUseClient
    rs.CursorType = adOpenKeyset
    rs.LockType = adLockOptimistic
    rs.Source = "select distinct machinenumber from t_machineprocess1,t_myplantask " & _
   " where added='否' and t_machineprocess1.drawingnumber=t_myplantask.drawingno " & _
   "and t_machineprocess1.processnumber=t_myplantask.processno order by machinenumber"
    rs.Open
    If rs.RecordCount = 0 Then
       MsgBox "当前没有加工设备", vbExclamation + vbInformation
       End
    End If
    mm = rs.RecordCount 'mm表示机器数
'    mm = CInt(txtmm.Text)
    ReDim maa(mm + 1)
    rs.MoveFirst
     i = 1
    Do Until rs.EOF
      maa(i) = Trim(rs("machinenumber"))
      i = i + 1
      rs.MoveNext
    Loop
    '求每台设备上的最大任务数
      hh = 0
     rs.MoveFirst
     Do Until rs.EOF
            Set findrs = Nothing
            findrs.ActiveConnection = "dsn=dbw;uid=sa"
            findrs.CursorLocation = adUseClient
            findrs.CursorType = adOpenKeyset
            findrs.LockType = adLockOptimistic
            findrs.Source = "select drawingno,processno " & _
              " from t_machineprocess1,t_myplantask " & _
              " where added='否' and t_machineprocess1.drawingnumber=t_myplantask.drawingno " & _
              "and t_machineprocess1.processnumber=t_myplantask.processno and t_machineprocess1.machinenumber='" & Trim$(rs("machinenumber")) & "'"
            findrs.Open
            If findrs.RecordCount > hh Then hh = findrs.RecordCount  'hh表示每台机器上的任务数
            rs.MoveNext
     Loop
    
    ll = 1

'   nn = CInt(txtnn.Text)
'   ll = CInt(txtll.Text)
'   hh = CInt(txthh.Text)
    '查询任务数
    Set rs = Nothing
    rs.ActiveConnection = "dsn=dbw;uid=sa"
    rs.CursorLocation = adUseClient
    rs.CursorType = adOpenKeyset
    rs.LockType = adLockOptimistic
    rs.Source = "select drawingno,processno,planquantity,timeoccupy ,machinenumber " & _
    "from t_myplantask ,t_machineprocess1 where t_machineprocess1.drawingnumber=t_myplantask.drawingno" & _
    " and t_machineprocess1.processnumber=t_myplantask.processno  and added='否' order by drawingno,processno"
    rs.Open
    If rs.RecordCount = 0 Then
       MsgBox "当前没有为排序的任务", vbExclamation + vbInformation
       End
    End If
    nn = rs.RecordCount
   ReDim p(ss + 1, nn + 1)
   ReDim pg(ss + 2, nn + 1)
   ReDim A(4, nn + 1)
   ReDim D(nn + 1)
   ReDim B(nn + 1, ll + 1)
   ReDim ran(nn + 1)
   ReDim f(ss + 1)
   ReDim mach(mm + 1, hh + 1)
   ReDim mach1(ss + 1, mm + 1, hh + 1)
   ReDim min(mm + 1)
   ReDim pf(ss + 1)
'   ReDim tt(1 To dd + 1)
   i = 1
   str = "ss"
   rs.MoveFirst
   Do Until rs.EOF
        A(1, i) = i   ' a存储工艺相关数据
        A(2, i) = findmachine(Trim$(rs("machinenumber")))
        A(3, i) = CSng(rs("timeoccupy") * rs("planquantity"))
        If str = Trim$(rs("drawingno")) Then
         B(i, 1) = i - 1
        Else
          B(i, 1) = 0
        End If
        str = Trim$(rs("drawingno"))
        i = i + 1
        rs.MoveNext
   Loop
 
End Sub
'遗传调度算法
Public Function genetic1() As Integer
  Dim k As Integer, i As Integer, j As Integer
  Dim imax As Single
  Dim sum As Single
  
  k = 1
  '初始化
  Call initial4
  '生成初始种群
  Call popsize(ss)
  Do Until k > dd
       '计算种群的适值
       Call translate(1)
        sum = 0
'        tt(k, 1) = k
        For i = 2 To ss
           sum = sum + 1 / f(i)
        Next i
'        tt(k) = sum / ss
       '计算选择概率
       Call fitness
       '选择操作
       Call chose
       '交叉操作
       Call crossover
       '变异操作
       Call mutation
       '重新设置种群
       Call fset
       '解码并计算适值
       'Call translate(1)
       k = k + 1
   Loop
   
   
   For i = 1 To ss
     '对每个染色体解码，
     Call ft(i, 1)
      For j = 1 To mm
         For k = 1 To hh
            mach1(i, j, k).gx = mach(j, k).gx
            mach1(i, j, k).start = mach(j, k).start
            mach1(i, j, k).stop = mach(j, k).stop
         Next k
      Next j
      imax = mach(1, min(1)).stop
              For j = 2 To mm
                If imax < mach(j, min(j)).stop Then imax = mach(j, min(j)).stop
              Next j
            f(i) = 1 / imax
    Next i
    k = 1
   ' 选出适值最大的染色体
   For i = 2 To ss
     If f(k) < f(i) Then
        k = i
     End If
   Next i
   genetic1 = k
  
End Function

'遗传禁忌调度算法
Public Function GA_TS() As Integer
  Dim k As Integer, i As Integer, j As Integer
  Dim imax As Single
  Dim sum As Single
  Dim tt(51) As Single
  
  k = 1
  '初始化
  Call initial4
  '生成初始种群
  Call popsize(ss)
  
  Do Until k > dd
       '计算种群的适值
       Call translate(1)
        sum = 0
'        tt(k, 1) = k
        For i = 2 To ss
           sum = sum + 1 / f(i)
        Next i
'        tt(k) = sum / ss
       '计算选择概率
       Call fitness
       '选择操作
       Call chose
       '交叉操作
       Call crossover
       '变异操作
       Call mutation
       '重新设置种群
       Call fset
    
        w = 1
   ' 选出适值最大的染色体
   For i = 2 To ss
     If f(w) < f(i) Then
        w = i
     End If
   Next i
   'tt(k) = 1 / f(w)
   'MSChart1.ChartData = tt
   'MSChart1.ColumnLabel = "完成时间"
   'MSChart1.RowLabel = "迭代次数"
   
   
   
    k = k + 1
   Loop
   For i = 1 To ss
     '对每个染色体解码，
     Call ft(i, 1)
      For j = 1 To mm
         For k = 1 To hh
            mach1(i, j, k).gx = mach(j, k).gx
            mach1(i, j, k).start = mach(j, k).start
            mach1(i, j, k).stop = mach(j, k).stop
         Next k
      Next j
      imax = mach(1, min(1)).stop
              For j = 2 To mm
                If imax < mach(j, min(j)).stop Then imax = mach(j, min(j)).stop
              Next j
            f(i) = 1 / imax
    Next i
    k = 1
   ' 选出适值最大的染色体
   For i = 2 To ss
     If f(k) < f(i) Then
        k = i
     End If
   Next i
   GA_TS = k
   

  
End Function

'重组算子
Public Sub tsm()
Dim i As Integer
Dim sum As Double  '适配值和
Dim ave As Single '适配值均值
Dim Tabu(50, 50) As Single '禁忌表
Dim flag As Boolean
Dim f1 As Single '父染色体一的适值
Dim f2 As Single '父染色体二的适值
Dim f3 As Single
Dim fn As Single '后代染色体的适值
Dim f(50) As Single '存储每个染色体的适值f(ss+1)

flag = False
sum = 0
For i = 1 To ss
  sum = sum + f(i)
Next i
ave = sum / ss
If f3 < ave Then
  ss = ss + 1
  Call tabu_change
Else
  For i = 1 To ss
    If Tabu(i, 1) = f3 Then
       flag = True
    End If
   Next i
  If flag = False Then
    ss = ss + 1
    Call tabu_change
    End If
End If
If flag = True Then
   fn = ddd(f1, f2, f3)
        If fn = f1 And fn <> f3 Then