frmMain, frmGetCPflowList.frm

This is the main form code:

----------
Dim PROMIS_LOGIN As String
Dim QueryStatus As String
Dim sCommand As String
Dim sQueue As String
Dim thisActivePrcdID As String
Const username As String = "STATSAPP"
Const password As String = "STATSAPP"
Const PROMIS_HEADER As String = "1C"
Const PROMIS_HEADER_SIZE As Integer = 8
Const PROMIS_COMMAND_SIZE As Integer = 40
Dim PipeIndex As Integer
Dim IntStr As String
Dim IntStr2 As String
Dim myCurrPinsDataSet(300, 7) As String


Private Sub btnGetFlowListing_Click()
txtStatus0.Text = ""
txtStatus0a.Text = ""
lblTPQuery0 = ""
txtStatus1.Text = ""
lblTPQuery2 = ""
txtStatus2.Text = ""
lblTPQuery3 = ""
txtStatus3.Text = ""
lblTPQuery4 = ""
txtStatus4.Text = ""
Me.lblPinsCount = "Pins Count: "
GetPinsData (Me.tbxCallProcName.Text)
End Sub

Private Sub Form_Load()
Dim status As Long
' Always call pams_exit on startup. This avoids
' leaving open connections if the app is stopped
' from VB run-mode without detaching.
'
status = pams_exit()

#If MessageQ_Server Then
txtStatus1.Text = "MessageQ Server environment"
#Else
txtStatus1.Text = "MessageQ Client environment"
#End If
End Sub


Function GetPinsData(ByVal myProcName As String) As Integer
Dim status As Long
Dim ReturnedData As Integer
'
GetPins500Series = 0
ReturnedData = 0
' attach Q
status = DmqAttachQ()
If (status <> 1) Then
' error attaching Q
txtStatus1.Text = "Error attaching Q"
Else
' means status is OK
' put msg
' query: "GetActivePrVersion"
QueryStatus = ""
Sleep (100)
Call PutMsg4(myProcName, "GetActivePrVersion", lblTPQuery0)
' get Msg
Sleep (100)
QueryStatus = GetMsg4(txtStatus0a)
' assign a default value for the Prcd Name
thisActivePrcdID = myProcName
' process the data
If (InStr(QueryStatus, "SUCCESS") > 0) Then
ReturnedData = Me.CleanSingleColumnTPResult(QueryStatus, txtStatus0)
If (ReturnedData > 0) Then
lblPrcdID = "PrcdID: " & txtStatus0.Text
thisActivePrcdID = txtStatus0.Text
Else
thisActivePrcdID = myProcName
End If
End If
' put Msg
' query: "CheckProdStatus"
QueryStatus = ""
Sleep (100)
Call PutMsg4(thisActivePrcdID, "CheckProdStatus", lblTPQuery2)
' get Msg
Sleep (100)
QueryStatus = GetMsg4(txtStatus2)
' put Msg
' query: "GetPins500Series"
QueryStatus = ""
Sleep (200) ' safe number, especially when the # of rows is increasing
Call PutMsg4(thisActivePrcdID, "GetPins500Series", lblTPQuery3)
' get Msg
Sleep (300) ' safe number, especially when the # of rows is increasing
QueryStatus = GetMsg4(txtStatus3)
' put Msg
' query: "GetFullPINSSet"
QueryStatus = ""
Sleep (400) ' safe number, especially when the # of rows is increasing
Call PutMsg4(thisActivePrcdID, "GetFullPINSSet", lblTPQuery4)
' get Msg
Sleep (500) ' safe number, especially when the # of rows is increasing
QueryStatus = GetMsg4(txtStatus4)
' process the data
If (InStr(QueryStatus, "SUCCESS") > 0) Then
GetPinsData = CleanCurrPinsDataSet(QueryStatus, txtStatus1)
If (GetPinsData > 0) Then
' show the full data set
'MsgBox ("Number of PINS is " & GetPinsData)
Me.lblPinsCount = "Pins Count: " & GetPinsData
End If
End If
End If
' detach Q, whether failed or succeeded
DmqExit
' clean up the msg, and return how many are captured
End Function

Sub PutMsg4(ByVal DataBuffer As String, ByVal ComType As String, ByVal thisLabel As Label)
Dim status As Long
Dim MsgArea As String * 4096

PutMsg.SrcTarget.Group = 1
PutMsg.SrcTarget.Queue = 4
PutMsg.Class = 0
PutMsg.Type = 0
PutMsg.timeout = 60000
PutMsg.MsgAreaSize = Len(MsgArea)

MsgArea = Compose1(DataBuffer, ComType)
thisLabel = MsgArea

status = DmqPutMsg(PutMsg, MsgArea)
End Sub

Function GetMsg4(ByVal thisControl As TextBox) As String
Dim status As Long
Dim MsgArea As String * 8192
thisControl.Text = ""
GetMsg.timeout = 900
GetMsg.MsgAreaSize = Len(MsgArea)
status = DmqGetMsg(GetMsg, MsgArea)
If (status = PAMS__NOMOREMSG) Then
thisControl.Text = thisControl.Name + ": " + DmqStatusText(status)
ElseIf (status = PAMS__SUCCESS) Then
thisControl.Text = thisControl.Name + ": " + MsgArea
Else
thisControl.Text = thisControl.Name + ": " + "GetMsg status: " + DmqStatusText(status)
End If
GetMsg4 = MsgArea
End Function

Function Compose1(ByVal DataBuffer As String, ByVal ComType As String) As String
PROMIS_LOGIN = "USERID " + username + "|PWD " + password + "|"
Compose1 = ""
Select Case ComType
Case "GetActivePrVersion"
VarProds = "LOWID " & DataBuffer & "|HIGHID " & DataBuffer & "|"
sCommand = "PROPRCD_LIST"
sQueue = VarProds + "FROM PRCDSET|" & _
"WHERE PRODSTATUS EQ 'A' AND ACTIVEFLAG EQ 'A'|" & _
"SHOW EXTERN(PRCDID)|"
Case "GetPins500Series"
VarProds = "PRCDID " + DataBuffer + "|"
sCommand = "PROPRCD_GETPRCD_INSTRUCTIONS"
sQueue = VarProds + "NUMBERINSTRUCTIONS 100|FROM PINSSET|" & _
"WHERE (PINSINSTNUM GE '500.000' AND PINSINSTNUM LT '595.000')|" & _
"SHOW PINSINSTNUM|SHOW INSTTYPE|SHOW STAGE|SHOW EXECUTERECPID|" & _
"SHOW LOCATIONID|SHOW CALLPRCDID|"
Case "GetFullPINSSet"
VarProds = "PRCDID " + DataBuffer + "|"
sCommand = "PROPRCD_GETPRCD_INSTRUCTIONS"
sQueue = VarProds + "NUMBERINSTRUCTIONS 300|FROM PINSSET|" & _
"SHOW PINSINSTNUM|SHOW INSTTYPE|SHOW EXECUTERECPID|SHOW STAGE|" & _
"SHOW LOCATIONID|SHOW CALLPRCDID|"
Case "CheckProdStatus"
VarProds = "PRCDID " + DataBuffer + "|"
sCommand = "PROPRCD_GETPRCD_HEADER"
sQueue = VarProds + "SHOW PRCD.PRODSTATUS|"
End Select
Compose1 = Me.FormQuery(sCommand, sQueue)
End Function

Public Function FormQuery(ByVal sCommand As String, ByVal sQueue As String) As String
FormQuery = PROMIS_HEADER & Space(PROMIS_HEADER_SIZE - Len(PROMIS_HEADER)) & _
Trim(sCommand) & Space(PROMIS_COMMAND_SIZE - Len(Trim(sCommand))) & _
"|" & PROMIS_LOGIN & sQueue & "END|"
End Function

Public Function CleanSingleColumnTPResult(ByVal thisReplyMsg As String, ByVal thisTextBox As TextBox) As Integer
Dim thisBuffer As String
Dim thisCntr As Integer
thisBuffer = ""
thisCntr = 0
CleanSingleColumnTPResult = 0
thisTextBox.Text = ""
'
PipeIndex = InStr(1, thisReplyMsg, "|")
IntStr = Right(thisReplyMsg, (Len(thisReplyMsg)) - PipeIndex)
PipeIndex = InStr(1, IntStr, "|")
thisCntr = Left(IntStr, (PipeIndex - 1))
'
If (thisCntr <> "0") Then
For i = 0 To (thisCntr - 1)
IntStr2 = Right(IntStr, (Len(IntStr)) - PipeIndex)
PipeIndex = InStr(1, IntStr2, "|")
thisBuffer = Left(IntStr2, PipeIndex - 1)
IntStr = IntStr2
myCurrPinsDataSet(i, 0) = thisBuffer
thisTextBox.Text = thisBuffer
Next
CleanSingleColumnTPResult = thisCntr
Else
CleanSingleColumnTPResult = 0
End If
End Function

Public Function CleanCurrPinsDataSet(ByVal thisReplyMsg As String, ByVal thisTextBox As TextBox) As Integer
Dim thisBuffer As String
Dim thisCntr As Integer
thisBuffer = ""
thisCntr = 0
CleanCurrPinsDataSet = 0
thisTextBox.Text = ""
'
PipeIndex = InStr(1, thisReplyMsg, "|")
IntStr = Right(thisReplyMsg, (Len(thisReplyMsg)) - PipeIndex)
PipeIndex = InStr(1, IntStr, "|")
thisCntr = Left(IntStr, (PipeIndex - 1))
'
If (thisCntr <> "0") Then
For i = 0 To (thisCntr - 1)
For j = 0 To 5
IntStr2 = Right(IntStr, (Len(IntStr)) - PipeIndex)
PipeIndex = InStr(1, IntStr2, "|")
thisBuffer = Left(IntStr2, PipeIndex - 1)
IntStr = IntStr2
If (j = 0) Then
myCurrPinsDataSet(i, j) = thisBuffer
ElseIf (j = 1) Then
myCurrPinsDataSet(i, j) = thisBuffer
ElseIf (j = 2) Then
myCurrPinsDataSet(i, j) = thisBuffer
ElseIf (j = 3) Then
myCurrPinsDataSet(i, j) = thisBuffer
ElseIf (j = 4) Then
myCurrPinsDataSet(i, j) = thisBuffer
ElseIf (j = 5) Then
myCurrPinsDataSet(i, j) = thisBuffer
End If
Next
Next
CleanCurrPinsDataSet = thisCntr
' do the textbox population here, so main code is clean
' current data set:
' 0 - Inst Num (7 chars, into 8)
' 1 - Inst Type (2 chars, into 3)
' 2 - Exec Recipe (5 chars, into 6)
' 3 - Stage (max 10 chars, into 11)
' 4 - LocationID (max 10 chars, into 11)
' 5 - Call Prcd (max 32 chars, into 33)
Dim tmpPinsBfr As String
' assign the header in the Textbox
thisTextBox.Text = "InstNum -Ityp -Recipe - StageID - LocationID - Call Procedure Name " & vbCrLf & _
"======= -==== -====== - ======= - ========== - =================== " & vbCrLf
For i = 0 To (thisCntr - 1)
For j = 0 To 5
If (j = 0) Then
thisTextBox.Text = thisTextBox.Text & myCurrPinsDataSet(i, j)
ElseIf (j = 1) Then
thisTextBox.Text = thisTextBox.Text & " - " & myCurrPinsDataSet(i, j)
ElseIf (j = 2) Then
tmpPinsBfr = myCurrPinsDataSet(i, j)
If (tmpPinsBfr = "") Then tmpPinsBfr = "Undef"
thisTextBox.Text = thisTextBox.Text & " - " & tmpPinsBfr & Space(6 - Len(tmpPinsBfr))
ElseIf (j = 3) Then
tmpPinsBfr = myCurrPinsDataSet(i, j)
If (tmpPinsBfr = "") Then tmpPinsBfr = "Undef"
thisTextBox.Text = thisTextBox.Text & " - " & tmpPinsBfr & Space(11 - Len(tmpPinsBfr))
ElseIf (j = 4) Then
tmpPinsBfr = myCurrPinsDataSet(i, j)
If (tmpPinsBfr = "") Then tmpPinsBfr = "Undef"
thisTextBox.Text = thisTextBox.Text & " - " & tmpPinsBfr & Space(11 - Len(tmpPinsBfr))
ElseIf (j = 5) Then
tmpPinsBfr = myCurrPinsDataSet(i, j)
If (tmpPinsBfr = "") Then tmpPinsBfr = "Undef"
thisTextBox.Text = thisTextBox.Text & " - " & tmpPinsBfr & Space(33 - Len(tmpPinsBfr)) & vbCrLf
End If
Next
Next
Else
CleanCurrPinsDataSet = 0
End If
End Function
----------