Option Strict Off
Option Explicit On
Imports VB = Microsoft.VisualBasic
Imports marshal = System.Runtime.InteropServices.Marshal
Imports System
Imports System.Text
<System.Runtime.InteropServices.ProgId("DataTable_NET.DataTable")> Public Class ADOBndDataTable
inherits System.Data.DataTable
' Fetch behaviour
'
' Fetchtype = DOES_FETCH_ABSOLUTE - next,previous,absolute
' Fetchtype = DOES_FETCH_BOOKMARK - next and positions on bookmark
' Fetchtype = DOES_FETCH_PRIOR - next,prior
' Fetchtype = DOES_FETCH_ROWID - use second cursor for rowid
' Fetchtype = DOES_FETCH_NEXT - next only
'
Private rowsknown As Boolean
private FirstFetchCall as boolean
Private maxrow As Integer
Private maxstdrow As Integer
Private numaddedrows As Integer
Private pvBOF As Boolean
Private pvEOF As Boolean
Private addedrows() As addedrowdata
Private scrollable As Boolean
Private dfu As Boolean
Private nonscrollrowid As String '* 50
public AOTableName as string
public Loading as boolean
'Private nonscrollrowidlen As Long
Private Const bkmrkcol As Short = 0
Private currpos As Integer
Private maxrowfetched As Integer
Private rows_fetched As Integer
Private stmt As Integer
Private mainstmt As Integer
Private createdok As Short
Private COlDat() As coldata
Private numcols As Short
Private CursorName As String
Private gHnd As Integer
Private GAddr As System.IntPtr
Private CurrAddr As System.IntPtr
Private recsize As Integer
Private noFetched As Integer
Private rowstat() As Short
Private tblName As string
Private FieldList As Object
Private whereclause As String
Private orderclause As String
Private updateclause As String
Private pvHstmt As Integer
Private hdbcv As Integer
Private henv As Integer
Private initialized As Boolean
Private fs As fileset
Public cols As New Collection
Private sqlstat As String
Private HDB As HDBC
Friend Sub setparent(ByRef po As HDBC)
HDB = po
initialized = True
End Sub
public readonly property HDBC() as HDBC
get
return HDB
End Get
End Property
Private Sub addcolumns(ByVal colnum As Short)
'Dim col As New DCol
'With col
' .datatype = COlDat(colnum%).datatype
' .colsize = COlDat(colnum%).colsize
' .coloffset = COlDat(colnum%).coloffset
' .coltitle = COlDat(colnum%).coltitle
' .colname = COlDat(colnum%).colname
' .extradata = COlDat(colnum%).extradata
' .retval = COlDat(colnum%).retval
' .defaultval = COlDat(colnum%).defaultval
' .capitalize = COlDat(colnum%).capitalize
' .editable = COlDat(colnum%).editable
' .longdata = COlDat(colnum%).longdata
' .nodisplay = COlDat(colnum%).nodisplay
'End With
'cols.Add col, CStr(colnum%)
'Set col = Nothing
End Sub
Private Sub AddRow()
Dim colnum As Short
Dim scnt As Short
Dim frs As Object
Dim l_true As Integer
l_true = -1
If Not createdok Then
MsgBox("Add Row executed on uninitialized dataset")
Exit Sub
End If
Do While Not rowsknown
frs = fetch()
Loop
numaddedrows = numaddedrows + 1
If numaddedrows = 1 Then
ReDim addedrows(1)
Else
ReDim Preserve addedrows(numaddedrows)
End If
addedrows(numaddedrows).RowHnd = GlobalAlloc(0, recsize)
addedrows(numaddedrows).RowAddr = GlobalLockPtr(addedrows(numaddedrows).RowHnd)
'addedrows(numaddedrows).RowAddr = marshal.AllocHGlobal(recsize)
currpos = maxstdrow + numaddedrows
maxrow = currpos
CurrAddr = addedrows(numaddedrows).RowAddr
If HDB.FetchType() = DOES_FETCH_ROWID Then
scnt = 2
Else
scnt = 1
End If
'initialize cols with null values
For colnum = scnt To numcols
marshal.WriteInt32(IntPtr.op_Explicit(CurrAddr.ToInt32 + COlDat(colnum).coloffset + COlDat(colnum).colsize), l_true)
'agCopyData(l_true, CInt(CurrAddr + COlDat(colnum).coloffset + COlDat(colnum).colsize), 4)
Next colnum
pvBOF = False
pvEOF = False
End Sub
Private ReadOnly Property nocols() As Short
Get
If HDB.FetchType() = DOES_FETCH_ROWID Then
nocols = numcols - 1
Else
nocols = numcols
End If
End Get
End Property
Private ReadOnly Property RowCount() As Integer
Get
Dim frs As Object
Do While Not rowsknown
frs = fetch()
Loop
RowCount = maxrow
End Get
End Property
Private ReadOnly Property Cursor() As String
Get
Return CursorName
End Get
End Property
Private ReadOnly Property BOF() As Boolean
Get
BOF = pvBOF
End Get
End Property
Private ReadOnly Property EOF() As Boolean
Get
EOF = pvEOF
End Get
End Property
Private ReadOnly Property CurrentMaxRow() As Integer
Get
If rowsknown Then
CurrentMaxRow = maxrow
Else
CurrentMaxRow = maxrowfetched
End If
End Get
End Property
private ReadOnly Property MaxRowKnown() As Boolean
Get
MaxRowKnown = rowsknown
End Get
End Property
friend Function create(ByVal f_nam As String, ByVal t_nam As String, ByVal w_cls As String, ByVal o_cls As String, ByVal u_cls As String, Optional ByRef scrollreq As Object = Nothing, Optional ByRef DropForUpdate As Object = Nothing) As Boolean
Dim es As String
Dim RL As Integer
Dim this_name As String
Dim pos As Short
Dim col_size As Short
Dim cnm As String
Dim cnt As Short
Dim off_now As Integer
Dim col_nullable As Short
Dim c_scale As Short
Dim col_pres As Integer
Dim data_type As Short
Dim ret_size As Short
Dim rsql As String
Dim fsql As String
Dim sql As String
Dim r As Short
Dim thdbcv As Object
Dim DataCol As System.Data.DataColumn
Dim tenv As Object
'debug.print "in create"
Loading = true
Dim RunWithInfo As Boolean
rowsknown = False
maxrow = 0
maxrowfetched = 0
numaddedrows = 0
ReDim addedrows(1)
pvBOF = True
'debug.print "pvBOF set to true on create"
pvEOF = False
On Error GoTo createerr
If IsNothing(scrollreq) Then
scrollable = False
'debug.print "Non-scrollable table to be created"
Else
If scrollreq Then
scrollable = True
'debug.print "Srollable table to be created"
Else
scrollable = False
'debug.print "Non-scrollable table to be created"
End If
End If
If IsNothing(DropForUpdate) Then
dfu = False
Else
If DropForUpdate Then
dfu = True
Else
dfu = False
End If
End If
'Debug.Print "DB IS " & HDB.HostDatabase & " o_cls$ " & o_cls$
If (HDB.HostDatabase = "ACCESS") Or (HDB.HostDatabase = "SQLBASE" And o_cls <> "") Then
'Debug.Print "DB IS " & HDB.HostDatabase & " o_cls$ " & o_cls$ & " Setting drop for update"
dfu = True
End If
tblName = UCase(Trim(t_nam))
If tblName = "" Then
MsgBox("Invalid table name")
create = False
Exit Function
End If
f_nam = (Trim(f_nam))
'''''''debug.print f_nam$
w_cls = Trim(w_cls)
If w_cls <> "" Then
If Left(w_cls, 5) <> "WHERE" Then
w_cls = " WHERE " & w_cls
Else
w_cls = " " & w_cls
End If
End If
whereclause = w_cls
o_cls = UCase(Trim(o_cls))
If o_cls <> "" Then
If Left(o_cls, 5) <> "ORDER" Then
o_cls = " ORDER BY " & o_cls
Else
o_cls = " " & o_cls
End If
End If
orderclause = o_cls
u_cls = UCase(Trim(u_cls))
If u_cls = "" Then
If f_nam <> "" And f_nam <> "'X'" Then
u_cls = f_nam
Else
MsgBox("Invalid FOR UPDATE field list")
Exit Function
End If
End If
updateclause = u_cls
If f_nam = "" Then
f_nam = "'X'"
End If
FieldList = f_nam
numcols = 0
currpos = 0
pvHstmt = 0
henv = tenv
hdbcv = thdbcv
CursorName = ""
maxrowfetched = 0
rows_fetched = -1
'''''''debug.print "IN create SQL " & sql$
ReDim rowstat(0)
If mainstmt <> 0 Then
'debug.print "Calling sqlfreestmt"
r = SQLFreeStmt(mainstmt, SQL_DROP)
End If
'debug.print "calling alloc"
r = SQLAllocStmt(HDB.handle, mainstmt)
If r <> SQL_SUCCESS Then
mainstmt = 0
create = False
Exit Function
End If
pvHstmt = mainstmt
'put proper test
'debug.print "setting statement options"
Select Case HDB.HostDatabase
Case "ACCESS"
'no settings
If scrollable Then
'r% = SQLSetScrollOptions(mainstmt&, SQL_CONCUR_READ_ONLY, SQL_SCROLL_KEYSET_DRIVEN, 1)
'If Not (r% = SQL_SUCCESS Or r% = SQL_SUCCESS_WITH_INFO) Then
' showerror r%, mainstmt&
' Exit Function
'End If
r = SQLSetScrollOptions(mainstmt, SQL_CONCUR_LOCK, SQL_SCROLL_KEYSET_DRIVEN, 1)
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
showerror(r, mainstmt)
Exit Function
End If
End If
Case "SQLSERVER" ', "ACCESS"
RunWithInfo = True
r = SQLSetStmtOption(mainstmt, SQL_CONCURRENCY, SQL_CONCUR_LOCK)
If Not r = SQL_SUCCESS Then '(r% = SQL_SUCCESS Or r% = SQL_SUCCESS_WITH_INFO) Then
showerror(r, mainstmt)
Exit Function
End If
r = SQLSetStmtOption(mainstmt, SQL_CURSOR_TYPE, SQL_CURSOR_DYNAMIC)
If Not r = SQL_SUCCESS Then 'Not (r% = SQL_SUCCESS Or r% = SQL_SUCCESS_WITH_INFO) Then
showerror(r, mainstmt)
Exit Function
End If
Case "SQLBASE"
If scrollable Then
r = SQLSetScrollOptions(mainstmt, SQL_CONCUR_READ_ONLY, SQL_SCROLL_KEYSET_DRIVEN, 1)
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
showerror(r, mainstmt)
Exit Function
End If
'r% = SQLSetScrollOptions(mainstmt&, SQL_CONCUR_LOCK, SQL_SCROLL_KEYSET_DRIVEN, 1)
'If Not (r% = SQL_SUCCESS Or r% = SQL_SUCCESS_WITH_INFO) Then
' showerror r%, mainstmt&
' Exit Function
'End If
Else
r = SQLSetScrollOptions(mainstmt, SQL_CONCUR_READ_ONLY, SQL_SCROLL_FORWARD_ONLY, 1)
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
showerror(r, mainstmt)
Exit Function
End If
'r% = SQLSetScrollOptions(mainstmt&, SQL_CONCUR_LOCK, SQL_SCROLL_FORWARD_ONLY, 1)
'If Not (r% = SQL_SUCCESS Or r% = SQL_SUCCESS_WITH_INFO) Then
' showerror r%, mainstmt&
' Exit Function
'End If
End If
Case "ANYWHERE"
'''''''debug.print "Setting anywhere dataset options"
r = SQLSetStmtOption(mainstmt, SQL_CONCURRENCY, SQL_CONCUR_LOCK)
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
'''''''debug.print "Failed on set concurrent lock"
showerror(r, mainstmt)
Exit Function
End If
r = SQLSetStmtOption(mainstmt, SQL_CURSOR_TYPE, SQL_CURSOR_STATIC)
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
'''''''debug.print "Failed on set dynamic cursor"
showerror(r, mainstmt)
Exit Function
End If
Case "ORACLE"
'no special settings required
Case Else
'''debug.print "****************** UNEXPECTED OPTION *****************"
If HDB.ssreq() Then
If HDB.sslockreq() Then
' "SQLSERVER"
r = SQLSetStmtOption(mainstmt, SQL_CONCURRENCY, SQL_CONCUR_LOCK)
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
'''''''debug.print "Failed on set concurrent lock"
showerror(r, mainstmt)
Exit Function
End If
r = SQLSetStmtOption(mainstmt, SQL_CURSOR_TYPE, SQL_CURSOR_DYNAMIC)
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
'''''''debug.print "Failed on set dynamic cursor"
showerror(r, mainstmt)
Exit Function
End If
Else
If scrollable Then
' "SQLBASE"
r = SQLSetScrollOptions(mainstmt, SQL_CONCUR_READ_ONLY, SQL_SCROLL_KEYSET_DRIVEN, 1)
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
'''''''debug.print "Failed on set dynamic cursor"
showerror(r, mainstmt)
Exit Function
End If
End If
'r% = SQLSetStmtOption(mainstmt&, SQL_CONCURRENCY, SQL_CONCUR_LOCK)
'If Not (r% = SQL_SUCCESS Or r% = SQL_SUCCESS_WITH_INFO) Then
' '''''''debug.print "Failed on set concurrency"
' showerror r%, mainstmt&
' Exit Function
'End If
End If
End If
End Select
'debug.print "create pos bef sql"
If HDB.FetchType() = DOES_FETCH_ROWID Then
sql = "SELECT ROWID," & FieldList & " FROM " & tblName
Else
sql = "SELECT " & FieldList & " FROM " & tblName
End If
'Debug.Print sql$
fsql = sql & w_cls & o_cls
If Not dfu Then
fsql = fsql & " FOR UPDATE OF " & u_cls
End If
'Debug.Print fsql$
'Debug.Print "Calling SQLExecDirectt"
r = SQLExecDirect(mainstmt, fsql, CInt(Len(fsql)))
'Debug.Print "SQLExecDirectt done"
If r <> SQL_SUCCESS Then
If Not (r = SQL_SUCCESS_WITH_INFO And RunWithInfo) Then
MsgBox("Fail on " & fsql)
Call showerror(r, mainstmt)
mainstmt = 0
create = False
Exit Function
End If
End If
db("SPHYG CREATE DTAB " & fsql)
If HDB.FetchType() = DOES_FETCH_ROWID And scrollable Then
fs.bufsize = 50
openset(fs)
fs.RowHnd = GlobalAlloc(0, fs.bufsize)
fs.RowAddr = GlobalLockPtr(fs.RowHnd)
'fs.RowAddr = marshal.AllocHGlobal(fs.bufsize)
rsql = sql & " WHERE ROWID = ?"
If fs.RowStmt <> 0 Then
r = SQLFreeStmt(fs.RowStmt, SQL_DROP)
End If
r = SQLAllocStmt(HDB.handle, fs.RowStmt)
'''''debug.print "Allocating row stmt"
'''''''debug.print "binding to mem addr " & Format$(fs.RowAddr)
'''''''debug.print "buf size " & Format$(fs.bufsize)
'addcursor fs.RowStmt, rsql$
r = SQLPrepare(fs.RowStmt, rsql, CInt(Len(rsql)))
If r <> SQL_SUCCESS Then
MsgBox("Failed on " & rsql)
'''''''debug.print rsql$
Call showerror(r, fs.RowStmt)
r = SQLFreeStmt(fs.RowStmt, SQL_DROP)
fs.RowStmt = 0
Exit Function
End If
'''''debug.print "row stmt prepared"
r = SQLSetParam(fs.RowStmt, 1, SQL_C_CHAR, SQL_CHAR, fs.bufsize, 0, fs.RowAddr, fs.reclen)
If r <> SQL_SUCCESS Then
showerror(r, fs.RowStmt)
Exit Function
End If
'''''debug.print "row param set"
ElseIf HDB.FetchType() = DOES_FETCH_BOOKMARK Then
fs.bufsize = 50
openset(fs)
fs.RowHnd = GlobalAlloc(0, fs.bufsize)
fs.RowAddr = GlobalLockPtr(fs.RowHnd)
'fs.RowAddr = marshal.AllocHGlobal(fs.bufsize)
End If
'debug.print "create pos b"
sqlstat = sql
CursorName = SGC(mainstmt)
'Debug.Print "Cursor is " & Format$(CursorName)
'''''debug.print "pos b1"
r = SQLNumResultCols(mainstmt, numcols)
'''''''debug.print "pos d"
'''''debug.print "pos b2"
If r <> SQL_SUCCESS Then
Call showerror(r, mainstmt)
MsgBox("Err on numresult col")
create = False
Exit Function
End If
'debug.print "pos b3"
ret_size = 0
data_type = 0
col_pres = 0
c_scale = 0
col_nullable = 0
ReDim COlDat(numcols)
off_now = 0
'debug.print "pos b4"
For cnt = 1 To numcols
DataCol = New system.Data.DataColumn()
'''''debug.print "pos b5 top loop"
cnm = New String(Chr(0), 501)
col_size = 500
r = SQLDescribeCol(mainstmt, cnt, cnm, col_size, ret_size, data_type, col_pres, c_scale, col_nullable)
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
Call showerror(r, mainstmt)
MsgBox("Error in sqldescribecol in " & sql)
create = False
Exit Function
End If
pos = InStr(1, cnm, Chr(0))
this_name = Left(cnm, pos - 1)
If this_name = "" Then
this_name = "CNM_" & VB6.Format(cnt)
End If
COlDat(cnt).colpres = col_pres
COlDat(cnt).colscale = c_scale
COlDat(cnt).colnullable = col_nullable
COlDat(cnt).dbdatatype = data_type
Select Case data_type
Case SQL_CHAR, SQL_VARCHAR, -9
COlDat(cnt).colsize = col_pres + 1
COlDat(cnt).extradata = False
COlDat(cnt).datatype = SQL_C_CHAR
DataCol.DataType = System.Type.GetType("System.String")
Case SQL_BINARY, SQL_VARBINARY, -9
COlDat(cnt).colsize = col_pres + 1
COlDat(cnt).extradata = False
COlDat(cnt).datatype = SQL_C_CHAR
DataCol.DataType = System.Type.GetType("System.String")
Case SQL_LONGVARCHAR
COlDat(cnt).colsize = 4096
COlDat(cnt).extradata = True
COlDat(cnt).datatype = SQL_C_CHAR
DataCol.DataType = System.Type.GetType("System.String")
Case SQL_LONGVARBINARY
COlDat(cnt).colsize = 4096
COlDat(cnt).extradata = True
COlDat(cnt).datatype = SQL_C_CHAR
DataCol.DataType = System.Type.GetType("System.String")
Case SQL_BIT, SQL_TINYINT, SQL_SMALLINT
COlDat(cnt).colsize = 2
COlDat(cnt).extradata = False
COlDat(cnt).datatype = SQL_C_SHORT
DataCol.DataType = System.Type.GetType("System.Int32")
Case SQL_INTEGER
COlDat(cnt).colsize = 4
COlDat(cnt).extradata = False
COlDat(cnt).datatype = SQL_C_LONG
DataCol.DataType = System.Type.GetType("System.Int32")
'Case SQL_BIGINT
' COlDat(cnt).colsize = 4
' COlDat(cnt).extradata = False
' COlDat(cnt).datatype = SQL_C_LONG
' DataCol.DataType = System.Type.GetType("System.Int64")
Case SQL_BIGINT,SQL_FLOAT, SQL_DOUBLE, SQL_NUMERIC, SQL_DECIMAL, SQL_REAL
COlDat(cnt).colsize = 8
COlDat(cnt).extradata = False
COlDat(cnt).datatype = SQL_C_DOUBLE
DataCol.DataType = System.Type.GetType("System.Decimal")
'Case SQL_TIME
' coldat(cnt%).colsize = 6
' coldat(cnt%).extradata = False
' coldat(cnt%).datatype = SQL_C_TIME
Case SQL_DATE
COlDat(cnt).colsize = 6
COlDat(cnt).extradata = False
COlDat(cnt).datatype = SQL_C_DATE
DataCol.DataType = System.Type.GetType("System.DateTime")
Case SQL_TIMESTAMP
COlDat(cnt).colsize = 16 '23
COlDat(cnt).extradata = False
COlDat(cnt).datatype = SQL_C_TIMESTAMP
DataCol.DataType = System.Type.GetType("System.DateTime")
Case Else
MsgBox("Unrecognized data type")
Exit Function
End Select
COlDat(cnt).coloffset = off_now
COlDat(cnt).colname = this_name
COlDat(cnt).coltitle = this_name
off_now = off_now + COlDat(cnt).colsize + 4 ' null ind/ length
COlDat(cnt).defaultval = System.DBNull.Value
'''''debug.print "Col " & Format$(cnt%) & " size is " & Format$(COlDat(cnt%).colsize)
'addcolumns cnt%
DataCol.ColumnName = this_name
DataCol.ReadOnly = false
DataCol.Unique = false
datacol.AllowDBNull = cbool(COlDat(cnt).colnullable)
mybase.Columns.Add(DataCol)
Next cnt
If gHnd <> 0 Then
RL = GlobalUnlock(gHnd)
gHnd = GlobalFree(gHnd)
gHnd = 0
End If
recsize = off_now
gHnd = GlobalAlloc(0, recsize)
GAddr = GlobalLockPtr(gHnd)
'GAddr = marshal.AllocHGlobal(recsize)
If HDB.FetchType() = DOES_FETCH_ROWID And scrollable Then
fs.FetchHnd = GlobalAlloc(0, recsize)
fs.FetchAddr = GlobalLockPtr(fs.FetchHnd)
'fs.FetchAddr = marshal.AllocHGlobal(recsize)
End If
For cnt = 1 To numcols
COlDat(cnt).retval = 0
''''''''''debug.print "Binding col " & Format$(cnt%) & " datatype is " & Format$(COlDat(cnt%).datatype) & " addr " & Format$(CLng(GAddr + COlDat(cnt%).coloffset)) & " size " & Format$(CLng(COlDat(cnt%).colsize))
r = SQLBindCol(mainstmt, cnt, COlDat(cnt).datatype, IntPtr.op_Explicit(GAddr.ToInt32 + COlDat(cnt).coloffset), CInt(COlDat(cnt).colsize), COlDat(cnt).retval)
If r <> SQL_SUCCESS Then
Call showerror(r, mainstmt)
MsgBox("Error in sqlbindcol")
End If
If HDB.FetchType() = DOES_FETCH_ROWID And scrollable Then
r = SQLBindCol(fs.RowStmt, cnt, COlDat(cnt).datatype, IntPtr.op_Explicit(fs.FetchAddr.ToInt32 + COlDat(cnt).coloffset), CInt(COlDat(cnt).colsize), COlDat(cnt).retval)
If r <> SQL_SUCCESS Then
Call showerror(r, fs.RowStmt)
MsgBox("Error in sqlbindcol")
End If
End If
''''''''''debug.print "col " & Format$(cnt%) & " bound"
Next cnt
Dim PrimaryKeyColumns(0) As DataColumn
dim pk_cnt as Integer = 0
sql = GetPKStr(t_nam)
dim sds as SDataset
dim ColNam as string
dim KeySeq as integer
sds = hdb.CreateSDataset(sql)
do while sds.fetch()
ColNam = sds.FetchString(4)
KeySeq = sds.FetchLong(5)
if pk_cnt > 0 then
redim preserve PrimaryKeyColumns(pk_cnt)
End If
PrimaryKeyColumns(pk_cnt)= mybase.Columns(COlNam)
pk_cnt += 1
Loop
sds.Free
sds = nothing
if pk_cnt > 0 then
mybase.PrimaryKey = PrimaryKeyColumns
end if
AOTableName = t_nam
mybase.TableName = t_nam
createdok = True
'Debug.Print "create pos d"
dim RowCnt as Integer
rowcnt = 0
do while fetch()
rowcnt+=1
dim datarow as dataRow
DataRow = mybase.NewRow
for cnt = 1 to numcols
select case COlDat(cnt).dbdatatype
Case SQL_CHAR, SQL_VARCHAR, SQL_BINARY, SQL_VARBINARY, -9
DataRow(coldat(cnt).colname) = FetchString(cnt)
Case SQL_LONGVARCHAR, SQL_LONGVARBINARY
DataRow(coldat(cnt).colname) = FetchString(cnt)
Case SQL_BIT, SQL_TINYINT, SQL_SMALLINT,SQL_INTEGER
DataRow(coldat(cnt).colname) = Fetchlong(cnt)
Case SQL_BIGINT
DataRow(coldat(cnt).colname) = cdec(Fetchdouble(cnt))
Case SQL_FLOAT, SQL_DOUBLE, SQL_NUMERIC, SQL_DECIMAL, SQL_REAL
DataRow(coldat(cnt).colname) = cdec(Fetchdouble(cnt))
Case SQL_DATE,SQL_TIMESTAMP
DataRow(coldat(cnt).colname) = Fetchdate(cnt)
Case Else
MsgBox("Unrecognized data type")
Exit Function
End Select
Next
mybase.Rows.Add(DataRow)
DataRow = nothing
loop
FirstFetchCall = true
Loading = false
create = True
Exit Function
createerr:
If Err.Number <> 0 Then
es = Err.Description
Else
es = ""
End If
Err.Raise(1 + vbObjectError, , es & " error creating datatable")
End Function
private Sub saveinserts()
Dim RL As Integer
Dim r As Short
Dim updstmt As Integer
Dim S As String
Dim copylen As Integer
Dim this_dbl_date As Double
Dim this_val As String
Dim Col As Object
Dim valstring As String
Dim colstring As String
Dim scnt As Short
Dim donecol1 As Object
Dim dirtyfnd As Object
Dim arcnt As Short
Dim lstring As String 'VB6.FixedLengthString(4096)
Dim ldouble(0) As Double
Dim lint(0) As Short
Dim llong(0) As Integer
Dim ldate As DATE_STRUCT
Dim ltimestamp As TIMESTAMP_STRUCT
If numaddedrows > 0 Then
For arcnt = 1 To numaddedrows
CurrAddr = addedrows(arcnt).RowAddr
dirtyfnd = False
donecol1 = False
If HDB.FetchType() = DOES_FETCH_ROWID Then
scnt = 2
Else
scnt = 1
End If
colstring = ""
valstring = ""
For Col = scnt To numcols
COlDat(Col).retval = marshal.readint32(CurrAddr, COlDat(Col).coloffset + COlDat(Col).colsize)
'agCopyData(CInt(CurrAddr + COlDat(Col).coloffset + COlDat(Col).colsize), COlDat(Col).retval, 4)
If COlDat(Col).retval <> SQL_NULL_DATA Then
dirtyfnd = True
Select Case COlDat(Col).datatype
Case SQL_C_DATE
Dim ldate1 As DATE_STRUCT = CType(marshal.PtrToStructure(IntPtr.op_Explicit(CurrAddr.ToInt32 + COlDat(Col).coloffset), GetType(DATE_STRUCT)), DATE_STRUCT)
ldate = ldate1
'agCopyData(CInt(CurrAddr + COlDat(Col).coloffset), ldate, CInt(COlDat(Col).colsize))
this_val = HDB.Fdate(DateSerial(ldate.year_Renamed, ldate.month_Renamed, ldate.day_Renamed))
Case SQL_C_TIMESTAMP
Dim ltimestamp1 As TIMESTAMP_STRUCT = CType(marshal.PtrToStructure(IntPtr.op_Explicit(CurrAddr.ToInt32 + COlDat(Col).coloffset), GetType(TIMESTAMP_STRUCT)), TIMESTAMP_STRUCT)
ltimestamp = ltimestamp1
'agCopyData(CInt(CurrAddr + COlDat(Col).coloffset), ltimestamp, CInt(COlDat(Col).colsize))
'''''''debug.print "Ret col " & Format$(col) & " as timestamp"
this_dbl_date = DateSerial(ltimestamp.year_Renamed, ltimestamp.month_Renamed, ltimestamp.day_Renamed).ToOADate() + (ltimestamp.hour_Renamed / 24) + (ltimestamp.minute_Renamed / (1440)) + (ltimestamp.second_Renamed / (86400))
this_val = HDB.Fdatetime(System.Date.FromOADate(this_dbl_date)) ' + hfrac# + mfrac# + sfrac#)
Case SQL_C_SHORT
marshal.Copy(IntPtr.op_Explicit(CurrAddr.ToInt32 + COlDat(Col).coloffset), lint, 0, 1)
'agCopyData(CInt(CurrAddr + COlDat(Col).coloffset), lint, CInt(COlDat(Col).colsize))
'''''''debug.print "Ret col " & Format$(col) & " as int"
this_val = CStr(lint(0))
Case SQL_C_LONG
marshal.Copy(IntPtr.op_Explicit(CurrAddr.ToInt32 + COlDat(Col).coloffset), llong, 0, 1)
'agCopyData(CInt(CurrAddr + COlDat(Col).coloffset), llong, CInt(COlDat(Col).colsize))
'''''''debug.print "Ret col " & Format$(col) & " as long"
this_val = CStr(llong(0))
Case SQL_C_DOUBLE
'agCopyData(CInt(CurrAddr + COlDat(Col).coloffset), ldouble, CInt(COlDat(Col).colsize))
marshal.Copy(IntPtr.op_Explicit(CurrAddr.ToInt32 + COlDat(Col).coloffset), ldouble, 0, 1) 'COlDat(Col).coloffset, CInt(COlDat(Col).colsize))
'''''''debug.print "Ret col " & Format$(col) & " as double"
this_val = CStr(ldouble(0))
Case Else
If COlDat(Col).retval <= 4096 Then
copylen = COlDat(Col).retval
Else
copylen = 4096
MsgBox("Warning, data greater than 4096 characters truncated")
End If
lstring = marshal.PtrToStringAnsi(IntPtr.op_Explicit(CurrAddr.ToInt32 + COlDat(Col).coloffset)) ', copylen)
'agCopyData(CInt(CurrAddr + COlDat(Col).coloffset), lstring.Value, copylen)
'''''''debug.print "Ret col " & Format$(col) & " as string"
this_val = fds(lstring) 'fds(Left(lstring.Value, COlDat(Col).retval))
End Select
If colstring <> "" Then
colstring = colstring & ", "
valstring = valstring & ", "
End If
colstring = colstring & COlDat(Col).colname
valstring = valstring & this_val
End If
Next Col
If dirtyfnd Then
S = "INSERT INTO " & tblName & " (" & colstring & ") VALUES (" & valstring & ")"
''''''debug.print s$
r = SQLAllocStmt(HDB.handle, updstmt)
If r <> SQL_SUCCESS Then
Call showerror(r, updstmt)
MsgBox("Insert Failed on alloc")
Exit Sub
End If
''debug.print s$
r = SQLExecDirect(updstmt, S, CInt(Len(S)))
If r = SQL_SUCCESS_WITH_INFO Then
Call showerror(r, updstmt)
ElseIf Not (r = SQL_SUCCESS) Then
Call showerror(r, updstmt)
MsgBox("Insert Failed on exec " & S)
Exit Sub
Else
''''''debug.print "upd returns " & Format$(r%)
End If
r = SQLFreeStmt(updstmt, SQL_DROP)
Else
''''''debug.print "dirty NOT FND on row " & Format$(arcnt%)
End If
RL = GlobalUnlock(addedrows(arcnt).RowHnd)
addedrows(arcnt).RowHnd = GlobalFree(addedrows(arcnt).RowHnd)
Next arcnt
End If
numaddedrows = 0
ReDim addedrows(1)
End Sub
Private Sub showerror(ByVal errnum As Short, ByVal hstmt As Integer)
showdberror(HDB.henv, HDB.handle, errnum, hstmt)
End Sub
private Function SGC(ByVal hstmt As Integer) As String
Dim pos As Short
Dim r As Short
Dim ohstmt As Integer
Dim lbuf As New VB6.FixedLengthString(255)
Dim cur_size As Short
Dim ret_size As Short
Dim cn As String
cn = ""
If HDB.FetchType() = DOES_FETCH_ROWID Then
If pvBOF Or pvEOF Then
cn = ""
Else
cn = FetchString(0) '(hstmt, 1)
End If
Else
cur_size = 255
r = SQLGetCursorName(hstmt, lbuf.Value, cur_size, ret_size)
pos = InStr(1, lbuf.Value, Chr(0))
If pos > 0 Then
cn = Trim(Left(lbuf.Value, pos - 1))
End If
End If
SGC = cn
End Function
Private Function fetch(Optional ByVal FetchType As Object = Nothing, Optional ByVal rval As Object = Nothing) As Boolean
Dim nxpos As Integer
Dim dbcnt As Short
Dim cpos As Integer
Dim cr As Short
Dim br As Short
Dim cnt As Short
Dim S As String
Dim r As Short
Dim fstfetch As Object
Dim chkrow As Integer
Dim rv As Integer 'set as required row
Dim lstring As New VB6.FixedLengthString(50)
Dim upd As Boolean
Dim freset As Boolean
Dim ftyp As Object
Static lr As Integer ' set as last row fetched overall
Static lmrf As Integer ' set as last row fetched overall
''''debug.print "In fetch routine"
rv = 0
fetch = False
freset = False
If Not createdok Then
MsgBox("Fetch executed on uninitialized dataset")
currpos = -1
Exit Function
End If
If IsNothing(FetchType) Then
ftyp = "N"
Else
ftyp = FetchType
End If
if ftyp = "N" and FirstFetchCall then
ftyp = "A"
rval = 1
End If
FirstFetchCall = false
If IsNothing(rval) Then
chkrow = -999
Else
chkrow = CInt(rval)
End If
If currpos > 0 Then
If Not (ftyp = "A" And chkrow = currpos) Then
If scrollable And HDB.HostDatabase = "SQLBASE" And HDB.FetchType() = DOES_FETCH_ROWID Then
Free()
'''debug.print "Calling create"
Call create(FieldList, tblName, whereclause, orderclause, updateclause, scrollable, dfu)
freset = True
End If
Else
fetch = True
Exit Function
End If
End If
If ftyp <> "N" And Not scrollable Then
MsgBox("Invalid fetch type on non-scrollable datatable")
Exit Function
End If
''''''debug.print "scroll or not?"
If scrollable Then
'''debug.print "in scrollable"
If freset Then
'''debug.print "pt A ftyp " & Format$(ftyp) & " lr& " & Format$(lr&)
If ftyp = "N" Then
rv = lr + 1
ftyp = "A"
ElseIf ftyp = "P" Then
rv = lr - 1
ftyp = "A"
ElseIf ftyp = "A" Then
rv = rval
End If
Else
'''debug.print "pt B"
If ftyp = "A" Then
'''debug.print "pt B1"
If IsNothing(rval) Then
ftyp = "N"
If pvBOF Then
rv = 1
ElseIf pvEOF Then
Exit Function
Else
rv = lr + 1
End If
Else
'''debug.print "pt B2"
rv = rval
If lr = rv Then
'already on required row
fetch = True
Exit Function
ElseIf lr = rv - 1 Then
'next row req
ftyp = "N"
ElseIf lr = rv + 1 Then
ftyp = "P"
End If
End If
ElseIf ftyp = "N" Then
If pvBOF Then
rv = 1
ElseIf pvEOF Then
Exit Function
Else
rv = lr + 1
End If
ElseIf ftyp = "P" Then
If pvBOF Then
Exit Function
ElseIf pvEOF Then
rv = maxrow
Else
rv = lr - 1
End If
End If
End If
'''debug.print "Fetching row with index " & Format$(rv) & " type " & ftyp
If rowsknown And rv > maxstdrow Then
''''''debug.print "rows known fetch "
If (rv - maxstdrow) <= numaddedrows Then
CurrAddr = addedrows(rv - maxstdrow).RowAddr
Else
rv = -1
pvEOF = True
End If
currpos = rv
''''''debug.print "currpos set to " & Format$(currpos)
ElseIf HDB.FetchType() = DOES_FETCH_ROWID And scrollable Then
'no longer supported
Else
CurrAddr = GAddr
stmt = mainstmt
If HDB.FetchType() = DOES_FETCH_BOOKMARK Then
'SET UP TO CREATE FILeSET INFO
''''''debug.print "In bookmark"
Else
''debug.print "In fetch abs supported"
Select Case ftyp
Case "N"
r = SQLExtendedFetch(mainstmt, SQL_FETCH_NEXT, rv, noFetched, rowstat(0))
Case "P"
If HDB.fp() Then
''''''debug.print "Calling prior fetch"
r = SQLExtendedFetch(mainstmt, SQL_FETCH_PRIOR, rv, noFetched, rowstat(0))
Else
r = SQLExtendedFetch(mainstmt, SQL_FETCH_ABSOLUTE, rv, noFetched, rowstat(0))
End If
Case "A"
If Not (HDB.FetchType() = DOES_FETCH_ABSOLUTE) Then
cpos = lr
''''''debug.print "Setting cpos to lr " & Format$(cpos&) & " rv is " & Format$(rv)
If rv > cpos And cpos >= 0 Then
''''''debug.print "In rv > cpos"
dbcnt = 0
Do While rv > cpos
''''''debug.print "In loop rv > cpos, about to fetch"
r = SQLExtendedFetch(mainstmt, SQL_FETCH_NEXT, rv, noFetched, rowstat(0))
''''''debug.print "Fetch done"
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
''''''debug.print "error on fetch"
If r = SQL_NO_DATA_FOUND Or HDB.HostDatabase = "ANYWHERE" Then
If lr > 0 Then
pvBOF = False
''''''debug.print "pvBOF set to false by fetch at end (lr > 0)"
End If
currpos = -1
pvEOF = True
rv = -1
cpos = -1
If rowsknown = False Then
rowsknown = True
maxrow = maxrowfetched
maxstdrow = maxrowfetched
End If
''''''debug.print "no data cpos is -1 rv is -1"
Else
currpos = -1
pvEOF = True
pvBOF = True
''''''debug.print "pvBOF set to true by error"
rv = -99
cpos = -99
''''''debug.print "error cpos is -99 rv is -99"
End If
Else
cpos = cpos + 1
If cpos > maxrowfetched Then
maxrowfetched = cpos
End If
''''''debug.print "Cpos incremented to " & Format$(cpos&) & " rv still " & Format$(rv)
End If
'dbcnt% = dbcnt% + 1
'If dbcnt% > 10 Then
' Exit Function
' ''''''debug.print "Crash out"
'End If
Loop
Else
If cpos < 0 Then
If rowsknown Then
If rv > maxstdrow Or maxstdrow = 0 Then
Exit Function
End If
r = SQLExtendedFetch(mainstmt, SQL_FETCH_PRIOR, rv, noFetched, rowstat(0))
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
currpos = -1
pvEOF = True
pvBOF = True
''''''debug.print "pvBOF set to true by fetch prior error"
rv = -99
cpos = -99
Exit Function
Else
cpos = maxstdrow
currpos = maxstdrow
End If
Else
currpos = -1
pvEOF = True
pvBOF = True
''''''debug.print "pvBOF set to true (x)"
rv = -99
cpos = -99
Exit Function
End If
End If
Do While cpos > rv
r = SQLExtendedFetch(mainstmt, SQL_FETCH_PRIOR, rv, noFetched, rowstat(0))
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
If r = SQL_NO_DATA_FOUND Or HDB.HostDatabase = "ANYWHERE" Then
If lr > 0 Then
pvEOF = False
End If
currpos = -1
pvBOF = True
''''''debug.print "pvBOF set to true on no data on prior by fetch"
rv = 0
cpos = 0
Else
currpos = -1
pvEOF = True
pvBOF = True
''''''debug.print "pvBOF set to true by error (y)"
rv = -99
cpos = -99
End If
Else
cpos = cpos - 1
End If
Loop
End If
Else
''debug.print "Calling absolute fetch"
r = SQLExtendedFetch(mainstmt, SQL_FETCH_ABSOLUTE, rv, noFetched, rowstat(0))
End If
Case Else
MsgBox("Invalid fetch request")
End Select
''''''debug.print "Fetch done"
If r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO Then
pvEOF = False
pvBOF = False
''''''debug.print "pvBOF set to false by fetch"
If rv > maxrowfetched Then
maxrowfetched = rv
End If
ElseIf r = SQL_NO_DATA_FOUND Or HDB.HostDatabase = "ANYWHERE" Then
Select Case ftyp
Case "N"
If lr > 0 Then
pvBOF = False
''''''debug.print "pvBOF set to false by no data (lr > 0)"
End If
If rowsknown = False Then
rowsknown = True
maxrow = maxrowfetched
maxstdrow = maxrow
End If
currpos = -1
pvEOF = True
rv = -1
Case "P"
If lr > 0 Then
pvEOF = False
End If
pvBOF = True
''''''debug.print "pvBOF set to true by fetch"
currpos = 0
rv = 0
Case "A"
If lr > 0 Then
pvBOF = False
''''''debug.print "pvBOF set to false by fetch abs"
End If
currpos = -1
pvEOF = True
rv = -1
End Select
Else
MsgBox("Error retrieving row from file set Fetch returns " & VB6.Format(r))
Call showerror(r, mainstmt)
rv = -99
currpos = -1
pvEOF = True
pvBOF = True
''''''debug.print "pvBOF set to true by z"
End If
End If
End If
lr = rv
currpos = rv
''''''debug.print "lr& currpos set to rv " & Format$(rv)
If currpos > 0 Then
pvBOF = False
''''''debug.print "pvBOF set to false by currpos"
pvEOF = False
End If
Else
If rowsknown And currpos >= maxstdrow Then
nxpos = currpos + 1
If (nxpos - maxstdrow) <= numaddedrows Then
CurrAddr = addedrows(nxpos - maxstdrow).RowAddr
currpos = nxpos
Else
currpos = -1
pvEOF = True
End If
Else
''debug.print "non-scroll option"
CurrAddr = GAddr
stmt = mainstmt
If HDB.FetchType() = DOES_FETCH_ROWID Then
''''debug.print "calling sqlfetch"
r = SQLFetch(mainstmt)
Else
''debug.print "calling sqlExtendedfetch"
r = SQLExtendedFetch(mainstmt, SQL_FETCH_NEXT, rv, noFetched, rowstat(0))
End If
''''debug.print "fetch ret " & Format$(r%)
If r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO Then
If r = SQL_SUCCESS_WITH_INFO And HDB.HostDatabase = "SQLBASE" Then
showerror(r, mainstmt)
currpos = -1
pvEOF = True
pvBOF = True
Else
pvEOF = False
pvBOF = False
''debug.print "pvBOF set to false by fwd fetch"
currpos = currpos + 1
If currpos > maxrowfetched Then
maxrowfetched = currpos
End If
If HDB.FetchType() = DOES_FETCH_ROWID Then
nonscrollrowid = FetchString(0)
End If
End If
ElseIf r = SQL_NO_DATA_FOUND Or HDB.HostDatabase = "ANYWHERE" Then
pvEOF = True
''''''debug.print "no data found on fwd fetch, setting currpos& to -1"
currpos = -1
If Not rowsknown Then
rowsknown = True
maxrow = maxrowfetched
maxstdrow = maxrow
End If
Else
Call showerror(r, mainstmt)
currpos = -1
pvEOF = True
pvBOF = True
''''''debug.print "pvBOF set to true by general error K (" & Format$(r%) & ")"
End If
End If
End If
If currpos > 0 Then
fetch = True
''debug.print "setting fetch true (currpos > 0) is " & Format$(currpos&)
Else
fetch = False
''''''debug.print "setting fetch false (currpos <= 0)"
End If
Exit Function
fetcherr:
showvberr(Err)
fetch = False
Exit Function
End Function
Private Function fqqstring(ByVal stmt As Integer, ByVal colnum As Short) As String
Dim r As Short
Dim rgbvalue As String
Dim pcbValue As Integer
Dim retval As String
rgbvalue = New String(Chr(0), 256)
r = SQLGetDataString(stmt, colnum, SQL_C_CHAR, rgbvalue, bufsize, pcbValue)
If Not ((r = SQL_SUCCESS) Or (r = SQL_SUCCESS_WITH_INFO)) Then
fqqstring = ""
showerror(r, stmt)
Else
retval = GetStringFromLPSTR(rgbvalue)
Do While pcbValue > bufsize
r = SQLGetDataString(stmt, colnum, SQL_C_CHAR, rgbvalue, bufsize, pcbValue)
If Not ((r = SQL_SUCCESS) Or (r = SQL_SUCCESS_WITH_INFO)) Then
fqqstring = ""
showerror(r, stmt)
Exit Function
Else
retval = retval & GetStringFromLPSTR(rgbvalue)
End If
Loop
fqqstring = Trim(retval)
End If
End Function
Private Function FetchDate(ByVal colnum As Short) As Date
Dim fd As Object
fd = FetchCol(colnum)
If IsDate(fd) Then
FetchDate = CDate(fd)
Else
FetchDate = Nothing
End If
End Function
Private Function FetchDouble(ByVal colnum As Short) As Double
Dim fchdouble As Object
''''''''debug.print "Fetching col 1"
fchdouble = FetchCol(colnum)
If IsNumeric(fchdouble) Then
''''''''debug.print "numeric ok"
FetchDouble = CDbl(fchdouble)
Else
''''''''debug.print "not numeric"
FetchDouble = 0.0#
End If
End Function
Private Function FetchInt(ByVal colnum As Short) As Short
Dim fchint As Object
On Error GoTo finterr
fchint = FetchCol(colnum)
If IsNumeric(fchint) Then
FetchInt = CShort(fchint)
Else
FetchInt = 0
End If
Exit Function
finterr:
'MsgBox "Error fetching " & fchint
''''''debug.print "Error fetching " & fchint
FetchInt = 0
End Function
Private Function FetchLong(ByVal colnum As Short) As Integer
Dim fchlong As Object
fchlong = FetchCol(colnum)
If IsNumeric(fchlong) Then
FetchLong = CInt(fchlong)
Else
FetchLong = 0
End If
End Function
Private Function FetchString(ByVal colnum As Short) As String
Dim fchString As Object
fchString = FetchCol(colnum)
If VarType(fchString) = VariantType.Null Then
FetchString = ""
Else
If VarType(fchString) = 8 Then
FetchString = fchString
Else
FetchString = CStr(fchString)
End If
End If
End Function
Private Sub Free()
Dim RL As Integer
Dim r As Short
''debug.print "In free"
If mainstmt <> 0 Then
''''''debug.print "Releasing mainstmt"
If currpos > 0 Then
''debug.print "Calling update, currpos is " & Format$(currpos&)
End If
''debug.print "Freeing now"
r = SQLFreeStmt(mainstmt, SQL_DROP)
mainstmt = 0
saveinserts()
End If
If gHnd <> 0 Then
''''''debug.print "releasing memory block"
RL = GlobalUnlock(gHnd)
gHnd = GlobalFree(gHnd)
gHnd = 0
End If
createdok = False
numcols = 0
CursorName = ""
''''''debug.print "dataset freed"
If fs.RowStmt <> 0 Then
''''''debug.print "Releasing rowstmt"
Call SQLFreeStmt(fs.RowStmt, SQL_DROP)
fs.RowStmt = 0
RL = GlobalUnlock(fs.RowHnd)
fs.RowHnd = GlobalFree(fs.RowHnd)
closeSet(fs)
ElseIf HDB.FetchType() = DOES_FETCH_BOOKMARK Then
closeSet(fs)
End If
End Sub
Private Function FetchCol(ByVal Col As Short) As Object
Dim copylen As Integer
Dim this_dbl_date As Double
Dim lstring As String 'New VB6.FixedLengthString(4096)
Dim ldouble(0) As Double
Dim lint(0) As Short
Dim llong(0) As Integer
Dim ldate As DATE_STRUCT
Dim ltimestamp As TIMESTAMP_STRUCT
Dim nullind As Short
'lstring = Space$(2048)
If pvBOF Then
MsgBox("Fetch column attempted when at beginning of data table")
FetchCol = System.DBNull.Value
Exit Function
End If
If pvEOF Then
MsgBox("Fetch column attempted when at end of data table")
FetchCol = System.DBNull.Value
Exit Function
End If
''''''debug.print "Fetching row " & Format$(currpos&) & " col " & Format$(Col) & " numcols is " & Format$(numcols)
If HDB.FetchType() = DOES_FETCH_ROWID Then
Col = Col + 1
End If
If Col > numcols Then
MsgBox("Column number greater than number of columns in data set")
FetchCol = System.DBNull.Value
Exit Function
End If
If rowsknown And currpos > maxstdrow Then
'debug.print "fETCH COL OUSIDE KNOWN RANGE"
COlDat(Col).retval = marshal.ReadInt32(CurrAddr, COlDat(Col).coloffset + COlDat(Col).colsize)
'agCopyData(CInt(CurrAddr + COlDat(Col).coloffset + COlDat(Col).colsize), COlDat(Col).retval, 4)
''''''debug.print "Rows known Copied into coldat(col).retval " & Format$(COlDat(Col).retval)
End If
If COlDat(Col).retval = SQL_NULL_DATA Then
FetchCol = System.DBNull.Value
Exit Function
End If
Select Case COlDat(Col).datatype
Case SQL_C_DATE
Dim ldate1 As DATE_STRUCT = CType(marshal.PtrToStructure(IntPtr.op_Explicit(CurrAddr.ToInt32 + COlDat(Col).coloffset), GetType(DATE_STRUCT)), DATE_STRUCT)
ldate = ldate1
'''''''debug.print "Ret col " & Format$(col) & " as date"
If ldate.year_Renamed <= 0 Then
FetchCol = System.DBNull.Value
Else
FetchCol = DateSerial(ldate.year_Renamed, ldate.month_Renamed, ldate.day_Renamed)
End If
Case SQL_C_TIMESTAMP
Dim ltimestamp1 As TIMESTAMP_STRUCT = CType(marshal.PtrToStructure(IntPtr.op_Explicit(CurrAddr.ToInt32 + COlDat(Col).coloffset), GetType(TIMESTAMP_STRUCT)), TIMESTAMP_STRUCT)
ltimestamp = ltimestamp1
'''''''debug.print "Ret col " & Format$(col) & " as timestamp"
If ltimestamp.year_Renamed <= 0 Then
FetchCol = System.DBNull.Value
Else
this_dbl_date = DateSerial(ltimestamp.year_Renamed, ltimestamp.month_Renamed, ltimestamp.day_Renamed).ToOADate() + (ltimestamp.hour_Renamed / 24) + (ltimestamp.minute_Renamed / (1440)) + (ltimestamp.second_Renamed / (86400))
FetchCol = System.DateTime.FromOADate(this_dbl_date) ' + hfrac# + mfrac# + sfrac#)
End If
Case SQL_C_SHORT
marshal.Copy(IntPtr.op_Explicit(CurrAddr.ToInt32 + COlDat(Col).coloffset), lint, 0, 1) 'CInt(COlDat(Col).colsize))
'''''''debug.print "Ret col " & Format$(col) & " as int"
FetchCol = lint(0)
Case SQL_C_LONG
marshal.Copy(IntPtr.op_Explicit(CurrAddr.ToInt32 + COlDat(Col).coloffset), llong, 0, 1) 'COlDat(Col).coloffset, 1) 'CInt(COlDat(Col).colsize))
'''''''debug.print "Ret col " & Format$(col) & " as long"
FetchCol = llong(0)
Case SQL_C_DOUBLE
marshal.Copy(IntPtr.op_Explicit(CurrAddr.ToInt32 + COlDat(Col).coloffset), ldouble, 0, 1) 'COlDat(Col).coloffset, 1) ' CInt(COlDat(Col).colsize))
''debug.print "Ret col " & Format$(Col) & " as double"
FetchCol = ldouble(0)
Case Else
'If tblName = "VIEWS.Q2RRESPSIG" Then 'debug.print "RETVAL IN FETCH COL " & CStr(Col) & " IS " & CStr(COlDat(Col).retval)
If COlDat(Col).retval <= 4096 Then
copylen = COlDat(Col).retval
Else
copylen = 4096
MsgBox("Warning, data greater than 4096 characters truncated")
End If
'If tblName = "VIEWS.Q2RRESPSIG" Then 'debug.print "COPYING FROM ADDRESS " & Format$(CurrAddr) & " OFFSET " & Format$(COlDat(Col).coloffset)
lstring = marshal.PtrToStringAnsi(IntPtr.op_Explicit(CurrAddr.ToInt32 + COlDat(Col).coloffset))
'If tblName = "VIEWS.Q2RRESPSIG" Then 'debug.print "Ret col " & Format$(Col) & " as string COPYLEN " & Format$(copylen&) & " " & Trim$(Left$(lstring, copylen&))
FetchCol = lstring 'Trim(Left(lstring.Value, copylen))
End Select
End Function
Private Function ColumnDatatype(ByRef Indx As Object) As Short
Dim cnt As Short
Dim Index As Short
Dim idx As String
On Error GoTo itcderr
If Not createdok Then
GoTo itcderr
End If
Index = 0
Select Case VarType(Indx)
Case VariantType.Currency, VariantType.Decimal, VariantType.Double, VariantType.Integer, VariantType.Long, VariantType.Short
Index = CShort(Indx)
If HDB.FetchType() = DOES_FETCH_ROWID Then
Index = Index + 1
End If
Case Else
idx = Indx
For cnt = 1 To numcols
If COlDat(cnt).colname = idx Then
Index = cnt
Exit For
End If
Next cnt
End Select
If Index = 0 Then
MsgBox("Invalid column " & VB6.Format(Index))
Exit Function 'colname = ""
End If
ColumnDatatype = COlDat(Index).dbdatatype
Exit Function
itcderr:
ColumnDatatype = 0
Exit Function
End Function
Private Function ColumnName(ByVal Index As Short) As String
Dim colnum As Short
If Index < 1 Or Index > numcols Then
GoTo iterr
End If
colnum = Index
If HDB.FetchType() = DOES_FETCH_ROWID Then
colnum = colnum + 1
End If
ColumnName = COlDat(colnum).colname
Exit Function
iterr:
ColumnName = ""
Exit Function
End Function
Private Sub SetColumnName(ByVal Index As Short, ByVal NewColName As String)
Dim colnum As Short
Dim errro As Object
Select Case errro
Case Is < 0
Error (5)
Case 1
GoTo siterr
End Select
If Index < 1 Or Index > numcols Then
GoTo siterr
End If
colnum = Index
If HDB.FetchType() = DOES_FETCH_ROWID Then
colnum = colnum + 1
End If
COlDat(colnum).colname = NewColName
Exit Sub
siterr:
Exit Sub
End Sub
Private Function ColumnSize(ByRef Indx As Object) As Short
Dim cnt As Short
Dim Index As Short
Dim idx As String
On Error GoTo itcserr
If Not createdok Then
GoTo itcserr
End If
Index = 0
Select Case VarType(Indx)
Case VariantType.Currency, VariantType.Decimal, VariantType.Double, VariantType.Integer, VariantType.Long, VariantType.Short
Index = CShort(Indx)
If HDB.FetchType() = DOES_FETCH_ROWID Then
Index = Index + 1
End If
Case Else
idx = Indx
For cnt = 1 To numcols
If COlDat(cnt).colname = idx Then
Index = cnt
Exit For
End If
Next cnt
End Select
If Index = 0 Then
GoTo itcserr
End If
ColumnSize = COlDat(Index).colsize
Exit Function
itcserr:
ColumnSize = 0
Exit Function
End Function
Private Function ColumnScale(ByRef Indx As Object) As Short
Dim cnt As Short
Dim Index As Short
Dim idx As String
On Error GoTo itcscerr
If Not createdok Then
GoTo itcscerr
End If
Index = 0
Select Case VarType(Indx)
Case VariantType.Currency, VariantType.Decimal, VariantType.Double, VariantType.Integer, VariantType.Long, VariantType.Short
Index = CShort(Indx)
If HDB.FetchType() = DOES_FETCH_ROWID Then
Index = Index + 1
End If
Case Else
idx = Indx
For cnt = 1 To numcols
If COlDat(cnt).colname = idx Then
Index = cnt
Exit For
End If
Next cnt
End Select
If Index = 0 Then
GoTo itcscerr
End If
ColumnScale = COlDat(Index).colscale
Exit Function
itcscerr:
ColumnScale = 0
Exit Function
End Function
Private Function ColumnPrecision(ByRef Indx As Object) As Integer
Dim cnt As Short
Dim Index As Short
Dim idx As String
On Error GoTo itcperr
If Not createdok Then
GoTo itcperr
End If
Index = 0
Select Case VarType(Indx)
Case VariantType.Currency, VariantType.Decimal, VariantType.Double, VariantType.Integer, VariantType.Long, VariantType.Short
Index = CShort(Indx)
If HDB.FetchType() = DOES_FETCH_ROWID Then
Index = Index + 1
End If
Case Else
idx = Indx
For cnt = 1 To numcols
If COlDat(cnt).colname = idx Then
Index = cnt
Exit For
End If
Next cnt
End Select
If Index = 0 Then
GoTo itcperr
End If
ColumnPrecision = COlDat(Index).colpres
Exit Function
itcperr:
ColumnPrecision = 0
Exit Function
End Function
Private Function ColumnNullable(ByRef Indx As Object) As Boolean
Dim cnt As Short
Dim Index As Short
Dim idx As String
On Error GoTo itcnerr
Index = 0
If Not createdok Then
GoTo itcnerr
End If
Select Case VarType(Indx)
Case VariantType.Currency, VariantType.Decimal, VariantType.Double, VariantType.Integer, VariantType.Long, VariantType.Short
Index = CShort(Indx)
If HDB.FetchType() = DOES_FETCH_ROWID Then
Index = Index + 1
End If
Case Else
idx = Indx
For cnt = 1 To numcols
If COlDat(cnt).colname = idx Then
Index = cnt
Exit For
End If
Next cnt
End Select
If Index = 0 Then
GoTo itcnerr
End If
If COlDat(Index).colnullable Then
ColumnNullable = True
Else
ColumnNullable = False
End If
Exit Function
itcnerr:
Exit Function
ColumnNullable = False
End Function
Private Sub Class_Initialize_Renamed()
pvBOF = True
''''''debug.print "BOF set to true on initialize"
mainstmt = 0
stmt = 0
fs.RowStmt = 0
CursorName = ""
initialized = False
db("SPHYG DTAB initialize")
End Sub
Public Sub New()
MyBase.New()
'AddHandler mybase.ColumnChanged, AddressOf OnColChanged
'AddHandler mybase.ColumnChanging, AddressOf OnColChanging
'AddHandler mybase.RowChanged, AddressOf OnRowChgd
AddHandler mybase.RowChanging, AddressOf OnRowChging
AddHandler mybase.RowDeleting, AddressOf OnRowDlting
'AddHandler mybase.RowDeleted, AddressOf OnRowDlted
Class_Initialize_Renamed()
End Sub
Private Sub Class_Terminate_Renamed()
Dim RL As Integer
Dim r As Short
On Error GoTo terr
db("SPHYG DTAB terminate " & sqlstat)
If Not initialized Then
Exit Sub
End If
If HDB.handle <> 0 Then
If mainstmt <> 0 Then
''''''debug.print "Releasing mainstmt"
If currpos > 0 Then
''debug.print "Calling update, currpos is " & Format$(currpos&)
End If
''debug.print "Freeing now"
r = SQLFreeStmt(mainstmt, SQL_DROP)
mainstmt = 0
saveinserts()
End If
If fs.RowStmt <> 0 Then
''''''debug.print "Releasing rowstmt"
Call SQLFreeStmt(fs.RowStmt, SQL_DROP)
fs.RowStmt = 0
RL = GlobalUnlock(fs.RowHnd)
fs.RowHnd = GlobalFree(fs.RowHnd)
closeSet(fs)
End If
End If
terr:
If gHnd <> 0 Then
''''''debug.print "releasing memory block"
RL = GlobalUnlock(gHnd)
gHnd = GlobalFree(gHnd)
gHnd = 0
End If
Exit Sub
End Sub
Private Shared Sub OnColChanged(sender As Object, args As DataColumnChangeEventargs)
'Console.Write(" ColumnChanged: ")
'Console.Write(args.Column.ColumnName & " changed to '" & args.ProposedValue.ToString() & "'" & vbCrLf)
End Sub
Private Shared Sub OnColChanging(sender As Object, args As DataColumnChangeEventargs)
'Console.Write("ColumnChanging: ")
'Console.Write(args.Column.ColumnName & " equals '" & args.Row(args.Column).ToString() & _
' "', changing to '" & args.ProposedValue.ToString() & "'" & vbCrLf)
End Sub
Private Shared Sub OnRowChging(sender As Object, args As DataRowChangeEventargs)
dim s as string
dim current as DataRowVersion
dim original as DataRowVersion
dim proposed as DataRowVersion
original = DataRowVersion.Original
current = DataRowVersion.Current
proposed = DataRowVersion.Proposed
if sender.loading then exit sub
If args.Action <> DataRowAction.Nothing Then
Dim actionStr As String
try
'actionStr = System.Enum.GetName(args.Action.GetType(), args.Action)
's = "Row CHANGING"
'if args.Row.HasVersion(DataRowVersion.Original) then
' s &= " Original " & args.Row(1,original).tostring()
'end if
'if args.Row.HasVersion(DataRowVersion.Current) then
' s &= ", Current " & args.Row(1,current).tostring()
'end if
'if args.Row.HasVersion(DataRowVersion.Proposed) then
' s &= ", Proposed " & args.Row(1,proposed).tostring()
'end if
dim w_cls as string
dim sql as string
dim cl as DataColumn
dim cl_cnt as Integer = 0
dim u_cnt as Integer = 0
select case args.Action
case DataRowAction.Add
sql = "INSERT INTO " & sender.AOTableName & " ("
cl_cnt = 0
u_cnt = 0
for cl_cnt = 0 to (args.Row.Table.Columns.Count - 1)
if not args.Row.Table.Columns.item(cl_cnt).readonly then
if u_cnt > 0 then
sql &= ","
End If
sql &= args.Row.Table.Columns.item(cl_cnt).ColumnName
u_cnt += 1
end if
Next
sql &= ") VALUES ("
u_cnt = 0
for cl_cnt = 0 to (args.Row.Table.Columns.Count - 1)
if not args.Row.Table.Columns.item(cl_cnt).ReadOnly then
if u_cnt > 0 then
sql &= ","
End If
if args.Row.Table.Columns.item(cl_cnt).DataType is System.Type.GetType("System.String") then
sql &= fnds(args.Row.Item(cl_cnt,DataRowVersion.proposed).toString)
elseif args.Row.Table.Columns.item(cl_cnt).DataType is System.Type.GetType("System.DateTime") then
sql &= args.Row.Table.Columns.item(cl_cnt).ColumnName & " = " & SQLFdate(args.Row.Item(cl_cnt,DataRowVersion.proposed))
else
sql &= args.Row.Item(cl_cnt,DataRowVersion.proposed).toString
end if
u_cnt += 1
end if
Next
sql &= ")"
sender.hdbc.execute( sql)
case DataRowAction.Change
cl_cnt = 0
u_cnt = 0
sql = "UPDATE " & sender.AOTableName & " SET "
for cl_cnt = 0 to (args.Row.Table.Columns.Count - 1)
if args.Row.Item(cl_cnt,DataRowVersion.Current) <> args.Row.Item(cl_cnt,DataRowVersion.proposed) then
if u_cnt > 0 then
sql &= ", "
End If
if args.Row.Table.Columns.item(cl_cnt).DataType is System.Type.GetType("System.String") then
sql &= args.Row.Table.Columns.item(cl_cnt).ColumnName & " = " & fnds(args.Row.Item(cl_cnt,DataRowVersion.proposed).toString)
elseif args.Row.Table.Columns.item(cl_cnt).DataType is System.Type.GetType("System.DateTime") then
sql &= args.Row.Table.Columns.item(cl_cnt).ColumnName & " = " & SQLFdate(args.Row.Item(cl_cnt,DataRowVersion.proposed))
else
sql &= args.Row.Table.Columns.item(cl_cnt).ColumnName & " = " & args.Row.Item(cl_cnt,DataRowVersion.proposed).toString
end if
u_cnt += 1
end if
next
if u_cnt > 0 then
sql &= " WHERE " & pkstr(args.Row)
sender.hdbc.execute( sql)
end if
'msgbox( sender.AOTableName)
end select
catch e as Exception
'no action
finally
'no action
end try
End If
End Sub
Private Shared Sub OnRowChgd(sender As Object, args As DataRowChangeEventargs)
End Sub
Private Shared Sub OnRowDlting(sender As Object, args As DataRowChangeEventargs)
dim s as string
dim current as DataRowVersion
dim original as DataRowVersion
dim proposed as DataRowVersion
original = DataRowVersion.Original
current = DataRowVersion.Current
proposed = DataRowVersion.Proposed
if sender.loading then exit sub
If args.Action <> DataRowAction.Nothing Then
Dim actionStr As String
try
'actionStr = System.Enum.GetName(args.Action.GetType(), args.Action)
's = "Row CHANGING"
'if args.Row.HasVersion(DataRowVersion.Original) then
' s &= " Original " & args.Row(1,original).tostring()
'end if
'if args.Row.HasVersion(DataRowVersion.Current) then
' s &= ", Current " & args.Row(1,current).tostring()
'end if
'if args.Row.HasVersion(DataRowVersion.Proposed) then
' s &= ", Proposed " & args.Row(1,proposed).tostring()
'end if
dim w_cls as string
dim sql as string
dim cl as DataColumn
dim cl_cnt as Integer = 0
dim u_cnt as Integer = 0
select case args.Action
case DataRowAction.Delete
sql = "DELETE FROM " & sender.AOTableName & " WHERE " & pkstr(args.Row)
sender.hdbc.execute( sql)
end select
catch e as Exception
'no action
finally
'no action
end try
End If
End Sub
Private Shared Sub OnRowDlted(sender As Object, args As DataRowChangeEventargs)
End Sub
private function GetPKStr(byval tbl_name as String) as string
dim pos as Integer
dim RetStr as string
dim os as string
dim ts as string
pos = instr(tbl_name,".")
if pos > 1 then
do while pos > 1
os = left(tbl_name,pos-1)
tbl_name = right(tbl_name,tbl_name.Length - pos)
pos = instr(tbl_name,".")
loop
ts = tbl_name
else
os = ""
ts = tbl_name
end if
RetStr = "exec sp_pkeys @table_name = " & fnds(ts)
if os <> "" then
RetStr &= ", @table_owner = " & fnds(os)
End If
return retstr
End Function
private shared function PKStr(byval Row as DataRow) as string
dim w_cls as string
dim cl as DataColumn
dim cl_cnt as Integer = 0
'dim current as DataRowVersion
'dim original as DataRowVersion
'dim proposed as DataRowVersion
'original = DataRowVersion.Original
'current = DataRowVersion.Current
'proposed = DataRowVersion.Proposed
if row.Table.PrimaryKey.length > 0 then
for each cl in Row.Table.primarykey
if cl_cnt > 0 then
w_cls &= " AND "
End If
if Row.Table.Columns.item(cl_cnt).DataType is System.Type.GetType("System.String") then
w_cls &= cl.ColumnName & " = " & fnds(Row(cl_cnt,DataRowVersion.Current).tostring())
elseif Row.Table.Columns.item(cl_cnt).DataType is System.Type.GetType("System.DateTime") then
w_cls &= cl.ColumnName & " = " & SQLFDate(Row(cl_cnt,DataRowVersion.Current))
else
w_cls &= cl.ColumnName & " = " & Row(cl_cnt,DataRowVersion.Current).tostring()
end if
cl_cnt += 1
Next
else
for each cl in Row.Table.Columns '.primarykey
if cl_cnt > 0 then
w_cls &= " AND "
End If
if Row.Table.Columns.item(cl_cnt).DataType is System.Type.GetType("System.String") then
w_cls &= cl.ColumnName & " = " & fnds(Row(cl_cnt,DataRowVersion.Current).tostring())
elseif Row.Table.Columns.item(cl_cnt).DataType is System.Type.GetType("System.DateTime") then
w_cls &= cl.ColumnName & " = " & SQLFDate(Row(cl_cnt,DataRowVersion.Current))
else
w_cls &= cl.ColumnName & " = " & Row(cl_cnt,DataRowVersion.Current).tostring()
end if
cl_cnt += 1
Next
end if
return w_cls
End Function
Protected Overrides Sub Finalize()
Class_Terminate_Renamed()
MyBase.Finalize()
End Sub
End Class
Submit an article or tip