AS400Connect

Option Explicit
Dim EnvRDO As rdoEnvironment
Dim ConRDO As rdoConnection
Dim rs As rdoResultset
Dim er As rdoError
Dim qd As New rdoQuery
Dim sBeginTime!
Dim sResultTime!
Dim SQL
Private Sub WriteRDOError()
Dim X As Integer
Dim sDate As String
Dim sTime As String
sDate = Format(Date, "dd.mm.yyyy")
sTime = Format(Time, "hh:mm.ss")
X = FreeFile
Open App.Path + "\Error.log" For Append As #X
Dim er As rdoError
Print #X, "Program drive time: " + sDate + " " + sTime
Print #X, "************************************************"
For Each er In rdoErrors
Print #X, "Error: " & er.Description
Next
Print #X, "************************************************"
Close #X
End Sub

Private Sub Cmd_List_Click()
On Error Goto ListError
Call sStart
Exit Sub
ListError:
WriteRDOError
Label_Info.Caption = "Error, check the error log!"
End Sub

Private Sub Form_Load()
optField1.Value = True
On Error Goto LoadError
Screen.MousePointer = vbHourglass
Me.Show
DoEvents
'************************************************

'Environment allocation

'************************************************

Set EnvRDO = rdoEngine.rdoEnvironments(0)
Label_Info.Caption = "Connecting to AS400..."
DoEvents
'************************************************

'Connection allocation

'************************************************

Set ConRDO = _
EnvRDO.OpenConnection(DsName:="", Prompt:=rdDriverNoPrompt, _
Connect:="uid=;pwd=;driver={Client Access ODBC Driver _
(32-bit)};system=S22ABC2;database=TESTDB.LIBRARY;")
'************************************************


Label_Info.Caption = "Connection ok!"
Screen.MousePointer = vbDefault
Exit Sub
LoadError:
WriteRDOError
End Sub

Private Sub Form_Unload(Cancel As Integer)
Dim result%
ConRDO.Close
EnvRDO.Close
Set rs = Nothing
Set ConRDO = Nothing
Set EnvRDO = Nothing
End Sub

Private Sub mnuLopeta_Click()
Unload Me
End Sub

Sub sStart()
sBeginTime! = Timer
Set qd.ActiveConnection = ConRDO
SQL = ""
'*****************************

'Search rules:

'*****************************

If optField1.Value = True Then
SQL = "select FIELD1, FIELD2, FIELD3 from " & _
"TESTDB.LIBRARY where FIELD1 = ?"
Else
If optField2.Value = True Then
SQL = "select FIELD1, FIELD2, FIELD3 from " & _
"TESTDB.LIBRARY where FIELD2 = ?"
Else
SQL = "select FIELD1, FIELD2, FIELD3 from " & _
"TESTDB.LIBRARY where FIELD3 like ?"
End If
End If
qd.SQL = SQL
qd(0) = Text1.Text
'*****************************

'Filling the list:

'*****************************

Set rs = qd.OpenResultset(rdOpenForwardOnly, rdConcurReadOnly)
Do Until rs.EOF
List1.AddItem rs!FILED1 + " " + rs!FIELD2 + " " + rs!FIELD3
rs.MoveNext
Loop
'*****************************

sResultTime! = Timer - sBeginTime!
Label_Info.Caption = "Selection took: " & _
Format(sResultTime!, "###0.00") & " seconds"
End Sub

Inputs:
To get it work, make new VB standard project and then add these
controls to the Form:

one TextBox (Text1)
three OptionBox (optField1, optField2, optField3)
one Label (Label_Info)
one ListBox (List1)
one Command button (Cmd_List)

Returns:
This code returns data from AS400 database depending
on your selection.

Assumes:
This code makes DNSless connection to AS400 Database.
I have made this connection using Client Access drivers
(If you dont have Client Access installed, just select
the correct driver and modify connect string).
You have to change the System Name to correspond to your
System Name.

Side Effects:
You have to change database name and library and naturally
you have to modify SQL statements according your database