frmsuanfa1.frm

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

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

Private Sub Cmbsuanfa_LostFocus()
    If Trim$(Cmbsuanfa.Text) = "算法1" Then
        Comok.Caption = "参数设置"
        str1 = "算法1"
    ElseIf Trim$(Cmbsuanfa.Text) = "算法2" Then
            Comok.Caption = "参数设置"
            str1 = "算法2"
         
    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 Combo1_Change()

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 = True Then
   MSChart2.chartType = VtChChartType2dLine
Else
   MSChart2.chartType = VtChChartType2dBar
End If
'findsql = "select  productname,totalamount,max(stateamount) as amount,state   from t_mmmobilestock where drawingnumber='" & Trim$(cmbproductname) & "' group by productname,totalamount,state"
findsql = "select sum(timeoccupy) as occupy,machinenumber from t_submachineload,device where machinenumber=deviceno and devicename='" & cmbmachine1.Text & "' group by machinenumber order by machinenumber"
Set findrs = Nothing
findrs.ActiveConnection = "dsn=dbw;uid=sa"
findrs.CursorLocation = adUseClient
findrs.CursorType = adOpenKeyset
findrs.LockType = adLockOptimistic
findrs.Source = findsql
findrs.Open

Dim sum As Integer
sum = findrs.RecordCount
 If sum = 0 Then
    Exit Sub
 End If
Dim my()
ReDim my(1 To sum, 1 To 3)
findrs.MoveFirst
For i = 1 To sum
 my(i, 1) = "设备号" & findrs("machinenumber")  'labels
 my(i, 2) = findrs("occupy") 'series1 values
' my(i, 3) = findrs("totalamount")
 findrs.MoveNext
Next
  findrs.MoveFirst
 MSChart2.ChartData = my
 MSChart2.TitleText = cmbmachine1.Text & "设备负荷图示"
 MSChart2.Legend.VtFont.size = 14
 MSChart2.Title.VtFont.size = 14

End Sub
Private Sub Command1_Click()
  If rs.State = 1 Then Set rs = Nothing
  Unload Me
End Sub
 Private Sub Comok_Click()
    Dim rs1 As New ADODB.Recordset  '用rs来对零件计划标排序并显示之
    'machine()代表机器编号，machine2()代表机器效率machine1()代表机器负荷
    Dim machine() As String, machine1() As Single, machine2() As Single
    Dim timeoccupy  '记录每台设备的时间占用
    Dim rs2 As New ADODB.Recordset '找出相应的产品对应的加工设备号
    Dim rs3 As New ADODB.Recordset '打开打开日生产计划表
    Dim rs5 As New ADODB.Recordset '用来给r表里添加数据
    Dim m As Integer, i As Integer
    Dim quota As Single
    Dim kkk As Integer
    Dim Strg As String
    Dim conn As New ADODB.Connection
If Comok.Caption = "任务分派" Then
    Strg = Cmbsuanfa.Text
    Select Case Strg
      Case "算法1"
        kkk = genetic1
      Case "算法2"
        kkk = GA_TS
     
    End Select

    Set rs = Nothing
  rs.ActiveConnection = "dsn=dbw;uid=sa"
  rs.CursorLocation = adUseClient
  rs.CursorType = adOpenKeyset
  rs.LockType = adLockOptimistic
  rs.Source = "t_submachineload"
      conn = "dsn=dbw;uid=sa"
    conn.Open
    conn.Execute "DELETE  FROM t_submachineload "

  rs.Open
  
  Set DataGrid1.DataSource = rs
  Call first(DataGrid1)
  Call initial(DataGrid1, "设备负荷表1")
    Set rs1 = Nothing
    rs1.ActiveConnection = "dsn=dbw;uid=sa"
    rs1.CursorLocation = adUseClient
    rs1.CursorType = adOpenKeyset
    rs1.LockType = adLockOptimistic
    rs1.Source = "select workcode,ordercode, drawingno,processno,planquantity,machinenumber,timeoccupy " & _
    "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"
    rs1.Open
    rs1.MoveFirst
  For i = 1 To mm
      j = 1
    
      
      Do Until j > hh Or mach1(kkk, i, j).gx = 0
      rs1.Move CLng(mach1(kkk, i, j).gx - 1), adBookmarkFirst
      
      rs.AddNew
      rs("workcode") = CStr(rs1("workcode"))
      rs("ordercode") = CStr(rs1("ordercode"))
      rs("drawingnumber") = CStr(rs1("drawingno"))
      rs("processnumber") = CInt(rs1("processno"))
      rs("machinenumber") = CStr(rs1("machinenumber"))
      rs("quantity") = CInt(rs1("planquantity"))
      rs("timeoccupy") = CInt(rs1("planquantity")) * CSng(rs1("timeoccupy"))
      rs("plandate") = mach1(kkk, i, j).start
      rs("note") = mach1(kkk, i, j).stop
      'rs.MoveNext
      rs.Update
     ' rs.Close
      
      j = j + 1
      Loop
  Next i

Else
    frmsfcsh.Show
End If
        
End Sub

Private Sub Form_Load()
combb.Enabled = False
 Set rs = Nothing
  rs.ActiveConnection = "dsn=dbw;uid=sa"
  rs.CursorLocation = adUseClient
  rs.CursorType = adOpenKeyset
  rs.LockType = adLockOptimistic
  rs.Source = "t_submachineload"
  rs.Open
  Set DataGrid1.DataSource = rs
  Call first(DataGrid1)
  Call initial(DataGrid1, "设备负荷表")
  SSTab1.Tab = 0
  rs.Close
End Sub

Private Sub Label3_Click()

End Sub

Private Sub SSTab1_Click(PreviousTab As Integer)
Dim findrs As New ADODB.Recordset
  Dim i As Integer
If SSTab1.Tab = 0 Then
   
      Set rs = Nothing
        rs.ActiveConnection = "dsn=dbw;uid=sa"
        rs.CursorLocation = adUseClient
        rs.CursorType = adOpenKeyset
        rs.LockType = adLockOptimistic
        rs.Source = "t_submachineload"
        rs.Open
        Set DataGrid1.DataSource = rs
        Call first(DataGrid1)
        Call initial(DataGrid1, "设备负荷表")
  ElseIf SSTab1.Tab = 1 Then
       Set rs = Nothing
       rs.ActiveConnection = "dsn=dbw;uid=sa"
       rs.CursorLocation = adUseClient
       rs.CursorType = adOpenKeyset
       rs.LockType = adLockOptimistic
       rs.Source = "select distinct machinenumber,devicename  from device ,t_submachineload  where machinenumber=deviceno order by machinenumber"
       rs.Open
       If rs.RecordCount <> 0 Then
         cmbmachine.Clear
         rs.MoveFirst
         Do Until rs.EOF
            cmbmachine.AddItem rs("machinenumber") & "/" & rs("devicename")
            rs.MoveNext
         Loop
        End If
Else
  If str1 <> "" Then
       Set rs = Nothing
       rs.ActiveConnection = "dsn=dbw;uid=sa"
       rs.CursorLocation = adUseClient
       rs.CursorType = adOpenKeyset
       rs.LockType = adLockOptimistic
       rs.Source = "select distinct  devicename,machinenumber  from device,t_submachineload where machinenumber=deviceno order by devicename"
       rs.Open
       If rs.RecordCount <> 0 Then
         ReDim tt(1 To rs.RecordCount, 1 To 3)
         rs.MoveFirst
         i = 1
         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 top 1 devicename,t_submachineload.note  from" & _
          " t_submachineload,device where  machinenumber=deviceno and machinenumber='" & Trim$(rs("machinenumber")) & "' order by t_submachineload.note desc"
          findrs.Open
          If findrs.RecordCount <> 0 Then
           tt(i, 1) = CStr(findrs("devicename"))
          If findrs("note") <> Null Then
           tt(i, 2) = CSng(findrs("note"))
           Else
           tt(i, 2) = 5
           End If
           i = i + 1
          End If
          rs.MoveNext
        Loop
        MSChart2.ChartData = tt
        MSChart2.chartType