Using VB6 with Client Access cwbautsv.tbl

[Blobtech]

Hi,

I am writing a VB6 app that connects to our AS400, runs an SQL command and retrieves returned records. I've got no problem splitting the returned data stream into the correct fields and unpacking the packed fields. What I cannot do though, is work out how to submit the SQL command to look at other members withing the file.

Any help would be appreciated.

P.S I don't want to do this with ODBC or ADO 'cos I find it a pain.

 

[sajaconsult]

Hi, I'm having the same problem.

did you resolve it?

thanks

saja

 

[Blobtech]

Hi Saja,

I solved the problem by using the cwbdbOverrideFile method.

If you need any more info, let me know.

Lee.

 

[sajaconsult]

Thanks Blobtech, a little extra info would be handy.

I have done a search on a few engines with "cwbdbOverrideFile" with no luck.

I, unlike yourself, have used ADO to connect to the AS400, but then I'm just making simple select queries. I know my connection and select structure are correct because it all worked fine prior to the database administrator adding members.

thanks for your time

SAJA

 

[Blobtech]

Saja,

Here's a program I wrote using the cwbdbOverrideFile override. If you start a new project, add a listview control, change the system name,library,file and member to match your system, and it should work.

Lee.

'***********************************************************
'* Copyright L.Greenwood - 2002,2003. blobtech@btinternet.com
'***********************************************************
Dim myDB2 As New cwbDatabaseDB2
Dim mySQL As New cwbDatabaseSQL
Dim myFmt As New cwbDatabaseDataFormat
Dim dbConn As New cwbDatabaseConnection
Dim errObj As New cwbErrorMessage

Dim mySystemName As String, myFilename As String, myLibraryName As String
Dim myMbrName As String, errorcount As Long, errorText As String
  
Dim dataBuf() As Byte, dataLen As Long, indicatorBuf() As Integer, indicatorCount As Long
Dim Cols As Long, colHdr As String, charLen As Long
Dim numLen As Integer, numDec As Integer, fldType As Integer, Fields() As String
Dim rcdLen As Long

Dim itmX As ListItem

Private Sub Form_Load()

Form1.Show
Form1.MousePointer = vbHourglass

mySystemName = "S44H2342" 'As defined in Client Access properties
myFilename = "IIM"
myMbrName = "M0102"
myLibraryName = "BPCSF"
mySelect = "IIM,IDESC,IVEND"
myWhere = " Where IID='IM'"
myOrderBy = " Order By IPROD"

'This bit sets up an error message object.
'This is used on most of the calls to the CA reference and has to be left in
errObj.cwbsvSetup
  
'This bit sets up the connection to the AS400 data base
dbConn.cwbdbSetup mySystemName, errObj
dbConn.cwbdbStartServer errObj

'This is the member override
myDB2.cwbdbSetup dbConn, errObj
myDB2.cwbdbOverrideFile myLibraryName, myFilename, myMbrName, myMbrName, errObj
If errObj.errorcount <> 0 Then GoSub errors

mySQL.cwbdbSetup dbConn, myFmt, errObj

mySQL.cwbdbPrepareDescribe &quot;SQL1&quot;, &quot;Select &quot; & mySelect & &quot; from &quot; & myMbrName & myWhere & myOrderBy, errObj
mySQL.cwbdbGetResultDataFormat errObj

Cols = myFmt.columnCount
ReDim Fields(Cols, 5)
rcdLen = myFmt.rowSize


'Create listView Headers
For x = 1 To Cols
  Call myFmt.cwbdbGetColumnName(x, colHdr, errObj)         'Field name
  Call myFmt.cwbdbGetColumnLength(x, charLen, errObj)      'Length of field
  Call myFmt.cwbdbGetColumnPrecision(x, numLen, errObj)    'For numeric field the number of decimals
  Call myFmt.cwbdbGetColumnScale(x, numDec, errObj)        'For numeric field the decimals
  Call myFmt.cwbdbGetColumnType(x, fldType, errObj)        'Type of field (Char,Zoned,Packed etc)
  Fields(x, 1) = Trim(colHdr)
  Fields(x, 2) = Trim(charLen)
  If fldType >= 2 Then
    Fields(x, 3) = Trim(numLen)
    Fields(x, 4) = Trim(numDec)
  End If
  Fields(x, 5) = Trim(fldType)
  
  ListView1.ColumnHeaders.Add , , Trim(colHdr)

Next x



'Now get the data
Call mySQL.cwbdbOpen(&quot;SQL1&quot;, &quot;tmpCur&quot;, 0, errObj)
If errObj.errorcount <> 0 Then GoSub errors

Call mySQL.cwbdbFetch(&quot;tmpCur&quot;, errObj)

Do Until mySQL.resultDataLength = 0
  
  DoEvents
  ReDim dataBuf(mySQL.resultDataLength)
  ReDim indicatorBuf(mySQL.resultDataLength)
  
  'This call actually gets the data from the system
  Call mySQL.cwbdbGetResultData(dataBuf, dataLen, indicatorBuf, indicatorCount, errObj)
  
  xFrom = 0

  'mySQL.resultDataLength is the rcdlen
  Do While xFrom < (mySQL.resultDataLength - 1)
    
    'This sub extracts a single record from the returned array
    Call xTractRcd(xFrom, rcdLen, xString, dataBuf)
    
    'This sub extracts the fields from the record
    Call xTractFld(xString, Fields, Cols)

    For x = 1 To Cols
      DoEvents
      tmpfield = RTrim(Fields(x, 0))
      If tmpfield = &quot;&quot; And Fields(x, 5) = &quot;1&quot; Then
        tmpfield = &quot; &quot;
      End If
      If tmpfield = &quot;&quot; And Fields(x, 5) <> &quot;1&quot; Then
        tmpfield = &quot;0&quot;
      End If

      If x = 1 Then
        Set itmX = ListView1.ListItems.Add(, , tmpfield)
        Else
        itmX.SubItems(x - 1) = tmpfield
      End If
      
    Next x
    xFrom = xFrom + rcdLen
  Loop
  
  Call mySQL.cwbdbFetch(&quot;tmpCur&quot;, errObj)
  
Loop

Form1.MousePointer = vbDefault

Set mySQL = Nothing
Set myDB2 = Nothing
Set myFmt = Nothing
Set dbConn = Nothing
Set errObj = Nothing

Exit Sub

errors:
  tmpErrMsg = &quot;&quot;

  For x = 1 To errObj.errorcount
    Call errObj.cwbsvGetErrTextIndexed(x, errorText)
    tmpErrMsg = tmpErrMsg & errorText & vbCrLf
  Next x
  MsgBox (tmpErrMsg)

  Set mySQL = Nothing
  Set myDB2 = Nothing
  Set myFmt = Nothing
  Set dbConn = Nothing
  Set errObj = Nothing
  Form1.MousePointer = vbDefault
'  Resume Next
End Sub


Private Sub xTractFld(xString, Fields, Cols)
  xFrom = 1
  For x = 1 To Cols
    tmpStr = &quot;&quot;
    tmpStr = Mid(xString, xFrom, Fields(x, 2))
    Fields(x, 0) = &quot;&quot;
    'At the moment I am only checking for text, zoned and packed fields
    If Fields(x, 5) = 1 Then Fields(x, 0) = tmpStr
    If Fields(x, 5) = 7 Then Fields(x, 0) = Val(tmpStr)
    
    'Type 6 = Packed field, so UnPack it
    If Fields(x, 5) = 6 Then
      Call unPack(tmpStr)
      If (Val(Fields(x, 3)) + 1) / 2 = Fields(x, 2) Then
        Fields(x, 0) = Val(Mid(tmpStr, 1, Len(tmpStr) - 1))
        Else
        Fields(x, 0) = Val(Mid(tmpStr, 2, Len(tmpStr) - 2))
      End If
      sign1 = Left(tmpStr, 1)
      sign2 = Right(tmpStr, 1)
      
      If sign2 = &quot;D&quot; Then
        Fields(x, 0) = Val(Fields(x, 0)) * -1
      End If
      
    End If
    
    'If this is a field with decimals, then refromat
    If Fields(x, 5) >= 2 And Fields(x, 5) <= 7 Then
      tmpDecPos1 = &quot;1&quot; & String(Fields(x, 4), &quot;0&quot;)
      tmpDecPos = Val(tmpDecPos1)
      Fields(x, 0) = Fields(x, 0) / tmpDecPos
      
      tmpFmt = String(Fields(x, 3) - Fields(x, 4), &quot;#&quot;)
      If Fields(x, 4) <> 0 Then tmpFmt = tmpFmt & &quot;.&quot; & String(Fields(x, 4), &quot;0&quot;)
      Fields(x, 0) = Val(Format(Fields(x, 0), tmpFmt))
    End If
    
    xFrom = xFrom + Val(Fields(x, 2))
  Next x
End Sub


Private Sub unPack(tmpStr)
tmpstr2 = &quot;&quot;
  For y = 1 To Len(tmpStr)
    'Find ASCII value of character
    tmpDec = Asc(Mid(tmpStr, y, 1))
    'Convert ASCII char to Hex
    tmpHex = Hex(tmpDec)
    'As this is a Hex field representing a 2 digit number, make sure it is 2 chars long (leading zero if necessary)
    tmpstr2 = tmpstr2 & String(2 - Len(tmpHex), &quot;0&quot;) & tmpHex
  Next y
tmpStr = tmpstr2
End Sub


Private Sub xTractRcd(xFrom, xLen, xString, dataBuf)
  xString = &quot;&quot;
  For x = xFrom To xFrom + xLen - 1
    xString = xString & Chr(dataBuf(x))
  Next x
End Sub


Private Sub Form_Resize()
With ListView1
  .Left = 0
  .Top = 0
  .Width = Form1.ScaleWidth
  .Height = Form1.ScaleHeight
  
  .View = lvwReport
End With
End Sub