перестала работать старая прога vb6 - PullRequest
Новая
       0

перестала работать старая прога vb6

0 голосов
/ 12 октября 2010

Я знаю, что большие блоки кода не очень-то любят, но фрагмент кода ниже - программа, вышедшая задолго до того, как я начал писать в VB6. Эта программа работала до вчерашнего дня, когда вдруг решила перестать работать.

Программа работает как задание на SQL, и никто не знает, как его находит SQL. Мы смогли переместить исходный код, и, посмотрев на код, я смог найти проблему в функции SendMailsortControls (). Он не отправляет электронное письмо и не обновляет базу данных. хотя большинство из них рассылаются по почте 0, те, которые равны 1, никогда не получают по электронной почте.

Теперь, я просмотрел этот код, но я впервые в vb6, поэтому мне было интересно, есть ли люди, которые могли бы увидеть, где этот код может начать давать сбой (видя, как он работал в течение 2-3 лет до вчерашнего дня).

Я знаю, что этот вопрос, скорее всего, неопределенный, но если у вас даже есть смутное представление, я бы оценил его.

РЕДАКТИРОВАТЬ Я должен был добавить, что программа не падает, она выполняет все свои задачи до этой части, а затем продолжает зависать (как бесконечный цикл). Я также добавил функцию, которая вызывается перед SendMailsortControls () и использует очень похожий код (если только он не начинает зависать после обновления обновления базы данных, но мне это кажется маловероятным)

Спасибо, что прочитали

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 = "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

Функция, выполняемая перед функцией SendMailsortControls () 

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

1 Ответ

0 голосов
/ 12 октября 2010

РЕДАКТИРОВАТЬ: проблема была в следующем бите кода. по какой-то причине больше не было файла строки, поэтому он не мог прикрепить его к электронному письму, что привело к зависанию. Еще раз спасибо всем, кто помог, и я рад, что наконец получил полный ответ. 

.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 строк кода требуется больше, чем исправлений.

Спасибо за ответы, они помогли мне сузить поиск. если вы знаете, почему он продолжал висеть, пожалуйста, дайте мне знать.

Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

Нет похожих вопросов

...