Programa Visual Basic. DLLGATWAY.BAS Option Explicit Public ColaEnvio As Long Public ColaRespuesta As Long Public HUpQ As Long Public HDownQ As Long Public queueName As String \' Funciones para el manjeo de Colas de datos Declare Function cwbDQ_CreateData Lib \"CwbDq.dll\" () As Long Declare Function cwbDQ_Open Lib \"CwbDq.dll\" _ (ByVal sQName As String, ByVal sLibrary As String, _ ByVal sSystem As String, hQHandle As Long, _ hErrorHandle As Long) As Long Declare Function cwbDQ_Read Lib \"CwbDq.dll\" _ (ByVal hQHandle As Long, _ ByVal hDataHandle As Long, _ ByVal lWaitTime As Long, _ ByVal hErrorHandle As Long) As Long Declare Function cwbDQ_GetData Lib \"CwbDq.dll\" _ (ByVal hDataHandle As Long, _ ByVal sData As String) As Long Declare Function cwbDQ_SetData Lib \"CwbDq.dll\" _ (ByVal hDataHandle As Long, _ ByVal sDataToSet As String, _ ByVal lLength As Long) As Long Declare Function cwbDQ_Write Lib \"CwbDq.dll\" _ (ByVal hQHandle As Long, _ ByVal hDataHandle As Long, _ ByVal bolCommit As Boolean, _ ByVal hError As Long) As Long Declare Function cwbDQ_DeleteData Lib \"CwbDq.dll\" _ (ByVal hDataHandle As Long) As Long Declare Function cwbDQ_Close Lib \"CwbDq.dll\" _ (ByVal hQHandle As Long) As Long Declare Function cwbDQ_Clear Lib \"CwbDq.dll\" _ (ByVal hDataHandle As Long, _ ByVal sKeyValue As String, _ ByVal lKeyLength As Long, _ ByVal hErrorHandle As Long) As Long Declare Function cwbDQ_CreateAttr Lib \"CwbDq.dll\" () As Long Declare Function cwbDQ_SetMaxRecLen Lib \"CwbDq.dll\" _ (ByVal hAttrHandle As Long, _ ByVal lLength As Long) As Long Declare Function cwbDQ_Create Lib \"CwbDq.dll\" _ (ByVal sQName As String, _ ByVal sLibrary As String, _ ByVal sSystem As String, _ ByVal hAttrHandle As Long, _ ByVal hErrorHandle As Long) As Long Declare Function cwbDQ_Delete Lib \"CwbDq.dll\" _ (ByVal sQName As String, _ ByVal sLibrary As String, _ ByVal sSystem As String, _ ByVal hErrorHandle As Long) As Long Declare Function cwbDQ_DeleteAttr Lib \"CwbDq.dll\" _ (ByVal hAttrHandle As Long) As Long Declare Function cwbDQ_SetConvert Lib \"CwbDq.dll\" _ (ByVal hDataHandle As Long, _ ByVal bolTranslate As Boolean) As Long Function PrepararColas(NombreColaSend As String, LibSend As String, NombreColaReceive, Libget As String, sistemaas400 As String) Dim CodigoError As Long Dim CodigoRespuesta As Long ColaEnvio = cwbDQ_CreateData() ColaRespuesta = cwbDQ_CreateData() CodigoRespuesta = cwbDQ_SetConvert(ColaEnvio, 1) CodigoRespuesta = cwbDQ_SetConvert(ColaRespuesta, 1) \' Establecer conversación con ambas colas de datos CodigoRespuesta = cwbDQ_Open(NombreColaSend, LibSend, sistemaas400, HUpQ, CodigoError) CodigoRespuesta = cwbDQ_Open(NombreColaReceive, Libget, sistemaas400, HDownQ, CodigoError) End Function Function PrepararColasSend(NombreColaSend As String, LibSend As String, sistemaas400 As String) Dim CodigoError As Long Dim CodigoRespuesta As Long ColaEnvio = cwbDQ_CreateData() CodigoRespuesta = cwbDQ_SetConvert(ColaEnvio, 1) \' Establecer conversación con ambas colas de datos CodigoRespuesta = cwbDQ_Open(Trim(NombreColaSend), Trim(LibSend), Trim(sistemaas400), HUpQ, CodigoError) End Function Function PrepararColasReceive(NombreColaReceive As String, LibReceive As String, sistemaas400 As String) Dim CodigoError As Long Dim CodigoRespuesta As Long ColaRespuesta = cwbDQ_CreateData() CodigoRespuesta = cwbDQ_SetConvert(ColaRespuesta, 1) \' Establecer conversación con ambas colas de datos CodigoRespuesta = cwbDQ_Open(NombreColaReceive, LibReceive, sistemaas400, HDownQ, CodigoError) End Function Sub Finalizar() Dim CodigoRespuesta As Long CodigoRespuesta = cwbDQ_DeleteData(ColaEnvio) CodigoRespuesta = cwbDQ_Close(HUpQ) CodigoRespuesta = cwbDQ_DeleteData(ColaRespuesta) CodigoRespuesta = cwbDQ_Close(HDownQ) End Sub Sub FinalizarColaReceive() Dim CodigoRespuesta As Long CodigoRespuesta = cwbDQ_DeleteData(ColaRespuesta) CodigoRespuesta = cwbDQ_Close(HDownQ) End Sub Sub FinalizarColaSend() Dim CodigoRespuesta As Long CodigoRespuesta = cwbDQ_DeleteData(ColaEnvio) CodigoRespuesta = cwbDQ_Close(HUpQ) End Sub Function GetTransa(DataEntrada As String) As String Dim CodigoRespuesta As Long Dim CodigoError As Long DataEntrada = String(1024, \" \") CodigoRespuesta = cwbDQ_SetData(ColaRespuesta, DataEntrada, Len(DataEntrada)) CodigoRespuesta = cwbDQ_Read(HDownQ, ColaRespuesta, 3, CodigoError) If CodigoRespuesta > 0 Then \' Error en leer cola de salida GetTransa = 1 Exit Function End If CodigoRespuesta = cwbDQ_GetData(ColaRespuesta, DataEntrada) GetTransa = DataEntrada \'OK End Function Function SendTransa(DataSalida As String) As Integer Dim CodigoRespuesta As Long Dim CodigoError As Long CodigoRespuesta = cwbDQ_SetData(ColaEnvio, DataSalida, Len(DataSalida)) CodigoRespuesta = cwbDQ_Write(HUpQ, ColaEnvio, False, CodigoError) If CodigoRespuesta > 0 Then \' Error en el envío SendTransa = 1 Exit Function End If SendTransa = 0 \'OK End Function Function BorrarCola(Nombrecola As String, libreria As String, systemname As String) Dim CodigoRespuesta As Integer Dim CodigoError As Long CodigoRespuesta = cwbDQ_Delete(Nombrecola, libreria, systemname, CodigoError) BorrarCola = CodigoRespuesta End Function Sub ClearCola() Dim CodigoRespuesta As Integer Dim CodigoError As Long CodigoRespuesta = cwbDQ_Clear(HUpQ, \"\", 0, CodigoError) CodigoRespuesta = cwbDQ_Clear(HDownQ, \"\", 0, CodigoError) End Sub \' PROGRAMA COLAS.VBP Dim Data As String * 1024 Private Sub cmdsalir_Click() Unload Me End Sub Private Sub ctrl_aceptar_Click() Dim codresp As Integer Dim DataSalida As String frmestadistica.MousePointer = vbHourglass \' Preparo las colas de envio y respuesta a \' Cambie la direcciòn 9.9.9.9 por la IP de su AS/400 o nombre de Sistema PrepararColas \"COLDTQE\", \"QGPL\", \"COLDTQS\", \"QGPL\", \"9.9.9.9\" ClearCola \'Verifico primero si el programa en el AS/400 esta activo SendTransa (\"120000000\") Data = Space(1024) Data = GetTransa(DataSalida) If Trim(Data) = \"*ACT\" Then SendTransa (\"100\" + Format(fldnumero.Text, \"000000\")) DataSalida = Space(1024) Data = GetTransa(DataSalida) fldrespuesta.Text = Trim(Data) End If Finalizar frmestadistica.MousePointer = 0 End Sub \' programa rpg SUMRP001 100 F*---------------------------------------------------------------* 12/06/97 200 F* PROGRAMA : SUPRP01 * 31/07/97 300 F* * 18/06/97 400 F* AUTOR : JAIME MIUR * 25/06/97 500 F*---------------------------------------------------------------* 22/09/05 600 IREGENT IDS 22/09/05 700 I 1 3 CODMSG 22/09/05 800 I 4 9 NUMENT 22/09/05 900 IREGSAL IDS 22/09/05 1000 I 1 6 NUMSAL 22/09/05 1100 C*---------------------------------------------------------------* 22/09/05 1200 I \'COLDTQE\' C DTQENT 22/09/05 1300 I \'COLDTQS\' C DTQSAL 22/09/05 1400 I \'QGPL \' C DTQLIB 22/09/05 1500 C*---------------------------------------------------------------* 13/06/97 1600 C** 22/09/05 1700 C** LEER LA DATA QUEQUE 20/05/97 1800 C** 20/05/97 1900 C Z-ADD*ZEROS LENDTA 50 02/06/97 2000 C Z-ADD2 TIEESP 50 31/07/97 2100 C SETOF 61 26/06/97 2200 C** 09/06/97 2300 C *IN61 DOWEQ*OFF 26/06/97 2400 C MOVE *BLANK NUMSAL 22/09/05 2500 C MOVE *BLANK DTAENT 10 11/07/97 2600 C MOVE *BLANK LIBENT 10 11/07/97 2700 C MOVE *BLANK DTASAL 10 11/07/97 2800 C MOVE *BLANK LIBSAL 10 11/07/97 2900 C MOVELDTQENT DTAENT 22/09/05 3000 C MOVELDTQLIB LIBENT 22/09/05 3100 C MOVELDTQSAL DTASAL 22/09/05 3200 C MOVELDTQLIB LIBSAL 22/09/05 3300 C Z-ADD*ZEROS LENDTA 50 09/06/97 3400 C** 09/06/97 3500 C CALL \'QRCVDTAQ\' 20/05/97 3600 C PARM DTAENT 11/07/97 3700 C PARM LIBENT 11/07/97 3800 C PARM LENDTA 20/05/97 3900 C PARM REGENT 22/09/05 4000 C PARM TIEESP 31/07/97 4100 C** 20/05/97 4200 C LENDTA IFGT *ZEROS 02/06/97 4300 C** 17/10/97 4400 C SELEC 22/09/05 4500 C** 22/09/05 4600 C** REALIZA MULTIPLICACIÒN 22/09/05 4700 C** 22/09/05 4800 C CODMSG WHEQ MSGMUL 22/09/05 4900 C EXSR PROMUL 22/09/05 5000 C** 22/09/05 5100 C** VERIFICA SI EL PROGRAMA ESTA ACTIVO 22/09/05 5200 C** 22/09/05 5300 C CODMSG WHEQ MSGSTS 22/09/05 5400 C EXSR PROSTS 22/09/05 5500 C** 22/09/05 5600 C** FINALIZACIÒN DE LA CONVERSACIÒN 22/09/05 5700 C** 22/09/05 5800 C CODMSG WHEQ MSGSAL 22/09/05 5900 C LEAVE 22/09/05 6000 C** 22/09/05 6100 C ENDSL 22/09/05 6200 C** 22/09/05 6300 C ENDIF 22/09/05 6400 C** 22/09/05 6500 C ENDDO 31/05/97 6600 C** 03/06/97 6700 C SETON LR 31/05/97 6800 C*---------------------------------------------------------------* 22/09/05 6900 C* SUBRUTINA : PROMUL * 22/09/05 7000 C* OBJETIVO : GENERA LA MULTIPLICACIÒN * 22/09/05 7100 C*---------------------------------------------------------------* 22/09/05 7200 C PROMUL BEGSR 22/09/05 7300 C MOVE NUMENT NUM1 60 22/09/05 7400 C NUM1 MULT 23 NUM2 60 22/09/05 7500 C MOVE *ALL\'0\' NUMSAL 22/09/05 7600 C MOVE NUM2 NUMSAL 22/09/05 7700 C EXSR SNDRES 22/09/05 7800 C ENDSR 22/09/05 7900 C*---------------------------------------------------------------* 22/09/05 8000 C* SUBRUTINA : PROSTS * 22/09/05 8100 C* OBJETIVO : PROCESAR MENSAJE * 22/09/05 8200 C*---------------------------------------------------------------* 22/09/05 8300 C PROSTS BEGSR 22/09/05 8400 C** 22/09/05 8500 C MOVEL\'*ACT\' NUMSAL 22/09/05 8600 C EXSR SNDRES 22/09/05 8700 C** 22/09/05 8800 C ENDSR 22/09/05 8900 C*---------------------------------------------------------------* 22/09/05 9000 C* SUBRUTINA : SNDRES * 22/09/05 9100 C* OBJETIVO : ENVIAR RESPUESTA DE AUTORIZACIóN * 22/09/05 9200 C*---------------------------------------------------------------* 22/09/05 9300 C SNDRES BEGSR 22/09/05 9400 C** 22/09/05 9500 C Z-ADD06 LENDTA 22/09/05 9600 C** 22/09/05 9700 C CALL \'QSNDDTAQ\' 22/09/05 9800 C PARM DTASAL 22/09/05 9900 C PARM LIBSAL 22/09/05 10000 C PARM LENDTA 22/09/05 10100 C PARM REGSAL 22/09/05 10200 C* 22/09/05 10300 C ENDSR 22/09/05 10400 C*---------------------------------------------------------------* 03/04/97 10500 C* SUBRUTINA : *INZSR * 13/06/97 10600 C* OBJETIVO : INICIALIZACIÓN Y DEFINICIÓN DE VARIABLES * 13/06/97 10700 C*---------------------------------------------------------------* 13/06/97 10800 C *INZSR BEGSR 13/06/97 10900 C** 22/09/05 11000 C MOVEL\'100\' MSGMUL 3 22/09/05 11100 C MOVEL\'120\' MSGSTS 3 22/09/05 11200 C MOVEL\'130\' MSGSAL 3 22/09/05 11300 C** 21/06/97 11400 C ENDSR 13/06/97 11500 C*---------------------------------------------------------------* 13/06/97