module1.bas

这些是我特地制作的分布式计算的示例程序

Attribute VB_Name = "Module1"
'分布式计算开发示例
'原作者 郝佳男
'force to declare the vars
Option Explicit

'define the max task number
Public Const MAXTASKN = 10000
Type ClStTy
 Status As Long
End Type

'task status type
Type TaskStTy
 BeginPos As Long
 EndPos As Long
 Status As Long
 BeginTime As Date
 Result As String
End Type

'define time out var
Public MAXMINUTE  As Long

'define the ado connection object
Public MDBCon As New ADODB.Connection

'define task status array
Public TaskSt(MAXTASKN) As TaskStTy

'define task number
Public TaskN As Long

'define winsocket number
Public SocketN As Long

Public Sub RefreshTaskStList(ID As Long)
Rem refresh an item in task status list

'judge if the id is valid
If ID < 0 Or ID > Form1.TaskStList.ListCount - 1 Then
'it is invalid
 'jump out
 Exit Sub
End If
'call function to get string and update it to listbox
Form1.TaskStList.List(ID) = GetTaskStString(ID)
End Sub

Public Function GetTaskStString(ID As Long) As String
Rem get task staus string

Dim s As String
'judge the task status
If TaskSt(ID).Status = 0 Then
'task is invalid
 s = "不存在"
ElseIf TaskSt(ID).Status = 1 Then
'task is ready but not assigned
 s = "未分配"
ElseIf TaskSt(ID).Status = 2 Then
'task is assigned
 s = "已于" + CStr(TaskSt(ID).BeginTime) + "分配，等待计算"
ElseIf TaskSt(ID).Status = 3 Then
'task is finished
 s = "计算完毕，点击察看结果"
End If
GetTaskStString = "任务" & (ID + 1) & vbTab & TaskSt(ID).BeginPos & "-" & TaskSt(ID).EndPos & vbTab + s
End Function

Public Sub AddLog(s As String)
Rem the sub to add to log

'add a new item to log listbox
Form1.LogList.AddItem Time$ + vbTab + s, 0
End Sub

Public Function GetTask() As String
Rem get task description string

Dim i As Long, j As Long
'set flag
j = 0
'loop to get an availiable task
For i = 0 To TaskN - 1
 'judge if the task is availiable
 If TaskAva(i) Then
 'it is availiable
  'update the flag
  j = 1
  'jump out hte loop
  Exit For
 End If
Next i
'judge the flag
If j = 0 Then
'no availiable task to assign
 'set return value
 GetTask = "NOTASK"
Else
'found an availiable task
 GetTask = "TASK" + Trim$(Str$(TaskSt(i).BeginPos)) + " " + Trim$(Str$(TaskSt(i).EndPos))
 'initialize the status
 TaskSt(i).Status = 2
 'set the task begin time
 TaskSt(i).BeginTime = Now
 'refresh the task status listbox
 Call RefreshTaskStList(i)
 'add to log
 AddLog "任务" + CStr(i) + "已分配，分配时间" + CStr(TaskSt(i).BeginTime)
End If
End Function

Public Sub CloseSocket(Index As Integer)
Rem close the winsocket

'judge if the winsocket is closed
If Form1.ws(Index).State <> sckClosed Then
'not closed
 'close it
 Form1.ws(Index).Close
 'add to log
 AddLog "Socket " + Str$(Index) + " 已关闭"
End If
End Sub

Public Sub ReceiveResult(BeginPos As Long, EndPos As Long, Result As String)
Rem check and process the result

Dim i As Long
'loop to match the result
For i = 0 To TaskN - 1
 'judge if the param is equal
 If TaskSt(i).Status = 2 And TaskSt(i).BeginPos = BeginPos And TaskSt(i).EndPos Then
 'found a valid task
  'copy the result
  TaskSt(i).Result = Result
  'update the status
  TaskSt(i).Status = 3
  'refresh the listbox
  Call RefreshTaskStList(i)
  'add to log
  AddLog "任务" + CStr(i) + "已收到结果"
  'exit the sub
  Exit Sub
 End If
Next i
'no match task is found
'add to log
AddLog "结果非法，未被接受"
End Sub

Public Function AllFinished() As Boolean
Rem judge if all task is finished

Dim i As Long
'loop to check all task
For i = 0 To TaskN - 1
 'judge if the task is finished
 If TaskSt(i).Status <> 3 Then
 'the task is not finished
  'set return value
  AllFinished = False
  'jump out function
  Exit Function
 End If
Next i
'all task is finished
'set return value
AllFinished = True
End Function

Public Sub DisplayResult()
Rem combine&display the result
Dim i As Long, s As String
Dim fn As Long
'set string value
s = "Assembled the result at " + CStr(Now) + vbCrLf
s = "Result from " + CStr(TaskSt(0).BeginPos) + " to " + CStr(TaskSt(TaskN - 1).EndPos) + " :" + vbCrLf
'loop each task
For i = 0 To TaskN - 1
 'add result to string
 s = s + TaskSt(i).Result
Next i
'write string to file
fn = FreeFile
Open "result.txt" For Output As fn
 Print #fn, s
Close #fn
'show message to user
MsgBox "所有任务完成，结果保存在result.txt中"
'Form1.GenCommand.Enabled = True
End Sub

Public Sub GenTask(BeginN, EndN, CountN, TimeOut)
Rem generate the task

Dim i As Long, j As Long, k As Long
'compute task length
k = Int((EndN - BeginN + 1) / CountN): j = BeginN
'set timeout
MAXMINUTE = TimeOut
'loop to generate task data
For i = 1 To CountN - 1
 'Begin position
 TaskSt(TaskN).BeginPos = j
 'End position
 TaskSt(TaskN).EndPos = j + k - 1
 'Set status to ready
 TaskSt(TaskN).Status = 1
 'Clear result
 TaskSt(TaskN).Result = ""
 'Set begin time
 TaskSt(TaskN).BeginTime = Now
 'compute next begin position
 j = j + k
 'Form1.TaskStList.AddItem GetTaskStString(TaskN)
 'inc task number
 TaskN = TaskN + 1
Next i

'special process to last task
'Begin position
TaskSt(TaskN).BeginPos = j
'End position
TaskSt(TaskN).EndPos = EndN
'Set status to ready
TaskSt(TaskN).Status = 1
'Clear result
TaskSt(TaskN).Result = ""
'Set begin time
TaskSt(TaskN).BeginTime = Now
'Form1.TaskStList.AddItem GetTaskStString(TaskN)
'inc task number
TaskN = TaskN + 1
'add to log
AddLog "任务已生成"
End Sub

Public Sub InitTaskStList()
Rem Iinitialize task status listbox

Dim i As Long
'Clear listbox
Form1.TaskStList.Clear
'loop to display each item
For i = 0 To TaskN - 1
 'add string to listbox
 Form1.TaskStList.AddItem GetTaskStString(i)
Next i
End Sub

Public Sub ReadFromMDB()
Rem read data from datanase

Dim constr As String, rsstr As String
Dim rs As New ADODB.Recordset
Dim n As Long, i As Long, ID As Long
On Error GoTo err
'
'NOTE
'
'
'connection string
constr = "DRIVER={Microsoft Access Driver (*.mdb)};DBQ=data.mdb;"
'set connection string
MDBCon.ConnectionString = constr
'open connection object
MDBCon.Open
're string
rsstr = "Select * from Global"
'resume when error
On Error Resume Next
'execute the command
Set rs = MDBCon.Execute(rsstr)
'rs.Open rsstr, MDBCon, adOpenDynamic, adLockReadOnly
'copy task number from database
TaskN = CLng(rs("TaskN"))
'copy timeout from database
MAXMINUTE = CLng(rs("MAXMINUTE"))
'copy listen port from database, and diaplay it
Form1.ListenText.Text = CStr(rs("Port"))
'close rs
Set rs = Nothing
'check valid
If TaskN > MAXTASKN Then
'invalid
 'set to zero
 TaskN = 0
 'add to log
 AddLog "数据库数据异常"
 'jump out sub
 Exit Sub
End If
'loop to clear task status
For i = 0 To TaskN - 1
 'set to invalid
 TaskSt(i).Status = 0
Next i

'set rsstr
rsstr = "Select * from Task"
'execute it
Set rs = MDBCon.Execute(rsstr)
'loop to read each item from database
While Not (rs.EOF Or rs.BOF)
 'convert to long
 ID = CLng(rs("ID"))
 'convert to long
 TaskSt(ID).BeginPos = CLng(rs("BeginPos"))
 'convert to long
 TaskSt(ID).EndPos = CLng(rs("EndPos"))
 'convert to string
 TaskSt(ID).Result = CStr(rs("Result"))
 'convert to data
 TaskSt(ID).BeginTime = CDate(rs("BeginTime"))
 'convert to long
 TaskSt(ID).Status = CLng(rs("Status"))
 'next item
 rs.MoveNext
Wend
'close rs
Set rs = Nothing
'loop to check valid
For i = 0 To TaskN - 1
 'judge if invalid
 If TaskSt(i).Status = 0 Then
 'invalid
  'zero task number
  TaskN = 0
  'add to log
  AddLog "数据库数据异常"
  'jump out
  Exit Sub
 End If
Next i

Exit Sub

err:
'open database error
'add to log
AddLog "数据库不存在或损坏，错误描述：" + MDBCon.Errors(0)
End Sub

Public Sub SavetoMDB()
Rem write to database

Dim rsstr As String
Dim rs As New ADODB.Recordset
Dim n As Long, i As Long, ID As Long
'write global value
'set rs string
rsstr = "Select * from Global"
'execute command and update recordset
rs.Open rsstr, MDBCon, adOpenDynamic, adLockOptimistic
'task number
rs("Taskn") = TaskN
'time out
rs("MAXMINUTE") = MAXMINUTE
'listen port
rs("Port") = CInt(Form1.ListenText.Text)
'flush
rs.Update
'close rs
Set rs = Nothing

'delete all task data
MDBCon.Execute ("delete * from Task")
'add task data
'set rs string
rsstr = "Select * from Task"
'open rs
rs.Open rsstr, MDBCon, adOpenDynamic, adLockOptimistic
'loop to write each task data
For i = 0 To TaskN - 1
 rs.AddNew Array("ID", "BeginPos", "EndPos", "BeginTime", "Status", "Result"), Array(i, TaskSt(i).BeginPos, TaskSt(i).EndPos, TaskSt(i).BeginTime, TaskSt(i).Status, TaskSt(i).Result)
 'flush
 rs.Update
Next i
'close rs
Set rs = Nothing

End Sub

Private Function TaskAva(ID As Long) As Boolean
Rem return is task availiable

'judge if task is unassigned
If TaskSt(ID).Status = 1 Then
'unassigned
 'set return value
 TaskAva = True
 'jump out
 Exit Function
End If
'judge if timeout
If TaskSt(ID).Status = 2 And DateDiff("n", TaskSt(ID).BeginTime, Now) > MAXMINUTE Then
'timeout, reassign
 'reset to unassigned
 TaskSt(ID).Status = 1
 'set return value
 TaskAva = True
 'add to log
 AddLog "任务" + CStr(ID) + "完成时间超时，被重置"
 'jump out
 Exit Function
End If
'set return value
TaskAva = False
End Function