我知道大块的代码不是很受欢迎，但下面的代码是一个程序soneone，在我开始用VB6编写之前很久就离开了。这项计划一直持续到昨天，当时它突然决定停止工作。
该程序在SQL中作为一个作业运行，没有人知道SQL如何找到它。我们能够重新定位原始代码并通过查看代码我能够在SendMailsortControls（）函数中找到问题。它不会发送电子邮件，也不会更新数据库。虽然大多数是mailsorted 0，但是1从未通过电子邮件发送过邮件。
现在，我已经查看了这段代码，但这是我第一次在vb6中，所以我想知道是否有人能够看到这段代码可以开始失败的地方（看看它是如何工作2 - 3年直到昨天。）
我知道这个问题很可能含糊不清，但如果你有一个含糊不清的想法，我会对它进行预测。
编辑我应该补充一点，程序不会崩溃，它会完成所有任务，直到这部分然后继续挂起（无限循环）。我还添加了在SendMailsortControls（）之前调用的函数，并使用非常相似的代码（除非它在更新数据库更新后开始挂起，但这对我来说似乎不太可能）
感谢您阅读
安迪
Private Function SendMailsortControls() As Boolean
On Error GoTo SendMailsortControlsError
Dim conOutput As ADODB.Connection
Dim cmdOutput As ADODB.Command
Dim rcsOutput As ADODB.Recordset
Dim cmdUpdate As ADODB.Command
Dim fsoMSFileSys As FileSystemObject
Dim fsofile As File
Dim TNTFile As String
Set conOutput = New ADODB.Connection
conOutput.ConnectionTimeout = 600
Set cmdOutput = New ADODB.Command
cmdOutput.CommandTimeout = 600
Set cmdUpdate = New ADODB.Command
cmdUpdate.CommandTimeout = 600
'conOutput.Open "Driver={SQL Server}; Server=GBADSRVSQL01; Database=EmtexEmails; Trusted_Connection=yes;"
conOutput.Open "Driver={SQL Server}; Server=GBADSRVSQL01; Database=EmtexEmails; Trusted_Connection=yes;"
Set cmdOutput.ActiveConnection = conOutput
Set cmdUpdate.ActiveConnection = conOutput
Set rcsOutput = New ADODB.Recordset
cmdOutput.CommandText = "select * from EmtexOutput where EmailedControls = 0 and Mailsorted = 1"
Set rcsOutput = cmdOutput.Execute
Set fsoMSFileSys = CreateObject("Scripting.FileSystemObject")
Do Until rcsOutput.EOF
With poSendMail
.Delimiter = ";"
'.SMTPHost = "linus5.lexicon.co.uk"
.SMTPHost = "172.20.2.26"
.From = "Admin@adarelexicon.co.uk"
.FromDisplayName = "Admin"
.Recipient = Left(rcsOutput.Fields("InputFilename").Value, 3) & "Mailsorts@adarelexicon.com"
.CcRecipient = "MCMSSupport@adarelexicon.com"
.RecipientDisplayName = Left(rcsOutput.Fields("InputFilename").Value, 3)
.Subject = "Emtex - " & Left(rcsOutput.Fields("InputFilename").Value, 3) & ": Daily Mailsort Controls " & rcsOutput.Fields("InputFilename").Value
.Priority = HIGH_PRIORITY
.message = "Mailsort control files for:" & _
vbCrLf & vbCrLf & "Emtex Job No: " & rcsOutput.Fields("EmtexJob").Value & _
" (mailsort Emtex Job no): " & rcsOutput.Fields("MSEmtexJob").Value & vbCrLf & vbCrLf & _
"Customer Filename: " & rcsOutput.Fields("CustomerFilename").Value & vbCrLf & _
"Route: " & rcsOutput.Fields("ProcessingRoute").Value & vbCrLf & vbCrLf & _
"Mailsort Type: " & rcsOutput.Fields("MailType").Value & vbCrLf & vbCrLf
.Attachment = rcsOutput.Fields("MailsortControlPath").Value & "control" & ";" & _
rcsOutput.Fields("MailsortControlPath").Value & "line"
TNTFile = Dir(rcsOutput.Fields("MailsortControlPath").Value & "*.tnt")
If Len(TNTFile) > 0 Then
.Attachment = .Attachment & ";" & _
rcsOutput.Fields("MailsortControlPath").Value & TNTFile
End If
.Send
.Attachment = ""
End With
'TNT EMAIL IF
cmdUpdate.CommandText = "update EmtexOutput set EmailedControls = 1 where counter = " & rcsOutput.Fields("Counter").Value
cmdUpdate.Execute
rcsOutput.MoveNext
Loop
Set conOutput = Nothing
Set cmdOutput = Nothing
Set rcsOutput = Nothing
Set cmdUpdate = Nothing
Exit Function
SendMailsortControlsError:
Call ErrLog(Err.Number, Err.Description, "Routine: SendMailsortControls")
Err.Raise 2700, "SendMailsortControls", Err.Description
Set conOutput = Nothing
Set cmdOutput = Nothing
Set rcsOutput = Nothing
Set cmdUpdate = Nothing
Exit Function
End Function
Private Sub OutputEmails()
On Error GoTo OutputEmailsError
Dim conOutput As ADODB.Connection
Dim cmdOutput As ADODB.Command
Dim rcsOutput As ADODB.Recordset
Dim cmdUpdate As ADODB.Command
Set conOutput = New ADODB.Connection
conOutput.ConnectionTimeout = 600
Set cmdOutput = New ADODB.Command
cmdOutput.CommandTimeout = 600
Set cmdUpdate = New ADODB.Command
cmdUpdate.CommandTimeout = 600
'conOutput.Open "Driver={SQL Server}; Server=GBADSRVSQL01; Database=EmtexEmails; Trusted_Connection=yes;"
conOutput.Open "Driver={SQL Server}; Server=GBADSRVSQL01; Database=EmtexEmails; Trusted_Connection=yes;"
Set cmdOutput.ActiveConnection = conOutput
Set cmdUpdate.ActiveConnection = conOutput
Set rcsOutput = New ADODB.Recordset
cmdOutput.CommandText = "select * from EmtexOutput where EmailSent = 0"
Set rcsOutput = cmdOutput.Execute
Do Until rcsOutput.EOF
With poSendMail
.Delimiter = ";"
'.SMTPHost = "linus5.lexicon.co.uk"
.SMTPHost = "172.20.2.26"
.From = "Admin@adarelexicon.co.uk"
.FromDisplayName = "Admin"
.Recipient = Left(rcsOutput.Fields("InputFilename").Value, 3) & "Output@adarelexicon.com"
.CcRecipient = "MCMSSupport@adarelexicon.com"
.RecipientDisplayName = Left(rcsOutput.Fields("InputFilename").Value, 3)
.Subject = "Emtex: " & rcsOutput.Fields("InputFilename").Value
.message = vbCrLf & "Emtex Job No: " & rcsOutput.Fields("EmtexJob").Value & vbCrLf & vbCrLf & _
"Customer Filename: " & rcsOutput.Fields("CustomerFilename").Value & vbCrLf & _
"Route: " & rcsOutput.Fields("ProcessingRoute").Value & vbCrLf & vbCrLf & _
"Pack Description: " & rcsOutput.Fields("PackDescription").Value & vbCrLf & vbCrLf & _
"Mail Type: " & rcsOutput.Fields("MailType").Value & vbCrLf & vbCrLf
If Len(rcsOutput.Fields("TNTListingFile").Value) > 0 Then
.message = .message & "TNT Listing: " & rcsOutput.Fields("TNTListingFile").Value & vbCrLf & vbCrLf
End If
.message = .message & "No of Envelopes: " & rcsOutput.Fields("NoEnvelopes").Value & vbCrLf & _
"No of Pages: " & rcsOutput.Fields("NoPages").Value & vbCrLf & _
"No of Documents: " & rcsOutput.Fields("NoDocuments").Value & vbCrLf & vbCrLf
.message = .message & "Selective Inserts" & vbCrLf & _
"Hopper 1: " & rcsOutput.Fields("NoInsertsHopper1").Value
If CLng(rcsOutput.Fields("NoInsertsHopper1").Value) > 0 Then
.message = .message & String(10 - Len(CStr(rcsOutput.Fields("NoInsertsHopper1").Value)), " ") & rcsOutput.Fields("InsertCodeHopper1").Value
End If
.message = .message & vbCrLf & "Hopper 2: " & rcsOutput.Fields("NoInsertsHopper2").Value
If CLng(rcsOutput.Fields("NoInsertsHopper2").Value) > 0 Then
.message = .message & String(10 - Len(CStr(rcsOutput.Fields("NoInsertsHopper2").Value)), " ") & rcsOutput.Fields("InsertCodeHopper2").Value
End If
.message = .message & vbCrLf & "Hopper 3: " & rcsOutput.Fields("NoInsertsHopper3").Value
If CLng(rcsOutput.Fields("NoInsertsHopper3").Value) > 0 Then
.message = .message & String(10 - Len(CStr(rcsOutput.Fields("NoInsertsHopper3").Value)), " ") & rcsOutput.Fields("InsertCodeHopper3").Value
End If
.message = .message & vbCrLf & "Hopper 4: " & rcsOutput.Fields("NoInsertsHopper4").Value
If CLng(rcsOutput.Fields("NoInsertsHopper4").Value) > 0 Then
.message = .message & String(10 - Len(CStr(rcsOutput.Fields("NoInsertsHopper4").Value)), " ") & rcsOutput.Fields("InsertCodeHopper4").Value
End If
.message = .message & vbCrLf & "Hopper 5: " & rcsOutput.Fields("NoInsertsHopper5").Value
If CLng(rcsOutput.Fields("NoInsertsHopper5").Value) > 0 Then
.message = .message & String(10 - Len(CStr(rcsOutput.Fields("NoInsertsHopper5").Value)), " ") & rcsOutput.Fields("InsertCodeHopper5").Value
End If
.message = .message & vbCrLf & "Hopper 6: " & rcsOutput.Fields("NoInsertsHopper6").Value
If CLng(rcsOutput.Fields("NoInsertsHopper6").Value) > 0 Then
.message = .message & String(10 - Len(CStr(rcsOutput.Fields("NoInsertsHopper6").Value)), " ") & rcsOutput.Fields("InsertCodeHopper6").Value
End If
.message = .message & vbCrLf & "Hopper 7: " & rcsOutput.Fields("NoInsertsHopper7").Value
If CLng(rcsOutput.Fields("NoInsertsHopper7").Value) > 0 Then
.message = .message & String(10 - Len(CStr(rcsOutput.Fields("NoInsertsHopper7").Value)), " ") & rcsOutput.Fields("InsertCodeHopper7").Value
End If
.message = .message & vbCrLf & "Hopper 8: " & rcsOutput.Fields("NoInsertsHopper8").Value
If CLng(rcsOutput.Fields("NoInsertsHopper8").Value) > 0 Then
.message = .message & String(10 - Len(CStr(rcsOutput.Fields("NoInsertsHopper8").Value)), " ") & rcsOutput.Fields("InsertCodeHopper8").Value
End If
If Not IsNull(rcsOutput.Fields("StockCountTray1").Value) Then
.message = .message & vbCrLf & vbCrLf & "Tray Stock Usage" & vbCrLf
.message = .message & "Tray 1 Stock " & _
rcsOutput.Fields("StockCodeTray1").Value & ", " & _
rcsOutput.Fields("StockCountTray1").Value & vbCrLf
End If
If Not IsNull(rcsOutput.Fields("StockCountTray2").Value) Then
.message = .message & "Tray 2 Stock " & _
rcsOutput.Fields("StockCodeTray2").Value & ", " & _
rcsOutput.Fields("StockCountTray2").Value & vbCrLf
.message = .message & "Tray 3 Stock " & _
rcsOutput.Fields("StockCodeTray3").Value & ", " & _
rcsOutput.Fields("StockCountTray3").Value & vbCrLf
.message = .message & "Tray 4 Stock " & _
rcsOutput.Fields("StockCodeTray4").Value & ", " & _
rcsOutput.Fields("StockCountTray4").Value & vbCrLf
.message = .message & "Tray 5 Stock " & _
rcsOutput.Fields("StockCodeTray5").Value & ", " & _
rcsOutput.Fields("StockCountTray5").Value & vbCrLf
.message = .message & "Tray 6 Stock " & _
rcsOutput.Fields("StockCodeTray6").Value & ", " & _
rcsOutput.Fields("StockCountTray6").Value & vbCrLf
End If
.Send
End With
cmdUpdate.CommandText = "update EmtexOutput set EmailSent = 1 where counter = " & rcsOutput.Fields("Counter").Value
cmdUpdate.Execute
rcsOutput.MoveNext
Loop
Set conOutput = Nothing
Set cmdOutput = Nothing
Set rcsOutput = Nothing
Set cmdUpdate = Nothing
Exit Sub
OutputEmailsError:
Call ErrLog(Err.Number, Err.Description, "Routine: OutputEmails")
Err.Raise 2600, "OutputEmails", Err.Description
Set conOutput = Nothing
Set cmdOutput = Nothing
Set rcsOutput = Nothing
Set cmdUpdate = Nothing
Exit Sub
End Sub
答案 0 :(得分：0)
.Attachment = rcsOutput.Fields("MailsortControlPath").Value & "control" & ";" & _
rcsOutput.Fields("MailsortControlPath").Value & "line"
select * from EmtexOutput where EmailedControls = 0 and Mailsorted = 1
它没有考虑到工作失败，而且返回的结果无法找到工作。由于某种原因，应用程序一直在等待，所以我仍然想知道它是如何发生的，但是通过手动将EmailedControls更改为True，以便所有先前失败的作业再次运行。
我更愿意更改应用程序，但政策是旧的vb6应用程序将重写为.net，我同意1614行代码需要更多的一些错误修正。
感谢您的回复，他们帮助我缩小搜索范围。如果你知道为什么它一直挂着，请告诉我。