test.frm

IBM 开发的easy cics通讯相关的源代码

VERSION 5.00
Begin VB.Form frmTest 
   Caption         =   "检测"
   ClientHeight    =   5520
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   11385
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   ScaleHeight     =   5520
   ScaleWidth      =   11385
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton btnTest3 
      Caption         =   "Test3"
      Height          =   375
      Left            =   9480
      TabIndex        =   7
      Top             =   4800
      Width           =   1335
   End
   Begin VB.CommandButton btnTest2 
      Caption         =   "Test2"
      Height          =   375
      Left            =   7920
      TabIndex        =   6
      Top             =   4800
      Width           =   1335
   End
   Begin VB.CommandButton btnTest 
      Caption         =   "Test"
      Height          =   375
      Left            =   6360
      TabIndex        =   5
      Top             =   4800
      Width           =   1335
   End
   Begin VB.CommandButton btnAbout 
      Caption         =   "About"
      Height          =   375
      Left            =   4800
      TabIndex        =   4
      Top             =   4800
      Width           =   1335
   End
   Begin VB.CommandButton btnTelecom 
      Caption         =   "Telecom"
      Height          =   375
      Left            =   3240
      TabIndex        =   3
      Top             =   4800
      Width           =   1335
   End
   Begin VB.CommandButton btnEC02 
      Caption         =   "EC02"
      Height          =   375
      Left            =   1680
      TabIndex        =   2
      Top             =   4800
      Width           =   1335
   End
   Begin VB.CommandButton btnEC00 
      Caption         =   "EC00"
      Height          =   375
      Left            =   240
      TabIndex        =   1
      Top             =   4800
      Width           =   1215
   End
   Begin VB.ListBox lstTest 
      Height          =   4350
      Left            =   120
      TabIndex        =   0
      Top             =   240
      Width           =   10935
   End
End
Attribute VB_Name = "frmTest"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim oEc As New EasyCics.App

Private Sub TestAbout()
        oEc.About
End Sub

Private Sub TestEc00()
Dim r%, s$

        r = oEc.ConnectServer("CICSNT01", "TEST", "TEST")
If r <> 0 Then
        MsgBox "Can't connect"
        Exit Sub
End If


        oEc.SetValue "", "Hello, friend!"
        oEc.CallProgram "EC00"
        
If oEc.GetErr <> "" Then
        MsgBox "CallProgram error"
        Exit Sub
End If
 

        oEc.Commit
        
        MsgBox oEc.GetValue("")
End Sub

Sub TestEc02()
Dim r%, s$, i As Long, j%, rc As Long, cc%
Dim t1, t2, t3

        r = oEc.ConnectServer("CICSNT01", "TEST", "TEST")
If r <> 0 Then
        MsgBox "Can't connect"
        Exit Sub
End If
        lstTest.Clear


        t1 = Time

        'oEc.SetValue "_LANG", "1"
        oEc.CallProgramAndCommit "EC02"

'''''''''''''''''''''''''''''''''''''
        'MsgBox oEc.GetValue("_TSQ"), 0, "_TSQ"
        'MsgBox oEc.GetValue("_SYSID"), 0, "_SYSID"

        t2 = Time

        oEc.RsOpen
        rc = oEc.RsGetRowNum
        cc = oEc.RsGetColNum

        s = ""
For i = 1 To rc
        oEc.RsFetchRow
 If (i Mod 1000) <= 1 Then
  For j = 1 To cc
        s = s + oEc.RsGetCol(j) + ","
  Next
        lstTest.AddItem s
        s = ""
 End If
Next

        'MsgBox ""

        oEc.RsClose
        
        t3 = Time
        MsgBox "耗时：(" & Second(t2 - t1) & ")" & Second(t3 - t1) & "秒"

End Sub

Sub TestTelecom()
Dim r%, s$, i%, j%, rc%, cc%

        r = oEc.ConnectServer("CICSNT01", "TEST", "TEST")
If r <> 0 Then
        MsgBox "Can't connect"
        Exit Sub
End If
        lstTest.Clear

        'oEc.SetValue "_LANG", "1"
        oEc.SetValue "NO", "2020088"

        'oEc.SetEciTimeOut 1
        oEc.CallProgramAndCommit "TELECOM"
        'oEc.CallProgramDSyncAndCommit "TELECOM"
        'oEc.Commit
'If oEc.GetErr <> "" Then
'        MsgBox "Error Call"
'        Exit Sub
'End If
        s = oEc.GetErr
If s <> "" Then
        MsgBox s
        Exit Sub
End If

        
'        r = oEc.GetReply()
'Do While r <> 0
'        DoEvents
'        r = oEc.GetReply()
'Loop

'''''''''''''''''''''''''''''''''''''
        oEc.RsOpen
        rc = oEc.RsGetRowNum
        cc = oEc.RsGetColNum
        
'For j = 1 To cc
        'MsgBox oEc.RsGetColName(j)
'Next

        s = ""
For i = 1 To rc
        oEc.RsFetchRow
 For j = 1 To cc
        s = s + oEc.RsGetCol(j) + ","
 Next
        lstTest.AddItem s
        s = ""
Next

        
End Sub

Private Sub btnAbout_Click()
        TestAbout
End Sub

Private Sub btnEC00_Click()
        TestEc00
End Sub

Private Sub btnEC02_Click()
        TestEc02
End Sub

Private Sub btnTelecom_Click()
        TestTelecom
End Sub

Private Sub btnTest_Click()
Dim ba() As Byte, fs$
Dim fn%, r%



        r = oEc.ConnectServer("CICSNT01", "TEST", "TEST")
If r <> 0 Then
        MsgBox "Can't connect"
        Exit Sub
End If


'        fs = InputBox("Input file name")
'        If fs = "" Then Exit Sub
'
'        oEc.BeginWrite
'
'        oEc.CallProgramAndCommit ("UPLOAD")
'If oEc.GetErr <> "" Then
'        MsgBox "Error when calling program"
'        Exit Sub
'End If
'
'        oEc.Upload fs, "1"
'If oEc.GetErr <> "" Then
'        MsgBox oEc.GetErr
'        Exit Sub
'End If
'
'        MsgBox "OK"
'        Exit Sub


        oEc.BeginWrite
        oEc.SetValue "FILE", "c:\bootfont.bin"
        oEc.CallProgramAndCommit "GETFILE"
If oEc.GetErr <> "" Then
        MsgBox "Error when calling program"
        Exit Sub
End If

        ba() = oEc.LoadBlock()
If oEc.GetErr <> "" Then
        MsgBox "Error when LoadBlock"
        Exit Sub
End If

        fn = FreeFile
        Open "c:\this" For Binary As fn
        Put fn, , ba
        Close fn

        MsgBox "Download OK !"
        Exit Sub

        'r = oEc.ConnectServer("CICSNT01", "TEST", "TEST")
        'r = oEc.ConnectServer("CICSX", "TEST", "TEST")
        'oEc.SetValue "_LANG", 1

        'oEc.BeginWrite

        'oEc.SetValue "flag", "Q"
        'oEc.SetValue "SQL", "select * from bas_infot"
        'oEc.CallProgramAndCommit "ADHOC"

        'MsgBox oEc.CommonStr
        'oEc.RsOpen
        'MsgBox oEc.RsGetColName(1)
        'MsgBox oEc.RsGetColName(2)

End Sub

Private Sub btnTest3_Click()
        Dim r%
        Dim oEc As New EasyCics.App

        r = oEc.ConnectServer("CICSNT01", "TEST", "TEST")
        MsgBox r

        oEc.BeginWrite
        oEc.SetValue "_LANG", "1"

        oEc.RsCreate 3

        oEc.RsAddRow
        oEc.RsSetCol 1, "%D0%D01%C1%D01"
        oEc.RsSetCol 2, "%D0%D01%C1%D02"
        oEc.RsSetCol 3, "%D0%D01%C1%D03"
        oEc.RsSaveRow

        oEc.RsAddRow
        oEc.RsSetCol 1, "%D0%D02%C1%D01"
        oEc.RsSetCol 2, "%D0%D02%C1%D02"
        oEc.RsSetCol 3, "%D0%D02%C1%D03"
        oEc.RsSaveRow

        oEc.CallProgramAndCommit "CLIRS"

        MsgBox oEc.GetValue("RETURN")

End Sub

Private Sub btnTest2_Click()
        Dim ba() As Byte
        Dim sz$
        Dim r%, b%, n&, i&
        Dim oEc As New EasyCics.App
        

        r = oEc.ConnectServer("CICSNT01", "TEST", "TEST")
If r <> 0 Then
        MsgBox "Can't connect"
        Exit Sub
End If


        sz = InputBox("Input byte array size")
        If sz = "" Then Exit Sub
        n = CLng(sz)

        oEc.BeginWrite
        
        ReDim ba(n - 1)
        b = 0
For i = 0 To n - 1
        ba(i) = b
        b = b + 1

        If b < 0 Or b > 127 Then b = 0
Next
        
        'n = UBound(ba) - LBound(ba) + 1
        
        oEc.SetValue "BlkLen", CStr(n)

        oEc.SetUploadBlk ba, "BLKPUT"

        oEc.CallProgramAndCommit "BLKPUT"
If oEc.GetErr <> "" Then
        MsgBox "Error when calling program"
        Exit Sub
End If

        MsgBox oEc.GetValue("Ok")
End Sub

Private Sub Form_Unload(Cancel As Integer)
        Set oEc = Nothing
End Sub