frmtabujsp.frm

采用面向负荷控制技术

    Debug.Print destring
Wend
Exit Sub
err:
  MsgBox "Error Happened : " & err.Description, vbOKOnly
  
End Sub

Sub PutTaskAhead0(dn As Integer, I As Integer, j As Integer)
'功能：将设备dn上的第j个任务放在第i个任务之前；
'设任务从0开始编号,且i<j
'则该设备上的从新的第i个任务（即原第j个任务）开始需要重新计算开始时间
'设备dn的任务涉及到边的重新连接！！其它设备顺序不变
'首先将设备dn上的相关任务放入队列，当队列非空时，进入循环
'取队首元素，计算新的开始时间（设备上个任务完成时间与队首上道工序完成时间之较大者），
'计算队首所有后道工序的新的开始时间，每道工序所在设备的该工序后面的任务也进入队列（若与队列中已有元素重复则报警）
'直到队列为空。
'  本图结构有顶点和边，移到顶点时连同指向它的边一起移动，首尾顶点需另外处理

Dim TQueue() As Integer, m As Integer, k As Integer, n As Integer
Dim PreviousI As Integer, PreviousJ As Integer, vt As Integer, hh As Integer, ti As Integer, tj As Integer
Dim nta As Integer, tjnta As Integer, pjnta As Integer, pinta As Integer

On Error GoTo err
If I >= j Then
    MsgBox "Parameter error,i should be less than j", vbOKOnly
    Exit Sub
End If
'找设备dn的首任务
hh = Task(dn)
vt = hh
ti = hh
nta = Vertex(hh).FirstArc
nta = Edge(nta).nextArc
'找第i和第j个任务
k = 0
While k < j And nta <> -1
    vt = hh
    If k = I - 1 Then
        PreviousI = vt  'i的前个任务,若i为0，即i为首任务则执行不到此句
    End If
    If k = I Then
        ti = hh         '任务i
    End If
    hh = Edge(nta).VertexNo
    nta = Vertex(hh).FirstArc
    nta = Edge(nta).nextArc
    k = k + 1
Wend
If k < j Then
    MsgBox "Error,check device task queue", vbOKOnly
End If
tj = hh         '任务j
PreviousJ = vt 'j的前个任务
'更改设备dn的任务顺序，任务j放在任务i的位置，其余依次后推，
'即任务j-1指向j+1,任务i-1指向j，j指向i，
'先连接j-1和j+1,若j为最后任务则无j+1任务
tjnta = Vertex(tj).FirstArc
tjnta = Edge(tjnta).nextArc
If tjnta = -1 Then
    'j为设备dn上最后一个任务，则j-1变成最后任务
    nta = Vertex(PreviousJ).FirstArc
    pjnta = Edge(nta).nextArc '保存j-1指向的边
    Edge(nta).nextArc = -1
Else
    'j不是最后任务，则将j所指向的边由j-1来指向
    nta = Vertex(PreviousJ).FirstArc
    pjnta = Edge(nta).nextArc '保存原j-1所指向的边,该边指向j
    Edge(nta).nextArc = tjnta
End If
'处理i-1,i和j

If ti = Task(dn) Then
    '若i为首任务，则无i-1任务，
    Task(dn) = tj
    nta = Vertex(tj).FirstArc
    Edge(nta).nextArc = pjnta  '原指向j的边需指向i
    Edge(pjnta).VertexNo = ti
Else
    'i不是首任务,则j指向i,i-1指向j
    nta = Vertex(PreviousI).FirstArc
    pinta = Edge(nta).nextArc '保存原i-1指向的边
    Edge(nta).nextArc = pjnta   'i-1指向j
    nta = Vertex(tj).FirstArc
    Edge(nta).nextArc = pinta 'j指向i
End If

'下面重新计算新的任务队列中i以后的各任务的开始时间


Exit Sub
err:
MsgBox err.Description, vbOKOnly + vbCritical

End Sub

Sub ExchangeTask(dn As Integer, I As Integer, j As Integer)
'功能：交换设备dn上的任务i和j
'设任务从0开始编号,且i<j
'则该设备上的从新的第i个任务（即原第j个任务）开始需要重新计算开始时间
'设备dn的任务涉及到边的重新连接！！其它设备顺序不变
'首先将设备dn上的相关任务放入队列，当队列非空时，进入循环
'取队首元素，计算新的开始时间（设备上个任务完成时间与队首上道工序完成时间之较大者），
'计算队首所有后道工序的新的开始时间，每道工序所在设备的该工序后面的任务也进入队列（若与队列中已有元素重复则报警）
'直到队列为空。
'  本图结构有顶点和边，移到顶点时连同它指向的nextarc边一起移动(因为它指向的边包含其权值)，首尾顶点需另外处理

Dim TQueue() As Integer, m As Integer, k As Integer, n As Integer
Dim PreviousI As Integer, PreviousJ As Integer, vt As Integer, hh As Integer, ti As Integer, tj As Integer
Dim nta As Integer, tjnta As Integer, pjnta As Integer, pinta As Integer, tinta As Integer
Dim vti As Integer, vtj As Integer

On Error GoTo err
If I >= j Then
    MsgBox "Parameter error,i should be less than j", vbOKOnly
    Exit Sub
End If
'找设备dn的首任务
hh = Task(dn)
vt = hh
ti = hh
nta = Vertex(hh).FirstArc
nta = Edge(nta).nextArc
'找第i和第j个任务
k = 0
While k < j And nta <> -1
    vt = hh
    If k = I - 1 Then
        PreviousI = vt  'i的前个任务,若i为0，即i为首任务则执行不到此句
    End If
    If k = I Then
        ti = hh         '任务i
    End If
    hh = Edge(nta).VertexNo
    nta = Vertex(hh).FirstArc
    nta = Edge(nta).nextArc
    k = k + 1
Wend
If k < j Then
    MsgBox "Error,check device task queue", vbOKOnly
End If
tj = hh         '任务j
PreviousJ = vt 'j的前个任务
'更改设备dn的任务顺序，任务j放在任务i的位置，i放在j的位置，
'即任务i-1指向j，j指向i+1，任务j-1指向i,i指向j+1
tjnta = Vertex(tj).FirstArc
tjnta = Edge(tjnta).nextArc '保存原j指向的边，该边指向j+1
pjnta = Vertex(PreviousJ).FirstArc
pjnta = Edge(pjnta).nextArc '保存原j-1指向的边，该边指向j
pinta = Vertex(PreviousI).FirstArc
pinta = Edge(pinta).nextArc '保存原i-1指向的边，该边指向i
tinta = Vertex(ti).FirstArc
tinta = Edge(tinta).nextArc '保存原i指向的边，该边指向i+1,应由j的nextarc来指向
If I + 1 <> j Then  '交换不相邻的任务
    '先连接j-1,i和j+1,若j为最后任务则无j+1任务
        vti = Edge(tinta).VertexNo   '保存原i指向的顶点
        Edge(tinta).VertexNo = Edge(tjnta).VertexNo
        vtj = Edge(pjnta).VertexNo  '保存原j-1指向的结点,tj?
        Edge(pjnta).VertexNo = ti   'j-1指向i
    
    '处理i-1,j和i+1
    If ti = Task(dn) Then
        '若i为首任务，则无i-1任务，
        Task(dn) = tj
        Edge(tjnta).VertexNo = vti   'j指向i+1
        Edge(pinta).VertexNo = tj   'i-1的指向j
    Else
        'i不是首任务,则j指向i+1,i-1指向j
        Edge(pinta).VertexNo = tj   'i-1指向j
        Edge(tjnta).VertexNo = vti  'j指向i+1
    End If
Else    '两相邻任务交换，仍使用上面方法会使结点指向自身，造成死锁
    'i指向j+1,i-1指向j,j指向i
    Edge(tinta).VertexNo = Edge(tjnta).VertexNo
    Edge(pinta).VertexNo = tj
    Edge(tjnta).VertexNo = ti
    If ti = Task(dn) Then
        Task(dn) = tj
    End If
End If
'下面重新计算新的任务队列中i以后的各任务的开始时间


Exit Sub
err:
MsgBox err.Description, vbOKOnly + vbCritical

End Sub

Sub PutTaskAhead(dn As Integer, pi As Integer, pj As Integer)
'将设备号dn的第j个任务放在第i个任务之前
'调用交换的函数Exchange()实现
Dim TQueue() As Integer, m As Integer, k As Integer, n As Integer
Dim nta As Integer

On Error GoTo err
If pi >= pj Then
    n = pi
    pi = pj
    pj = n
    If pi = pj Then
        pi = pi - 1
    End If
'    MsgBox "Parameter error,pi" & pi & " should be less than pj" & pj, vbOKOnly
    Exit Sub
End If
k = pj
While k > pi
    Call ExchangeTask(dn, k - 1, k)
    k = k - 1
Wend
Exit Sub
err:
MsgBox err.Description, vbOKOnly + vbCritical
'
End Sub

Function GetPreviousTask(pi As Integer) As Integer
'参数i为顶点编号
Dim j As Integer, h As Integer, vt As Integer, nta As Integer
Dim dn As Integer, flag As Boolean

dn = Process(Vertex(pi).PartNo, Vertex(pi).ProcessNo) - 1 '得到顶点i（即任务i）的加工设备号
h = Task(dn)
If h = pi Then
GetPreviousTask = -1
Exit Function
End If
vt = h
flag = True
nta = Vertex(h).FirstArc
nta = Edge(nta).nextArc
While nta <> -1 And flag = True
    vt = h
    h = Edge(nta).VertexNo
    If h = pi Then
        flag = False
    End If
    nta = Vertex(h).FirstArc
    nta = Edge(nta).nextArc
Wend
GetPreviousTask = vt

End Function

Function GetStartTime(h As Integer) As Double
Dim vt As Integer, etime As Double, pstime As Double
'前道任务完成时间
vt = GetPreviousTask(h) '得到前道任务顶点编号
'计算前道任务完成时间=开始时间＋加工时间
If vt = -1 Then 'vt=-1即该任务为设备的第一个任务，无前道任务
    etime = 0
Else
    etime = Vertex(vt).StartTime + ProcessTime(Vertex(vt).PartNo, Vertex(vt).ProcessNo)
End If
'得到前道工序顶点编号
vt = GetPreviousProcess(Vertex(h).PartNo, Vertex(h).ProcessNo)
'计算前道工序完成时间
If vt = 0 Then 'vt=0即该工序为工件的第一道工序，无前道工序
    pstime = 0
Else
    pstime = Vertex(vt).StartTime + ProcessTime(Vertex(vt).PartNo, Vertex(vt).ProcessNo)
End If

'If pstime > etime Then
'    Vertex(h).StartTime = pstime
'Else
'    Vertex(h).StartTime = etime
'End If
If pstime < etime Then
     pstime = etime
End If
GetStartTime = pstime
End Function

Sub SortTask(h As Integer)

End Sub

Sub AlterGraph(dn As Integer, t As Integer)
'修改图中设备号dn的第t个任务及其之后的任务的起始及结束时间，所有修改过的任务进入队列，
'队列中的任务所在的设备及设备上该任务之后的任务也要同此处理
'队列，一个用于设备的后继任务
Dim qtask() As Integer, I As Long, j As Integer, tt As Integer, TaskQH As Long, TaskQT As Long
Dim h As Integer, vt As Integer, nta As Integer, pt As Integer, vtdn As Integer
Dim etime As Double, pstime As Double, flag As Boolean

h = Task(dn)
For I = 0 To t - 1
    nta = Vertex(h).FirstArc
    nta = Edge(nta).nextArc
    h = Edge(nta).VertexNo
Next I
'找到设备dn上第t个任务的后继任务进入队列Qtask
ReDim qtask(1)
TaskQH = 0: TaskQT = 0
'Qtask(TaskQH) = h
'将任务h的后继任务进入队列，以备处理
nta = Vertex(h).FirstArc
nta = Edge(nta).nextArc
vt = Edge(nta).VertexNo
While (vt <> DeviceCount * PartCount + 1)
    qtask(TaskQT) = vt
    TaskQT = TaskQT + 1
    ReDim Preserve qtask(TaskQT)
    nta = Vertex(vt).FirstArc
    nta = Edge(nta).nextArc
    vt = Edge(nta).VertexNo
Wend
'将交换至前的任务h及其后继工序优先排好序，（绝对提前）
'参数代表的任务在其所在设备上提前，其后继工序在各自的设备上也要提前
pstime = Vertex(h).StartTime
Vertex(h).StartTime = GetStartTime(h)
If Vertex(h).StartTime > 1000 Then
    Vertex(h).StartTime = 900
End If
If Vertex(h).StartTime = pstime Then
    '关键的提前任务时间无变化，则整张图也无变化，可以退出
    Exit Sub
End If

nta = Vertex(h).FirstArc
vt = Edge(nta).VertexNo
While vt <> DeviceCount * PartCount + 1
    '上道工序结束时间
    h = GetPreviousProcess(Vertex(vt).PartNo, Vertex(vt).ProcessNo)
    etime = Vertex(h).StartTime + ProcessTime(Vertex(h).PartNo, Vertex(h).ProcessNo)
    '找到本工序的加工设备
    vtdn = Process(Vertex(vt).PartNo, Vertex(vt).ProcessNo) - 1
    '在设备上找第一个完成时间在上道工序结束时间之后的任务,本任务放在其前,若找不到,则位置不动，但时间也要改
    '先找到设备首任务
    h = Task(vtdn): flag = False: j = 0 'j记录任务在设备上的序号
    While h <> vt
        pstime = Vertex(h).StartTime + ProcessTime(Vertex(h).PartNo, Vertex(h).ProcessNo)
        If pstime > etime And flag = False Then '找到则置找到标志
            flag = True
            tt = j  'tt记下任务编号
        Else    '找下道任务,同时进行任务编号
            nta = Vertex(h).FirstArc
            nta = Edge(nta).nextArc
            h = Edge(nta).VertexNo
            j = j + 1
        End If
    Wend
    If flag = True Then
        '找到,则任务置前
        If j <> 0 And tt <> 0 Then
            Call PutTaskAhead(vtdn, tt, j)
        End If
    End If
    '本任务位置不能提前，时间也要改
    '开始时间为上道工序结束时间
    pstime = Vertex(vt).StartTime
    Vertex(vt).StartTime = etime
    If Vertex(vt).StartTime <> pstime Then
    '本任务开始时间有变化，则后继任务的时间必有变化，进入队列
        nta = Vertex(h).FirstArc
        nta = Edge(nta).nextArc
        h = Edge(nta).VertexNo
        While h <> PartCount * DeviceCount + 1
            qtask(TaskQT) = h
            TaskQT = TaskQT + 1
            ReDim Preserve qtask(TaskQT)
            nta = Vertex(h).FirstArc
            nta = Edge(nta).nextArc
            h = Edge(nta).VertexNo
        Wend
    Else
        '
    End If
    
    '找下道工序
    nta = Vertex(vt).FirstArc
    vt = Edge(nta).VertexNo
Wend
'队列中的任务按常规进行插空式排序，每个任务还要检查其后继工序所在设备上有无后继任务，若有则进入队列
While TaskQH < TaskQT
    '队列非空，计算队首及其后的工序的开始时间,
    h = qtask(TaskQH)
    While h <> DeviceCount * PartCount + 1
        '判断是否最后一道工序，不能用nta<>-1，因为最后一个结点不属于任何工件
        '得到上道工序结束时间
        vt = GetPreviousProcess(Vertex(h).PartNo, Vertex(h).ProcessNo)
        If vt = 0 Then  'vt为0说明为第一道工序，
            etime = 0
        Else
            etime = Vertex(vt).StartTime + ProcessTime(Vertex(vt).PartNo, Vertex(vt).ProcessNo)
        End If
        '本任务所在设备
        vtdn = Process(Vertex(h).PartNo, Vertex(h).ProcessNo) - 1
        vt = Task(vtdn): j = 0: flag = False
        '在任务所在设备上从头开始找，看是否可以插空排入
        '先判断是否可以插在队首
'??        pstime = Vertex(vt).StartTime + ProcessTime(Vertex(vt).PartNo, Vertex(vt).ProcessNo)
        pstime = Vertex(vt).StartTime
        If pstime > etime Then
            While h <> vt
                pt = vt
                nta = Vertex(pt).FirstArc
                nta = Edge(nta).nextArc
                vt = Edge(nta).VertexNo
                j = j + 1
            Wend
        If j <> 0 Then
            Call PutTaskAhead(vtdn, tt, j)
        End If