Multiple Instances of MQ Client Piece Getting Created.

[maheshws]

Hi,
Here is the problem which needs a resolution and any help would be greatly appreciated.
MQClient piece in my application is creating multiple instances on our Windows NT 4.0 Automation Server. It is creating an instance of the client executable for each message it is processing.(These messages are coming from our Integration Server which is again Windows NT 4.0).
Everything was working fine till about a month ago and this problem has come up suddenly. There has been no code change
on the MQ Client Piece. I am attaching the code piece along
with the mail.
Please help me if possible!!!!




Option Explicit

Private Const QManagerName = "" 'default
Private Const QueueName = "ACS.U.TTS.NTASYNCTRANS.A0203"

Private mFileName As String

'API to alter the processes return code
Private Declare Sub ExitProcess Lib "kernel32" (ByVal uExitCode As Long)


'Extracts the value of the named argument. If there isn't a
' value (or the argument is not found) it returns EMPTY. Does
' not handle special characters.
Private Function Extract(ArgName As String, Message As String) As Variant
Dim p1 As Integer
Dim p2 As Integer

p1 = VBA.InStr(UCase$(Message), UCase$(ArgName) & "=&quot
If p1 > 0 Then
p1 = p1 + Len(ArgName) + 1
p2 = VBA.InStr(p1, Message, "&&quot
If p1 = p2 Then
'return Empty
ElseIf p2 > 0 Then
Extract = VBA.Mid$(Message, p1, p2 - p1)
Else
Extract = VBA.Mid$(Message, p1)
End If
End If
End Function

Sub Main()
Dim MQSess As MQAX200.MQSession ' session object
Dim QMgr As MQAX200.MQQueueManager ' queue manager object
Dim Mqueue As MQAX200.MQQueue ' queue object
Dim GetMsg As MQAX200.MQMessage ' message object for get
Dim GetOptions As MQAX200.MQGetMessageOptions ' put message options

Dim Message As String
Dim LogMsg As String
Dim TaskID As Long
Dim UserID As String
Dim ItemUID As String
Dim ComponentName As String
Dim Action As String

Dim doi As W0060901.IUnitOfWorkService
Dim eoi As W0060903.IExternalLogic
Dim NewItem As W0060903.IUnitOfWork
Dim rc As W0060938.ServiceErrCodes
Dim ErrorMsg As String
Dim NoMoreMessages As Boolean

Dim EventType As LogEventTypeConstants

On Error GoTo Abort

mFileName = App.Path & "\" & Format$(Now, "mmdd-hhNNss&quot & "-" & Right$(Format$(Timer - Int(Timer), ".0000&quot, 4) & ".log"

'Create the MQSession object and access the MQQueueManager and (local) MQQueue
Set MQSess = New MQSession

Set QMgr = MQSess.AccessQueueManager(QManagerName)
Set Mqueue = QMgr.AccessQueue( _
QueueName, _
MQOO_OUTPUT Or MQOO_INPUT_AS_Q_DEF)
If Not Mqueue.IsOpen Then
Mqueue.Open
End If

Set GetMsg = MQSess.AccessMessage()
Set GetOptions = MQSess.AccessGetMessageOptions()
GetOptions.Options = GetOptions.Options Or MQGMO_FAIL_IF_QUIESCING _
Or MQGMO_CONVERT
Do
Mqueue.Get GetMsg, GetOptions

'extract the message content
Message = GetMsg.MessageData
LogMsg = "Received message: " & Message & vbNewLine

TaskID = VBA.CLng(Extract("TaskID", Message))
UserID = Extract("UserID", Message)
ItemUID = Extract("ItemUID", Message)
ComponentName = Extract("ComponentName", Message)
Action = Extract("Action", Message)

'check what action to take
EventType = vbLogEventTypeInformation
ErrorMsg = ""

If LCase$(Action) = "markincomplete" Then

'use the data object to mark the automated task incomplete
Set doi = CreateObject("W0060902.CUnitOfWorkService&quot
rc = doi.MarkIncomplete(ErrorMsg, TaskID, ItemUID, "System", "Automation rule: the triggering task was marked incomplete.&quot
If rc = 0 Then
LogMsg = LogMsg & "Task was marked incomplete."
Else
LogMsg = LogMsg & "ErrorMsg: " & ErrorMsg
End If
Set doi = Nothing

Else

'create the component
If ComponentName = "" Then
Set eoi = CreateObject("W0060904.CUnitOfWork&quot
Else
Set eoi = CreateObject(ComponentName)
End If

'execute the external logic, logging any problems which occur
rc = eoi.Execute(UserID, TaskID, ItemUID, ErrorMsg)
If rc = 0 Then
LogMsg = LogMsg & "Automation completed successfully."
If Len(ErrorMsg) > 0 Then
LogMsg = LogMsg & vbNewLine & ErrorMsg
End If
Else
EventType = vbLogEventTypeWarning
LogMsg = LogMsg & _
vbNewLine & "Component: " & ComponentName & _
vbNewLine & " Error: " & ErrorMsg & _
vbNewLine & " Code: " & rc
End If
Set eoi = Nothing

End If
App.LogEvent LogMsg, EventType
Loop Until NoMoreMessages
rc = 0

Done:
'close the queue
If Mqueue Is Nothing Then
Else
If Mqueue.IsOpen Then
Mqueue.Close
'Code added by Sumeet for disconnecting the Que
QMgr.Disconnect
End If
End If

'terminate the objects
Set MQSess = Nothing
Set QMgr = Nothing
Set Mqueue = Nothing
Set GetMsg = Nothing
Set GetOptions = Nothing


'return the exit code
If NoMoreMessages Then
End
Else
ExitProcess rc
End If
Exit Sub


Abort:
If Mqueue Is Nothing Then
Else
'check to see if we ran out of messages
If Mqueue.ReasonCode = MQRC_NO_MSG_AVAILABLE Then
NoMoreMessages = True
Resume Done
End If
End If

rc = Err.Number
ErrorMsg = Err.Description
If rc = 429 Then
'could not create the component specified
ErrorMsg = ErrorMsg & " '" & ComponentName & "'"
End If
App.LogEvent _
vbNewLine & "Client process for '" & QueueName & "' ended unexpectedly." & _
vbNewLine & " Error: " & ErrorMsg & _
vbNewLine & " Code: " & rc, vbLogEventTypeError
Resume Done
End Sub