frmsuanfa1.frm

采用面向负荷控制技术

     fmax1 = 1
     For i = 2 To j
        If fnew(fmax1) < fnew(i) Then
           fmax1 = i
        End If
     Next i
End Function

' 此函数为计算适值函数，他将染色体翻译成解,并求出解的适值
Public Sub translate(str As Integer)
   Dim i As Integer, j As Integer, k As Integer, h As Integer
   Dim m As Integer '代表工序所对应的机器号
   Dim imax As Single
   Dim lg As Single
     '初始化适值
      For j = 1 To ss
         f(j) = 0
      Next j
      '初始化
'      For j = 1 To mm
'         For k = 1 To hh
'          mach(j, k).gx = 0
'           mach(j, k).start = 0
'           mach(j, k).stop = 0
'         Next k
'      Next j
   '解码
       For i = 1 To ss
              'ft为解码函数
              Call ft(i, str)
              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
End Sub
'参数n代表工序号，返回本道工序的约束工序的最迟完成时间
'本函数来求工序n的约束工序的最迟完成时间
Public Function precede(n As Integer) As Single
    Dim i As Integer, k As Integer, j As Integer
    i = 1
    precede = 0
    'b(n,i)为工序n的约束工艺
    Do Until i > ll Or b(n, i) = 0
     '找出生产b(n,i)工序的机器号k
       k = a(2, b(n, i))
         For j = min(k) To 1 Step -1
            If mach(k, j).gx = b(n, i) Then
              If precede < mach(k, j).stop Then
                precede = mach(k, j).stop
              End If
            End If
         Next j
              i = i + 1
   Loop
    
End Function

'参数说明a为代表工艺、加工机器，及加工施加的数组，其大小为a(n,3),
'b为表示工艺间约束关系的二维数组，它为b(n,m);
'size设定初始种群的大小，n即可代表共艺数，又可代表染色体长度
Public Sub popsize(size As Integer)
   Dim s() As Integer '表示当前可调度工艺
   Dim i As Integer
   Dim k As Integer
   Dim h As Integer
   Dim j As Integer
   Dim imax As Integer
   ReDim s(nn)
   Randomize
 '生成初始种群
  For h = 1 To size
   '初始化d(n)
   
    i = 1
    Do Until i > nn
       If b(i, 1) = 0 Then
          d(i) = 0
       Else
          d(i) = 1
       End If
       i = i + 1
    Loop
   '初始化s(n)
    i = 1
    k = 1
   Do Until i > nn
      If d(i) = 0 Then
         s(k) = i
         d(i) = 2
         k = k + 1
       End If
       i = i + 1
   Loop
       k = k - 1
   '生成初始种群中的一条染色体
   For j = 1 To nn
       '计算k割可调度工序的随机数
        For i = 1 To k
           ran(i) = Rnd()
        Next i
       'imax为可放入染色体中工序的序号
         imax = big(k)
         p(h, j) = s(imax)
         If k <> imax Then
            s(imax) = s(k)
         End If
        
         '设置每个工序的约束状态
         Call change(h, j)
          '设置可调度工艺序列s
         i = 1
         Do Until i > nn
           If d(i) = 0 Then
                s(k) = i
                d(i) = 2
                k = k + 1
           End If
           i = i + 1
         Loop
         k = k - 1
    Next j
 Next h
End Sub
'参数说明a为代表工艺、加工机器，及加工施加的数组，其大小为a(n,3),
'b为表示工艺间约束关系的二维数组，它为b(n,m);
'size设定初始种群的大小，n即可代表共艺数，又可代表染色体长度
Public Sub popsize1(size As Integer)
   Dim h As Integer
   Dim j As Integer
   Randomize
 '生成初始种群
  For h = 1 To size
     '生成初始种群中的一条染色体
     For j = 1 To nn
       '生成一个1到mm的随机数
         p(h, j) = Int(mm * Rnd) + 1
       'imax为可放入染色体中工序的序号
       Next j
 Next h
End Sub
'用来改变每道工艺的约素状态
'参数n代表第几条染色体m代表当前染色体的长度
Public Sub change(n As Integer, m As Integer)
   Dim flag1 As Boolean, flag2 As Boolean
   Dim i As Integer, j As Integer, k As Integer
     k = 1
   Do Until k > nn
    If d(k) = 1 Then
           flag1 = False
           i = 1
        Do Until i > ll Or flag1 Or b(k, i) = 0
             j = 1
             flag2 = False
                Do Until (j > m Or flag2)
                   If p(n, j) = b(k, i) Then
                      flag2 = True
                   End If
                      j = j + 1
                Loop
                i = i + 1
            If b(k, i) = 0 Then
               If flag2 Then
                   flag1 = True
               End If
            End If
        Loop
         If flag1 Then
           d(k) = 0
         End If
    End If
       k = k + 1
 Loop
End Sub
'参数k表示随机数的个数
Public Function big(k As Integer) As Integer
     Dim i As Integer
      big = 1
      For i = 2 To k
        If ran(big) < ran(i) Then
            big = i
        End If
      Next i
End Function





Public Sub initial2()
 
   ss = CInt(txtss.Text)
   pc = CSng(txtpc.Text)
   pm = CSng(txtpm.Text)
   mm = CInt(txtmm.Text)
   nn = CInt(txtnn.Text)
   ll = CInt(txtll.Text)
   hh = CInt(txthh.Text)
   dd = CInt(txtdd.Text)
   ReDim p(ss + 1, nn + 1)
   ReDim pg(ss + 3, nn + 1)
   ReDim a(nn + 1, mm + 1)
   ReDim d(nn + 1, mm + 1)
   ReDim b(nn + 1, ll + 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)
   Dim i As Integer, j As Integer
   a(1, 1) = 3
   a(1, 2) = 2
   a(1, 3) = 6
   a(1, 4) = 8
   a(2, 1) = 8
   a(2, 2) = 6
   a(2, 3) = 3
   a(2, 4) = 5
   a(3, 1) = 4
   a(3, 2) = 3
   a(3, 3) = 6
   a(3, 4) = 7
   a(4, 1) = 3
   a(4, 2) = 9
   a(4, 3) = 4
   a(4, 4) = 6
   a(5, 1) = 9
   a(5, 2) = 3
   a(5, 3) = 5
   a(5, 4) = 3
   a(6, 1) = 3
   a(6, 2) = 4
   a(6, 3) = 8
   a(6, 4) = 5
   a(7, 1) = 5
   a(7, 2) = 4
   a(7, 3) = 4
   a(7, 4) = 5
   a(8, 1) = 7
   a(8, 2) = 5
   a(8, 3) = 4
   a(8, 4) = 3
End Sub

'初始化初始种群
Public Sub initial3()
  Dim j As Integer
  '设置初始种群
   Call popsize1(ss)
   Text1 = ""
   text2 = ""
   Text3 = ""

  For j = 1 To nn
     Text1.Text = Text1.Text & p(1, j)
  Next j
  For j = 1 To nn
     text2.Text = text2.Text & p(2, j)
  Next j
   For j = 1 To nn
     Text3.Text = Text3.Text & p(3, j)
  Next j
End Sub









Private Sub Cmbsuanfa_LostFocus()
    If Trim$(Cmbsuanfa.Text) = "启发式遗传算法" Then
        Comok.Caption = "参数设置"
        str1 = "启发式遗传算法"
    End If
End Sub

Private Sub Combb_Click()
   Dim bbrs As New ADODB.Recordset
  Dim findrs As New ADODB.Recordset
  If rs.RecordCount <> 0 Then
        Set bbrs = Nothing
        bbrs.ActiveConnection = "dsn=dbw;uid=sa"
        bbrs.CursorLocation = adUseClient
        bbrs.CursorType = adOpenKeyset
        bbrs.LockType = adLockOptimistic
        bbrs.Source = "DELETE FROM t_machine"
        bbrs.Open
        Set bbrs = Nothing
        bbrs.ActiveConnection = "dsn=dbw;uid=sa"
        bbrs.CursorLocation = adUseClient
        bbrs.CursorType = adOpenKeyset
        bbrs.LockType = adLockOptimistic
        bbrs.Source = "select * from  t_machine  "
        bbrs.Open
        rs.MoveFirst
      Do Until rs.EOF
         bbrs.AddNew
         bbrs("ordercode") = CStr(rs("ordercode"))
         bbrs("workcode") = CStr(rs("workcode"))
         bbrs("machinecode") = CStr(rs("machinenumber"))
         Set findrs = Nothing
        findrs.ActiveConnection = "dsn=dbw;uid=sa"
        findrs.CursorLocation = adUseClient
        findrs.CursorType = adOpenKeyset
        findrs.LockType = adLockOptimistic
        findrs.Source = "select devicename from  device  where deviceno='" & Trim$(rs("machinenumber")) & "'"
        findrs.Open
        If findrs.RecordCount <> 0 Then
          findrs.MoveFirst
          bbrs("machinename") = CStr(findrs("devicename"))
         End If
         bbrs("drawingnumber") = CStr(rs("drawingnumber"))
         bbrs("quantity") = CInt(rs("quantity"))
         bbrs("state") = CInt(rs("processnumber"))
         bbrs("timeoccupy") = CSng(rs("timeoccupy"))
         bbrs.Update
         rs.MoveNext
      Loop
  End If
      On Error Resume Next
     'CrystalReport1.ReportFileName = App.Path & "\report\machine.rpt"
     'CrystalReport1.Action = 1
        
End Sub

Private Sub Comexit_Click()
  Unload Me
End Sub

Private Sub Comexit1_Click()
 Unload Me
End Sub

Private Sub comfind_Click()
   Dim number As Integer
   Dim str As String
   If cmbmachine.Text = "" Then
      MsgBox "请您选择设备", vbExclamation + vbInformation
      Exit Sub
   End If
    number = InStr(1, cmbmachine.Text, "/", vbTextCompare)
    str = Left(Trim$(cmbmachine.Text), number - 1)
    Set rs = Nothing
    rs.ActiveConnection = "dsn=dbw;uid=sa"
    rs.CursorLocation = adUseClient
    rs.CursorType = adOpenKeyset
    rs.LockType = adLockOptimistic
    rs.Source = "select * from t_submachineload where machinenumber='" & str & "'"
    rs.Open
    If rs.RecordCount = 0 Then
       MsgBox "此设备上目前没有派任务", vbExclamation + vbInformation
    End If
    combb.Enabled = True
    Set DataGrid2.DataSource = rs
    Call first(DataGrid2)
    Call initial(DataGrid2, "设备负荷表")
    
End Sub

Private Sub comfresh_Click()
  Dim findrs As New ADODB.Recordset
  Set findrs = Nothing
  findrs.ActiveConnection = "dsn=dbw;uid=sa"
  findrs.CursorLocation = adUseClient
  findrs.CursorType = adOpenDynamic
  findrs.LockType = adLockOptimistic
  findrs.Source = "delete from t_submachineload"
  findrs.Open
  Set findrs = Nothing
  findrs.ActiveConnection = "dsn=dbw;uid=sa"
  findrs.CursorLocation = adUseClient
  findrs.CursorType = adOpenDynamic
  findrs.LockType = adLockOptimistic
  findrs.Source = "delete from t_subdaytaskplan"
  findrs.Open
  Set findrs = Nothing
  findrs.ActiveConnection = "dsn=dbw;uid=sa"
  findrs.CursorLocation = adUseClient
  findrs.CursorType = adOpenDynamic
  findrs.LockType = adLockOptimistic
  findrs.Source = "delete from t_spgeneralpartplan"
  findrs.Open
  Set findrs = Nothing
  findrs.ActiveConnection = "dsn=dbw;uid=sa"
  findrs.CursorLocation = adUseClient
  findrs.CursorType = adOpenDynamic
  findrs.LockType = adLockOptimistic
  findrs.Source = "delete from t_myplantask"
  findrs.Open
  Set findrs = Nothing
  findrs.ActiveConnection = "dsn=dbw;uid=sa"
  findrs.CursorLocation = adUseClient
  findrs.CursorType = adOpenDynamic
  findrs.LockType = adLockOptimistic
  findrs.Source = "update t_suborder  set  added='否'"
  findrs.Open

End Sub

Private Sub Comgtt_Click()
Dim findsql As String
Dim findrs As New ADODB.Recordset
If Trim$(cmbmachine1.Text) = "" Then
   MsgBox "请您选择查看的设备类", vbExclamation + vbInformation
   Exit Sub
End If
If Option1.Value