old vb6 prog stopped working

Question

Hello,

I know big blocks of code aren't loved much but the below piece of code is a program soneone that left long before i started wrote in VB6. This program worked until yesterday, when it suddenly decided to stop working.

The program runs as a job in SQL and no one knows how SQL finds it. We where able to relocate the original code and by looking at the code i was able to locate the problem in the SendMailsortControls() function. It does not send an email nor does it update the database. although most are mailsorted 0 the ones that are 1 never get emailed.

Now, i have looked through this code but this is my first time in vb6, so i was wondering if there are any people that could see where this code could start failing (seeing as how it has worked for 2-3 years till yesterday).

I know this question is most likely vague but if you even have a vague idea i'd apreciate it.

EDIT i should have added that the program doesn't crash, it does all its tasks until this part and then keeps hanging (infinite loop like). I have also added the function that gets called before the SendMailsortControls() and uses very similar code (unless it start hanging after updating the database update, but that seems very unlikely to me)

Thank you for reading

Andy

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 = "[email protected]"
        .FromDisplayName = "Admin"
            .Recipient = Left(rcsOutput.Fields("InputFilename").Value, 3) & "[email protected]"
            .CcRecipient = "[email protected]"
        .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

---

Function that gets excecuted before the SendMailsortControls() 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 = "[email protected]"
        .FromDisplayName = "Admin"
            .Recipient = Left(rcsOutput.Fields("InputFilename").Value, 3) & "[email protected]"
            .CcRecipient = "[email protected]"
        .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

Answer 1

EDIT: the problem was the next bit of code. for some reason, there was no line file anymore so it couldn't attach it to the email, causing it to hang. Thanks again to all that helped and i'm happy that i finally got the full answer.

.Attachment = rcsOutput.Fields("MailsortControlPath").Value & "control" & ";" & _
        rcsOutput.Fields("MailsortControlPath").Value & "line"

old post

---

select * from EmtexOutput where EmailedControls = 0 and Mailsorted = 1

it did not take into account that the job had failed and that the results that where returned could not find the attaachments. For some reason the app kept waiting forever though so i am still wondering how that came, but by manually changing EmailedControls to True for all previously failed jobs the app works again.

I would prefer to change the app but the policy is that old vb6 apps will be rewrote into .net and i can agree that the 1614 lines of code need more then some bugfixes.

Thank you for the replies, they helped me narrow down the search. if you know why it kept hanging though, please let me know.