MQSeries.net :: View topic - Unable to clear mq after browsing from it usingVB program

zigeesha · Posted: Tue Apr 12, 2005 9:11 am Post subject:

Hi all,

I am using a VB program which first reads from a queue(browses) and then after done tries to clear the queue...The problem i have at hand is when the VB program is triggered the clear queue part doesn't work .but when the program is kicked off manually it works..

this is the chunk of code which performs the operation

---------------------------------------------------------------------------
Public Sub GetFile(Optional ByVal sGetOption As String, Optional ByVal sQueueOpenOption As String = "BROWSE")

Const MethodName As String = "GetFile"
Dim bUnknownDataFlag As Boolean
Dim lngBufLen As Long 'size of get buffer
Dim lngMessLen As Long 'actual size of returned message
Dim strFilename As String 'File name created by PrepareFileName routine
Dim intSetVersion As Integer 'Set version, used to create unique file name
Dim blnMessageEnd As Boolean 'The flag to indicate end of Queue, or to stop processing
Dim FIRST_HEADER_RECIEVED_FLAG As Boolean
Dim blnDisconnected As Boolean
Dim ctr As Integer
Dim lref As Long
Dim sCmd As String
Dim sTemp As String
Dim strLog As String 'variable to hold string to be logged to MQLog.txt
'MQLog.txt contains headers and trailers of all the

On Error GoTo errHandler

mlngRetryAttemptsMade = 0
bUnknownDataFlag = False
bErrorHandlerEmailSent = False
Set saFileMgrObj = New FileManager

' Counter to indicate total number of MQ Get commands executed
' This counter resets aftter each execution of the getFile method ..
' It is different from the lngMsgsReadFromMQ ctr (which resets for each file get)
mqGetCtr = 0

'Initialized the properties of the class, i.e. set values to either 0 or blank
InitializeProperties

FIRST_HEADER_RECIEVED_FLAG = False
strLastReceivedHeader = "(empty)" 'initialize var, used w/NO_HEADER_ERROR & NO_TRAILER_ERROR
strLastReceivedTrailer = "(empty)" 'initialize var, used w/NO_HEADER_ERROR & NO_TRAILER_ERROR

mlngCurrentDepth = 0
Call OpenLocalQueue
mlngCurrentDepth = moLocalQueue.CurrentDepth

If mlngCurrentDepth = 0 Then
strLog = "ERROR - EMPTY MQ QUEUE " + mstrLocalQueue + vbCrLf
mobjErrObject.AddToLogFile strLog, mstrINILogFileName
SendMail strLog
#If DEBUGMODE Then
Position1:
strLog = "DEBUG: MQ_SeriesCOM.GetFile - About to GoTo ExitSub, from Position 1" + vbCrLf
mobjErrObject.AddToLogFile strLog, mstrINILogFileName
#End If
GoTo ExitSub
End If

'Initialize message & record counters
lngMsgsReadFromMQ = 0
lngRecsReadFromMQ = 0
lngRecsWrittenToFile = 0
lngRecsInBuffer = 0

'Initialize boolean Header and Trailer "received" flags
blnHeader = False
blnTrailer = False
strStatusCode = ""
'blnMessageEnd flag is set when loop hits Trailer message, OR an Error occurred

Do While blnMessageEnd = False And mqGetCtr < mlngCurrentDepth
If mqGetCtr >= mlngCurrentDepth Then
#If DEBUGMODE Then
Position2:
strLog = "DEBUG: MQ_SeriesCOM.GetFile - About to Exit Do Loop, from Position 2" + vbCrLf
mobjErrObject.AddToLogFile strLog, mstrINILogFileName
'GoTo ExitSub
#End If
Exit Do
Else
Set moGetOptions = moMQSession.AccessGetMessageOptions()
If mqGetCtr = 0 Then
moGetOptions.Options = MQ.MQGMO_BROWSE_FIRST
Else
moGetOptions.Options = MQ.MQGMO_BROWSE_NEXT
End If
'moLocalQueue.Get moLocalMsg, moGetOptions
If Not getMessage() Then
#If DEBUGMODE Then
Position3:
strLog = "DEBUG: MQ_SeriesCOM.GetFile - About to GoTo ExitSub, from Position 3" + vbCrLf
mobjErrObject.AddToLogFile strLog, mstrINILogFileName
#End If
GoTo ExitSub
End If

moLocalMsg.MessageId = ""
moLocalMsg.CorrelationId = ""
strBuffer = moLocalMsg.MessageData
lngBufLen = moLocalMsg.MessageLength
mqGetCtr = mqGetCtr + 1
lngMsgsReadFromMQ = lngMsgsReadFromMQ + 1
'After each MQGET call from here on increments message counter
End If

mlngCompletionCode = moLocalQueue.CompletionCode
mlngReasonCode = moLocalQueue.ReasonCode

If mlngCompletionCode = MQCC_WARNING Then

strLog = strLog + "Warning: " + CStr(mlngReasonCode) + vbCrLf + "MsgId: " _
+ CStr(moLocalMsg.MessageIdHex) + vbCrLf
mobjErrObject.AddToLogFile strLog, mstrINILogFileName

ElseIf mlngCompletionCode = MQCC_OK Then

If Left$(strBuffer, 6) = mstrHEADER Then

If bUnknownDataFlag = True Then
' Now report for this problem as a warning or a error and stop.
' No more unknown data, we again have a valid header
' proposed message - Unknown data encountered followed by a header record.
sTemp = NO_HEADER_OR_TRAILER_ERROR + " in MQSeries.GetFile" + vbCrLf _
+ "Last Received Trailer: " + strLastReceivedTrailer + vbCrLf _
+ "Last Received Header: " + strLastReceivedHeader
SendMail sTemp
bUnknownDataFlag = False
#If DEBUGMODE Then
Position4:
strLog = "DEBUG: MQ_SeriesCOM.GetFile - About to GoTo ExitSub, from Position 4" + vbCrLf
mobjErrObject.AddToLogFile strLog, mstrINILogFileName
#End If
GoTo ExitSub
End If

'Now that we have a header, we are no longer dealing with unknown data.
bUnknownDataFlag = False

'Debug.Print strBuffer, strFilename, mqGetCtr
FIRST_HEADER_RECIEVED_FLAG = True
If Not ValidateHeaderMessage(strFilename, intSetVersion) Then
#If DEBUGMODE Then
Position5:
strLog = "DEBUG: MQ_SeriesCOM.GetFile - About to GoTo ExitSub, from Position 5" + vbCrLf
mobjErrObject.AddToLogFile strLog, mstrINILogFileName
#End If
GoTo ExitSub
End If
'Debug.Print strBuffer, strFilename

ElseIf Left$(strBuffer, 6) = mstrTRAILER Then

If bUnknownDataFlag = True Then
' ' Now report for this problem as a warning or a error and stop.
' ' proposed message - Unknown data encountered followed by a trailer record..
' sTemp = NO_HEADER_OR_TRAILER_ERROR & " in MQSeries.GetFile"
' sTemp = sTemp & vbCrLf & "Last Received Trailer: " & strLastReceivedTrailer
' sTemp = sTemp & vbCrLf & "Last Received Header: " & strLastReceivedHeader
' SendMail sTemp
bUnknownDataFlag = False
' GoTo ExitSub
End If

If Not ValidateTrailerMessage(strFilename, intSetVersion) Then
#If DEBUGMODE Then
Position6:
strLog = "DEBUG: MQ_SeriesCOM.GetFile - About to GoTo ExitSub, from Position 6" + vbCrLf
mobjErrObject.AddToLogFile strLog, mstrINILogFileName
#End If
GoTo ExitSub
End If
If sGetOption = "ONE" Then blnMessageEnd = True

Else
If FIRST_HEADER_RECIEVED_FLAG = False Then
If blnHeader = False Then
sTemp = NO_HEADER_IN_FIRSTFILE_ERROR + " in MQSeries.GetFile" + vbCrLf _
+ "Last Received Trailer: " + strLastReceivedTrailer + vbCrLf _
+ "Last Received Header: " + strLastReceivedHeader
SendMail sTemp
#If DEBUGMODE Then
Position7:
strLog = "DEBUG: MQ_SeriesCOM.GetFile - About to GoTo ExitSub, from Position 7" + vbCrLf
mobjErrObject.AddToLogFile strLog, mstrINILogFileName
#End If
GoTo ExitSub
End If
End If

MESSAGE_TYPE = Trim$(UCase$(Mid$(strBuffer, 1, 7)))
mstrBuffer = ""
mstrNewBuffer = ""

If saFile Is Nothing And blnHeader = False Then
' This means that we got data message without recieving a header message.
' Unknown File , this will be closed when it hits the next trailer.
Set saFile = saFileMgrObj.CreateBinaryFile(mstrDestinationDirectory + "\Unknown_" + _
DatePart("yyyy", Now) + "_" + Right$("0" + DatePart("m", Now), 2) + "_" _
+ Right$("0" + DatePart("d", Now), 2) + "_" + ".txt")
bUnknownDataFlag = True
End If

Select Case MESSAGE_TYPE
Case "AHMACCT"
Call GetFunc.Save_Acct_Buffer
Case "AHMNAME"
Call GetFunc.Save_Name_Buffer
Case "AHMSTML"
Call GetFunc.Save_STML_Buffer
Case "AHMSTMR"
Call GetFunc.Save_STMR_Buffer
Case "AHMHIST", "AHMHIS1", "AHMHIS2", "AHMHIS3", "AHMHIS4", "AHMHIS5", "AHMHIS6", "AHMHIS7", "AHMHIS8", "AHMHIS9"
Call GetFunc.Save_HIST_Buffer
Case "AHMASST"
Call GetFunc.Save_ASST_Buffer
Case "AHMPYOF"
Call GetFunc.Save_PYOF_Buffer
Case Else
mstrNewBuffer = strBuffer
End Select

'Write out the remaining part of the buffer that is not already written
If Not (saFile Is Nothing) Then
saFile.Write (StrConv(mstrNewBuffer, vbFromUnicode))
lngRecsWrittenToFile = lngRecsWrittenToFile + lngRecsInBuffer
lngRecsInBuffer = 0
End If
End If

Else
strLog = "Error in getting following message: " + vbCrLf + "MsgId: " _
+ CStr(moLocalMsg.MessageIdHex) + "; Completion Code: " _
+ CStr(mlngCompletionCode) + "; Reason: " + CStr(mlngReasonCode) + vbCrLf
mobjErrObject.AddToLogFile strLog, mstrINILogFileName
End If

Loop

If bUnknownDataFlag = True Then
' End of queue encountered after unknown data
' Now report for this problem as a warning or a error and stop.
' proposed message - Unknown data encountered that neither had a header or trailer at the end of the queue
sTemp = NO_HEADER_OR_TRAILER_ERROR + " at end of queue in MQSeries.GetFile" + vbCrLf _
+ "Last Received Trailer: " + strLastReceivedTrailer + vbCrLf + "Last Received Header: " _
+ strLastReceivedHeader
SendMail sTemp
bUnknownDataFlag = False
#If DEBUGMODE Then
Position8:
strLog = "DEBUG: MQ_SeriesCOM.GetFile - About to GoTo ExitSub, from Position 8" + vbCrLf
mobjErrObject.AddToLogFile strLog, mstrINILogFileName
#End If
GoTo ExitSub
End If

' Check for NO_TRAILER_ERROR Condition
If (blnHeader) And (Not blnTrailer) Then

sTemp = NO_TRAILER_ERROR + " in MQSeries.GetFile." + vbCrLf + "Last Received Header: " _
+ strLastReceivedHeader + vbCrLf + "Last Received Trailer: " + strLastReceivedTrailer
SendMail sTemp

strStatusCode = "I"

'Execute SP hfsp_MQSeries to Write to MQJobControl table
'if Filename does NOT exist - Do not write...
If (Len(Trim$(strFilename)) > 0) Or (Not IsNull(strFilename)) Then
WriteToMQJobControlTable strFilename, intSetVersion, strStatusCode, _
lngRecsReadFromMQ, lngMsgsReadFromMQ, lngRecsWrittenToFile, mstrLocalQueue
End If
End If ''NO_TRAILER_ERROR Condition

'Write to trigger table ONLY if StatusCode <> "I" ( = Incomplete )
' sTemp = "DEBUG: MQSeries.GetFile - strStatusCode = '" + strStatusCode + "'"
If (strStatusCode <> "I") Then
#If DEBUGMODE Then
sTemp = "DEBUG: About to call MQSeriesTrigger from MQSeries.GetFile"
mobjErrObject.AddToLogFile sTemp, mstrINILogFileName
#End If
' Debug.Print sTemp
Call MQSeriesTrigger(Mid$(strFilename, 9, 10))
End If

ExitSub:
'**** FOR TESTING PURPOSES: Set this to a constant.
'**** Should be read in from INI file.
Const c_intRetries = 10

For ctr = 1 To c_intRetries
blnDisconnected = DisconnectFromMQ()
If blnDisconnected = True Then
If UCase$(sQueueOpenOption) <> "BROWSE" Then

sCmd = App.Path + "\ClearQueue.bat"
mobjErrObject.AddToLogFile "Executing Clear Queue batch file '" + sCmd + "' now.", mstrINILogFileName
lref = Shell(sCmd, vbHide)

If lref > 0 Then
'MsgBox "Waiting for process to end"
WaitForProcessToEnd (lref)
'MsgBox "batch file process has ended..."
#If DEBUGMODE Then
Else
strLog = "DEBUG: Shell() command returned " + CStr(lref)
mobjErrObject.AddToLogFile strLog, mstrINILogFileName
#End If
End If
' After batch file executes, rename the error file with the date time hour second postfix
' After the batch file has been executed, check queue if it has been emptied..
' if not empty send error message by mail and log details if any.
Call ConnectToMQ("")
Call OpenLocalQueue
If moLocalQueue.CurrentDepth = 0 Then
mobjErrObject.AddToLogFile "MQ Queue " + mstrLocalQueue + " cleared.", mstrINILogFileName
'Make sure we terminate any lingering connections.
DisconnectFromMQ
'Success: Don't retry again.
Exit For
Else
If ctr >= c_intRetries Then
strLog = "ERROR - ClearQueue batch file failed to empty the Queue." + vbCrLf _
+ "Queue " + mstrLocalQueue + " must be cleared manually before sending the next set of messages." + vbCrLf _
+ "Current Queue Depth = " + CStr(moLocalQueue.CurrentDepth)
mobjErrObject.AddToLogFile strLog, mstrINILogFileName
SendMail strLog
End If
'Make sure we terminate any lingering connections.
DisconnectFromMQ
End If
Else
mobjErrObject.AddToLogFile "BROWSE MODE : Clear Queue batch file was not called.", mstrINILogFileName
'If we are not trying to clear the queue, there's no need to retry.
Exit For
End If
End If

'If we did NOT diconnect successfully, we will go back to the top of the loop and retry.
'First, let's pause for a little bit to allow the queue to quit being busy.
DoEvents
SleepSeconds 60

#If DEBUGMODE Then
If ctr < c_intRetries Then
'Log the retry attempt.
strLog = "DEBUG: About to retry (#" + CStr(ctr + 1) + ") disconnecting from MQ - MQSeriesCOM.GetFile."
mobjErrObject.AddToLogFile strLog, mstrINILogFileName
End If
#End If

Next ctr

Exit Sub

errHandler:

gsErrSource = Err.Source + " " + MethodName + " - " + mcOBJECT_NAME
gsErrDescription = Err.Description
glErrNumber = Err.Number
strMsg = "HF MQ ERROR: " + CStr(glErrNumber) + " " + gsErrDescription + " " + gsErrSource
LogError m_sAppID, m_sAppTitle, Err, , , m_sProgID, , "MQSeries.GetFile"

SendMail strMsg
bErrorHandlerEmailSent = True
Err.Raise glErrNumber, gsErrSource, gsErrDescription
'Resume 0
End Sub
Private Function getMessage() As Boolean

Const MethodName As String = "GetMessage"
On Error GoTo errHandler

getMessage = True

Dim bFlagNavigateMQ_To_LastRead As Boolean
bFlagNavigateMQ_To_LastRead = False

Dim bFlagRetry As Boolean
bFlagRetry = True
moLocalQueue.Get moLocalMsg, moGetOptions
bFlagRetry = False

mstrLastReadMessageID = moLocalMsg.MessageIdHex

If bFlagNavigateMQ_To_LastRead = True Then
bFlagRetry = True
Call NavigateMQ_To_LastRead(bFlagRetry)
bFlagRetry = False
End If

Exit Function
errHandler:

If bFlagRetry = True Then
mlngCompletionCode = moMQSession.CompletionCode
mlngReasonCode = moMQSession.ReasonCode
If InStr(mStrRetryErrorCodes, CStr(mlngReasonCode)) Then
' pt code to wait for a minute - to do
Call ConnectToMQ("")
Call OpenLocalQueue
If bFlagNavigateMQ_To_LastRead = True Then
' Already in navigate mode, error now has occured during navigating back.
' The error occured below in the function "NavigateMQ_To_LastRead"
' This function does not have error handling since the whole function will be re-executed.
Resume 0
Else
bFlagNavigateMQ_To_LastRead = True
Resume Next
End If
End If
End If

getMessage = False

gsErrSource = Err.Source + " " + MethodName + " - " + mcOBJECT_NAME
gsErrDescription = Err.Description + " Error " & Err
glErrNumber = Err.Number

strMsg = "HF MQ ERROR: " + CStr(glErrNumber) + " " + gsErrDescription + " " + gsErrSource
LogError m_sAppID, m_sAppTitle, Err, , , m_sProgID, , "MQSeries.GetMessage"
SendMail strMsg
bErrorHandlerEmailSent = True
Err.Raise glErrNumber, gsErrSource, gsErrDescription

End Function

Can anyone suggest ,i have looked at the log files ,I have run the qm in the trace mode ,the error
"Clear the queue manually before trying to put another message