📄 frmsuanfa1.frm
字号:
TabIndex = 1
Top = 1920
Width = 14295
_ExtentX = 25215
_ExtentY = 11218
_Version = 393216
HeadLines = 1
RowHeight = 15
BeginProperty HeadFont {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ColumnCount = 2
BeginProperty Column00
DataField = ""
Caption = ""
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 2052
SubFormatType = 0
EndProperty
EndProperty
BeginProperty Column01
DataField = ""
Caption = ""
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 2052
SubFormatType = 0
EndProperty
EndProperty
SplitCount = 1
BeginProperty Split0
BeginProperty Column00
EndProperty
BeginProperty Column01
EndProperty
EndProperty
End
Begin MSDataGridLib.DataGrid DataGrid1
Height = 7815
Left = -74880
TabIndex = 6
Top = 1680
Width = 14775
_ExtentX = 26061
_ExtentY = 13785
_Version = 393216
HeadLines = 1
RowHeight = 15
BeginProperty HeadFont {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ColumnCount = 2
BeginProperty Column00
DataField = ""
Caption = ""
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 2052
SubFormatType = 0
EndProperty
EndProperty
BeginProperty Column01
DataField = ""
Caption = ""
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 2052
SubFormatType = 0
EndProperty
EndProperty
SplitCount = 1
BeginProperty Split0
BeginProperty Column00
EndProperty
BeginProperty Column01
EndProperty
EndProperty
End
Begin VB.Label Label3
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = " 大连铁道学院电器信息分院课题组 "
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00C00000&
Height = 210
Left = -72120
TabIndex = 9
Top = 8760
Width = 8505
End
End
End
Attribute VB_Name = "frmsuanfa1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim c() As Integer
Dim str1 As String
Dim rs As New ADODB.Recordset
'编写初始种群模块
'Dim p(31, 13) As Integer '存储初始种群
'Dim a(4, 13) As Integer '存储工艺相关数据a(4,nn+1)
'Dim b(13, 6) As Integer '存储工艺约束b（nn+1,ll+1)
'Dim d(13) As Integer '用d(i)=0来标志递i倒工序可放入可调度集s中，
'd(i)=1，表示本倒工艺当前有约素工艺未调度，
'd(i)=2表示本倒工艺已调度,d(nn+1)
'Dim ran(13) As Single '存储随即数ran(nn+1)
'Dim f(31) As Single '存储每个染色体的适值f(ss+1)
'Dim mach(4, 5) As machine '用它来存储机器的任务集mach(mm+1,hh+1)
Dim maa() As String
Dim tt()
Dim p() As Integer '存储初始种群p(ss+1,nn+1)
Dim pg() As Integer '存储新种群p(ss+1,nn+1)
Dim a() As Integer '存储工艺相关数据a(mm+1,nn+1)
Dim b() As Integer '存储工艺约束b（nn+1,ll+1)
Dim pgg() As Integer '新产生的染色体串
Dim d() As Integer '
Dim dd As Integer
Dim pnew() As Integer
Dim fnew() As Single
'用d(i)=0来标志递i倒工序可放入可调度集s中，
'd(i)=1，表示本倒工艺当前有约素工艺未调度，
'd(i)=2表示本倒工艺已调度,d(nn+1)
Dim ran() As Single '存储随即数ran(nn+1)
Dim pran() As Single '存储各个染色体的选择概率pran(ss+1)
Dim pf() As Single '存储每个染色体的适值f(ss+1)
Dim f() As Single '存储每个染色体的适值f(ss+1)
Dim mach() As machine '用它来存储机器的任务集mach(mm+1,hh+1)
Dim mach1() As machine
Dim min() As Integer '用来记录设备当前的任务数
Dim ss As Integer '用它来设置种群大小
Dim pc As Single '用它来表示复制率
Dim pm As Single '用它来表示变异率
Dim mm As Integer '用它来表示机器数
Dim nn As Integer '用它来表示工序数
Dim ll As Integer '用它来表示约束工艺的最大数
Dim hh As Integer '用它来表示每台机器上的最多任务数
'drawingnumber为产品名称，quantitys为计划数量，pcocdssquatos为产品定额，manchine1 为设备的占用时间，manchine2为设备工作效率，
Public Sub mpop(quantitys As Integer, processquatos As Single, mach1() As Single, mach2() As Single)
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 = 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
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)
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -