Option Strict Off
Option Explicit On
Imports System
Imports System.text
Imports System.IO
Imports System.Attribute
Imports System.Data
Imports System.ComponentModel
Public Class HDBC
Implements IDisposable
Friend dbinf As dbinfo
Friend real_password As String = ""
Private acc_tran As Boolean
Public ShowActions As Boolean = False
'Private ShowActionsX As Boolean = False
Private pvLogName As String = ""
Friend dt_prf As String = ""
Friend dt_sfx As String = ""
Friend tm_sfx As String = ""
Private pvCreateScript As Boolean
Private ScriptFile As Short
Private ScriptName As String = ""
Private ScriptEOL As String = ""
Friend pvLicenseInfo As String = ""
Friend pvCompUserRoot As String = ""
Private disposed As Boolean = False
Friend TablePrefix As String = ""
Friend PrefixSet As Boolean = False
Friend con_string As String = ""
Friend lgonUser As String = ""
Friend lgonPwd As String = ""
Friend pvDBName As String = ""
Friend pvCloneSResultSets As Boolean = False
Private pvCloned As Boolean = False
Private pvCloneParent As HDBC
Private pvLogOpenStatements As Boolean = False
'Public Track As Boolean
Private pvOpenBoundDataTables As New System.Collections.Generic.List(Of BoundDataTable)
Private pvOpenBrowseDataTables As New System.Collections.Generic.List(Of BrowseDataTable)
Private pvOpenDBQueries As New System.Collections.Generic.List(Of nbfDBQuery)
Private pvOpenDBTables As New System.Collections.Generic.List(Of NbfDbTable)
Private pvOpenResultSets As New System.Collections.Generic.List(Of nbfResultSet)
Private pvOpenQnbfResultSets As New System.Collections.Generic.List(Of QNbfResultSet)
Private pvOpenSnbfResultSets As New System.Collections.Generic.List(Of SNbfResultSet)
Private pvCachedTemplates As New System.Collections.Generic.Dictionary(Of String, Object)
Private pvOpenStatements As New System.Collections.Generic.Dictionary(Of String, StatementInfo)
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Integer, ByVal lpFileName As String) As Integer
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpFileName As String) As Integer
Public Overloads Sub Dispose() Implements IDisposable.Dispose
GC.SuppressFinalize(Me)
Dispose(True)
End Sub
Public ReadOnly Property CachedTemplates() As System.Collections.Generic.Dictionary(Of String, Object)
Get
If Cloned AndAlso Not pvCloneParent Is Nothing Then
Return pvCloneParent.CachedTemplates
Else
Return pvCachedTemplates
End If
End Get
End Property
Protected Overridable Overloads Sub Dispose(ByVal disposing As Boolean)
' Check to see if Dispose has already been called.
'If Track Then
' MsgBox("Trk HDB Disposing")
'End If
If Not (Me.disposed) Then
' If disposing equals true, dispose all managed
' and unmanaged resources.
If (disposing) Then
' Dispose managed resources.
If pvCloned Then
pvCloneParent = Nothing
Else
pvCachedTemplates.Clear()
End If
End If
' Release unmanaged resources. If disposing is false,
' only the following code is executed.
logoff()
' Note that this is not thread safe.
' Another thread could start disposing the object
' after the managed resources are disposed,
' but before the disposed flag is set to true.
' If thread safety is necessary, it must be
' implemented by the client.
End If
Me.disposed = True
End Sub
Protected Overrides Sub Finalize()
If False Then 'MonitorFinalize Then
ShowMessage("Finalize called on HDBC")
End If
'If Track Then
' MsgBox("Trk HDB Finalize")
'End If
Dispose(False)
End Sub
Public Sub SetPrefix(ByVal tf As String)
If Not tf Is Nothing Then
If tf <> "" Then
TablePrefix = tf
PrefixSet = True
End If
End If
End Sub
Public Sub AddStatement(ByVal Statement As Object, ByVal hstmt As Integer, ByVal SQL As String)
'Dim tSI As StatementInfo
Dim SI As New StatementInfo
SI.StatementType = Statement.GetType.Name
SI.SQL = SQL
'LogMsg("Added " & hstmt.ToString() & " " & SQL)
If Not pvOpenStatements.TryGetValue(hstmt.ToString(), SI) Then
pvOpenStatements.Add(hstmt.ToString(), SI)
End If
End Sub
Public Sub EndStatement(ByVal hstmt As Integer)
'LogMsg("Removed " & hstmt.ToString())
pvOpenStatements.Remove(hstmt.ToString())
End Sub
Public ReadOnly Property OpenStatements() As System.Collections.Generic.Dictionary(Of String, StatementInfo)
Get
Return pvOpenStatements
End Get
End Property
Private Sub ChkPrf(ByRef Sql As String)
If PrefixSet Then
Sql = Sql.Replace("<{[PREFIX]}>", TablePrefix)
End If
End Sub
Public Function Clone() As HDBC
Try
If pvDBName = "" Then
Dim sql$ = "SELECT DB_NAME()"
Dim ds As SNbfResultSet
Dim ccs As Boolean = pvCloneSResultSets
pvCloneSResultSets = False
ds = CreateSNbfResultSet(sql$)
If ds.fetch() Then
pvDBName = ds.FetchString(1)
End If
ds.Free()
pvCloneSResultSets = ccs
End If
Dim hdb As New HDBC
hdb.SetClone(Me)
Return hdb
Catch ex As Exception
logDBError(Me, "Clone error " & ex.Message)
Return Nothing
End Try
End Function
Public ReadOnly Property CloneParent() As HDBC
Get
Return pvCloneParent
End Get
End Property
Public Sub DumpOut(ByVal filename As String)
Dim this_val As String
Dim usql As String
Dim cnt As Long
Dim isql As String
Dim tcnt As Long
Dim tbcnt As Long
Dim this_table As String = ""
Dim f_num As Short
System.Windows.Forms.Cursor.Current = System.Windows.Forms.Cursors.WaitCursor
On Error GoTo stperr
Dim ds As nbfResultSet
Dim dst As nbfResultSet
Dim tables As New ArrayList
f_num = FreeFile()
FileOpen(f_num, filename, OpenMode.Binary)
dst = CreateNbfResultSet("TABLES")
Do While dst.fetch()
this_table = dst.FetchString(3)
tbcnt = tbcnt + 1
tables.Add(this_table)
this_table = Nothing
'ReDim Preserve tables(tbcnt)
'tables(tbcnt) = this_table
Loop
dst.Free()
tcnt = 0
For Each this_table In tables
tcnt += 1
'this_table = tables(tcnt)
'If tcnt < 5 Or (tcnt Mod 10 = 0) Then
'ShowMessage(this_table)
'End If
ds = CreateNbfResultSet("SELECT * FROM " & this_table)
If ds.nocols > 0 Then
isql = "INSERT INTO " & this_table & "("
For cnt = 1 To ds.nocols
isql = isql & ds.ColumnName(cnt)
If cnt = ds.nocols Then
isql = isql & ")"
Else
isql = isql & ","
End If
Next cnt
isql = isql & " VALUES ("
Do While ds.fetch()
usql = this_table & "," & isql
For cnt = 1 To ds.nocols
If this_table = "SYSPARAM" And ds.ColumnName(cnt) = "SERIALNO" Or ds.ColumnName(cnt) = "SECSET" Or ds.ColumnName(cnt) = "NUMUSERS" Or ds.ColumnName(cnt) = "EXPIRYDATE" Then
usql = usql & "NULL"
Else
If this_table = "QUERIES" Then
End If
Select Case ds.ColumnDatatype(cnt)
Case SQL_CHAR, SQL_VARCHAR, SQL_LONGVARCHAR, SQL_LONGVARBINARY, SQL_BINARY, SQL_VARBINARY, -9
usql = usql & fnds(ds.FetchString(cnt))
usql = rep_string(usql, Chr(13), "<{(13)}>")
usql = rep_string(usql, Chr(10), "<{(10)}>")
Case SQL_BIT, SQL_TINYINT, SQL_SMALLINT
this_val = ds.FetchString(cnt)
If this_val = "" Then
If ds.ColumnNullable(cnt) Then
this_val = "NULL"
Else
this_val = "0"
End If
End If
usql = usql & this_val
Case SQL_INTEGER, SQL_BIGINT, SQL_FLOAT, SQL_DOUBLE, SQL_NUMERIC, SQL_DECIMAL, SQL_REAL
this_val = ds.FetchString(cnt)
If this_val = "" Then
If ds.ColumnNullable(cnt) Then
this_val = "NULL"
Else
this_val = "0"
End If
End If
usql = usql & this_val
Case SQL_DATE
usql = usql & Fdate(ds.FetchDate(cnt))
Case SQL_TIMESTAMP
usql = usql & Fdate(ds.FetchDate(cnt))
Case Else
'ShowMessage("Unrecognized data type")
usql = usql & fnds(ds.FetchString(cnt))
usql = rep_string(usql, Chr(13), "<{(13)}>")
usql = rep_string(usql, Chr(10), "<{(10)}>")
End Select
End If
If cnt = ds.nocols Then
usql = usql & ")"
Else
usql = usql & ","
End If
Next cnt
usql = usql & Chr(13) & Chr(10)
FilePut(f_num, usql)
Loop
End If
ds.Free()
ds = Nothing
Next
FileClose(f_num)
System.Windows.Forms.Cursor.Current = System.Windows.Forms.Cursors.Default
Exit Sub
stperr:
ShowMessage(ErrorToString(Err.Number))
Exit Sub
End Sub
Public Property DBName() As String
Get
Return pvDBName
End Get
Set(ByVal value As String)
Try
pvDBName = value
execsql("USE """ & pvDBName & """")
Catch ex As Exception
logDBError(Me, "Set Db Name error " & ex.Message)
End Try
End Set
End Property
'Public Property CloneSResultSets() As Boolean
' Get
' Return pvCloneSResultSets
' End Get
' Set(ByVal value As Boolean)
' pvCloneSResultSets = value
' End Set
'End Property
Private Function lgon(ByVal SupressErr As Boolean, ByVal dsource As String, ByVal usnm As String, ByVal pswd As String, Optional ByVal Encrypt As Boolean = False, Optional ByVal NonEncryptedUser As String = "") As Boolean
Try
Dim stmt As Integer
Dim S As String
Dim r As Short = 0
Dim retval As Short
Dim date_dtype As String
Dim timestamp_dtype As String
Dim dummy3 As String
Dim dummy2 As String
Dim dummy1 As String
Dim dummy As Integer
Dim dparam As String
Dim dpres As Integer
Dim dbl_dtype As String
Dim long_dtype As String
Dim lParam As String
Dim lpres As Integer
Dim int_dtype As String
Dim iParam As String
Dim ipres As Integer
Dim bin_dtype As String
Dim lv_dtype As String
Dim char_dtype As String
Dim s_suf As String
Dim s_prf As String
Dim vchar_dtype As String
Dim suf As String
Dim prf As String
Dim sparam As String
Dim spres As Integer
Dim iso_lev As Integer
Dim lgUsnm As String = ""
lgon = False
If dbinf.hdbcv <> 0 Then
ShowMessage("Already logged on, using previous connection")
Exit Function
End If
System.Windows.Forms.Cursor.Current = System.Windows.Forms.Cursors.WaitCursor
If IsNothing(Encrypt) Then
If Not qqconnect(SupressErr, dsource, usnm, pswd) Then
If SupressErr Then
lgon = False
Else
jump()
End If
Exit Function
End If
Else
If Not qqconnect(SupressErr, dsource, usnm, pswd, Encrypt, NonEncryptedUser) Then
If SupressErr Then
lgon = False
Else
jump()
End If
Exit Function
End If
End If
System.Windows.Forms.Cursor.Current = System.Windows.Forms.Cursors.WaitCursor
If dbinf.HostDB = "SQLSERVER" Then
dbinf.VarCharDataType = "varchar"
dbinf.CharDataType = "char"
dbinf.LongVarCharDataType = "text"
dbinf.BinaryDataType = "binary"
dbinf.IntDataType = "smallint"
dbinf.LongDataType = "int"
dbinf.DoubleDataType = "float"
dbinf.DoublePrec = 15
dbinf.DoublePrecReq = False
dbinf.TimestampDataType = "datetime"
dbinf.host_timestamp = SQL_TIMESTAMP
dbinf.DateDataType = "datetime"
dbinf.host_date = SQL_TIMESTAMP
dbinf.date_sel = False
dbinf.host_int = SQL_SMALLINT
dbinf.host_long = SQL_INTEGER
dbinf.host_double = SQL_FLOAT
dt_prf = "{ts'"
dt_sfx = " 00:00:00'}"
tm_sfx = "'}"
Else
vchar_dtype = gethosttype(SQL_VARCHAR, spres, sparam, prf, suf)
If vchar_dtype = "" Then
vchar_dtype = gethosttype(SQL_CHAR, spres, sparam, s_prf, s_suf)
If vchar_dtype = "" Then
vchar_dtype = "CHAR"
End If
End If
dbinf.VarCharDataType = vchar_dtype
char_dtype = gethosttype(SQL_CHAR, spres, sparam, s_prf, s_suf)
If char_dtype = "" Then
char_dtype = gethosttype(SQL_VARCHAR, spres, sparam, prf, suf)
If vchar_dtype = "" Then
char_dtype = "CHAR"
End If
End If
dbinf.CharDataType = char_dtype
lv_dtype = gethosttype(SQL_LONGVARCHAR, spres, sparam, prf, suf)
If lv_dtype = "" Then
lv_dtype = gethosttype(SQL_BINARY, spres, sparam, prf, suf)
If lv_dtype = "" Then
ShowMessage("unable to get a host long varchar type, assuming LONG VARCHAR")
lv_dtype = "LONG VARCHAR"
End If
End If
dbinf.LongVarCharDataType = lv_dtype
bin_dtype = gethosttype(SQL_BINARY, spres, sparam, prf, suf)
If bin_dtype = "" Then
bin_dtype = gethosttype(SQL_LONGVARCHAR, spres, sparam, prf, suf)
If bin_dtype = "" Then
ShowMessage("unable to get a host binary type, assuming LONG VARCHAR")
bin_dtype = "long varchar"
End If
End If
dbinf.BinaryDataType = bin_dtype
int_dtype = gethosttype(SQL_SMALLINT, ipres, iParam, prf, suf)
If int_dtype <> "" Then
dbinf.host_int = SQL_SMALLINT
Else
int_dtype = gethosttype(SQL_INTEGER, ipres, iParam, prf, suf)
If int_dtype <> "" Then
dbinf.host_int = SQL_INTEGER
Else
int_dtype = gethosttype(SQL_NUMERIC, ipres, iParam, prf, suf)
If int_dtype <> "" Then
dbinf.host_int = SQL_NUMERIC
Else
int_dtype = gethosttype(SQL_DECIMAL, ipres, iParam, prf, suf)
If int_dtype <> "" Then
dbinf.host_int = SQL_DECIMAL
Else
int_dtype = gethosttype(SQL_FLOAT, ipres, iParam, prf, suf)
If int_dtype <> "" Then
dbinf.host_int = SQL_FLOAT
Else
int_dtype = gethosttype(SQL_DOUBLE, ipres, iParam, prf, suf)
If int_dtype <> "" Then
dbinf.host_int = SQL_DOUBLE
Else
ShowMessage("unable to get a host integer type")
jump() 'jump
End If
End If
End If
End If
End If
End If
dbinf.IntDataType = int_dtype
long_dtype = gethosttype(SQL_INTEGER, lpres, lParam, prf, suf)
If long_dtype <> "" Then
dbinf.host_long = SQL_INTEGER
Else
long_dtype = gethosttype(SQL_NUMERIC, lpres, lParam, prf, suf)
If long_dtype <> "" Then
dbinf.host_long = SQL_NUMERIC
Else
long_dtype = gethosttype(SQL_DECIMAL, lpres, lParam, prf, suf)
If long_dtype <> "" Then
dbinf.host_long = SQL_DECIMAL
Else
long_dtype = gethosttype(SQL_FLOAT, lpres, lParam, prf, suf)
If long_dtype <> "" Then
dbinf.host_long = SQL_FLOAT
Else
long_dtype = gethosttype(SQL_DOUBLE, lpres, lParam, prf, suf)
If long_dtype <> "" Then
dbinf.host_long = SQL_DOUBLE
Else
ShowMessage("unable to get a host long type")
jump()
End If
End If
End If
End If
End If
dbinf.LongDataType = long_dtype
If dbinf.HostDB = "SQLSERVER" Then
dbl_dtype = ""
Else
dbl_dtype = gethosttype(SQL_DOUBLE, dpres, dparam, prf, suf)
End If
If dbl_dtype <> "" Then
dbinf.host_double = SQL_DOUBLE
Else
dbl_dtype = gethosttype(SQL_FLOAT, dpres, dparam, prf, suf)
If dbl_dtype <> "" Then
dbinf.host_double = SQL_FLOAT
Else
dbl_dtype = gethosttype(SQL_DECIMAL, dpres, dparam, prf, suf)
If dbl_dtype <> "" Then
dbinf.host_double = SQL_DECIMAL
Else
dbl_dtype = gethosttype(SQL_NUMERIC, dpres, dparam, prf, suf)
If dbl_dtype <> "" Then
dbinf.host_double = SQL_NUMERIC
Else
ShowMessage("unable to get a host double type")
End If
End If
End If
End If
dbinf.DoubleDataType = dbl_dtype
dbinf.DoublePrecReq = False
dbinf.DoublePrec = dpres
If dparam <> "" Then
If InStr(1, dparam, ",") > 0 Then
dbinf.DoublePrecReq = True
End If
End If
timestamp_dtype = gethosttype(SQL_TIMESTAMP, dummy, dummy1, dummy2, dummy3)
If timestamp_dtype <> "" Then
dbinf.TimestampDataType = timestamp_dtype
dbinf.host_timestamp = SQL_TIMESTAMP
End If
If dbinf.HostDB = "SQLSERVER" Then
date_dtype = ""
Else
date_dtype = gethosttype(SQL_DATE, dummy, dummy1, dummy2, dummy3)
End If
If date_dtype <> "" Then
dbinf.host_date = SQL_DATE
dbinf.date_sel = True
dt_prf = "{d'"
dt_sfx = "'}"
Else
date_dtype = gethosttype(SQL_TIMESTAMP, dummy, dummy1, dummy2, dummy3)
If date_dtype <> "" Then
dbinf.host_date = SQL_TIMESTAMP
dbinf.date_sel = False
dt_prf = "{ts'"
dt_sfx = " 00:00:00'}"
Else
ShowMessage("unable to get a host date type")
jump()
End If
End If
tm_sfx = "'}"
dbinf.DateDataType = date_dtype
End If
Call cvtype()
r = SQLGetInfoInt(dbinf.hdbcv, SQL_TXN_ISOLATION_OPTION, iso_lev, 4, retval)
If r <> SQL_SUCCESS Then
ShowMessage("Error on getting Isolation Information")
Call showerror(r, 0)
End If
If iso_lev And SQL_TXN_VERSIONING Then
dbinf.isolev = SQL_TXN_VERSIONING
ElseIf iso_lev And SQL_TXN_SERIALIZABLE And dbinf.HostDB <> "ORACLE" Then
dbinf.isolev = SQL_TXN_SERIALIZABLE
ElseIf (iso_lev And SQL_TXN_REPEATABLE_READ) Then
dbinf.isolev = SQL_TXN_REPEATABLE_READ
Else
'ShowMessage "Database does not support Serializable transactions"
'jump
If iso_lev And SQL_TXN_READ_COMMITTED Then
r = SQLSetConnectOptionInt(dbinf.hdbcv, SQL_TXN_ISOLATION, SQL_TXN_READ_COMMITTED)
If Not r = SQL_SUCCESS Then
ShowMessage("Unable to set isolation level")
jump()
End If
dbinf.isolev = SQL_TXN_READ_COMMITTED
ElseIf iso_lev And SQL_TXN_READ_UNCOMMITTED Then
r = SQLSetConnectOptionInt(dbinf.hdbcv, SQL_TXN_ISOLATION, SQL_TXN_READ_UNCOMMITTED)
If Not r = SQL_SUCCESS Then
ShowMessage("Unable to set default isolation level")
jump()
End If
dbinf.isolev = SQL_TXN_READ_UNCOMMITTED
End If
End If
If iso_lev And SQL_TXN_READ_COMMITTED Then
r = SQLSetConnectOptionInt(dbinf.hdbcv, SQL_TXN_ISOLATION, SQL_TXN_READ_COMMITTED)
If Not r = SQL_SUCCESS Then
ShowMessage("Unable to set default isolation level")
jump()
End If
dbinf.normisolev = SQL_TXN_READ_COMMITTED
ElseIf iso_lev And SQL_TXN_REPEATABLE_READ Then
r = SQLSetConnectOptionInt(dbinf.hdbcv, SQL_TXN_ISOLATION, SQL_TXN_REPEATABLE_READ)
If Not r = SQL_SUCCESS Then
ShowMessage("Unable to set default isolation level")
jump()
End If
dbinf.normisolev = SQL_TXN_REPEATABLE_READ
ElseIf iso_lev And SQL_TXN_READ_UNCOMMITTED Then
r = SQLSetConnectOptionInt(dbinf.hdbcv, SQL_TXN_ISOLATION, SQL_TXN_READ_UNCOMMITTED)
If Not r = SQL_SUCCESS Then
ShowMessage("Unable to set default isolation level")
jump()
End If
dbinf.normisolev = SQL_TXN_READ_UNCOMMITTED
Else
ShowMessage("Unable to set default isolation level on start up")
jump()
End If
r = SQLSetConnectOptionInt(dbinf.hdbcv, SQL_AUTOCOMMIT, SQL_AUTOCOMMIT_ON)
If Not r = SQL_SUCCESS Then
showerror(r, SQL_NULL_HSTMT)
ShowMessage("Unable to set autocommit")
jump()
End If
If dbinf.HostDB = "WATCOM" Then
S = "SET OPTION DATE_ORDER = 'DMY'"
r = SQLAllocStmt(dbinf.hdbcv, stmt) '
r = SQLExecDirect(stmt, S, CInt(Len(S)))
r = SQLFreeStmt(stmt, SQL_DROP)
S = "SET OPTION ROW_COUNTS = OFF"
r = SQLAllocStmt(dbinf.hdbcv, stmt) '
r = SQLExecDirect(stmt, S, CInt(Len(S)))
r = SQLFreeStmt(stmt, SQL_DROP)
S = "SET OPTION SCALE = 6"
r = SQLAllocStmt(dbinf.hdbcv, stmt) '
r = SQLExecDirect(stmt, S, CInt(Len(S)))
r = SQLFreeStmt(stmt, SQL_DROP)
End If
'If r% <> SQL_SUCCESS Then
' Call showerror((r%, stmt&)
' jump
'End If
System.Windows.Forms.Cursor.Current = System.Windows.Forms.Cursors.WaitCursor
'debug.print "C"
If dbinf.HostDB = "ORACLE" And dbinf.DBVersion < 8 Then
'If dbinf.HostDB = "ORACLE" Then
dbinf.host_bint = SQL_CHAR
dbinf.host_blong = SQL_CHAR
dbinf.host_bdouble = SQL_CHAR
'dbinf.host_bdate = SQL_CHAR
'dbinf.host_btimestamp = SQL_CHAR
Else
dbinf.host_bint = dbinf.host_int
dbinf.host_blong = dbinf.host_long
dbinf.host_bdouble = dbinf.host_double
'dbinf.host_bdate = dbinf.host_date
'dbinf.host_btimestamp = dbinf.host_timestamp
End If
dbinf.host_bdate = dbinf.host_date
dbinf.host_btimestamp = dbinf.host_timestamp
System.Windows.Forms.Cursor.Current = System.Windows.Forms.Cursors.Default
'DebugOut = CBool(GetSetting("NbfDb", "Settings", "ShowDebug", 0))
lgon = True
Exit Function
Catch ex As Exception
logDBError(Me, ex.Message)
jump()
End Try
End Function
Public WriteOnly Property LicenseInfo() As String
Set(ByVal Value As String)
pvLicenseInfo = Value
End Set
End Property
Public ReadOnly Property DBVersion() As Decimal
Get
DBVersion = dbinf.DBVersion
End Get
End Property
Public Function CreateBoundDataTable(ByVal t_nam As String, ByVal sql As String, ByVal AutoGenPK As Boolean) As BoundDataTable
On Error GoTo dtaberr
Dim dbs As New BoundDataTable(Me)
Dim sr As Object
Dim dfu As Object
If ShowActions Then logDBError(Me, "Show Action SQL " & sql)
ChkPrf(sql)
If pvCreateScript Then
ShowMessage("Cannot create NbfResultSets, queries or tables in create script mode")
GoTo dtaberr
Exit Function
End If
sr = True
'LogMess("creating bound table " & sql)
If Not dbs.create(dbinf.henv, dbinf.hdbcv, t_nam, sql, AutoGenPK) Then
GoTo dtaberr
Else
pvOpenBoundDataTables.Add(dbs)
Return dbs
End If
Exit Function
dtaberr:
logDBError(Me, Err.Description)
dbs = Nothing
Return Nothing
End Function
Public Function CreateBrowseDataTable(ByVal t_nam As String, ByVal sql As String) As BrowseDataTable
On Error GoTo dtaberr
Dim dbs As New BrowseDataTable(Me)
Dim sr As Object
Dim dfu As Object
If ShowActions Then logDBError(Me, "Show Action SQL " & sql)
If pvCreateScript Then
ShowMessage("Cannot create NbfResultSets, queries or tables in create script mode")
GoTo dtaberr
Exit Function
End If
sr = True
'LogMess("creating browse data table " & sql)
If Not dbs.create(dbinf.henv, dbinf.hdbcv, t_nam, sql) Then
GoTo dtaberr
Else
pvOpenBrowseDataTables.Add(dbs)
Return dbs
End If
Exit Function
dtaberr:
logDBError(Me, Err.Description)
dbs = Nothing
Return Nothing
End Function
Public Function ADODataTable(ByVal DTName As String, ByVal SqlString As String) As System.Data.DataTable
On Error GoTo dseterr
Dim dbs As New nbfResultSet
Dim ds As New System.Data.DataTable(DTName)
Dim DataCol As System.Data.DataColumn
Dim DataRow As System.Data.DataRow
Dim cc As Integer
dbs.setparent(Me)
dbs.Cloned = True
ChkPrf(SqlString)
'LogMess("creating ADO data table " & sqlString)
If Not dbs.create(Me, SqlString) Then
GoTo dseterr
End If
For cc = 1 To dbs.nocols
DataCol = New System.Data.DataColumn()
Select Case dbs.ColumnDatatype(cc)
Case SQL_CHAR, SQL_VARCHAR, SQL_BINARY, SQL_VARBINARY, -9
DataCol.DataType = System.Type.GetType("System.String")
Case SQL_LONGVARCHAR, SQL_LONGVARBINARY
DataCol.DataType = System.Type.GetType("System.String")
Case SQL_BIT, SQL_TINYINT, SQL_SMALLINT, SQL_INTEGER
DataCol.DataType = System.Type.GetType("System.Int32")
Case SQL_BIGINT
DataCol.DataType = System.Type.GetType("System.Decimal")
Case SQL_FLOAT, SQL_DOUBLE, SQL_NUMERIC, SQL_DECIMAL, SQL_REAL
DataCol.DataType = System.Type.GetType("System.Decimal")
Case SQL_DATE, SQL_TIMESTAMP
DataCol.DataType = System.Type.GetType("System.DateTime")
Case Else
DataCol.DataType = System.Type.GetType("System.String")
End Select
DataCol.ColumnName = dbs.ColumnName(cc)
DataCol.ReadOnly = False
DataCol.Unique = False
ds.Columns.Add(DataCol)
Next
Do While dbs.fetch()
DataRow = ds.NewRow
For cc = 1 To dbs.nocols
Select Case dbs.ColumnDatatype(cc)
Case SQL_CHAR, SQL_VARCHAR, SQL_BINARY, SQL_VARBINARY, -9
DataRow(dbs.ColumnName(cc)) = dbs.FetchString(cc)
Case SQL_LONGVARCHAR, SQL_LONGVARBINARY
DataRow(dbs.ColumnName(cc)) = dbs.FetchString(cc)
Case SQL_BIT, SQL_TINYINT, SQL_SMALLINT, SQL_INTEGER
DataRow(dbs.ColumnName(cc)) = dbs.FetchLong(cc)
Case SQL_BIGINT
DataRow(dbs.ColumnName(cc)) = CDec(dbs.FetchDouble(cc))
Case SQL_FLOAT, SQL_DOUBLE, SQL_NUMERIC, SQL_DECIMAL, SQL_REAL
DataRow(dbs.ColumnName(cc)) = CDec(dbs.FetchDouble(cc))
Case SQL_DATE, SQL_TIMESTAMP
DataRow(dbs.ColumnName(cc)) = dbs.FetchDate(cc)
Case Else
DataRow(dbs.ColumnName(cc)) = dbs.FetchString(cc)
End Select
Next
ds.Rows.Add(DataRow)
DataRow = Nothing
Loop
dbs.Free()
Return ds
Exit Function
dseterr:
dbs = Nothing
ADODataTable = Nothing
ShowMessage(Err.Description)
Err.Raise(2 + vbObjectError, , Err.Description & " unable to create table " & SqlString)
Exit Function
End Function
Public Function ADODataSet(ByVal DSName As String, ByVal SqlString As String) As System.Data.DataSet
On Error GoTo dseterr
Dim ndSet As New DataSet
Dim nTable As DataTable = ADODataTable(DSName, SqlString)
Dim productTable As New DataTable
ChkPrf(SqlString)
' Add the tables to the DataSet:
ndSet.Tables.Add(nTable)
'' Load the data into the existing DataSet.
'Dim reader As DataTableReader = ndSet.CreateDataReader()
'ndSet.Load(reader, LoadOption.OverwriteChanges, nTable)
Return ndSet
Exit Function
dseterr:
ShowMessage(Err.Description)
Err.Raise(2 + vbObjectError, , Err.Description & " unable to create dataset " & SqlString)
Exit Function
End Function
Public ReadOnly Property cachesetting() As Object
Get
Dim ask As Short
Dim xc As String
Dim cnt As Short
Dim os As String
Dim tp As String
tp = Trim(dbinf.this_pswd)
If Len(tp) = 0 Then
os = ""
Else
For cnt = 1 To Len(tp)
xc = Mid(tp, cnt, 1)
ask = Asc(xc)
If ask = 255 Then
ask = 1
Else
ask = ask + 1
End If
os = os & VB6.Format(ask, "000")
Next cnt
End If
cachesetting = os
End Get
End Property
Public ReadOnly Property DSN() As String
Get
DSN = dbinf.DSN
End Get
End Property
Public ReadOnly Property henv() As Object
Get
henv = dbinf.henv
End Get
End Property
Public ReadOnly Property handle() As Object
Get
Return dbinf.hdbcv
End Get
End Property
Public ReadOnly Property LongDT() As Short
Get
LongDT = dbinf.host_blong
End Get
End Property
Public ReadOnly Property IntDT() As Short
Get
IntDT = dbinf.host_bint
End Get
End Property
Public ReadOnly Property DoubleDT() As Short
Get
DoubleDT = dbinf.host_bdouble
End Get
End Property
Public ReadOnly Property DateDT() As Short
Get
DateDT = dbinf.host_bdate
End Get
End Property
Public ReadOnly Property LongVarCharDataType() As Object
Get
LongVarCharDataType = dbinf.LongVarCharDataType
End Get
End Property
Public ReadOnly Property NoPOSUpdate() As Boolean
Get
NoPOSUpdate = dbinf.NoPOSUpdate
End Get
End Property
Public ReadOnly Property TimestampDT() As Short
Get
TimestampDT = dbinf.host_btimestamp
End Get
End Property
Public ReadOnly Property TimestampDataType() As Short
Get
TimestampDataType = CShort(dbinf.TimestampDataType)
End Get
End Property
Public ReadOnly Property UserName() As Object
Get
UserName = dbinf.this_user
End Get
End Property
Public Property LogName() As String
Get
If pvCloneParent Is Nothing Then
If String.IsNullOrEmpty(pvLogName) Then
Return "My.N"
Else
Return pvLogName
End If
Else
Return pvCloneParent.LogName
End If
End Get
Set(ByVal value As String)
If Not String.IsNullOrEmpty(value) Then
pvLogName = value
'eventLog = pvLogName
Try
If Not System.Diagnostics.EventLog.SourceExists(pvLogName) Then
System.Diagnostics.EventLog.CreateEventSource(pvLogName, "MyNLog")
System.Windows.Forms.Application.DoEvents()
End If
Catch
'no action
End Try
End If
End Set
End Property
Public ReadOnly Property HostDatabase() As Object
Get
HostDatabase = dbinf.HostDB
End Get
End Property
Public ReadOnly Property IntDataType() As Object
Get
IntDataType = dbinf.IntDataType
End Get
End Property
Public ReadOnly Property LongDataType() As Object
Get
LongDataType = dbinf.LongDataType
End Get
End Property
Public ReadOnly Property DoubleDataType() As Object
Get
DoubleDataType = dbinf.DoubleDataType
End Get
End Property
Public ReadOnly Property DateDataType() As Object
Get
DateDataType = dbinf.DateDataType
End Get
End Property
Public ReadOnly Property CharDataType() As Object
Get
CharDataType = dbinf.CharDataType
End Get
End Property
Public ReadOnly Property VarCharDataType() As Object
Get
VarCharDataType = dbinf.VarCharDataType
End Get
End Property
Public ReadOnly Property BinaryDataType() As Object
Get
BinaryDataType = dbinf.BinaryDataType
End Get
End Property
Public ReadOnly Property DoublePrecReq() As Object
Get
DoublePrecReq = dbinf.DoublePrecReq
End Get
End Property
Public ReadOnly Property DoublePrec() As Object
Get
DoublePrec = dbinf.DoublePrec
End Get
End Property
Public ReadOnly Property DoubleScale() As Object
Get
DoubleScale = dbinf.DoubleScale
End Get
End Property
Public ReadOnly Property intransact() As Object
Get
intransact = dbinf.intransact
End Get
End Property
Public Function callfunction(ByVal f_name As String, ByVal ParamArray fargs() As Object) As Decimal
Dim mr As Short
Dim prm As String
Dim cnt As Short
Dim sql As String
Dim r As Short = 0
Dim hstmt As Integer
Dim retval As Double
Dim inlval As Integer
Dim rgbvalue As String
Dim pcbValue As Integer
Dim bufsize As Integer
rgbvalue = Space(256)
bufsize = 255
On Error GoTo cferr
ChkPrf(f_name)
Dim gch As System.Runtime.InteropServices.GCHandle
gch = System.Runtime.InteropServices.GCHandle.Alloc(retval, System.Runtime.InteropServices.GCHandleType.Pinned)
'LogMess("calling funtion " & f_name)
r = SQLAllocStmt(dbinf.hdbcv, hstmt)
r = SQLBindParameter(hstmt, 1, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval, 8, NULL_POINTER)
'r% = SQLSetParam(hstmt&, 1, SQL_C_DOUBLE, dbinf.host_bdouble, 8&, 0, retval, ByVal NULL_POINTER)
'r% = SQLSetParam(hstmt&, 1, SQL_C_SHORT, dbinf.host_bint, 2&, 0, retval, ByVal NULL_POINTER)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
gch.Free()
jump()
End If
If fargs.Length = 0 Then
sql = "{?=call " & f_name & "}"
Else
sql = "{?=call " & f_name & "("
'paramarray
For cnt = LBound(fargs) To UBound(fargs)
Select Case VarType(fargs(cnt))
Case VariantType.Null
prm = "NULL"
Case VariantType.Short, VariantType.Integer, VariantType.Single, VariantType.Double, VariantType.Decimal
prm = VB6.Format(fargs(cnt))
Case VariantType.Date
prm = Fdatetime(fargs(cnt))
Case Else
prm = fnds(CStr(fargs(cnt)))
End Select
If cnt = LBound(fargs) Then
sql = sql & prm
Else
sql = sql & "," & prm
End If
Next cnt
sql = sql & ")}"
End If
r = SQLExecDirect(hstmt, sql, CInt(Len(sql)))
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
showerror(r, hstmt)
gch.Free()
GoTo cferr
Else
End If
mr = SQLMoreResults(hstmt)
Do While mr <> SQL_NO_DATA_FOUND
mr = SQLMoreResults(hstmt)
Loop
r = SQLFreeStmt(hstmt, SQL_DROP)
gch.Free()
callfunction = retval
'If retval = 0 Then
' callfunction = False
'Else
' callfunction = True
'End If
Exit Function
cferr:
callfunction = 0
If Err.Number <> 0 Then
ShowMessage(Err.Description)
End If
Err.Raise(20 + vbObjectError, , Err.Description & " Error calling function " & f_name)
Exit Function
End Function
Public Function CallFunctionExp(ByVal f_name As String, ByVal S As String) As Decimal
Dim mr As Short
Dim sql As String
Dim r As Short = 0
Dim hstmt As Integer
Dim retval As Double
Dim inlval As Integer
Dim rgbvalue As String
Dim pcbValue As Integer
Dim bufsize As Integer
rgbvalue = Space(256)
bufsize = 255
On Error GoTo cfeerr
ChkPrf(f_name)
'LogMess("calling funtion " & f_name)
Dim gch As System.Runtime.InteropServices.GCHandle
gch = System.Runtime.InteropServices.GCHandle.Alloc(retval, System.Runtime.InteropServices.GCHandleType.Pinned)
r = SQLAllocStmt(dbinf.hdbcv, hstmt)
r = SQLBindParameter(hstmt, 1, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval, 8, NULL_POINTER)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
gch.Free()
jump()
End If
sql = "{?=call " & f_name & "(" & S & ")}"
r = SQLExecDirect(hstmt, sql, CInt(Len(sql)))
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
showerror(r, hstmt)
gch.Free()
GoTo cfeerr
Else
End If
mr = SQLMoreResults(hstmt)
Do While mr <> SQL_NO_DATA_FOUND
mr = SQLMoreResults(hstmt)
Loop
r = SQLFreeStmt(hstmt, SQL_DROP)
gch.Free()
CallFunctionExp = retval
Exit Function
cfeerr:
CallFunctionExp = 0
If Err.Number <> 0 Then
ShowMessage(Err.Description)
End If
Err.Raise(22 + vbObjectError, , Err.Description & " Error calling function " & f_name)
Exit Function
End Function
Public Sub CallProcedure(ByVal f_name As String, ByVal ParamArray fargs() As Object)
Dim mr As Short
Dim prm As String
Dim cnt As Short
Dim sql As String
Dim r As Short = 0
Dim hstmt As Integer
On Error GoTo cpferr
'LogMess("calling funtion " & f_name)
ChkPrf(f_name)
r = SQLAllocStmt(dbinf.hdbcv, hstmt)
'paramarray
If fargs.Length = 0 Then
sql = "{call " & f_name & "}"
Else
sql = "{call " & f_name & "("
For cnt = LBound(fargs) To UBound(fargs)
Select Case VarType(fargs(cnt))
Case VariantType.Null
prm = "NULL"
Case VariantType.Short, VariantType.Integer, VariantType.Single, VariantType.Double, VariantType.Decimal
prm = VB6.Format(fargs(cnt))
Case VariantType.Date
prm = Fdatetime(fargs(cnt))
Case Else
prm = fnds(CStr(fargs(cnt)))
End Select
If cnt = LBound(fargs) Then
sql = sql & prm
Else
sql = sql & "," & prm
End If
Next cnt
sql = sql & ")}"
End If
r = SQLExecDirect(hstmt, sql, CInt(Len(sql)))
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
showerror(r, hstmt)
GoTo cpferr
Else
End If
mr = SQLMoreResults(hstmt)
Do While mr <> SQL_NO_DATA_FOUND
mr = SQLMoreResults(hstmt)
Loop
r = SQLFreeStmt(hstmt, SQL_DROP)
Exit Sub
cpferr:
If Err.Number <> 0 Then
ShowMessage(Err.Description)
End If
Err.Raise(26 + vbObjectError, , Err.Description & " Error calling procedure " & f_name)
Exit Sub
End Sub
Public Sub CallProcedureExp(ByVal f_name As String, ByVal S As String)
Dim mr As Short
Dim sql As String
Dim r As Short = 0
Dim hstmt As Integer
On Error GoTo cpfeerr
'LogMess("calling funtion " & f_name)
ChkPrf(f_name)
r = SQLAllocStmt(dbinf.hdbcv, hstmt)
sql = "{call " & f_name & "(" & S & ")}"
r = SQLExecDirect(hstmt, sql, CInt(Len(sql)))
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
showerror(r, hstmt)
GoTo cpfeerr
Else
End If
mr = SQLMoreResults(hstmt)
Do While mr <> SQL_NO_DATA_FOUND
mr = SQLMoreResults(hstmt)
Loop
r = SQLFreeStmt(hstmt, SQL_DROP)
Exit Sub
cpfeerr:
If Err.Number <> 0 Then
ShowMessage(Err.Description)
End If
Err.Raise(26 + vbObjectError, , Err.Description & " Error calling procedure " & f_name)
Exit Sub
End Sub
Public Function CallR1function(ByVal f_name As String, ByRef FirstParam As Double, ByVal ParamArray fargs() As Object) As Decimal
Dim mr As Short
Dim prm As String
Dim cnt As Short
Dim sql As String
Dim r As Short = 0
Dim hstmt As Integer
Dim retval As Double
Dim retval1 As Double
Dim inlval As Integer
Dim rgbvalue As String
Dim pcbValue As Integer
Dim bufsize As Integer
rgbvalue = Space(256)
bufsize = 255
On Error GoTo cferr
ChkPrf(f_name)
Dim gch As System.Runtime.InteropServices.GCHandle
gch = System.Runtime.InteropServices.GCHandle.Alloc(retval, System.Runtime.InteropServices.GCHandleType.Pinned)
Dim gch1 As System.Runtime.InteropServices.GCHandle
gch1 = System.Runtime.InteropServices.GCHandle.Alloc(retval1, System.Runtime.InteropServices.GCHandleType.Pinned)
'LogMess("calling funtion " & f_name)
r = SQLAllocStmt(dbinf.hdbcv, hstmt)
r = SQLBindParameter(hstmt, 1, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval, 8, NULL_POINTER)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
jump()
End If
r = SQLBindParameter(hstmt, 2, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval1, 8, NULL_POINTER)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
jump()
End If
sql = "{?=call " & f_name & "(?"
'paramarray
If fargs.Length > 0 Then
For cnt = LBound(fargs) To UBound(fargs)
Select Case VarType(fargs(cnt))
Case VariantType.Null
prm = "NULL"
Case VariantType.Short, VariantType.Integer, VariantType.Single, VariantType.Double, VariantType.Decimal
prm = VB6.Format(fargs(cnt))
Case VariantType.Date
prm = Fdatetime(fargs(cnt))
Case Else
prm = fnds(CStr(fargs(cnt)))
End Select
sql = sql & "," & prm
Next cnt
End If
sql = sql & ")}"
r = SQLExecDirect(hstmt, sql, CInt(Len(sql)))
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
GoTo cferr
Else
End If
mr = SQLMoreResults(hstmt)
Do While mr <> SQL_NO_DATA_FOUND
mr = SQLMoreResults(hstmt)
Loop
r = SQLFreeStmt(hstmt, SQL_DROP)
gch.Free()
gch1.Free()
FirstParam = retval1
CallR1function = retval
Exit Function
cferr:
CallR1function = 0
If Err.Number <> 0 Then
ShowMessage(Err.Description)
End If
Err.Raise(20 + vbObjectError, , Err.Description & " Error calling function " & f_name)
Exit Function
End Function
Public Function CallR2function(ByVal f_name As String, ByRef FirstParam As Double, ByRef SecondParam As Double, ByVal ParamArray fargs() As Object) As Decimal
Dim mr As Short
Dim prm As String
Dim cnt As Short
Dim sql As String
Dim r As Short = 0
Dim hstmt As Integer
Dim retval As Double
Dim retval1 As Double
Dim retval2 As Double
Dim inlval As Integer
Dim rgbvalue As String
Dim pcbValue As Integer
Dim bufsize As Integer
rgbvalue = Space(256)
bufsize = 255
On Error GoTo cferr
ChkPrf(f_name)
'LogMess("calling funtion " & f_name)
Dim gch As System.Runtime.InteropServices.GCHandle
gch = System.Runtime.InteropServices.GCHandle.Alloc(retval, System.Runtime.InteropServices.GCHandleType.Pinned)
Dim gch1 As System.Runtime.InteropServices.GCHandle
gch1 = System.Runtime.InteropServices.GCHandle.Alloc(retval1, System.Runtime.InteropServices.GCHandleType.Pinned)
Dim gch2 As System.Runtime.InteropServices.GCHandle
gch2 = System.Runtime.InteropServices.GCHandle.Alloc(retval2, System.Runtime.InteropServices.GCHandleType.Pinned)
r = SQLAllocStmt(dbinf.hdbcv, hstmt)
r = SQLBindParameter(hstmt, 1, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval, 8, NULL_POINTER)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
gch2.Free()
jump()
End If
r = SQLBindParameter(hstmt, 2, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval1, 8, NULL_POINTER)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
gch2.Free()
jump()
End If
r = SQLBindParameter(hstmt, 3, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval2, 8, NULL_POINTER)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
gch2.Free()
jump()
End If
sql = "{?=call " & f_name & "(?,?"
'paramarray
If fargs.Length > 0 Then
For cnt = LBound(fargs) To UBound(fargs)
Select Case VarType(fargs(cnt))
Case VariantType.Null
prm = "NULL"
Case VariantType.Short, VariantType.Integer, VariantType.Single, VariantType.Double, VariantType.Decimal
prm = VB6.Format(fargs(cnt))
Case VariantType.Date
prm = Fdatetime(fargs(cnt))
Case Else
prm = fnds(CStr(fargs(cnt)))
End Select
sql = sql & "," & prm
Next cnt
End If
sql = sql & ")}"
r = SQLExecDirect(hstmt, sql, CInt(Len(sql)))
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
gch2.Free()
GoTo cferr
Else
End If
mr = SQLMoreResults(hstmt)
Do While mr <> SQL_NO_DATA_FOUND
mr = SQLMoreResults(hstmt)
Loop
r = SQLFreeStmt(hstmt, SQL_DROP)
gch.Free()
gch1.Free()
gch2.Free()
FirstParam = retval1
SecondParam = retval2
CallR2function = retval
Exit Function
cferr:
CallR2function = 0
If Err.Number <> 0 Then
ShowMessage(Err.Description)
End If
Err.Raise(20 + vbObjectError, , Err.Description & " Error calling function " & f_name)
Exit Function
End Function
Public Function CallR3function(ByVal f_name As String, ByRef FirstParam As Double, ByRef SecondParam As Double, ByRef ThirdParam As Double, ByVal ParamArray fargs() As Object) As Decimal
Dim mr As Short
Dim prm As String
Dim cnt As Short
Dim sql As String
Dim r As Short = 0
Dim hstmt As Integer
Dim retval As Double
Dim retval1 As Double
Dim retval2 As Double
Dim retval3 As Double
Dim inlval As Integer
Dim rgbvalue As String
Dim pcbValue As Integer
Dim bufsize As Integer
rgbvalue = Space(256)
bufsize = 255
On Error GoTo cferr
ChkPrf(f_name)
'LogMess("calling funtion " & f_name)
Dim gch As System.Runtime.InteropServices.GCHandle
gch = System.Runtime.InteropServices.GCHandle.Alloc(retval, System.Runtime.InteropServices.GCHandleType.Pinned)
Dim gch1 As System.Runtime.InteropServices.GCHandle
gch1 = System.Runtime.InteropServices.GCHandle.Alloc(retval1, System.Runtime.InteropServices.GCHandleType.Pinned)
Dim gch2 As System.Runtime.InteropServices.GCHandle
gch2 = System.Runtime.InteropServices.GCHandle.Alloc(retval2, System.Runtime.InteropServices.GCHandleType.Pinned)
Dim gch3 As System.Runtime.InteropServices.GCHandle
gch3 = System.Runtime.InteropServices.GCHandle.Alloc(retval3, System.Runtime.InteropServices.GCHandleType.Pinned)
r = SQLAllocStmt(dbinf.hdbcv, hstmt)
r = SQLBindParameter(hstmt, 1, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval, 8, NULL_POINTER)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
gch2.Free()
gch3.Free()
jump()
End If
r = SQLBindParameter(hstmt, 2, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval1, 8, NULL_POINTER)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
gch2.Free()
gch3.Free()
jump()
End If
r = SQLBindParameter(hstmt, 3, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval2, 8, NULL_POINTER)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
gch2.Free()
gch3.Free()
jump()
End If
r = SQLBindParameter(hstmt, 4, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval3, 8, NULL_POINTER)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
gch2.Free()
gch3.Free()
jump()
End If
sql = "{?=call " & f_name & "(?,?,?"
'paramarray
If fargs.Length > 0 Then
For cnt = LBound(fargs) To UBound(fargs)
Select Case VarType(fargs(cnt))
Case VariantType.Null
prm = "NULL"
Case VariantType.Short, VariantType.Integer, VariantType.Single, VariantType.Double, VariantType.Decimal
prm = VB6.Format(fargs(cnt))
Case VariantType.Date
prm = Fdatetime(fargs(cnt))
Case Else
prm = fnds(CStr(fargs(cnt)))
End Select
sql = sql & "," & prm
Next cnt
End If
sql = sql & ")}"
r = SQLExecDirect(hstmt, sql, CInt(Len(sql)))
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
showerror(r, hstmt)
GoTo cferr
Else
End If
mr = SQLMoreResults(hstmt)
Do While mr <> SQL_NO_DATA_FOUND
mr = SQLMoreResults(hstmt)
Loop
r = SQLFreeStmt(hstmt, SQL_DROP)
gch.Free()
gch1.Free()
gch2.Free()
gch3.Free()
FirstParam = retval1
SecondParam = retval2
ThirdParam = retval3
Return retval
Exit Function
cferr:
CallR3function = 0
If Err.Number <> 0 Then
ShowMessage(Err.Description)
End If
Err.Raise(20 + vbObjectError, , Err.Description & " Error calling function " & f_name)
Exit Function
End Function
Public Function CallR4function(ByVal f_name As String, ByRef FirstParam As Double, ByRef SecondParam As Double, ByRef ThirdParam As Double, ByRef FourthParam As Double, ByVal ParamArray fargs() As Object) As Decimal
Dim mr As Short
Dim prm As String
Dim cnt As Short
Dim sql As String
Dim r As Short = 0
Dim hstmt As Integer
Dim retval As Double
Dim retval1 As Double
Dim retval2 As Double
Dim retval3 As Double
Dim retval4 As Double
Dim inlval As Integer
Dim rgbvalue As String
Dim pcbValue As Integer
Dim bufsize As Integer
rgbvalue = Space(256)
bufsize = 255
On Error GoTo cferr
ChkPrf(f_name)
'LogMess("calling funtion " & f_name)
Dim gch As System.Runtime.InteropServices.GCHandle
gch = System.Runtime.InteropServices.GCHandle.Alloc(retval, System.Runtime.InteropServices.GCHandleType.Pinned)
Dim gch1 As System.Runtime.InteropServices.GCHandle
gch1 = System.Runtime.InteropServices.GCHandle.Alloc(retval1, System.Runtime.InteropServices.GCHandleType.Pinned)
Dim gch2 As System.Runtime.InteropServices.GCHandle
gch2 = System.Runtime.InteropServices.GCHandle.Alloc(retval2, System.Runtime.InteropServices.GCHandleType.Pinned)
Dim gch3 As System.Runtime.InteropServices.GCHandle
gch3 = System.Runtime.InteropServices.GCHandle.Alloc(retval3, System.Runtime.InteropServices.GCHandleType.Pinned)
Dim gch4 As System.Runtime.InteropServices.GCHandle
gch4 = System.Runtime.InteropServices.GCHandle.Alloc(retval4, System.Runtime.InteropServices.GCHandleType.Pinned)
r = SQLAllocStmt(dbinf.hdbcv, hstmt)
r = SQLBindParameter(hstmt, 1, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval, 8, NULL_POINTER)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
gch2.Free()
gch3.Free()
gch4.Free()
jump()
End If
r = SQLBindParameter(hstmt, 2, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval1, 8, NULL_POINTER)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
gch2.Free()
gch3.Free()
gch4.Free()
jump()
End If
r = SQLBindParameter(hstmt, 3, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval2, 8, NULL_POINTER)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
gch2.Free()
gch3.Free()
gch4.Free()
jump()
End If
r = SQLBindParameter(hstmt, 4, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval3, 8, NULL_POINTER)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
gch2.Free()
gch3.Free()
gch4.Free()
jump()
End If
r = SQLBindParameter(hstmt, 5, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval4, 8, NULL_POINTER)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
gch2.Free()
gch3.Free()
gch4.Free()
jump()
End If
sql = "{?=call " & f_name & "(?,?,?,?"
'paramarray
If fargs.Length > 0 Then
For cnt = LBound(fargs) To UBound(fargs)
Select Case VarType(fargs(cnt))
Case VariantType.Null
prm = "NULL"
Case VariantType.Short, VariantType.Integer, VariantType.Single, VariantType.Double, VariantType.Decimal
prm = VB6.Format(fargs(cnt))
Case VariantType.Date
prm = Fdatetime(fargs(cnt))
Case Else
prm = fnds(CStr(fargs(cnt)))
End Select
sql = sql & "," & prm
Next cnt
End If
sql = sql & ")}"
r = SQLExecDirect(hstmt, sql, CInt(Len(sql)))
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
gch2.Free()
gch3.Free()
gch4.Free()
GoTo cferr
Else
End If
mr = SQLMoreResults(hstmt)
Do While mr <> SQL_NO_DATA_FOUND
mr = SQLMoreResults(hstmt)
Loop
r = SQLFreeStmt(hstmt, SQL_DROP)
gch.Free()
gch1.Free()
gch2.Free()
gch3.Free()
gch4.Free()
FirstParam = retval1
SecondParam = retval2
ThirdParam = retval3
FourthParam = retval4
CallR4function = retval
Exit Function
cferr:
CallR4function = 0
If Err.Number <> 0 Then
ShowMessage(Err.Description)
End If
Err.Raise(20 + vbObjectError, , Err.Description & " Error calling function " & f_name)
Exit Function
End Function
Public Function CallR1FunctionExp(ByVal f_name As String, ByRef FirstParam As Double, ByVal S As String) As Decimal
Dim mr As Short
Dim sql As String
Dim r As Short = 0
Dim hstmt As Integer
Dim retval As Double
Dim retval1 As Double
Dim inlval As Integer
Dim rgbvalue As String
Dim pcbValue As Integer
Dim bufsize As Integer
rgbvalue = Space(256)
bufsize = 255
On Error GoTo cfeerr
ChkPrf(f_name)
'LogMess("calling funtion " & f_name)
Dim gch As System.Runtime.InteropServices.GCHandle
gch = System.Runtime.InteropServices.GCHandle.Alloc(retval, System.Runtime.InteropServices.GCHandleType.Pinned)
Dim gch1 As System.Runtime.InteropServices.GCHandle
gch1 = System.Runtime.InteropServices.GCHandle.Alloc(retval1, System.Runtime.InteropServices.GCHandleType.Pinned)
r = SQLAllocStmt(dbinf.hdbcv, hstmt)
r = SQLBindParameter(hstmt, 1, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval, 8, NULL_POINTER)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
jump()
End If
r = SQLBindParameter(hstmt, 2, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval1, 8, NULL_POINTER)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
jump()
End If
sql = "{?=call " & f_name & "(?," & S & ")}"
r = SQLExecDirect(hstmt, sql, CInt(Len(sql)))
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
GoTo cfeerr
Else
End If
mr = SQLMoreResults(hstmt)
Do While mr <> SQL_NO_DATA_FOUND
mr = SQLMoreResults(hstmt)
Loop
r = SQLFreeStmt(hstmt, SQL_DROP)
FirstParam = retval1
gch.Free()
gch1.Free()
Return retval
Exit Function
cfeerr:
CallR1FunctionExp = 0
If Err.Number <> 0 Then
ShowMessage(Err.Description)
End If
Err.Raise(22 + vbObjectError, , Err.Description & " Error calling function " & f_name)
Exit Function
End Function
Public Function CallR2FunctionExp(ByVal f_name As String, ByRef FirstParam As Double, ByRef SecondParam As Double, ByVal S As String) As Decimal
Dim mr As Short
Dim sql As String
Dim r As Short = 0
Dim hstmt As Integer
Dim retval As Double
Dim retval1 As Double
Dim retval2 As Double
Dim inlval As Integer
Dim rgbvalue As String
Dim pcbValue As Integer
Dim bufsize As Integer
rgbvalue = Space(256)
bufsize = 255
On Error GoTo cfeerr
ChkPrf(f_name)
'LogMess("calling funtion " & f_name)
Dim gch As System.Runtime.InteropServices.GCHandle
gch = System.Runtime.InteropServices.GCHandle.Alloc(retval, System.Runtime.InteropServices.GCHandleType.Pinned)
Dim gch1 As System.Runtime.InteropServices.GCHandle
gch1 = System.Runtime.InteropServices.GCHandle.Alloc(retval1, System.Runtime.InteropServices.GCHandleType.Pinned)
Dim gch2 As System.Runtime.InteropServices.GCHandle
gch2 = System.Runtime.InteropServices.GCHandle.Alloc(retval2, System.Runtime.InteropServices.GCHandleType.Pinned)
r = SQLAllocStmt(dbinf.hdbcv, hstmt)
r = SQLBindParameter(hstmt, 1, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval, 8, NULL_POINTER)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
gch2.Free()
jump()
End If
r = SQLBindParameter(hstmt, 2, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval1, 8, NULL_POINTER)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
gch2.Free()
jump()
End If
r = SQLBindParameter(hstmt, 3, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval2, 8, NULL_POINTER)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
gch2.Free()
jump()
End If
sql = "{?=call " & f_name & "(?,?," & S & ")}"
r = SQLExecDirect(hstmt, sql, CInt(Len(sql)))
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
gch2.Free()
GoTo cfeerr
Else
End If
mr = SQLMoreResults(hstmt)
Do While mr <> SQL_NO_DATA_FOUND
mr = SQLMoreResults(hstmt)
Loop
r = SQLFreeStmt(hstmt, SQL_DROP)
gch.Free()
gch1.Free()
gch2.Free()
FirstParam = retval1
SecondParam = retval2
CallR2FunctionExp = retval
Exit Function
cfeerr:
CallR2FunctionExp = 0
If Err.Number <> 0 Then
ShowMessage(Err.Description)
End If
Err.Raise(22 + vbObjectError, , Err.Description & " Error calling function " & f_name)
Exit Function
End Function
Public Function CallR3FunctionExp(ByVal f_name As String, ByRef FirstParam As Double, ByRef SecondParam As Double, ByRef ThirdParam As Double, ByVal S As String) As Decimal
Dim mr As Short
Dim sql As String
Dim r As Short = 0
Dim hstmt As Integer
Dim retval As Double
Dim retval1 As Double
Dim retval2 As Double
Dim retval3 As Double
Dim inlval As Integer
Dim rgbvalue As String
Dim pcbValue As Integer
Dim bufsize As Integer
rgbvalue = Space(256)
bufsize = 255
On Error GoTo cfeerr
ChkPrf(f_name)
'LogMess("calling funtion " & f_name)
Dim gch As System.Runtime.InteropServices.GCHandle
gch = System.Runtime.InteropServices.GCHandle.Alloc(retval, System.Runtime.InteropServices.GCHandleType.Pinned)
Dim gch1 As System.Runtime.InteropServices.GCHandle
gch1 = System.Runtime.InteropServices.GCHandle.Alloc(retval1, System.Runtime.InteropServices.GCHandleType.Pinned)
Dim gch2 As System.Runtime.InteropServices.GCHandle
gch2 = System.Runtime.InteropServices.GCHandle.Alloc(retval2, System.Runtime.InteropServices.GCHandleType.Pinned)
Dim gch3 As System.Runtime.InteropServices.GCHandle
gch3 = System.Runtime.InteropServices.GCHandle.Alloc(retval3, System.Runtime.InteropServices.GCHandleType.Pinned)
r = SQLAllocStmt(dbinf.hdbcv, hstmt)
r = SQLBindParameter(hstmt, 1, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval, 8, NULL_POINTER)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
gch2.Free()
gch3.Free()
jump()
End If
r = SQLBindParameter(hstmt, 2, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval1, 8, NULL_POINTER)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
gch2.Free()
gch3.Free()
jump()
End If
r = SQLBindParameter(hstmt, 3, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval2, 8, NULL_POINTER)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
gch2.Free()
gch3.Free()
jump()
End If
r = SQLBindParameter(hstmt, 4, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval3, 8, NULL_POINTER)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
gch2.Free()
gch3.Free()
jump()
End If
sql = "{?=call " & f_name & "(?,?,?," & S & ")}"
r = SQLExecDirect(hstmt, sql, CInt(Len(sql)))
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
gch2.Free()
gch3.Free()
GoTo cfeerr
Else
End If
mr = SQLMoreResults(hstmt)
Do While mr <> SQL_NO_DATA_FOUND
mr = SQLMoreResults(hstmt)
Loop
r = SQLFreeStmt(hstmt, SQL_DROP)
gch.Free()
gch1.Free()
gch2.Free()
gch3.Free()
FirstParam = retval1
SecondParam = retval2
ThirdParam = retval3
Return retval
Exit Function
cfeerr:
CallR3FunctionExp = 0
If Err.Number <> 0 Then
ShowMessage(Err.Description)
End If
Err.Raise(22 + vbObjectError, , Err.Description & " Error calling function " & f_name)
Exit Function
End Function
Public Function CallR4FunctionExp(ByVal f_name As String, ByRef FirstParam As Double, ByRef SecondParam As Double, ByRef ThirdParam As Double, ByRef FourthParam As Double, ByVal S As String) As Decimal
Dim mr As Short
Dim sql As String
Dim r As Short = 0
Dim hstmt As Integer
Dim retval As Double
Dim retval1 As Double
Dim retval2 As Double
Dim retval3 As Double
Dim retval4 As Double
Dim inlval As Integer
Dim rgbvalue As String
Dim pcbValue As Integer
Dim bufsize As Integer
rgbvalue = Space(256)
bufsize = 255
On Error GoTo cfeerr
ChkPrf(f_name)
'LogMess("calling funtion " & f_name)
Dim gch As System.Runtime.InteropServices.GCHandle
gch = System.Runtime.InteropServices.GCHandle.Alloc(retval, System.Runtime.InteropServices.GCHandleType.Pinned)
Dim gch1 As System.Runtime.InteropServices.GCHandle
gch1 = System.Runtime.InteropServices.GCHandle.Alloc(retval1, System.Runtime.InteropServices.GCHandleType.Pinned)
Dim gch2 As System.Runtime.InteropServices.GCHandle
gch2 = System.Runtime.InteropServices.GCHandle.Alloc(retval2, System.Runtime.InteropServices.GCHandleType.Pinned)
Dim gch3 As System.Runtime.InteropServices.GCHandle
gch3 = System.Runtime.InteropServices.GCHandle.Alloc(retval3, System.Runtime.InteropServices.GCHandleType.Pinned)
Dim gch4 As System.Runtime.InteropServices.GCHandle
gch4 = System.Runtime.InteropServices.GCHandle.Alloc(retval4, System.Runtime.InteropServices.GCHandleType.Pinned)
r = SQLAllocStmt(dbinf.hdbcv, hstmt)
r = SQLBindParameter(hstmt, 1, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval, 8, NULL_POINTER)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
gch2.Free()
gch3.Free()
gch4.Free()
jump()
End If
r = SQLBindParameter(hstmt, 2, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval1, 8, NULL_POINTER)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
gch2.Free()
gch3.Free()
gch4.Free()
jump()
End If
r = SQLBindParameter(hstmt, 3, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval2, 8, NULL_POINTER)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
gch2.Free()
gch3.Free()
gch4.Free()
jump()
End If
r = SQLBindParameter(hstmt, 4, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval3, 8, NULL_POINTER)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
gch2.Free()
gch3.Free()
gch4.Free()
jump()
End If
r = SQLBindParameter(hstmt, 5, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval4, 8, NULL_POINTER)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
gch2.Free()
gch3.Free()
gch4.Free()
jump()
End If
sql = "{?=call " & f_name & "(?,?,?,?," & S & ")}"
r = SQLExecDirect(hstmt, sql, CInt(Len(sql)))
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
showerror(r, hstmt)
GoTo cfeerr
Else
End If
mr = SQLMoreResults(hstmt)
Do While mr <> SQL_NO_DATA_FOUND
mr = SQLMoreResults(hstmt)
Loop
r = SQLFreeStmt(hstmt, SQL_DROP)
gch.Free()
gch1.Free()
gch2.Free()
gch3.Free()
gch4.Free()
FirstParam = retval1
SecondParam = retval2
ThirdParam = retval3
FourthParam = retval4
Return retval
Exit Function
cfeerr:
CallR4FunctionExp = 0
If Err.Number <> 0 Then
ShowMessage(Err.Description)
End If
Err.Raise(22 + vbObjectError, , Err.Description & " Error calling function " & f_name)
Exit Function
End Function
Public Sub CallR1ProcedureExp(ByVal f_name As String, ByRef FirstParam As Double, ByVal S As String)
Dim mr As Short
Dim sql As String
Dim r As Short = 0
Dim hstmt As Integer
Dim retval As Double
Dim retval1 As Double
Dim inlval As Integer
Dim rgbvalue As String
Dim pcbValue As Integer
Dim bufsize As Integer
rgbvalue = Space(256)
bufsize = 255
On Error GoTo cfeerr
'LogMess("calling funtion " & f_name)
ChkPrf(f_name)
Dim gch As System.Runtime.InteropServices.GCHandle
gch = System.Runtime.InteropServices.GCHandle.Alloc(retval, System.Runtime.InteropServices.GCHandleType.Pinned)
r = SQLAllocStmt(dbinf.hdbcv, hstmt)
r = SQLBindParameter(hstmt, 1, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval, 8, NULL_POINTER)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
gch.Free()
jump()
End If
sql = "{call " & f_name & "(?," & S & ")}"
r = SQLExecDirect(hstmt, sql, CInt(Len(sql)))
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
showerror(r, hstmt)
gch.Free()
GoTo cfeerr
Else
End If
mr = SQLMoreResults(hstmt)
Do While mr <> SQL_NO_DATA_FOUND
mr = SQLMoreResults(hstmt)
Loop
r = SQLFreeStmt(hstmt, SQL_DROP)
gch.Free()
FirstParam = retval
Exit Sub
cfeerr:
If Err.Number <> 0 Then
ShowMessage(Err.Description)
End If
Err.Raise(22 + vbObjectError, , Err.Description & " Error calling " & f_name)
Exit Sub
End Sub
Public Sub CallR2ProcedureExp(ByVal f_name As String, ByRef FirstParam As Double, ByRef SecondParam As Double, ByVal S As String)
Dim mr As Short
Dim sql As String
Dim r As Short = 0
Dim hstmt As Integer
Dim retval As Double
Dim retval1 As Double
Dim inlval As Integer
Dim rgbvalue As String
Dim pcbValue As Integer
Dim bufsize As Integer
rgbvalue = Space(256)
bufsize = 255
On Error GoTo cfeerr
ChkPrf(f_name)
'LogMess("calling funtion " & f_name)
Dim gch As System.Runtime.InteropServices.GCHandle
gch = System.Runtime.InteropServices.GCHandle.Alloc(retval, System.Runtime.InteropServices.GCHandleType.Pinned)
Dim gch1 As System.Runtime.InteropServices.GCHandle
gch1 = System.Runtime.InteropServices.GCHandle.Alloc(retval1, System.Runtime.InteropServices.GCHandleType.Pinned)
r = SQLAllocStmt(dbinf.hdbcv, hstmt)
r = SQLBindParameter(hstmt, 1, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval, 8, NULL_POINTER)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
jump()
End If
r = SQLBindParameter(hstmt, 2, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval1, 8, NULL_POINTER)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
jump()
End If
sql = "{call " & f_name & "(?,?" & S & ")}"
r = SQLExecDirect(hstmt, sql, CInt(Len(sql)))
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
GoTo cfeerr
Else
End If
mr = SQLMoreResults(hstmt)
Do While mr <> SQL_NO_DATA_FOUND
mr = SQLMoreResults(hstmt)
Loop
r = SQLFreeStmt(hstmt, SQL_DROP)
gch.Free()
gch1.Free()
FirstParam = retval
SecondParam = retval1
Exit Sub
cfeerr:
If Err.Number <> 0 Then
ShowMessage(Err.Description)
End If
Err.Raise(22 + vbObjectError, , Err.Description & " Error calling " & f_name)
Exit Sub
End Sub
Public Sub CallR1Procedure(ByVal f_name As String, ByRef FirstParam As Double, ByVal ParamArray fargs() As Object)
Dim mr As Short
Dim prm As String
Dim cnt As Short
Dim sql As String
Dim r As Short = 0
Dim hstmt As Integer
Dim retval As Double
Dim retval1 As Double
Dim inlval As Integer
Dim rgbvalue As String
Dim pcbValue As Integer
Dim bufsize As Integer
rgbvalue = Space(256)
bufsize = 255
On Error GoTo cfeerr
ChkPrf(f_name)
'LogMess("calling funtion " & f_name)
Dim gch As System.Runtime.InteropServices.GCHandle
gch = System.Runtime.InteropServices.GCHandle.Alloc(retval, System.Runtime.InteropServices.GCHandleType.Pinned)
r = SQLAllocStmt(dbinf.hdbcv, hstmt)
r = SQLBindParameter(hstmt, 1, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval, 8, NULL_POINTER)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
gch.Free()
jump()
End If
sql = "{call " & f_name & "(?"
If fargs.Length > 0 Then
For cnt = LBound(fargs) To UBound(fargs)
Select Case VarType(fargs(cnt))
Case VariantType.Null
prm = "NULL"
Case VariantType.Short, VariantType.Integer, VariantType.Single, VariantType.Double, VariantType.Decimal
prm = VB6.Format(fargs(cnt))
Case VariantType.Date
prm = Fdatetime(fargs(cnt))
Case Else
prm = fnds(CStr(fargs(cnt)))
End Select
sql = sql & "," & prm
Next cnt
End If
sql = sql & ")}"
r = SQLExecDirect(hstmt, sql, CInt(Len(sql)))
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
showerror(r, hstmt)
gch.Free()
GoTo cfeerr
Else
End If
mr = SQLMoreResults(hstmt)
Do While mr <> SQL_NO_DATA_FOUND
mr = SQLMoreResults(hstmt)
Loop
r = SQLFreeStmt(hstmt, SQL_DROP)
gch.Free()
FirstParam = retval
Exit Sub
cfeerr:
If Err.Number <> 0 Then
ShowMessage(Err.Description)
End If
Err.Raise(22 + vbObjectError, , Err.Description & " Error calling " & f_name)
Exit Sub
End Sub
Public Sub CallR2Procedure(ByVal f_name As String, ByRef FirstParam As Double, ByRef SecondParam As Double, ByVal ParamArray fargs() As Object)
Dim mr As Short
Dim prm As String
Dim cnt As Short
Dim sql As String
Dim r As Short = 0
Dim hstmt As Integer
Dim retval As Double
Dim retval1 As Double
Dim inlval As Integer
Dim rgbvalue As String
Dim pcbValue As Integer
Dim bufsize As Integer
rgbvalue = Space(256)
bufsize = 255
On Error GoTo cfeerr
ChkPrf(f_name)
'LogMess("calling funtion " & f_name)
Dim gch As System.Runtime.InteropServices.GCHandle
gch = System.Runtime.InteropServices.GCHandle.Alloc(retval, System.Runtime.InteropServices.GCHandleType.Pinned)
Dim gch1 As System.Runtime.InteropServices.GCHandle
gch1 = System.Runtime.InteropServices.GCHandle.Alloc(retval1, System.Runtime.InteropServices.GCHandleType.Pinned)
r = SQLAllocStmt(dbinf.hdbcv, hstmt)
r = SQLBindParameter(hstmt, 1, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval, 8, NULL_POINTER)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
jump()
End If
r = SQLBindParameter(hstmt, 2, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval1, 8, NULL_POINTER)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
jump()
End If
sql = "{call " & f_name & "(?,?"
If fargs.Length > 0 Then
For cnt = LBound(fargs) To UBound(fargs)
Select Case VarType(fargs(cnt))
Case VariantType.Null
prm = "NULL"
Case VariantType.Short, VariantType.Integer, VariantType.Single, VariantType.Double, VariantType.Decimal
prm = VB6.Format(fargs(cnt))
Case VariantType.Date
prm = Fdatetime(fargs(cnt))
Case Else
prm = fnds(CStr(fargs(cnt)))
End Select
sql = sql & "," & prm
Next cnt
End If
sql = sql & ")}"
r = SQLExecDirect(hstmt, sql, CInt(Len(sql)))
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
showerror(r, hstmt)
gch.Free()
gch1.Free()
GoTo cfeerr
Else
End If
mr = SQLMoreResults(hstmt)
Do While mr <> SQL_NO_DATA_FOUND
mr = SQLMoreResults(hstmt)
Loop
r = SQLFreeStmt(hstmt, SQL_DROP)
gch.Free()
gch1.Free()
FirstParam = retval
SecondParam = retval1
Exit Sub
cfeerr:
If Err.Number <> 0 Then
ShowMessage(Err.Description)
End If
Err.Raise(22 + vbObjectError, , Err.Description & " Error calling " & f_name)
Exit Sub
End Sub
Public Sub ReduceInteractivity()
NoInteraction = True
End Sub
Public Sub IncreaseInteractivity()
NoInteraction = False
End Sub
Public Function ChangePassword(ByVal UserName As String, ByVal NewPassword As String) As Boolean
Dim S As String
Dim co As Integer
Dim r As Short = 0
On Error GoTo cruerr
'LogMess("creating user " & NewUserName)
r = SQLGetConnectOptionInt(dbinf.hdbcv, SQL_OPT_TRACE, co)
If Not r = SQL_SUCCESS Then
ShowMessage("Unable to get trace status")
End If
r = SQLSetConnectOptionInt(dbinf.hdbcv, SQL_OPT_TRACE, SQL_OPT_TRACE_OFF)
If Not r = SQL_SUCCESS Then
ShowMessage("Unable to set trace status")
End If
If dbinf.DBVersion >= 9 Then
S = "ALTER LOGIN " & UserName
S &= " WITH PASSWORD = " & fnds(NewPassword)
execute(S)
Else
CallProcedure("sp_password", Nothing, NewPassword, UserName)
End If
If co <> SQL_OPT_TRACE_OFF Then
r = SQLSetConnectOptionInt(dbinf.hdbcv, SQL_OPT_TRACE, co)
End If
System.Windows.Forms.Cursor.Current = System.Windows.Forms.Cursors.Default
Return True
Exit Function
cruerr:
ShowMessage(Err.Description)
Return False
Exit Function
End Function
Friend Sub AddRecompile(ByRef sql As String)
If (dbinf.HostDB = "SQLSERVER") AndAlso (dbinf.DBVersion >= 9) AndAlso (sql.Trim.ToUpper.StartsWith("SELECT")) Then sql &= " OPTION(RECOMPILE)"
End Sub
Public Function AddDbRole(ByVal RoleName As String, Optional ByVal RoleOwner As String = "") As Boolean
Dim S As String
Dim co As Integer
Dim r As Short = 0
On Error GoTo cruerr
'LogMess("creating user " & NewUserName)
r = SQLGetConnectOptionInt(dbinf.hdbcv, SQL_OPT_TRACE, co)
If Not r = SQL_SUCCESS Then
ShowMessage("Unable to get trace status")
End If
r = SQLSetConnectOptionInt(dbinf.hdbcv, SQL_OPT_TRACE, SQL_OPT_TRACE_OFF)
If Not r = SQL_SUCCESS Then
ShowMessage("Unable to set trace status")
End If
If dbinf.DBVersion >= 9 Then
S = "CREATE ROLE " & RoleName
If RoleOwner <> "" Then
S &= " AUTHORIZATION " & RoleOwner
End If
execute(S)
Else
If RoleOwner = "" Then
CallProcedure("sp_addrole", RoleName)
Else
CallProcedure("sp_addrole", RoleName, RoleOwner)
End If
End If
If co <> SQL_OPT_TRACE_OFF Then
r = SQLSetConnectOptionInt(dbinf.hdbcv, SQL_OPT_TRACE, co)
End If
System.Windows.Forms.Cursor.Current = System.Windows.Forms.Cursors.Default
Return True
Exit Function
cruerr:
ShowMessage(Err.Description)
Return False
Exit Function
End Function
Public Function AddDbRoleMember(ByVal RoleName As String, ByVal RoleMember As String) As Boolean
Dim S As String
Dim co As Integer
Dim r As Short = 0
On Error GoTo cruerr
'LogMess("creating user " & NewUserName)
r = SQLGetConnectOptionInt(dbinf.hdbcv, SQL_OPT_TRACE, co)
If Not r = SQL_SUCCESS Then
ShowMessage("Unable to get trace status")
End If
r = SQLSetConnectOptionInt(dbinf.hdbcv, SQL_OPT_TRACE, SQL_OPT_TRACE_OFF)
If Not r = SQL_SUCCESS Then
ShowMessage("Unable to set trace status")
End If
CallProcedure("sp_addrolemember", RoleName, RoleMember)
If co <> SQL_OPT_TRACE_OFF Then
r = SQLSetConnectOptionInt(dbinf.hdbcv, SQL_OPT_TRACE, co)
End If
System.Windows.Forms.Cursor.Current = System.Windows.Forms.Cursors.Default
Return True
Exit Function
cruerr:
ShowMessage(Err.Description)
Return False
Exit Function
End Function
Public Function CreateDBUser(ByVal UserName As String, ByVal DBUserName As String, Optional ByVal GroupName As String = "", Optional ByVal DBName As String = "") As Boolean
Dim QDBName As String
Dim ds As Object
Dim S As String
Dim u_fnd As Object
Dim r As Short = 0
Dim co As Integer
Dim umpsw As String
Dim MB_ICONEXCLAMATION As Object
Dim unm As String
Dim psw As String
Dim cnt As Short
Dim nval As Short
On Error GoTo cruerr
'LogMess("creating user " & NewUserName)
unm = UserName
r = SQLGetConnectOptionInt(dbinf.hdbcv, SQL_OPT_TRACE, co)
If Not r = SQL_SUCCESS Then
ShowMessage("Unable to get trace status")
End If
r = SQLSetConnectOptionInt(dbinf.hdbcv, SQL_OPT_TRACE, SQL_OPT_TRACE_OFF)
If Not r = SQL_SUCCESS Then
ShowMessage("Unable to set trace status")
End If
u_fnd = False
S = "SELECT 'X' FROM MASTER.DBO.SYSLOGINS WHERE NAME = " & fnds(unm)
ds = CreateNbfResultSet(S)
If ds.fetch() Then
u_fnd = True
End If
ds.Free()
If Not u_fnd Then
Return False
End If
If DBName = "" Then
QDBName = ""
Else
If Left(DBName, 1) <> """" Then
QDBName = """" & DBName & """"
Else
QDBName = DBName
End If
End If
If QDBName <> "" Then
execute("USE " & QDBName)
End If
If dbinf.DBVersion >= 9 Then
S = "CREATE USER " & unm & " FOR LOGIN " & unm
S &= " WITH DEFAULT_SCHEMA = " & unm
execute(S)
S = "CREATE SCHEMA " & unm & " AUTHORIZATION " & unm
execute(S)
If GroupName <> "" Then
AddDbRoleMember(GroupName, unm)
End If
Else
If GroupName <> "" Then
CallProcedure("sp_adduser", unm, unm, GroupName)
Else
CallProcedure("sp_adduser", unm, unm)
End If
End If
If co <> SQL_OPT_TRACE_OFF Then
r = SQLSetConnectOptionInt(dbinf.hdbcv, SQL_OPT_TRACE, co)
End If
System.Windows.Forms.Cursor.Current = System.Windows.Forms.Cursors.Default
Return True
Exit Function
cruerr:
ShowMessage(Err.Description)
Return False
Exit Function
End Function
Public Function CreateUser(ByVal NewUserName As String, ByVal NewPassWord As String, Optional ByVal GroupName As String = "", Optional ByVal Encrypt As Boolean = False, Optional ByVal DBName As String = "") As Boolean
Dim QDBName As String
Dim ds As Object
Dim S As String
Dim u_fnd As Object
Dim r As Short = 0
Dim co As Integer
Dim umpsw As String
Dim MB_ICONEXCLAMATION As Object
Dim unm As String
Dim psw As String
Dim cnt As Short
Dim nval As Short
On Error GoTo cruerr
CreateUser = False
'LogMess("creating user " & NewUserName)
If (Len(NewUserName) < 4) Or (Len(NewPassWord) < 4) Then
ShowMessage("Names and Passwords must be at least 4 Characters")
Exit Function
End If
unm = NewUserName
umpsw = NewPassWord
If Encrypt Then
psw = mangle(umpsw)
Else
psw = umpsw
End If
r = SQLGetConnectOptionInt(dbinf.hdbcv, SQL_OPT_TRACE, co)
If Not r = SQL_SUCCESS Then
ShowMessage("Unable to get trace status")
End If
r = SQLSetConnectOptionInt(dbinf.hdbcv, SQL_OPT_TRACE, SQL_OPT_TRACE_OFF)
If Not r = SQL_SUCCESS Then
ShowMessage("Unable to set trace status")
End If
Select Case dbinf.HostDB
Case "SQLSERVER"
u_fnd = False
S = "SELECT 'X' FROM MASTER.DBO.SYSLOGINS WHERE NAME = '" & unm & "'"
ds = CreateNbfResultSet(S)
If ds.fetch() Then
u_fnd = True
End If
ds.Free()
If DBName = "" Then
QDBName = ""
Else
If Left(DBName, 1) <> """" Then
QDBName = """" & DBName & """"
Else
QDBName = DBName
End If
End If
If QDBName <> "" Then
execute("USE " & QDBName)
End If
If Not u_fnd Then
If dbinf.DBVersion >= 9 Then
S = "CREATE LOGIN " & unm & " WITH PASSWORD = " & fnds(psw)
S &= ", CHECK_POLICY = OFF"
If DBName <> "" Then
S &= ", DEFAULT_DATABASE = " & DBName
End If
execute(S)
'If DBName <> "" Then
S = "CREATE USER " & unm & " FOR LOGIN " & unm
S &= " WITH DEFAULT_SCHEMA = " & unm
execute(S)
S = "CREATE SCHEMA " & unm & " AUTHORIZATION " & unm
execute(S)
If GroupName <> "" Then
AddDbRoleMember(GroupName, unm)
End If
'End If
Else
If DBName <> "" Then
CallProcedure("sp_addlogin", unm, psw, DBName)
Else
CallProcedure("sp_addlogin", unm, psw)
End If
If GroupName <> "" Then
CallProcedure("sp_adduser", unm, unm, GroupName)
Else
CallProcedure("sp_adduser", unm)
End If
End If
Else
S = "SELECT 'X' FROM " & QDBName & ".DBO.SYSUSERS WHERE NAME = " & fnds(unm)
ds = CreateNbfResultSet(S)
If Not ds.fetch() Then
If dbinf.DBVersion >= 9 Then
S = "CREATE USER " & unm & " FOR LOGIN " & unm
S = S & " WITH DEFAULT_SCHEMA = " & unm
execute(S)
If GroupName <> "" Then
r = AddDbRoleMember(GroupName, unm)
End If
Else
If GroupName$ <> "" Then
CallProcedure("sp_adduser", unm$, unm$, GroupName$)
Else
CallProcedure("sp_adduser", unm$, unm$)
End If
End If
End If
ds.Free()
'If UCase(Trim(dbinf.this_user)) <> "SA" And UCase(Trim(dbinf.this_user)) <> "ACOCMP0DBA" Then
'If UserName <> "" And (NewUserName = UserName) Then
'CallProcedure("sp_password", real_password, psw)
'End If
'Else
'If unm <> "" Then
If dbinf.DBVersion >= 9 Then
S = "ALTER LOGIN " & unm$ & " WITH PASSWORD = " & fnds(psw$)
execute(S)
If GroupName <> "" Then
r = AddDbRoleMember(GroupName, unm)
End If
Else
CallProcedure("sp_password", Nothing, psw, unm)
If GroupName <> "" Then
CallProcedure("sp_changegroup", GroupName, unm)
End If
End If
'End If
End If
Case "ORACLE"
S = "grant connect to " & unm & " identified by " & psw
execute(S)
If GroupName <> "" Then
S = "GRANT " & GroupName & " TO " & unm
execute(S)
End If
Case Else ' "SQLBASE","WATCOM", "ANYWHERE"
S = "grant connect to " & unm & " identified by " & psw
execute(S)
'If GroupName$ <> "" Then
' S$ = "GRANT " & GroupName$ & " TO " & unm$
' execute S$
'End If
End Select
If co <> SQL_OPT_TRACE_OFF Then
r = SQLSetConnectOptionInt(dbinf.hdbcv, SQL_OPT_TRACE, co)
End If
System.Windows.Forms.Cursor.Current = System.Windows.Forms.Cursors.Default
CreateUser = True
Exit Function
cruerr:
ShowMessage(Err.Description)
CreateUser = False
Exit Function
End Function
Public Function GrantPermissions(ByVal Grantee As String) As Boolean
Dim r As Short = 0
'Dim data_dir As Object
Dim pos As Short
Dim this_proc As String
Dim this_col_2 As String
Dim this_col_1 As String
Dim S As String
Dim tcnt As Short
Dim cnt As Short
Dim this_table As String
'Dim this_table As String
System.Windows.Forms.Cursor.Current = System.Windows.Forms.Cursors.WaitCursor
'Dim tables() As String
On Error GoTo stperr
Dim ds As nbfResultSet
GrantPermissions = False
'ReDim tables(0)
'tables(0) = ""
'LogMess("granting permisions")
If dbinf.HostDB = "SQLBASE" Then
ShowMessage("Permissions for SQLBASE databases must be assigned individually by your DBA")
Exit Function
End If
ds = CreateNbfResultSet("TABLES")
Do While ds.fetch()
this_table = ds.FetchString(3)
S = "table " & this_table
If this_table <> "USERAUTH" Then
'cnt = cnt + 1
'ReDim Preserve tables(cnt)
'tables(cnt) = String.Copy(this_table)
'End If
S = "GRANT ALL ON " & this_table & " TO " & Grantee
execute(S)
End If
Loop
ds.Free()
'For tcnt = 1 To cnt
'S = "tab now " & tables(tcnt)
'Next tcnt
'For tcnt = 1 To cnt
'S = "GRANT ALL ON " & tables(tcnt) & " TO " & Grantee
'execute(S)
'Next tcnt
If dbinf.HostDB = "ORACLE" Then
'procedures
S = "SELECT OBJECT_NAME FROM USER_OBJECTS WHERE OBJECT_TYPE = 'PROCEDURE' OR OBJECT_TYPE = 'FUNCTION'"
ds = CreateNbfResultSet(S)
Do While ds.fetch()
S = "GRANT EXECUTE ON " & ds.FetchString(1) & " TO " & Grantee
execute(S)
Loop
ds.Free()
Else
'ReDim tables(0)
'tables(0) = ""
cnt = 0
S = "PROCEDURES"
ds = CreateNbfResultSet(S)
Do While ds.fetch()
this_col_1 = ds.FetchString(1)
this_col_2 = ds.FetchString(2)
this_proc = ds.FetchString(3)
pos = InStr(this_proc, ";")
If pos > 1 Then
this_proc = Left(this_proc, pos - 1)
End If
'cnt = cnt + 1
S = "GRANT EXECUTE ON " & this_proc & " TO " & Grantee
execute(S)
'ReDim Preserve tables(cnt)
'tables(cnt) = String.Copy(this_proc)
Loop
ds.Free()
'For tcnt = 1 To cnt
'S = "GRANT EXECUTE ON " & tables(tcnt) & " TO " & Grantee
'execute(S)
'Next tcnt
End If
'S = "GRANT SELECT ON " & data_dir & "USERAUTH TO " & Grantee
'r = execsql(S)
If dbinf.HostDB = "ORACLE" Then
'packages
S = "SELECT OBJECT_NAME FROM USER_OBJECTS WHERE OBJECT_TYPE = 'PACKAGE'"
ds = CreateNbfResultSet(S)
Do While ds.fetch()
S = "GRANT EXECUTE ON " & ds.FetchString(1) & " TO " & Grantee
execute(S)
Loop
ds.Free()
' now sequences
S = "SELECT SEQUENCE_NAME FROM USER_SEQUENCES"
ds = CreateNbfResultSet(S)
Do While ds.fetch()
S = "GRANT ALL ON " & ds.FetchString(1) & " TO " & Grantee
execute(S)
Loop
ds.Free()
End If
GrantPermissions = True
System.Windows.Forms.Cursor.Current = System.Windows.Forms.Cursors.Default
Exit Function
stperr:
ShowMessage(ErrorToString(Err.Number))
Exit Function
End Function
Public Function UpdateStream(ByVal DestTable$, ByVal DestCol$, ByVal WhereCond$, ByVal fs As Stream) As Boolean
Try
ChkPrf(DestTable)
Dim s$ = "UPDATE " & DestTable$ & " SET " & DestCol$ & " = ? WHERE " & WhereCond$
Dim hstmt As Integer
Dim r As Short
Dim rgbvalue As Byte()
Dim rchrs As Char()
Dim pcbValue As Integer
Dim retval As New StringBuilder()
Dim rv As String
Dim cnt As Integer
Dim bufSize As Integer = 30000
Dim RemBuf As Integer
Dim idx As Integer
Dim sl As Integer
Dim SpaceReq As Integer = 0
Dim totBytes As Long
ReDim rgbvalue(bufSize - 1)
Dim br As New BinaryReader(fs)
br.BaseStream.Position = 0
Dim StreamSize As Long = fs.Length
Dim BytesSent As Integer
r = SQLAllocStmt(dbinf.hdbcv, hstmt)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
Exit Function
End If
'ShowMessage(s$)
r = SQLPrepare(hstmt, s$, SQL_NTS)
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
ShowMessage("SQL Prepare failed " & CStr(r))
Exit Function
End If
'r = SQLAllocStmt(dbinf.hdbcv, hstmt)
'r = SQLBindParameter(hstmt, 1, SQL_PARAM_OUTPUT, SQL_C_DOUBLE, dbinf.host_bdouble, 8, 0, retval, 8, NULL_POINTER)
r = SQLBindParameterByRef(hstmt, 1, SQL_PARAM_INPUT, SQL_C_BINARY, SQL_LONGVARBINARY, 0, 0, 1, 0, SQL_DATA_AT_EXEC) 'pcbValue)
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
ShowMessage("SQL Bind Param failed " & CStr(r))
Exit Function
End If
r = SQLExecute(hstmt)
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO Or r = SQL_NEED_DATA) Then
showerror(r, hstmt)
ShowMessage("SQL Execute failed " & CStr(r))
Exit Function
End If
r = SQLParamDataBytes(hstmt, rgbvalue)
Dim lcnt& = 0
If r = SQL_NEED_DATA Then
Do 'While BytesSent > -< StreamSize
'If (StreamSize - BytesSent) > bufSize Then
lcnt& += 1
rgbvalue = br.ReadBytes(bufSize)
BytesSent = rgbvalue.Length
totBytes += BytesSent
'ShowMessage("To Send " & BytesSent.ToString)
If BytesSent > 0 Then
r = SQLPutDataBytes(hstmt, rgbvalue, BytesSent)
If Not (r = SQL_SUCCESS) Then ' Or r = SQL_SUCCESS_WITH_INFO) Then
ShowMessage("Put Data failed " & CStr(r) & " loop " & lcnt.ToString & " bs " & BytesSent.ToString())
showerror(r, hstmt)
Exit Function
End If
'ShowMessage("Sent " & BytesSent.ToString)
'Else
'RemBuf = (StreamSize - BytesSent)
'rgbvalue = br.ReadBytes(RemBuf)
'ShowMessage("rgbval len " & rgbvalue.LongLength.ToString & " rem buf " & RemBuf.ToString)
'r = SQLPutDataBytes(hstmt, rgbvalue, RemBuf)
''ShowMessage("put data done")
'If Not (r = SQL_SUCCESS) Then ' Or r = SQL_SUCCESS_WITH_INFO) Then
'ShowMessage("Put Data failed " & CStr(r))
'showerror(r, hstmt)
'Exit Function
'End If
'BytesSent += RemBuf
'ShowMessage("Sent " & BytesSent.ToString)
End If
Loop While BytesSent > 0
'ShowMessage("Sent " & totBytes.ToString)
Else
'ShowMessage("SQL PAram no need data " & CStr(r))
'Exit Function
End If
r = SQLParamDataBytes(hstmt, rgbvalue)
r = SQLFreeStmt(hstmt, SQL_DROP)
Catch ex As Exception
ShowMessage("Update stream error " & ex.Message)
End Try
End Function
Private Function UpdateText_Old(ByVal DestTable$, ByVal DestCol$, ByVal WhereCond$, ByVal updText As String) As Boolean
Try
ChkPrf(DestTable)
Dim s$ = "UPDATE " & DestTable$ & " SET " & DestCol$ & " = ? WHERE " & WhereCond$
Dim hstmt As Integer
Dim r As Short
Dim rgbvalue As Byte()
Dim bufSize As Integer = 30000
Dim SpaceReq As Integer = 0
Dim totBytes As Long
ReDim rgbvalue(bufSize - 1)
Dim ae As Encoding = Encoding.Unicode
Dim UniBytes As Byte() = ae.GetBytes(updText)
Dim BlockBytes As Byte()
Dim arysz As Long = UBound(UniBytes) + 1
Dim BytesSent As Integer
r = SQLAllocStmt(dbinf.hdbcv, hstmt)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
Exit Function
End If
r = SQLPrepare(hstmt, s$, SQL_NTS)
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
ShowMessage("SQL Prepare failed " & CStr(r))
Exit Function
End If
r = SQLBindParameterByRef(hstmt, 1, SQL_PARAM_INPUT, SQL_UNICODE, SQL_UNICODE, 0, 0, 1, 0, SQL_DATA_AT_EXEC) 'pcbValue)
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
ShowMessage("SQL Bind Param failed " & CStr(r))
Exit Function
End If
r = SQLExecute(hstmt)
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO Or r = SQL_NEED_DATA) Then
showerror(r, hstmt)
ShowMessage("SQL Execute failed " & CStr(r))
Exit Function
End If
r = SQLParamDataBytes(hstmt, rgbvalue)
Dim apos As Long = 0
If r = SQL_NEED_DATA Then
Do While arysz > 0
If arysz > rgbvalue.LongLength Then
Array.Copy(UniBytes, apos, rgbvalue, 0, bufSize)
BytesSent = bufSize
apos += bufSize
arysz -= bufSize
Else
Array.Copy(UniBytes, apos, rgbvalue, 0, arysz)
BytesSent = arysz
arysz = 0
End If
totBytes += BytesSent
If BytesSent > 0 Then
r = SQLPutDataBytes(hstmt, rgbvalue, BytesSent)
If Not (r = SQL_SUCCESS) Then ' Or r = SQL_SUCCESS_WITH_INFO) Then
ShowMessage("Put Data failed " & CStr(r))
showerror(r, hstmt)
Exit Function
End If
End If
Loop
End If
r = SQLParamDataBytes(hstmt, rgbvalue)
r = SQLFreeStmt(hstmt, SQL_DROP)
Catch ex As Exception
ShowMessage("Update text error " & ex.Message)
End Try
End Function
Public Function UpdateText(ByVal DestTable$, ByVal DestCol$, ByVal WhereCond$, ByVal updText As String) As Boolean
Try
ChkPrf(DestTable)
Dim sql$ = "UPDATE " & DestTable$ & " SET " & DestCol$ & " = " & fnds(updText) & " WHERE " & WhereCond$
execute(sql$)
Catch ex As Exception
ShowMessage("Update text error " & ex.Message)
End Try
End Function
Public Function UpdateBytes(ByVal DestTable$, ByVal DestCol$, ByVal WhereCond$, ByVal updBytes As Byte()) As Boolean
Try
ChkPrf(DestTable)
Dim s$ = "UPDATE " & DestTable$ & " SET " & DestCol$ & " = ? WHERE " & WhereCond$
Dim hstmt As Integer
Dim r As Short
Dim rgbvalue As Byte()
Dim bufSize As Integer = 30000
Dim SpaceReq As Integer = 0
Dim totBytes As Long
ReDim rgbvalue(bufSize - 1)
'Dim ae As Encoding = Encoding.Unicode
'Dim UniBytes As Byte() = ae.GetBytes(updText)
Dim arysz As Long = UBound(updBytes) + 1
Dim BytesSent As Integer
r = SQLAllocStmt(dbinf.hdbcv, hstmt)
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
Exit Function
End If
r = SQLPrepare(hstmt, s$, SQL_NTS)
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
ShowMessage("SQL Prepare failed " & CStr(r))
Exit Function
End If
r = SQLBindParameterByRef(hstmt, 1, SQL_PARAM_INPUT, SQL_C_BINARY, SQL_LONGVARBINARY, 0, 0, 1, 0, SQL_DATA_AT_EXEC) 'pcbValue)
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
ShowMessage("SQL Bind Param failed " & CStr(r))
Exit Function
End If
r = SQLExecute(hstmt)
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO Or r = SQL_NEED_DATA) Then
showerror(r, hstmt)
ShowMessage("SQL Execute failed " & CStr(r))
Exit Function
End If
r = SQLParamDataBytes(hstmt, rgbvalue)
Dim apos As Long = 0
If r = SQL_NEED_DATA Then
Do While arysz > 0
If arysz > rgbvalue.LongLength Then
Array.Copy(updBytes, apos, rgbvalue, 0, bufSize)
BytesSent = bufSize
apos += bufSize
arysz -= bufSize
Else
Array.Copy(updBytes, apos, rgbvalue, 0, arysz)
BytesSent = arysz
arysz = 0
End If
totBytes += BytesSent
If BytesSent > 0 Then
r = SQLPutDataBytes(hstmt, rgbvalue, BytesSent)
If Not (r = SQL_SUCCESS) Then ' Or r = SQL_SUCCESS_WITH_INFO) Then
ShowMessage("Put Data failed " & CStr(r))
showerror(r, hstmt)
Exit Function
End If
End If
Loop
End If
r = SQLParamDataBytes(hstmt, rgbvalue)
r = SQLFreeStmt(hstmt, SQL_DROP)
Catch ex As Exception
ShowMessage("Update bytes error " & ex.Message)
End Try
End Function
Public Function GrantDBOPermissions(ByVal Grantee As String) As Boolean
Dim r As Short = 0
Dim S As String
Dim tcnt As Short
Dim cnt As Short
Dim this_table As String
System.Windows.Forms.Cursor.Current = System.Windows.Forms.Cursors.WaitCursor
Dim tables() As String
On Error GoTo stperr
Dim ds As nbfResultSet
GrantDBOPermissions = False
ReDim tables(0)
'LogMess("granting dbo perms")
ds = CreateNbfResultSet("SELECT S.NAME FROM SYSOBJECTS S, SYSUSERS U WHERE S.XTYPE = 'U' AND S.UID = U.UID AND U.NAME = 'dbo'")
Do While ds.fetch()
this_table = ds.FetchString(1)
If this_table <> "USERAUTH" Then
cnt = cnt + 1
ReDim Preserve tables(cnt)
tables(cnt) = this_table
End If
Loop
ds.Free()
For tcnt = 1 To cnt
S = "GRANT ALL ON " & tables(tcnt) & " TO " & Grantee
r = execsql(S)
Next tcnt
GrantDBOPermissions = True
System.Windows.Forms.Cursor.Current = System.Windows.Forms.Cursors.Default
Exit Function
stperr:
ShowMessage(ErrorToString(Err.Number))
Exit Function
End Function
Private Function mangle(ByVal inpswd As String) As String
Dim c4 As String
Dim c6 As String
Dim CI6 As Short
Dim c5 As String
Dim ci5 As Short
Dim ci4 As Short
Dim c3 As String
Dim ci3 As Short
Dim c2 As String
Dim ci2 As Short
Dim ci1 As Short
Dim c1 As String
If Len(inpswd) < 4 Then
ShowMessage("Password too short. Must be at lease four characters. Returned unchanged")
mangle = inpswd
Exit Function
End If
c1 = Right(VB6.Format((Len(inpswd) * 127) + Asc(Mid(inpswd, 3, 1))), 1)
ci1 = Asc(c1)
ci2 = Asc(Right(inpswd, 1))
If ci2 >= (13 * ci1) Then
ci2 = ci2 - (13 * ci1)
ElseIf ci2 >= (7 * ci1) Then
ci2 = ci2 - (7 * ci1)
ElseIf ci2 >= (2 * ci1) Then
ci2 = ci2 - (2 * ci1)
Else
ci2 = CShort(ci2 / 2)
End If
Do While ci2 < 65
ci2 = ci2 + 13
Loop
Do While ci2 > 122
ci2 = ci2 - 21
Loop
If ci2 > 90 And ci2 < 97 Then
ci2 = ci2 - 90 + 48
End If
c2 = Chr(ci2)
ci3 = ((ci1 + 12) * 5) - 3
Do While ci3 < 97
ci3 = ci3 + 19
Loop
Do While ci3 > 90
ci3 = ci3 - 17
Loop
c3 = Chr(ci3)
ci4 = Asc(Mid(inpswd, 2, 1)) - 32
Do While ci4 < 48
ci4 = ci4 + 7
Loop
Do While ci4 > 122
ci4 = ci4 - 23
Loop
If ci4 > 90 And ci4 < 97 Then
ci4 = ci4 - 90 + 65
End If
ci5 = Asc(Left(inpswd, 1)) - 13
Do While ci5 < 65
ci5 = ci5 + 25
Loop
Do While ci5 > 122
ci5 = ci5 - 20
Loop
If ci5 > 90 And ci5 < 97 Then
ci5 = ci5 - 90 + 97
End If
c5 = Chr(ci5)
CI6 = ci1 + ci2 + ci3 + ci4 + ci5
Do While CI6 > 57
CI6 = CI6 - 8
Loop
If CI6 < 48 Then
CI6 = 48
End If
c6 = Chr(CI6)
mangle = c2 & c1 & c3 & c4 & c5 & c6
End Function
Public Sub StartScript(ByVal filename As String)
Try
If pvCreateScript Then
Exit Sub
End If
'LogMess("starting script")
ScriptFile = FreeFile()
ScriptName = filename
FileOpen(ScriptFile, ScriptName, OpenMode.Binary)
pvCreateScript = True
If dbinf.HostDB = "SQLSERVER" Then
ScriptEOL = Chr(13) & Chr(10)
Else
ScriptEOL = ";" & Chr(13) & Chr(10)
End If
Catch ex As Exception
ShowMessage(ex.Message)
End Try
End Sub
Friend Function fp() As Boolean
fp = dbinf.fetchprior
End Function
Private Sub listprocs()
Dim proc_name As String
Dim proc_own As String
Dim proc_qual As String
Dim pcbValue As Integer
Dim rgbvalue As Object
Dim r As Short = 0
Dim hstmt As Integer
'LogMess("listing procs")
r = SQLAllocStmt(dbinf.hdbcv, hstmt)
Dim np As IntPtr = IntPtr.op_Explicit(0)
r = SQLProceduresNQ(hstmt, np, 0, "", 0, "", 0) ', ByVal owner$, CInt(Len(owner$)), ByVal table_name$, CInt(Len(table_name$)), ByVal tab_typ$, CInt(Len(tab_typ$)))
If r <> SQL_SUCCESS Then
showerror(r, hstmt)
jump()
Else
End If
Do While SQLFetch(hstmt) = SQL_SUCCESS
r = SQLGetData(hstmt, 1, SQL_C_CHAR, rgbvalue, bufsize, pcbValue)
If r = SQL_SUCCESS Then
If pcbValue > 0 Then
proc_qual = Left(rgbvalue, pcbValue)
Else
proc_qual = ""
End If
Else
ShowMessage("Error in GetData")
Exit Sub
End If
r = SQLGetData(hstmt, 2, SQL_C_CHAR, rgbvalue, bufsize, pcbValue)
If r = SQL_SUCCESS Then
If pcbValue > 0 Then
proc_own = Left(rgbvalue, pcbValue)
Else
proc_own = ""
End If
Else
ShowMessage("Error in GetData")
Exit Sub
End If
r = SQLGetData(hstmt, 3, SQL_C_CHAR, rgbvalue, bufsize, pcbValue)
If r = SQL_SUCCESS Then
If pcbValue > 0 Then
proc_name = Left(rgbvalue, pcbValue)
Else
proc_name = ""
End If
Else
ShowMessage("Error in GetData")
Exit Sub
End If
Loop
r = SQLFreeStmt(hstmt, SQL_DROP)
End Sub
Public Function checktable(ByVal owner As String, ByVal table_name As String) As Boolean
Dim ret As Object
Dim S As String
Dim tab_typ As String
Dim r As Short = 0
Dim hstmt As Integer
Dim tab_name As String
Dim tab_owner As String
checktable = False
tab_owner = owner
tab_name = table_name
On Error GoTo cterr
'LogMess("checking table")
r = SQLAllocStmt(dbinf.hdbcv, hstmt)
tab_typ = "'TABLE'"
'ptable_type& = agGetAddressForVBString(tab_typ$)
'ptable_type_length% = Len(tab_typ$)
'owner_typ$ = this_user$
'powner_type& = agGetAddressForVBString(owner_typ$)
'powner_type_length% = Len(owner_typ$)
'Debug.Print "|" & this_user$ & "|"
Dim np As IntPtr = IntPtr.op_Explicit(0)
r = SQLTablesNQ(hstmt, np, 0, tab_owner, CShort(Len(tab_owner)), tab_name, CShort(Len(tab_name)), tab_typ, CShort(Len(tab_typ)))
If r <> SQL_SUCCESS Then
ShowMessage("GetTables failed")
showerror(r, hstmt)
GoTo cterr
End If
If SQLFetch(hstmt) = SQL_SUCCESS Then
ret = True
Else
ret = False
End If
r = SQLFreeStmt(hstmt, SQL_DROP)
checktable = ret
Exit Function
cterr:
ShowMessage("Error in check table function")
checktable = False
Exit Function
End Function
Public Function checkproc(ByVal owner As String, ByVal proc_name As String) As Boolean
Dim ret As Object
Dim S As String
Dim r As Short = 0
Dim hstmt As Integer
checkproc = False
On Error GoTo cperr
'LogMess("checking proc")
If dbinf.HostDB = "ORACLE" Then
proc_name = Trim(UCase(proc_name))
owner = Trim(UCase(owner))
r = SQLAllocStmt(dbinf.hdbcv, hstmt)
S = "SELECT 'X' FROM ALL_OBJECTS WHERE OWNER = " & fnds(owner)
S = S & " AND OBJECT_NAME = " & fnds(proc_name)
S = S & " AND (OBJECT_TYPE = 'PROCEDURE' OR OBJECT_TYPE = 'FUNCTION')"
r = SQLExecDirect(hstmt, S, CInt(Len(S)))
If r <> SQL_SUCCESS Then
GoTo cperr
End If
If SQLFetch(hstmt) = SQL_SUCCESS Then
ret = True
Else
ret = False
End If
r = SQLFreeStmt(hstmt, SQL_DROP)
checkproc = ret
Exit Function
End If
'r% = SQLAllocStmt(dbinf.hdbcv, hstmt&)
'r% = SQLProcedures(hstmt&, ByVal NULL_POINTER, 0, ByVal owner$, CInt(Len(owner$)), ByVal NULL_POINTER, 0)
'Do While SQLFetch(hstmt&) = SQL_SUCCESS
' S$ = qqstring$(hstmt&, 1) & "," & qqstring$(hstmt&, 2) & "," & qqstring$(hstmt&, 3)
' S$ = S$ & "," & qqstring$(hstmt&, 4) & "," & qqstring$(hstmt&, 5) & "," & qqstring$(hstmt&, 6)
' S$ = S$ & "," & qqstring$(hstmt&, 7) & "," & qqstring$(hstmt&, 8)
' Debug.Print S$
'Loop
'r% = SQLFreeStmt(hstmt&, SQL_DROP)
r = SQLAllocStmt(dbinf.hdbcv, hstmt)
Dim np As IntPtr = IntPtr.op_Explicit(0)
If dbinf.HostDB = "ACCESS" Then
'Debug.Print "ACCESS ROUTE"
r = SQLProceduresNQ(hstmt, np, 0, "", 0, proc_name, CShort(Len(proc_name)))
Else
If False Then 'dbinf.HostDB = "SQLSERVER" Then
S = "exec sp_stored_procedures " & fnds(proc_name) & "," & fnds(owner)
r = SQLExecDirect(hstmt, S, CInt(Len(S)))
Else
r = SQLProceduresNQ(hstmt, np, 0, owner, CShort(Len(owner)), proc_name, CShort(Len(proc_name)))
End If
End If
If r <> SQL_SUCCESS Then
ShowMessage("Get Procedures failed")
showerror(r, hstmt)
GoTo cperr
End If
If SQLFetch(hstmt) = SQL_SUCCESS Then
ret = True
Else
ret = False
End If
r = SQLFreeStmt(hstmt, SQL_DROP)
checkproc = ret
Exit Function
cperr:
ShowMessage(Err.Description & " Error in check procedure function")
checkproc = False
Exit Function
End Function
Public Function checkpackproc(ByVal owner As String, ByVal pack_name As String, ByVal proc_name As String) As Boolean
Dim ret As Object
Dim S As String
Dim r As Short
Dim hstmt As Integer
checkpackproc = False
On Error GoTo cpperr
If dbinf.HostDB = "ORACLE" Then
proc_name = Trim(UCase(proc_name))
owner = Trim(UCase(owner))
r = SQLAllocStmt(dbinf.hdbcv, hstmt)
S = "SELECT 'X' FROM ALL_OBJECTS WHERE OWNER = " & fnds(owner)
S = S & " AND OBJECT_NAME = " & fnds(pack_name)
S = S & " AND OBJECT_TYPE = 'PACKAGE'"
r = SQLExecDirect(hstmt, S, CInt(Len(S)))
If r <> SQL_SUCCESS Then
GoTo cpperr
End If
If SQLFetch(hstmt) = SQL_SUCCESS Then
ret = checkproc(owner, proc_name)
Else
ret = False
End If
r = SQLFreeStmt(hstmt, SQL_DROP)
checkpackproc = ret
Exit Function
End If
r = SQLAllocStmt(dbinf.hdbcv, hstmt)
If dbinf.HostDB = "ACCESS" Then
checkpackproc = False
Exit Function
Else
r = SQLProcedures(hstmt, pack_name, CShort(Len(pack_name)), owner, CShort(Len(owner)), proc_name, CShort(Len(proc_name)))
End If
If r <> SQL_SUCCESS Then
ShowMessage("Get Procedures failed")
showerror(r, hstmt)
GoTo cpperr
End If
If SQLFetch(hstmt) = SQL_SUCCESS Then
ret = True
Else
ret = False
End If
r = SQLFreeStmt(hstmt, SQL_DROP)
checkpackproc = ret
Exit Function
cpperr:
ShowMessage("Error in check procedure package function")
checkpackproc = False
Exit Function
End Function
Public Function CreateNbfResultSet(ByVal sql As String, ByVal ClonedConnection As Boolean) As nbfResultSet
Dim dbs As New nbfResultSet
If pvCreateScript Then
ShowMessage("Cannot create NbfResultSets, queries or tables in create script mode")
Exit Function
End If
ChkPrf(sql)
'LogMess("creating nbf result set " & sql)
'dbs.setparent(Me)
dbs.Cloned = ClonedConnection
If Not dbs.create(Me, sql) Then
Exit Function
Else
pvOpenResultSets.Add(dbs)
Return dbs
End If
End Function
Public Function CreateNbfResultSet(ByVal sql As String) As nbfResultSet
Return CreateNbfResultSet(sql, False)
End Function
Public Function CreateQNbfResultSet(ByVal sql As String) As QNbfResultSet
On Error GoTo dseterr
Dim dbs As New QNbfResultSet
If pvCreateScript Then
ShowMessage("Cannot create NbfResultSets, queries or tables in create script mode")
GoTo dseterr
Exit Function
End If
ChkPrf(sql)
'LogMess("creating Q nbf result set " & sql)
dbs.setparent(Me)
If Not dbs.create(dbinf.henv, dbinf.hdbcv, sql) Then
GoTo dseterr
Else
pvOpenQnbfResultSets.Add(dbs)
CreateQNbfResultSet = dbs
End If
Exit Function
dseterr:
dbs = Nothing
CreateQNbfResultSet = Nothing
LogError("unable to create QnbfResultSet")
Err.Raise(2 + vbObjectError, , Err.Description & " unable to create table " & sql)
Exit Function
End Function
Public Function CreateSNbfResultSet(ByVal sql As String) As SNbfResultSet
On Error GoTo dseterr
Dim dbs As New SNbfResultSet
'LogMess("creating S nbf result set " & sql)
If ShowActions Then logDBError(Me, "Show Action SQL " & sql)
If pvCreateScript Then
ShowMessage("Cannot create NbfResultSets, queries or tables in create script mode")
GoTo dseterr
Exit Function
End If
ChkPrf(sql)
dbs.setparent(Me)
If Not dbs.create(dbinf.hdbcv, sql) Then
GoTo dseterr
Else
pvOpenSnbfResultSets.Add(dbs)
CreateSNbfResultSet = dbs
End If
Exit Function
dseterr:
dbs = Nothing
CreateSNbfResultSet = Nothing
LogError("unable to create SnbfResultSet")
Err.Raise(2 + vbObjectError, , Err.Description & " unable to create table " & sql)
Exit Function
End Function
Public Function CreateNbfResultSetNoErr(ByVal sql As String) As nbfResultSet
Return CreateNbfResultSetNoErr(sql, False)
End Function
Public Function CreateNbfResultSetNoErr(ByVal sql As String, ByVal ClonedConnection As Boolean) As nbfResultSet
On Error GoTo dseterr
Dim dbs As New nbfResultSet
If pvCreateScript Then
ShowMessage("Cannot create NbfResultSets, queries or tables in create script mode")
GoTo dseterr
Exit Function
End If
ChkPrf(sql)
dbs.Cloned = ClonedConnection
'LogMess("creating nbf result set NO Err" & sql)
'dbs.setparent(Me)
If Not dbs.create(Me, sql, 0, True) Then
GoTo dseterr
Else
pvOpenResultSets.Add(dbs)
CreateNbfResultSetNoErr = dbs
End If
Exit Function
dseterr:
dbs = Nothing
CreateNbfResultSetNoErr = Nothing
LogError("unable to create nbfResultSet(NoErr)")
Exit Function
End Function
Public Function CreateNbfDbTable(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 NbfDbTable
On Error GoTo dtaberr
Dim dbs As New NbfDbTable
Dim sr As Object
Dim dfu As Object
If ShowActions Then logDBError(Me, "Show Action table " & t_nam)
If pvCreateScript Then
ShowMessage("Cannot create NbfResultSets, queries or tables in create script mode")
GoTo dtaberr
Exit Function
End If
ChkPrf(t_nam)
'LogMess("creating nbf db table " & t_nam)
dbs.setparent(Me)
If IsNothing(scrollreq) Then
sr = False
Else
sr = scrollreq
End If
If dbinf.HostDB = "SQLSERVER" And dbinf.DBVersion >= 7 Then
dfu = True
ElseIf IsNothing(DropForUpdate) Then
dfu = False
Else
dfu = DropForUpdate
End If
If Not dbs.create(f_nam, t_nam, w_cls, o_cls, u_cls, sr, dfu) Then
GoTo dtaberr
Else
pvOpenDBTables.Add(dbs)
CreateNbfDbTable = dbs
End If
Exit Function
dtaberr:
dbs = Nothing
CreateNbfDbTable = Nothing
LogError("unable to create data table")
Err.Raise(3 + vbObjectError, , Err.Description & " unable to create data table " & t_nam & " (" & f_nam & ")")
Exit Function
End Function
Public Function CreateShareNbfDbTable(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 NbfDbTable
On Error GoTo dtaberr
Dim dbs As New NbfDbTable
Dim sr As Object
Dim dfu As Object
If ShowActions Then logDBError(Me, "Show Action table " & t_nam)
If pvCreateScript Then
ShowMessage("Cannot create NbfResultSets, queries or tables in create script mode")
GoTo dtaberr
Exit Function
End If
ChkPrf(t_nam)
'LogMess("creating shared db table " & t_nam)
dbs.setparent(Me)
If IsNothing(scrollreq) Then
sr = False
Else
sr = scrollreq
End If
If dbinf.HostDB = "SQLSERVER" And dbinf.DBVersion >= 7 Then
dfu = True
ElseIf IsNothing(DropForUpdate) Then
dfu = False
Else
dfu = DropForUpdate
End If
dbs.SharedTable = True
If Not dbs.create(f_nam, t_nam, w_cls, o_cls, u_cls, sr, dfu) Then
GoTo dtaberr
Else
pvOpenDBTables.Add(dbs)
Return dbs
End If
Exit Function
dtaberr:
dbs = Nothing
LogError("unable to create SharenbfDBTable")
Err.Raise(3 + vbObjectError, , Err.Description & " unable to create data table " & t_nam & " (" & f_nam & ")")
Return Nothing
End Function
Public Function CreateNbfDBQuery(ByVal sql As String, ByVal Clone As Boolean) As nbfDBQuery
On Error GoTo dqerr
Dim dbs As New nbfDBQuery
Dim sr As Object
If ShowActions Then logDBError(Me, "Show Action SQL " & sql)
If pvCreateScript Then
ShowMessage("Cannot create NbfResultSets, queries or tables in create script mode")
GoTo dqerr
Exit Function
End If
'LogMess("creating nbf DB Query" & sql)
ChkPrf(sql)
dbs.setparent(Me)
dbs.Cloned = Clone
If Not dbs.create(sql) Then
GoTo dqerr
Else
pvOpenDBQueries.Add(dbs)
CreateNbfDBQuery = dbs
End If
Exit Function
dqerr:
dbs = Nothing
CreateNbfDBQuery = Nothing
LogError("unable to create query table")
Err.Raise(4 + vbObjectError, , Err.Description & " unable to create query table ")
Exit Function
End Function
Public Function CreateNbfDBQuery(ByVal sql As String) As nbfDBQuery
Return CreateNbfDBQuery(sql, False)
End Function
Public Sub crfkey(ByVal stab As String, ByVal kname As String, ByVal klist As String, ByRef ktab As String, ByVal ktlist As String)
Dim isql As String
'LogMess("creating f key")
Select Case dbinf.HostDB
Case "ORACLE", "SQLSERVER"
isql = "alter table " & stab & " add foreign key (" & klist & ") references " & ktab & " (" & ktlist & ")"
Case "SQLBASE"
isql = "alter table " & stab & " foreign key " & kname & " (" & klist & ") references " & ktab
If Trim(UCase(ktab)) = Trim(UCase(stab)) Then
isql = isql & " ON DELETE CASCADE"
End If
Case "ACCESS"
kname = stab & kname
isql = "alter table " & stab & " add constraint " & kname & " foreign key (" & klist & ") references " & ktab & " (" & ktlist & ")"
Case Else
isql = "alter table " & stab & " add foreign key " & kname & " (" & klist & ") references " & ktab & " (" & ktlist & ")"
End Select
execute(isql)
End Sub
Friend Sub FreeBoundDataTable(ByVal ds As BoundDataTable)
pvOpenBoundDataTables.Remove(ds)
End Sub
Friend Sub FreeBrowseDataTable(ByVal ds As BrowseDataTable)
pvOpenBrowseDataTables.Remove(ds)
End Sub
Friend Sub FreeDBQuery(ByVal ds As nbfDBQuery)
pvOpenDBQueries.Remove(ds)
End Sub
Friend Sub FreeDBTable(ByVal ds As NbfDbTable)
pvOpenDBTables.Remove(ds)
End Sub
Friend Sub FreeResultSet(ByVal ds As nbfResultSet)
pvOpenResultSets.Remove(ds)
End Sub
Friend Sub FreeQNbfResultSet(ByVal ds As QNbfResultSet)
pvOpenQnbfResultSets.Remove(ds)
End Sub
Friend Sub FreeSNbfResultSet(ByVal ds As SNbfResultSet)
pvOpenSnbfResultSets.Remove(ds)
End Sub
Public Sub crsqltable(ByVal isql As String)
'LogMess("creating sql table " & isql)
ChkPrf(isql)
isql = exch_string(isql, "SQL_DOUBLE", dbinf.DoubleDataType)
If dbinf.TimestampDataType <> "" Then
isql = exch_string(isql, "SQL_TIMESTAMP", dbinf.TimestampDataType)
Else
isql = exch_string(isql, "SQL_TIMESTAMP", dbinf.DateDataType)
End If
isql = exch_string(isql, "SQL_DATE", dbinf.DateDataType)
isql = exch_string(isql, "SQL_LONGVARCHAR", dbinf.LongVarCharDataType)
isql = exch_string(isql, "SQL_BINARY", dbinf.BinaryDataType)
Select Case dbinf.HostDB
Case "ORACLE"
isql = exch_string(isql, "SQL_CURRENCY", "NUMBER(38,4)")
isql = exch_string(isql, "SQL_CHAR", "CHAR")
isql = exch_string(isql, "SQL_VARCHAR", "VARCHAR2")
isql = exch_string(isql, "SQL_TEXT", "VARCHAR2(2000)")
isql = exch_string(isql, "SQL_SMALLINT", "NUMBER(10,0)")
isql = exch_string(isql, "SQL_INTEGER", "NUMBER(38,0)")
isql = exch_string(isql, "SQL_LONGINT", "NUMBER(38,0)")
Case "SQLSERVER"
isql = exch_string(isql, "SQL_CURRENCY", "NUMERIC(28,4)")
isql = exch_string(isql, "SQL_CHAR", "CHAR")
isql = exch_string(isql, "SQL_VARCHAR", "VARCHAR")
isql = exch_string(isql, "SQL_TEXT", "TEXT")
isql = exch_string(isql, "SQL_SMALLINT", dbinf.IntDataType)
isql = exch_string(isql, "SQL_INTEGER", dbinf.LongDataType)
isql = exch_string(isql, "SQL_LONGINT", "NUMERIC (28,0)")
Case "ACCESS"
isql = exch_string(isql, "SQL_CURRENCY", "CURRENCY")
isql = exch_string(isql, "SQL_CHAR", "TEXT")
isql = exch_string(isql, "SQL_VARCHAR", "TEXT")
isql = exch_string(isql, "SQL_TEXT", "MEMO")
isql = exch_string(isql, "SQL_SMALLINT", dbinf.IntDataType)
isql = exch_string(isql, "SQL_INTEGER", dbinf.LongDataType)
isql = exch_string(isql, "SQL_LONGINT", dbinf.LongDataType)
Case "SQLBASE"
isql = exch_string(isql, "SQL_CHAR", dbinf.CharDataType)
isql = exch_string(isql, "SQL_CURRENCY", dbinf.DoubleDataType)
isql = exch_string(isql, "SQL_VARCHAR", dbinf.VarCharDataType)
isql = exch_string(isql, "SQL_TEXT", "VARCHAR(254)")
isql = exch_string(isql, "SQL_SMALLINT", dbinf.IntDataType)
isql = exch_string(isql, "SQL_INTEGER", dbinf.LongDataType)
isql = exch_string(isql, "SQL_LONGINT", dbinf.LongDataType)
Case Else
isql = exch_string(isql, "SQL_CHAR", dbinf.CharDataType)
isql = exch_string(isql, "SQL_CURRENCY", dbinf.DoubleDataType)
isql = exch_string(isql, "SQL_VARCHAR", dbinf.VarCharDataType)
isql = exch_string(isql, "SQL_TEXT", dbinf.BinaryDataType)
isql = exch_string(isql, "SQL_SMALLINT", dbinf.IntDataType)
isql = exch_string(isql, "SQL_INTEGER", dbinf.LongDataType)
isql = exch_string(isql, "SQL_LONGINT", dbinf.LongDataType)
End Select
'need to add procees for double prec req using dbinf.DoublePrecReq
execute(isql)
End Sub
Public Function execsql(ByVal sql As String) As Boolean
Dim r As Short
execsql = False
On Error GoTo execfail
If ShowActions Then logDBError(Me, "Show Action SQL " & sql)
ChkPrf(sql)
Dim stmt As Integer
If pvCreateScript Then
FilePut(ScriptFile, sql & ScriptEOL)
execsql = True
Exit Function
End If
'LogMess("executing " & sql)
r = SQLAllocStmt(dbinf.hdbcv, stmt)
If r <> SQL_SUCCESS Then
GoTo execfail
End If
'r = SQLExecDirect(stmt, sql, CInt(Len(sql)))
Dim gh As System.Runtime.InteropServices.GCHandle = System.Runtime.InteropServices.GCHandle.Alloc(sql, System.Runtime.InteropServices.GCHandleType.Pinned)
' get address of variable
Dim StrAddr As IntPtr = gh.AddrOfPinnedObject()
r = SQLExecDirectW(stmt, StrAddr, sql.Length)
gh.Free()
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
GoTo execfail
End If
r = SQLFreeStmt(stmt, SQL_DROP)
execsql = True
Exit Function
execfail:
'If designmode% Then
'showerror r%, stmt&
'End If
logDBError(Me, Err.Description)
execsql = False
Exit Function
End Function
Sub jump()
If dbinf.hdbcv <> 0 Then
logoff()
End If
End Sub
Public Function RefreshConnection() As Boolean
Return ReLogOn()
End Function
Private Function ReLogOn() As Boolean
Try
Dim co As Integer
Dim rc As Short
logoff()
Dim r As Short
r = SQLAllocEnv(dbinf.henv)
If r <> SQL_SUCCESS Then
ShowMessage("Unable to allocate ODBC envelope handle")
Exit Function
End If
r = SQLAllocConnect(dbinf.henv, dbinf.hdbcv)
If r <> SQL_SUCCESS Then
ShowMessage("Unable to allocate ODBC connection handle")
Exit Function
End If
If con_string = "" Then
ShowMessage("Empty connection string")
Return False
End If
dbinf.DSN = con_string
'Debug.Print "dbh set"
r = SQLSetConnectOptionInt(dbinf.hdbcv, SQL_ODBC_CURSORS, SQL_CUR_USE_DRIVER)
'r% = SQLSetConnectOption(dbinf.hdbcv, SQL_ODBC_CURSORS, SQL_CUR_USE_IF_NEEDED)
'r% = SQLSetConnectOption(dbinf.hdbcv, SQL_ODBC_CURSORS, SQL_CUR_USE_ODBC)
If Not r = SQL_SUCCESS Then
'showerror r%, SQL_NULL_HSTMT
ShowMessage("Unable to set driver cursors")
Return False
End If
r = SQLGetConnectOptionInt(dbinf.hdbcv, SQL_OPT_TRACE, co)
If Not r = SQL_SUCCESS Then
ShowMessage("Unable to get trace status")
End If
r = SQLSetConnectOptionInt(dbinf.hdbcv, SQL_OPT_TRACE, SQL_OPT_TRACE_OFF)
If Not r = SQL_SUCCESS Then
ShowMessage("Unable to set trace status")
End If
rc = SQLConnect(dbinf.hdbcv, con_string, con_string.Length, lgonUser, lgonUser.Length, lgonPwd, lgonPwd.Length)
If co <> SQL_OPT_TRACE_OFF Then
r = SQLSetConnectOptionInt(dbinf.hdbcv, SQL_OPT_TRACE, co)
End If
If Not ((rc = SQL_SUCCESS) Or (rc = SQL_SUCCESS_WITH_INFO)) Then
Return False
End If
If dbinf.HostDB = "Microsoft SQL Server" Then
Dim SQL_PRESERVE_CURSORS As Short
Dim SQL_PC_ON As Integer
SQL_PRESERVE_CURSORS = 1204
SQL_PC_ON = 1
r = SQLSetConnectOptionInt(dbinf.hdbcv, SQL_PRESERVE_CURSORS, SQL_PC_ON)
If Not r = SQL_SUCCESS Then
ShowMessage("Unable to set driver cursors")
jump()
End If
End If
Return True
Catch ex As Exception
logDBError(Me, "Relogon error " & ex.Message)
Return False
End Try
End Function
Friend Function CloneConnect() As Integer
Try
Dim rc As Short
Dim hdbc As Integer
'Dim oConString As String
'Dim oConString As String
Dim MAXBUFLEN As Integer = 255
Dim Buf As String = New String(" "c, MAXBUFLEN)
Dim osLen As Short
'Dim hWind As IntPtr
If pvDBName = "" Then
Dim sql$ = "SELECT DB_NAME()"
Dim ds As SNbfResultSet
'Dim ccs As Boolean = pvCloneSResultSets
'pvCloneSResultSets = False
ds = CreateSNbfResultSet(sql$)
If ds.fetch() Then
pvDBName = ds.FetchString(1)
End If
ds.Free()
'pvCloneSResultSets = ccs
If pvDBName = "" Then
Return -1
End If
End If
rc = SQLAllocConnect(dbinf.henv, hdbc)
If rc <> SQL_SUCCESS Then
Return -1
End If
'oConString = " " * 256
rc = SQLSetConnectOptionInt(hdbc, SQL_ODBC_CURSORS, SQL_CUR_USE_DRIVER)
If Not rc = SQL_SUCCESS Then
Return -1
End If
rc = SQLSetConnectOptionInt(hdbc, SQL_OPT_TRACE, SQL_OPT_TRACE_OFF)
Dim dsn_string$ = "DSN=" & con_string & ";DATABASE=" & pvDBName & ";UID=" & lgonUser & ";PWD=" & lgonPwd
rc = SQLDriverConnect(hdbc, NULL_POINTER, dsn_string$, dsn_string$.Length, Buf, MAXBUFLEN, osLen, SQL_DRIVER_COMPLETE)
'rc = SQLConnect(hdbc, con_string, con_string.Length, lgonUser, lgonUser.Length, lgonPwd, lgonPwd.Length)
If Not ((rc = SQL_SUCCESS) Or (rc = SQL_SUCCESS_WITH_INFO)) Then
'rc = SQLDisconnect(hdbc)
showdberror(Me, dbinf.henv, hdbc, rc, 0)
Return -1
End If
If dbinf.HostDB = "SQLSERVER" Then
rc = SQLSetConnectOptionInt(hdbc, SQL_PRESERVE_CURSORS, SQL_PC_ON)
If Not rc = SQL_SUCCESS Then
Return -1
End If
End If
Return hdbc
Catch ex As Exception
logDBError(Me, "CloneConnect error " & ex.Message)
Return -1
End Try
End Function
Private Function qqconnect(ByVal SupressErr As Boolean, ByVal dsource As Object, ByVal usnm As Object, ByVal pswd As Object, Optional ByVal Encrypt As Boolean = False, Optional ByVal NonEncryptedUser As String = "") As Boolean
Dim global_pswd As Object
Dim pos_type As Integer
Dim fetch_type As Integer
Dim ODBCVer As Object
Dim this_odbc_ver As String
Dim tdb As String
Dim pos2 As Short
Dim this_db_ver As String
Dim this_db As String
Dim retval As Short
Dim error_mess As String
Dim pos As Short
Dim sql_stat As String
Dim rc As Short
Dim co As Integer
Dim orig_pwd As String
Dim pwd As String
Dim unm As String
Dim lgunm As String
Dim cpwd As Object
Dim no_att As Short
Dim r As Short
Dim designmode As Short
Dim nhstmt As Integer
Dim stmt As Integer
Dim sysDirBuffer As New StringBuilder(256)
Dim get_string As New VB6.FixedLengthString(70)
Dim lbuf As New VB6.FixedLengthString(255)
Dim sqlstate As New VB6.FixedLengthString(100)
Dim sqlstatesize As Short
Dim host_error As Integer
Dim host_error_text As New VB6.FixedLengthString(251)
Dim host_error_size As Short
Dim cur_size As Short
Dim ret_size As Short
Dim Server As New VB6.FixedLengthString(255)
Dim lic As String
Dim pw As String
Dim S As String
Dim x As Object
Dim Title As String
Dim clsnam As Integer
Dim titaddr As Integer
Dim DSN As New VB6.FixedLengthString(125)
Dim dsndes As New VB6.FixedLengthString(125)
qqconnect = False
'LogMess("Connecting")
If Not designmode Then On Error GoTo dbconerr
S = ""
r = SQLAllocEnv(dbinf.henv)
If r <> SQL_SUCCESS Then
ShowMessage("Unable to allocate ODBC envelope handle")
Exit Function
End If
r = SQLAllocConnect(dbinf.henv, dbinf.hdbcv)
If r <> SQL_SUCCESS Then
ShowMessage("Unable to allocate ODBC connection handle")
Exit Function
End If
con_string = Trim(CStr(dsource))
If con_string = "" Then
ShowMessage("Empty connection string")
GoTo dbabandon
End If
dbinf.DSN = con_string
'Debug.Print "dbh set"
r = SQLSetConnectOptionInt(dbinf.hdbcv, SQL_ODBC_CURSORS, SQL_CUR_USE_DRIVER)
'r% = SQLSetConnectOption(dbinf.hdbcv, SQL_ODBC_CURSORS, SQL_CUR_USE_IF_NEEDED)
'r% = SQLSetConnectOption(dbinf.hdbcv, SQL_ODBC_CURSORS, SQL_CUR_USE_ODBC)
If Not r = SQL_SUCCESS Then
'showerror r%, SQL_NULL_HSTMT
ShowMessage("Unable to set driver cursors")
GoTo dbabandon
End If
no_att = 0
cpwd = pswd
'If cpwd = "" Then
' ShowMessage "Missing password"
' GoTo dbabandon
'End If
unm = Trim(CStr(usnm))
pwd = Trim(CStr(pswd))
orig_pwd = pwd
If Encrypt Then
If UCase(unm) <> UCase(NonEncryptedUser) Then
pwd = mangle(pwd)
End If
End If
lgunm = unm
If pvCompUserRoot <> "" Then
If pvCompUserRoot <> "ACOCMP" Then
If lgunm.Length > 6 Then
If Microsoft.VisualBasic.Left(lgunm, 6).ToUpper <> pvCompUserRoot.Trim.ToUpper Then
lgunm = "U" & pvCompUserRoot & unm
End If
Else
lgunm = "U" & pvCompUserRoot & unm
End If
End If
End If
r = SQLGetConnectOptionInt(dbinf.hdbcv, SQL_OPT_TRACE, co)
If Not r = SQL_SUCCESS Then
ShowMessage("Unable to get trace status")
End If
r = SQLSetConnectOptionInt(dbinf.hdbcv, SQL_OPT_TRACE, SQL_OPT_TRACE_OFF)
If Not r = SQL_SUCCESS Then
ShowMessage("Unable to set trace status")
End If
lgonUser = lgunm
lgonPwd = pwd
rc = SQLConnect(dbinf.hdbcv, con_string, con_string.Length, lgunm, lgunm.Length, pwd, pwd.Length)
If co <> SQL_OPT_TRACE_OFF Then
r = SQLSetConnectOptionInt(dbinf.hdbcv, SQL_OPT_TRACE, co)
End If
If Not ((rc = SQL_SUCCESS) Or (rc = SQL_SUCCESS_WITH_INFO)) Then
If SupressErr Then
qqconnect = False
Exit Function
End If
host_error_size = 250
r = SQLError(dbinf.henv, dbinf.hdbcv, nhstmt, sqlstate.Value, host_error, host_error_text.Value, host_error_size, ret_size)
sql_stat = GetStringFromLPSTR(sqlstate.Value)
If False Then 'sql_stat = "28000" Then
System.Windows.Forms.Cursor.Current = System.Windows.Forms.Cursors.Default
ShowMessage("Invalid user name or password")
GoTo dbabandon
ElseIf sql_stat = "08001" Then
System.Windows.Forms.Cursor.Current = System.Windows.Forms.Cursors.Default
ShowMessage("Unable to find the specified SQL Server." & Chr(13) & Chr(10) & Chr(13) & Chr(10) & "Please make sure that SQL Server is running." & Chr(13) & Chr(10) & Chr(13) & Chr(10) & "See Installation and Getting Started Guide.")
GoTo dbabandon
End If
pos = InStr(1, host_error_text.Value, Chr(0))
If pos > 0 Then
error_mess = Trim(Left(host_error_text.Value, pos - 1))
pos = InStr(1, error_mess, "]")
Do While pos > 0
error_mess = Right(error_mess, Len(error_mess) - pos)
pos = InStr(1, error_mess, "]")
Loop
System.Windows.Forms.Cursor.Current = System.Windows.Forms.Cursors.Default
ShowMessage(error_mess)
End If
GoTo dbabandon
End If
r = DBW.SQLGetInfoString(dbinf.hdbcv, SQL_DATABASE_NAME, sysDirBuffer, sysDirBuffer.Capacity, retval)
this_db = sysDirBuffer.ToString
r = DBW.SQLGetInfoString(dbinf.hdbcv, SQL_DBMS_NAME, sysDirBuffer, sysDirBuffer.Capacity, retval)
dbinf.HostDB = sysDirBuffer.ToString
r = DBW.SQLGetInfoString(dbinf.hdbcv, SQL_DBMS_VER, sysDirBuffer, sysDirBuffer.Capacity, retval)
this_db_ver = sysDirBuffer.ToString
If IsNumeric(this_db_ver) Then
dbinf.DBVersion = CDec(this_db_ver)
Else
If Len(this_db_ver) > 1 Then
pos = InStr(this_db_ver, ".")
If pos > 0 Then
pos2 = InStr(pos + 1, this_db_ver, ".")
If pos2 > 0 Then
pos = pos2
End If
tdb = Left(this_db_ver, pos - 1)
If IsNumeric(tdb) Then
dbinf.DBVersion = CDec(tdb)
Else
dbinf.DBVersion = -1
End If
Else
dbinf.DBVersion = -1
End If
Else
dbinf.DBVersion = -1
End If
End If
r = DBW.SQLGetInfoString(dbinf.hdbcv, SQL_ODBC_VER, sysDirBuffer, sysDirBuffer.Capacity, retval)
this_odbc_ver = sysDirBuffer.ToString
pos = InStr(1, this_odbc_ver, ".")
If pos > 0 Then
this_odbc_ver = Trim(Left(this_odbc_ver, pos - 1))
End If
ODBCVer = 1
If IsNumeric(this_odbc_ver) Then
If CInt(this_odbc_ver) > 1 Then
ODBCVer = 2
End If
End If
'r% = SQLGetInfo(dbinf.hdbcv, SQL_USER_NAME, ByVal get_string, 70, retval%)
'pos% = InStr(1, get_string, Chr$(0))
'dbret_user_name$ = Trim$(Left$(get_string, pos% - 1))
dbinf.setstmtreq = False
dbinf.setstmtlockreq = False
dbinf.NoPOSUpdate = False
If dbinf.HostDB = "Microsoft SQL Server" Then
dbinf.HostDB = "SQLSERVER"
r = SQLSetConnectOptionInt(dbinf.hdbcv, SQL_PRESERVE_CURSORS, SQL_PC_ON)
If Not r = SQL_SUCCESS Then
ShowMessage("Unable to set driver cursors")
jump()
End If
dbinf.setstmtreq = True
dbinf.setstmtlockreq = True
ElseIf UCase(Left(dbinf.HostDB, 6)) = "WATCOM" Then
dbinf.HostDB = "WATCOM"
ElseIf UCase(Left(dbinf.HostDB, 6)) = "ORACLE" Then
dbinf.HostDB = "ORACLE"
ElseIf UCase(Left(dbinf.HostDB, 7)) = "SQLBASE" Then
dbinf.HostDB = "SQLBASE"
dbinf.NoPOSUpdate = True
dbinf.setstmtreq = True
ElseIf UCase(dbinf.HostDB) = "SYBASE SQL ANYWHERE" Then
dbinf.HostDB = "ANYWHERE"
ElseIf UCase(Left(dbinf.HostDB, 6)) = "ACCESS" Then
dbinf.NoPOSUpdate = True
dbinf.HostDB = "ACCESS"
End If
r = SQLGetConnectOptionInt(dbinf.hdbcv, SQL_ODBC_CURSORS, co)
If Not r = SQL_SUCCESS Then
ShowMessage("Unable to get cursor use")
Else
Select Case co
Case SQL_CUR_USE_DRIVER
Case SQL_CUR_USE_ODBC
Case SQL_CUR_USE_IF_NEEDED
End Select
End If
dbinf.fetchprior = False
r = SQLGetInfoInt(dbinf.hdbcv, SQL_FETCH_DIRECTION, fetch_type, 4, retval)
If r <> SQL_SUCCESS Then
ShowMessage("Error on getting Fetch direction information")
Call showerror(r, 0)
End If
If dbinf.HostDB = "ORACLE" Or (gupta_rowid And dbinf.HostDB = "SQLBASE") Then
dbinf.FetchType = DOES_FETCH_ROWID
ElseIf dbinf.HostDB = "SQLSERVER" Then
dbinf.FetchType = DOES_FETCH_PRIOR
dbinf.fetchprior = True
'ElseIf dbinf.HostDB = "ACCESS" Then
' dbinf.FetchType = DOES_FETCH_PRIOR
' dbinf.fetchprior = True
Else
If fetch_type And SQL_FD_FETCH_ABSOLUTE Then
dbinf.FetchType = DOES_FETCH_ABSOLUTE
'ElseIf fetch_type& And SQL_FD_FETCH_BOOKMARK Then
' dbinf.FetchType = DOES_FETCH_BOOKMARK
' Debug.Print "Fetch bookmark supported"
ElseIf fetch_type And SQL_FD_FETCH_PRIOR Then
dbinf.FetchType = DOES_FETCH_PRIOR
dbinf.fetchprior = True
Else
ShowMessage("No available mechanism for scrolling cursors")
GoTo dbabandon
End If
If dbinf.FetchType <> DOES_FETCH_PRIOR Then
If fetch_type And SQL_FD_FETCH_PRIOR Then
dbinf.fetchprior = True
End If
End If
End If
If dbinf.HostDB = "WATCOM" Then
dbinf.sfuok = True
dbinf.sfuupdateok = True
dbinf.sfudeleteok = True
'ElseIf dbinf.HostDB = "SQLBASE" And Not gupta_rowid Then
' dbinf.sfuok = True
' dbinf.sfuupdateok = True
' dbinf.sfudeleteok = True
' dbinf.posok = False
' dbinf.posrefreshok = False
' dbinf.posupdateok = False
' dbinf.posdeleteok = False
' dbinf.posaddok = False
ElseIf dbinf.HostDB <> "ORACLE" Then 'And dbinf.HostDB <> "SQLBASE" Then
r = SQLGetInfoInt(dbinf.hdbcv, SQL_POS_OPERATIONS, pos_type, 4, retval)
If r <> SQL_SUCCESS Then
dbinf.posok = False
dbinf.posrefreshok = False
dbinf.posupdateok = False
dbinf.posdeleteok = False
dbinf.posaddok = False
Else
If pos_type And SQL_POS_POSITION Then
'positions OK
dbinf.posok = True
If pos_type And SQL_POS_REFRESH Then
'refreshess OK
dbinf.posrefreshok = True
Else
dbinf.posrefreshok = False
End If
If pos_type And SQL_POS_UPDATE Then
'updates OK
dbinf.posupdateok = True
Else
dbinf.posupdateok = False
End If
If pos_type And SQL_POS_DELETE Then
'deletes OK
dbinf.posdeleteok = True
Else
dbinf.posdeleteok = False
End If
If pos_type And SQL_POS_ADD Then
'adds OK
dbinf.posaddok = True
Else
dbinf.posaddok = False
End If
Else
dbinf.posok = False
dbinf.posrefreshok = False
dbinf.posupdateok = False
dbinf.posdeleteok = False
dbinf.posaddok = False
End If
End If
r = SQLGetInfoInt(dbinf.hdbcv, SQL_POSITIONED_STATEMENTS, pos_type, 4, retval)
If r <> SQL_SUCCESS Then
showerror(r, 0)
dbinf.sfuok = False
dbinf.sfuupdateok = False
dbinf.sfudeleteok = False
Else
If pos_type And SQL_PS_SELECT_FOR_UPDATE Then
'select OK
dbinf.sfuok = True
If pos_type And SQL_PS_POSITIONED_UPDATE Then
'update OK
dbinf.sfuupdateok = True
Else
dbinf.sfuupdateok = False
End If
If pos_type And SQL_PS_POSITIONED_DELETE Then
'delete OK
dbinf.sfudeleteok = True
Else
dbinf.sfudeleteok = False
End If
Else
dbinf.sfuok = False
dbinf.sfuupdateok = False
dbinf.sfudeleteok = False
End If
End If
End If
'If dbinf.posok Then
'Else
'End If
'If dbinf.posupdateok Then
'Else
'End If
If (dbinf.FetchType <> DOES_FETCH_ROWID) And (dbinf.sfuupdateok = False) And (dbinf.posupdateok = False) Then
dbinf.NoPOSUpdate = True
End If
If dbinf.HostDB = "ORACLE" Then
unm = UCase(Trim(unm))
End If
dbinf.this_user = unm
dbinf.this_pswd = orig_pwd
global_pswd = orig_pwd ' sets global in app if it exists
real_password = pwd
qqconnect = True
Exit Function
dbconerr:
showvberr(Err)
ShowMessage("Error connecting to database")
dbinf.henv = 0
dbinf.hdbcv = 0
qqconnect = False
Exit Function
dbabandon:
If dbinf.hdbcv <> 0 Then
r = SQLDisconnect(dbinf.hdbcv)
r = SQLFreeConnect(dbinf.hdbcv)
End If
If dbinf.henv <> 0 Then
r = SQLFreeEnv(dbinf.henv)
End If
dbinf.henv = 0
dbinf.hdbcv = 0
qqconnect = False
Exit Function
End Function
Friend Function FetchType() As Short
FetchType = dbinf.FetchType
End Function
Friend Function posok() As Boolean
posok = dbinf.posupdateok
End Function
Friend Function sfuok() As Boolean
sfuok = dbinf.sfuupdateok
End Function
Private Sub cvtype()
Dim r As Short
Dim retval As Short
Dim cv_ret As Integer
Dim cv_type As Short
'Select Case source_type%
'Case SQL_SMALLINT
Select Case dbinf.host_int
Case SQL_SMALLINT
cv_type = SQL_CONVERT_SMALLINT
Case SQL_INTEGER
cv_type = SQL_CONVERT_INTEGER
Case SQL_DOUBLE
cv_type = SQL_CONVERT_DOUBLE
Case SQL_NUMERIC
cv_type = SQL_CONVERT_NUMERIC
Case SQL_FLOAT
cv_type = SQL_CONVERT_FLOAT
Case SQL_DECIMAL
cv_type = SQL_CONVERT_DECIMAL
Case Else
ShowMessage("Error in CVTYPE function, unknowm host integer type")
End Select
r = SQLGetInfoInt(dbinf.hdbcv, cv_type, cv_ret, 4, retval)
If (cv_ret And SQL_CVT_SMALLINT) <> 0 Then
dbinf.host_cint = True
Else
dbinf.host_cint = False
End If
'Case SQL_INTEGER
Select Case dbinf.host_long
Case SQL_INTEGER
cv_type = SQL_CONVERT_INTEGER
Case SQL_DOUBLE
cv_type = SQL_CONVERT_DOUBLE
Case SQL_NUMERIC
cv_type = SQL_CONVERT_NUMERIC
Case SQL_FLOAT
cv_type = SQL_CONVERT_FLOAT
Case SQL_DECIMAL
cv_type = SQL_CONVERT_DECIMAL
Case Else
ShowMessage("Error in CVTYPE function, unknowm host long type")
End Select
r = SQLGetInfoInt(dbinf.hdbcv, cv_type, cv_ret, 4, retval)
If (cv_ret And SQL_CVT_INTEGER) <> 0 Then
dbinf.host_clong = True
Else
dbinf.host_clong = False
End If
'Case SQL_DOUBLE
Select Case dbinf.host_double
Case SQL_DOUBLE
cv_type = SQL_CONVERT_DOUBLE
Case SQL_NUMERIC
cv_type = SQL_CONVERT_NUMERIC
Case SQL_FLOAT
cv_type = SQL_CONVERT_FLOAT
Case SQL_DECIMAL
cv_type = SQL_CONVERT_DECIMAL
Case Else
ShowMessage("Error in CVTYPE function, unknowm host doubletype")
End Select
r = SQLGetInfoInt(dbinf.hdbcv, cv_type, cv_ret, 4, retval)
If (cv_ret And SQL_CVT_DOUBLE) <> 0 Then
dbinf.host_cdouble = True
Else
dbinf.host_cdouble = False
End If
'Case date
r = SQLGetInfoInt(dbinf.hdbcv, SQL_CONVERT_TIMESTAMP, cv_ret, 4, retval)
If (cv_ret And SQL_CVT_TIMESTAMP) <> 0 Then
dbinf.host_ctimestamp = True
Else
dbinf.host_ctimestamp = False
End If
If dt_prf = "{d'" Then
r = SQLGetInfoInt(dbinf.hdbcv, SQL_CONVERT_DATE, cv_ret, 4, retval)
If (cv_ret And SQL_CVT_DATE) <> 0 Then
dbinf.host_cdate = True
Else
dbinf.host_cdate = False
End If
Else
dbinf.host_cdate = dbinf.host_ctimestamp
End If
End Sub
Sub RollBackTran()
Dim r As Short
If acc_tran Then
acc_tran = False
ShowMessage("Your Access database was unable to support a transaction that has been rolled back. Your database is now probably corrupt. It is essential that you revert to a backup copy of your .mdb file")
dbinf.intransact = False
Exit Sub
End If
'LogMess("Rolling Back ")
r = SQLTransact(dbinf.henv, dbinf.hdbcv, SQL_ROLLBACK)
If Not r = SQL_SUCCESS Then
showerror(r, SQL_NULL_HSTMT)
ShowMessage("Unable to RollBack transaction")
logoff()
Exit Sub
End If
r = SQLSetConnectOptionInt(dbinf.hdbcv, SQL_AUTOCOMMIT, SQL_AUTOCOMMIT_ON)
If Not r = SQL_SUCCESS Then
showerror(r, SQL_NULL_HSTMT)
ShowMessage("Unable to release transaction mode")
logoff()
Exit Sub
End If
dbinf.intransact = False
If dbinf.isolev <> dbinf.normisolev Then
r = SQLSetConnectOptionInt(dbinf.hdbcv, SQL_TXN_ISOLATION, dbinf.normisolev)
If Not r = SQL_SUCCESS Then
ShowMessage("Unable to set default isolation level on rollback")
logoff()
End If
Else
End If
End Sub
Sub BeginTransact()
Dim r As Short
If dbinf.intransact Then
Dim s$ = "There is an attempt to begin a transaction when a transaction is already in progress"
Err.Raise(1 + vbObjectError, , s$)
Exit Sub
End If
If dbinf.isolev <> dbinf.normisolev Then
r = SQLSetConnectOptionInt(dbinf.hdbcv, SQL_TXN_ISOLATION, dbinf.isolev)
If Not r = SQL_SUCCESS Then
If dbinf.HostDB = "ACCESS" Then
'forget transaction protection for demo database, monitor only
acc_tran = True
dbinf.intransact = True
Exit Sub
End If
showerror(r, SQL_NULL_HSTMT)
ShowMessage("Unable to set transaction isolation level")
'jump
End If
Else
End If
r = SQLSetConnectOptionInt(dbinf.hdbcv, SQL_AUTOCOMMIT, SQL_AUTOCOMMIT_OFF)
If Not r = SQL_SUCCESS Then
If dbinf.HostDB = "ACCESS" Then
'forget transaction protection for demo database, monitor only
acc_tran = True
dbinf.intransact = True
Exit Sub
End If
showerror(r, SQL_NULL_HSTMT)
ShowMessage("Unable to begin transaction")
jump()
End If
dbinf.intransact = True
End Sub
Private Sub showerror(ByVal errnum As Short, ByVal hstmt As Integer)
showdberror(Me, dbinf.henv, dbinf.hdbcv, errnum, hstmt)
End Sub
Sub CommitTransact()
Dim r As Short
If acc_tran Then
acc_tran = False
dbinf.intransact = False
Exit Sub
Else
If Not dbinf.intransact Then
Dim s$ = "There is an attempt to commit a transaction when no transaction is in progress"
Err.Raise(1 + vbObjectError, , s$)
Exit Sub
End If
End If
'LogMess("Commit Transact ")
r = SQLTransact(dbinf.henv, dbinf.hdbcv, SQL_COMMIT)
If Not r = SQL_SUCCESS Then
showerror(r, SQL_NULL_HSTMT)
ShowMessage("Unable to commit transaction")
jump()
'Else
'ShowMessage("Commit Successful")
End If
r = SQLSetConnectOptionInt(dbinf.hdbcv, SQL_AUTOCOMMIT, SQL_AUTOCOMMIT_ON)
If Not r = SQL_SUCCESS Then
showerror(r, SQL_NULL_HSTMT)
ShowMessage("Unable to release transaction mode")
jump()
End If
dbinf.intransact = False
If dbinf.isolev <> dbinf.normisolev Then
r = SQLSetConnectOptionInt(dbinf.hdbcv, SQL_TXN_ISOLATION, dbinf.normisolev)
If Not r = SQL_SUCCESS Then
ShowMessage("Unable to set default isolation level following commit")
'jump
End If
Else
End If
End Sub
Function gethosttype(ByVal sql_type As Short, ByRef pres As Integer, ByRef param As String, ByRef prf As String, ByRef sfx As String) As String
Dim typ As String
Dim cntg As Short
Dim sql As String
Dim in_type As Short
Dim hstmt As Integer
Dim dbs As New nbfResultSet
gethosttype = ""
in_type = sql_type
sql = "GETTYPEINFO"
If Not dbs.create(Me, sql, sql_type) Then
ShowMessage("Database " & dbinf.HostDB & " Unable to create type info NbfResultSet for type " & VB6.Format(sql_type))
dbs = Nothing
Exit Function
End If
Dim NbfResultSets(0) As Object
cntg = 0
Do While dbs.fetch()
typ = dbs.FetchString(1) 'strip(host_type$)
If cntg = 0 Then
pres = CInt(dbs.FetchString(3)) 'host_pres&
prf = dbs.FetchString(4) 'strip(host_pref$)
sfx = dbs.FetchString(5) 'strip(host_suf$)
param = dbs.FetchString(6) 'strip(host_param$)
If dbinf.HostDB = "ORACLE" Then
If sql_type = 1 Then
typ = "VARCHAR2"
ElseIf sql_type = 8 Then
typ = "NUMBER"
End If
End If
gethosttype = typ
End If
cntg = cntg + 1
Loop
dbs.Free()
If cntg = 0 Then
End If
End Function
Function qqsqlstate(ByRef errnum As Short, ByRef nhstmt As Integer) As String
Dim error_mess As String
Dim pos As Short
Dim r As Short
Dim lbuf As New VB6.FixedLengthString(255)
Dim sqlstate As New VB6.FixedLengthString(100)
Dim sqlstatesize As Short
Dim host_error As Integer
Dim host_error_text As New VB6.FixedLengthString(251)
Dim host_error_size As Short
Dim cur_size As Short
Dim ret_size As Short
'ShowMessage "Error occurred, ref: " & Format$(errnum%)
host_error_size = 250
r = SQLError(dbinf.henv, dbinf.hdbcv, nhstmt, sqlstate.Value, host_error, host_error_text.Value, host_error_size, ret_size)
pos = InStr(1, sqlstate.Value, Chr(0))
If pos > 0 Then
error_mess = Trim(Left(sqlstate.Value, pos - 1))
ShowMessage("sqlstate message " & error_mess)
End If
ShowMessage("error code " & VB6.Format(host_error))
pos = InStr(1, host_error_text.Value, Chr(0))
If pos > 0 Then
error_mess = Trim(Left(host_error_text.Value, pos - 1))
ShowMessage("error message " & error_mess)
End If
System.Windows.Forms.Cursor.Current = System.Windows.Forms.Cursors.Default
End Function
Public Sub logoff()
Dim stmt As Integer
Dim r As Short
'If Track Then
' MsgBox("Trk HDB Logfoff")
'End If
Try
While pvOpenBoundDataTables.Count > 0
pvOpenBoundDataTables(0).Free()
End While
While pvOpenBrowseDataTables.Count > 0
pvOpenBrowseDataTables(0).Free()
End While
While pvOpenDBQueries.Count > 0
pvOpenDBQueries(0).Free()
End While
While pvOpenDBTables.Count > 0
pvOpenDBTables(0).Free()
End While
While pvOpenResultSets.Count > 0
pvOpenResultSets(0).Free()
End While
While pvOpenQnbfResultSets.Count > 0
pvOpenQnbfResultSets(0).Free()
End While
While pvOpenSnbfResultSets.Count > 0
pvOpenSnbfResultSets(0).Free()
End While
Catch ex As Exception
'MsgBox("Free db col error " & ex.Message)
'no action
End Try
If dbinf.hdbcv = 0 Then
Exit Sub
End If
'LogMess("Logging Off ")
r = SQLDisconnect(dbinf.hdbcv)
'If r <> SQL_SUCCESS Then
' ShowMessage("Error on disconnect")
'End If
r = SQLFreeConnect(dbinf.hdbcv)
'If r <> SQL_SUCCESS Then
' ShowMessage("Error on free connect")
' Call showerror(r, stmt)
'End If
If dbinf.henv <> 0 Then
r = SQLFreeEnv(dbinf.henv)
'If r <> SQL_SUCCESS Then
' ShowMessage("Error on free envelope")
' Call showerror(r, stmt)
'End If
End If
dbinf.henv = 0
dbinf.hdbcv = 0
End Sub
Public Sub logon(ByVal dsource As String, ByVal usnm As String, ByVal pswd As String, Optional ByVal Encrypt As Boolean = False, Optional ByVal NonEncryptedUser As String = "")
Dim res As Object
If NonEncryptedUser.Length > 6 Then
pvCompUserRoot = Mid(NonEncryptedUser, 1, 6)
End If
res = lgon(False, dsource, usnm, pswd, Encrypt, NonEncryptedUser)
End Sub
Public ReadOnly Property Cloned() As Boolean
Get
Return pvCloned
End Get
End Property
Friend Sub SetClone(ByVal Parent As HDBC)
pvCloned = True
pvCompUserRoot = Parent.pvCompUserRoot
dbinf = Parent.dbinf
real_password = Parent.real_password
dt_prf = Parent.dt_prf
dt_sfx = Parent.dt_sfx
tm_sfx = Parent.tm_sfx
pvLicenseInfo = Parent.pvLicenseInfo
TablePrefix = Parent.TablePrefix
PrefixSet = Parent.PrefixSet
con_string = Parent.con_string
lgonUser = Parent.lgonUser
lgonPwd = Parent.lgonPwd
pvDBName = Parent.pvDBName
pvLogName = Parent.LogName
pvCloneSResultSets = Parent.pvCloneSResultSets
pvCloneParent = Parent
Dim rc As Short
Dim hdbc As Integer
Dim MAXBUFLEN As Integer = 255
Dim Buf As String = New String(" "c, MAXBUFLEN)
Dim osLen As Short
rc = SQLAllocEnv(dbinf.henv)
If rc <> SQL_SUCCESS Then
'ShowMessage("Unable to allocate ODBC envelope handle")
Return
Exit Sub
End If
rc = SQLAllocConnect(dbinf.henv, hdbc)
If rc <> SQL_SUCCESS Then
Return
End If
rc = SQLSetConnectOptionInt(hdbc, SQL_ODBC_CURSORS, SQL_CUR_USE_DRIVER)
If Not rc = SQL_SUCCESS Then
Return
End If
rc = SQLSetConnectOptionInt(hdbc, SQL_OPT_TRACE, SQL_OPT_TRACE_OFF)
Dim dsn_string$
If pvDBName = "" Then
dsn_string$ = "DSN=" & con_string & ";UID=" & lgonUser & ";PWD=" & lgonPwd
Else
dsn_string$ = "DSN=" & con_string & ";DATABASE=" & pvDBName & ";UID=" & lgonUser & ";PWD=" & lgonPwd
End If
rc = SQLDriverConnect(hdbc, NULL_POINTER, dsn_string$, dsn_string$.Length, Buf, MAXBUFLEN, osLen, SQL_DRIVER_COMPLETE)
If Not ((rc = SQL_SUCCESS) Or (rc = SQL_SUCCESS_WITH_INFO)) Then
rc = SQLDisconnect(hdbc)
showdberror(Me, dbinf.henv, hdbc, rc, 0)
Return
End If
If dbinf.HostDB = "SQLSERVER" Then
rc = SQLSetConnectOptionInt(hdbc, SQL_PRESERVE_CURSORS, SQL_PC_ON)
If Not rc = SQL_SUCCESS Then
Return
End If
End If
dbinf.hdbcv = hdbc
End Sub
Public Function Fdate(ByVal indate As Object) As String
If IsDBNull(indate) Then
Fdate = "NULL"
Else
If IsDate(indate) Then
If Year(indate) > 1899 Then
If dbinf.HostDB = "ORACLE" And dbinf.DBVersion >= 8 Then
Fdate = "TO_DATE('" & VB6.Format(indate, "dd-mmm-yyyy") & "','DD-MON-YYYY')"
Else
Fdate = dt_prf & VB6.Format(indate, "yyyy-mm-dd") & dt_sfx
End If
Else
Fdate = "NULL"
End If
Else
Fdate = "NULL"
End If
End If
End Function
Public Function Fdatetime(ByVal indate As Object) As String
If IsDBNull(indate) Then
Fdatetime = "NULL"
Else
If IsDate(indate) Then
If Year(indate) > 1899 Then
If dbinf.HostDB = "ORACLE" And dbinf.DBVersion >= 8 Then
Fdatetime = "TO_DATE('" & VB6.Format(indate, "dd-mmm-yyyy hh:mm:ss") & "','DD-MON-YYYY HH24:MI:SS')"
Else
Fdatetime = "{ts'" & VB6.Format(indate, "yyyy-mm-dd hh:mm:ss") & "'}"
End If
Else
Fdatetime = "NULL"
End If
Else
Fdatetime = "NULL"
End If
End If
End Function
Public Function dbltype(Optional ByRef colprecision As Object = Nothing, Optional ByRef colscale As Object = Nothing) As String
Dim rval As String
Dim def_scale As String
def_scale = "6"
If IsNothing(colprecision) Then
If dbinf.DoublePrecReq Then
rval = dbinf.DoubleDataType & "(" & VB6.Format(dbinf.DoublePrec) & "," & def_scale & ")"
Else
rval = dbinf.DoubleDataType
End If
Else
If IsNothing(colscale) Then
rval = dbinf.DoubleDataType & "(" & VB6.Format(colprecision) & "," & def_scale & ")"
Else
rval = dbinf.DoubleDataType & "(" & VB6.Format(colprecision) & "," & VB6.Format(colscale) & ")"
End If
End If
dbltype = rval
End Function
Friend Function ssreq() As Boolean
ssreq = dbinf.setstmtreq
End Function
Friend Function sslockreq() As Boolean
sslockreq = dbinf.setstmtlockreq
End Function
Public Sub StopScript()
If Not pvCreateScript Then
Exit Sub
End If
FileClose(ScriptFile)
ScriptFile = 0
ScriptName = ""
pvCreateScript = False
End Sub
Public Function TryLogon(ByVal dsource As Object, ByVal usnm As Object, ByVal pswd As Object, Optional ByVal Encrypt As Boolean = False, Optional ByVal NonEncryptedUser As String = "") As Boolean
Dim r As Short
'LogMess("Try Log On ")
If Not lgon(False, dsource, usnm, pswd, Encrypt, NonEncryptedUser) Then
'If Not lgon(True, dsource, usnm, pswd, Encrypt, NonEncryptedUser) Then
If dbinf.hdbcv <> 0 Then
r = SQLDisconnect(dbinf.hdbcv)
r = SQLFreeConnect(dbinf.hdbcv)
End If
If dbinf.henv <> 0 Then
r = SQLFreeEnv(dbinf.henv)
End If
dbinf.henv = 0
dbinf.hdbcv = 0
TryLogon = False
Else
TryLogon = True
End If
End Function
Public Sub execute(ByVal sql As String)
'Dim es As New StringBuilder(sql.Length)
Dim ess As String
Dim r As Short
On Error GoTo executeerr
Dim stmt As Integer
If ShowActions Then logDBError(Me, "Show Action SQL " & sql)
ChkPrf(sql)
If pvCreateScript Then
FilePut(ScriptFile, sql & ScriptEOL)
Exit Sub
End If
'LogMess("Executing " & sql)
r = SQLAllocStmt(dbinf.hdbcv, stmt)
If r <> SQL_SUCCESS Then
showerror(r, stmt)
GoTo executeerr
End If
'r = SQLExecDirect(stmt, sql, CInt(sql.Length))
' pin variable and create
' GC handle instance
Dim gh As System.Runtime.InteropServices.GCHandle = System.Runtime.InteropServices.GCHandle.Alloc(sql, System.Runtime.InteropServices.GCHandleType.Pinned)
' get address of variable
Dim StrAddr As IntPtr = gh.AddrOfPinnedObject()
r = SQLExecDirectW(stmt, StrAddr, sql.Length)
gh.Free()
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
Dim emsg$ = Getdberror(dbinf.henv, dbinf.hdbcv, r, stmt)
If sql.Length < 1000 Then
emsg$ &= " executing " & sql
End If
LogMsg(emsg$)
Err.Raise(20 + vbObjectError, , emsg$)
End If
r = SQLFreeStmt(stmt, SQL_DROP)
Exit Sub
executeerr:
If Err.Number <> 0 Then
ess = Err.Description
Else
ess = ""
End If
If sql.Length < 1000 Then
ess = ess & " unable to execute: " & sql
ElseIf ess.Length = 0 Then
ess = ess & " unable to execute statement"
End If
logDBError(Me, ess)
Err.Raise(1 + vbObjectError, , ess)
End Sub
Public Sub execsingle(ByVal sql As String)
'Dim es As New StringBuilder(sql.Length)
If ShowActions Then logDBError(Me, "Show Action SQL " & sql)
Dim ess As String
Dim r As Short
On Error GoTo executeerr
Dim stmt As Integer
ChkPrf(sql)
If pvCreateScript Then
FilePut(ScriptFile, sql & ScriptEOL)
Exit Sub
End If
Dim hdbc As Integer = 0
If Not intransact Then
hdbc = CloneConnect()
If hdbc > 0 Then
r = SQLAllocStmt(hdbc, stmt)
Else
r = SQLAllocStmt(dbinf.hdbcv, stmt)
End If
Else
r = SQLAllocStmt(dbinf.hdbcv, stmt)
End If
If r <> SQL_SUCCESS Then
showerror(r, stmt)
GoTo executeerr
End If
'r = SQLExecDirect(stmt, sql, CInt(sql.Length))
' pin variable and create
' GC handle instance
Dim gh As System.Runtime.InteropServices.GCHandle = System.Runtime.InteropServices.GCHandle.Alloc(sql, System.Runtime.InteropServices.GCHandleType.Pinned)
' get address of variable
Dim StrAddr As IntPtr = gh.AddrOfPinnedObject()
r = SQLExecDirectW(stmt, StrAddr, sql.Length)
gh.Free()
If Not (r = SQL_SUCCESS Or r = SQL_SUCCESS_WITH_INFO) Then
db("Exec direct failed ret code " & CStr(r))
showdberror(Me, henv, hdbc, r, stmt)
If hdbc > 0 Then
r = SQLDisconnect(hdbc)
r = SQLFreeConnect(hdbc)
End If
GoTo executeerr
End If
r = SQLFreeStmt(stmt, SQL_DROP)
If hdbc > 0 Then
r = SQLDisconnect(hdbc)
r = SQLFreeConnect(hdbc)
End If
Exit Sub
executeerr:
If Err.Number <> 0 Then
ess = Err.Description
Else
ess = ""
End If
If False Then
If Left(UCase(sql), 5) = "GRANT" Then
sql = "(GRANT STATEMENT)"
ElseIf Left(UCase(sql), 6) = "CREATE" Then
If Len(sql) > 12 Then
If Left(UCase(sql), 12) <> "CREATE TABLE" Then
sql = "(CREATE STATEMENT)"
End If
Else
sql = "(CREATE STATEMENT)"
End If
End If
End If
logDBError(Me, ess & " unable to execute single: " & sql)
Err.Raise(1 + vbObjectError, , ess & " unable to execute: " & sql)
End Sub
Private Sub Class_Initialize_Renamed()
Try
If Not System.Diagnostics.EventLog.SourceExists(LogName) Then
System.Diagnostics.EventLog.CreateEventSource(LogName, "MyNLog")
System.Windows.Forms.Application.DoEvents()
End If
Catch ex As Exception
'no action
End Try
dbinf.hdbcv = 0
dbinf.intransact = False
Dim mfz As String
Try
mfz = GetSetting("nbfDB", "SystemSetup", "dbdbg", "")
If mfz Is Nothing Then
mfz = ""
End If
If mfz = "" Then
SaveSetting("nbfDB", "SystemSetup", "dbdbg", "N")
End If
If mfz = "Y" Then
MonitorFinalize = True
End If
Catch
'no action
End Try
'If debugout% Then
' 'On Error Resume Next
'' 'Kill "SPHYGLOG"
' debugfile% = FreeFile
' Open "SPHYGLOG" For Output As debugfile%
'End If
End Sub
Public Property LogOpenStatements() As Boolean
Get
Return pvLogOpenStatements
End Get
Set(ByVal value As Boolean)
pvLogOpenStatements = value
End Set
End Property
Public Sub New()
MyBase.New()
Class_Initialize_Renamed()
End Sub
Public Sub New(ByVal dsource As String, ByVal usnm As String, ByVal pswd As String, Optional ByVal Encrypt As Boolean = False, Optional ByVal NonEncryptedUser As String = "")
MyBase.New()
Class_Initialize_Renamed()
logon(dsource, usnm, pswd, Encrypt, NonEncryptedUser)
End Sub
Public Sub New(ByVal CompRoot As String)
MyBase.New()
Class_Initialize_Renamed()
pvCompUserRoot = CompRoot
End Sub
Sub LogError(ByVal msg As String)
Try
msg = "OS" & Err.Description & " - " & msg
Catch
'no action
End Try
Dim prfx As String = ""
For Each kp As System.Collections.Generic.KeyValuePair(Of String, StatementInfo) In pvOpenStatements
prfx = "OS - " & kp.Value.TimeCreated.ToString() & vbCrLf
prfx = kp.Value.StatementType.ToString() & vbCrLf
prfx = kp.Value.SQL & vbCrLf
Next
msg = prfx & msg
Dim log As New EventLog
log.Source = LogName
Try
log.WriteEntry(msg)
Catch ex As Exception
log.Clear()
log.WriteEntry(msg)
End Try
End Sub
Sub LogMsg(ByVal msg As String)
Dim log As New EventLog
log.Source = LogName
Try
log.WriteEntry(msg)
Catch ex As Exception
log.Clear()
log.WriteEntry(msg)
End Try
End Sub
End Class
Public Class StatementInfo
Public TimeCreated As Date
Public SQL As String = ""
Public StatementType As String = ""
End Class
'Public Declare Function SQLAllocEnv Lib "odbc32.dll" (ByRef env As Integer)
'As Short
'Public Declare Function SQLAllocConnect Lib "odbc32.dll" (ByVal env As
'Integer, ByRef lHdbc As Integer) As Short
'Public Declare Function SQLDriverConnect Lib "ODBC32.DLL" (ByVal hDBC As
'Integer, ByVal hWnd As Integer, ByVal constr As String, ByVal constrlen As
'Short, ByVal buf As String, ByVal buflen As Short, ByRef outlen As Short,
'ByVal prompt As Short) As Short
'Public Declare Function SQLFreeConnect Lib "odbc32.dll" (ByVal lHdbc As
'Integer) As Short
'Public Declare Function SQLFreeEnv Lib "odbc32.dll" (ByVal env As Integer)
'As Short
'Public Declare Function SQLDisconnect Lib "odbc32.dll" (ByVal lHdbc As
'Integer) As Short
'Private Sub Button_Click(ByVal sender As System.Object, ByVal e As
'System.EventArgs) Handles Button.Click
' Const SQL_NTS = -3 'Null-terminated string
' Const SQL_NOSCAN = 2
' Const SQL_NOSCAN_ON = 1
' Const SQL_NULL_HENV = 0
' Const SQL_NULL_HDBC = 0
' Const SQL_NULL_HSTMT = 0
' Const SQL_SUCCESS = 0
' Const SQL_DROP = 1
' Const MAXBUFLEN = 255
' Const SQL_DRIVER_PROMPT = 2
' Dim Buf As String = New String(" "c, MAXBUFLEN)
' Dim constr As String = ""
' Dim outlen As Short
' Dim Retcode As Short
' Dim hEnv As Integer
' Dim hDBC As Integer
' If SQLAllocEnv(hEnv) = SQL_SUCCESS Then
' If SQLAllocConnect(hEnv, hDBC) = SQL_SUCCESS Then
' If SQLDriverConnect(hDBC, Me.Handle.ToInt32, constr, Len(constr), _
' Buf, MAXBUFLEN, outlen, SQL_DRIVER_PROMPT) = SQL_SUCCESS Then
' MsgBox(Buf)
' Retcode = SQLDisconnect(hDBC)
' End If
' Retcode = SQLFreeConnect(hDBC)
' End If
' Retcode = SQLFreeEnv(hEnv)
' End If
'End Sub
Submit an article or tip