Option Strict Off
Option Explicit On
Imports VB = Microsoft.VisualBasic
Module DBSQLFUN
'Public eventLog As String = "My.N"
Public NoInteraction As Boolean = True
Sub db(ByVal msg As String)
'If debugout Then
'PrintLine(debugfile, msg)
' ShowMessage(msg)
'Else
' 'Debug.Print msg$
'End If
End Sub
Function rep_string(ByVal bstr As String, ByVal dchr As String, ByVal rchr As String, Optional ByRef txtcomp As Boolean = False) As String
Dim cp As Short
Dim Start As Object
Dim spos As Short
Dim retv As String ' Declare variables.
If txtcomp Then
cp = 1
Else
cp = 0
End If
Start = InStr(1, bstr, dchr, cp) ' Find where "fox" begins.
While Not Start = 0 'InStr(spos%, rs, "'") = 0
bstr = Mid(bstr, 1, Start - 1) & rchr & Mid(bstr, Start + Len(dchr), Len(bstr))
spos = Start + Len(rchr)
Start = InStr(spos, bstr, dchr, cp)
End While
rep_string = bstr
End Function
Function fds(ByVal istr As Object) As String
If IsDBNull(istr) Then
fds = "''"
Else
fds = "'" & Trim(rep_quote(CStr(istr))) & "'"
End If
End Function
Sub LogMess(ByVal Msg As String)
ShowMessage(Msg)
End Sub
Sub showvberr(ByRef vberr As Object)
Dim msg As Object
Dim MyError As Object
'my simple code
If Err.Number <> 0 Then
ShowMessage(Err.Description)
Else
ShowMessage("Error")
End If
Exit Sub
'some vb example stuff follows, for enhancement later
' First, strip off the constant added by the object to indicate one
' of its own errors.
MyError = vberr.Number - vbObjectError
' If you subtract the vbObjectError constant, and the number is still
' in the range 0-65,535, it is an object-defined error code.
If MyError > 0 And MyError < 65535 Then
msg = "The object you accessed assigned this number to the error: " & MyError & ". The originator of the error was: " & Err.Source & ". Press F1 to see originator's Help topic."
' Otherwise it is a Visual Basic error number.
Else
msg = "This error (# " & vberr.Number & ") is a Visual Basic error"
msg = msg & " number. Press Help button or F1 for the Visual Basic Help"
msg = msg & " topic for this error."
End If
ShowMessage(msg)
End Sub
Function znull(ByVal inval As Object) As String
'if number > 0 returns as long, else null
If IsDBNull(inval) Then
znull = "NULL"
ElseIf IsNumeric(inval) Then
If inval > 0 Then
znull = VB6.Format(CInt(inval))
Else
znull = "NULL"
End If
Else
znull = "NULL"
End If
End Function
Function fnds(ByVal istr As Object) As String
If IsDBNull(istr) Then
fnds = "NULL"
ElseIf istr = "" Then
fnds = "NULL"
Else
fnds = "'" & Trim(rep_quote(CStr(istr))) & "'"
End If
End Function
Function rep_quote(ByVal rs As String) As String
Dim spos As Short
Dim dpos As Short
Dim Start As Object
Start = InStr(rs, "'")
Do While Start > 0
dpos = InStr(Start + 1, rs, "'")
If Not (dpos = Start + 1) Then
rs = Mid(rs, 1, Start) & "'" & Mid(rs, Start + 1, Len(rs))
End If
spos = Start + 2
Start = InStr(spos, rs, "'")
Loop
rep_quote = rs
End Function
Function exch_string(ByVal bstr As String, ByVal dchr As String, ByVal rchr As String) As String
Dim Start As Object
Dim spos As Short
Dim retv As String ' Declare variables.
Start = InStr(bstr, dchr) ' Find where "fox" begins.
While Not Start = 0 'InStr(spos%, rs, "'") = 0
bstr = Mid(bstr, 1, Start - 1) & rchr & Mid(bstr, Start + Len(dchr), Len(bstr))
spos = Start + Len(rchr)
Start = InStr(spos, bstr, dchr)
End While
exch_string = bstr
End Function
Function GetStringFromLPSTR(ByRef inval As String) As String
Dim pos As Short
pos = InStr(inval, Chr(0))
If pos <= 1 Then
GetStringFromLPSTR = ""
Else
GetStringFromLPSTR = Left(inval, pos - 1)
End If
End Function
Public Function qqdate(ByVal stmt As Integer, ByVal colnum As Short) As Object
Dim host_cdate As Short
Dim ret_string As String
Dim ds As Object
Dim date_sel As Short
Dim r As Short
Dim pcbValue As Integer
Dim dummy As Integer
Dim rgbvalue As DATE_STRUCT
Dim rgbval2 As TIMESTAMP_STRUCT
If host_cdate Then
If date_sel Then
r = SQLGetDataSDate(stmt, colnum, SQL_C_DATE, rgbvalue, dtlen, pcbValue)
Else
r = SQLGetDataLDate(stmt, colnum, SQL_C_TIMESTAMP, rgbval2, tslen, pcbValue)
End If
If Not ((r = SQL_SUCCESS) Or (r = SQL_SUCCESS_WITH_INFO)) Then
qqdate = System.DBNull.Value
'showdberror r%, stmt&
Else
If pcbValue = SQL_NULL_DATA Then
qqdate = System.DBNull.Value
Else
If date_sel Then
qqdate = DateSerial(rgbvalue.year_Renamed, rgbvalue.month_Renamed, rgbvalue.day_Renamed)
Else
qqdate = DateSerial(rgbval2.year_Renamed, rgbval2.month_Renamed, rgbval2.day_Renamed)
End If
End If
End If
Else
ret_string = ds.FetchString(colnum)
If ret_string <> "" Then
qqdate = DateSerial(CShort(Mid(ret_string, 1, 4)), CShort(Mid(ret_string, 6, 2)), CShort(Mid(ret_string, 9, 2)))
Else
qqdate = System.DBNull.Value
End If
End If
End Function
Public Function qqdouble(ByVal stmt As Integer, ByVal colnum As Short) As Double
Dim host_cdouble As Short
Dim ret_val As String
Dim r As Short
Dim rgbvalue As Double
Dim pcbValue As Integer
Dim dummy As Integer
If host_cdouble Then
r = SQLGetDataDouble(stmt, colnum, SQL_C_DOUBLE, rgbvalue, doublelen, pcbValue)
If Not ((r = SQL_SUCCESS) Or (r = SQL_SUCCESS_WITH_INFO)) Then
qqdouble = 0
'showdberror r%, stmt&
Else
qqdouble = rgbvalue
End If
Else
ret_val = qqstring(stmt, colnum)
If IsNumeric(ret_val) Then
qqdouble = CDbl(ret_val)
Else
qqdouble = 0
End If
End If
End Function
Public Function qqint(ByVal stmt As Integer, ByVal colnum As Short) As Short
Dim host_cint As Short
Dim ret_val As String
Dim ds As Object
Dim r As Short
Dim rgbvalue As Short
Dim pcbValue As Integer
If host_cint Then
r = SQLGetDataInt(stmt, colnum, SQL_C_SHORT, rgbvalue, intlen, pcbValue)
If r = SQL_SUCCESS Then
If pcbValue = SQL_NULL_DATA Then
qqint = 0
Else
qqint = rgbvalue
End If
ElseIf r = SQL_SUCCESS_WITH_INFO Then
'showdberror r%, stmt&
If pcbValue = SQL_NULL_DATA Then
qqint = 0
Else
qqint = rgbvalue
End If
Else
qqint = 0
'showdberror r%, stmt&
End If
Else
ret_val = ds.FetchString(colnum)
If IsNumeric(ret_val) Then
qqint = CShort(ret_val)
Else
qqint = 0
End If
End If
End Function
Public Function qqlong(ByVal stmt As Integer, ByVal colnum As Short) As Integer
Dim host_clong As Short
Dim ret_val As String
Dim ds As Object
Dim r As Short
Dim rgbvalue As Integer
Dim pcbValue As Integer
If host_clong Then
r = SQLGetDataLong(stmt, colnum, SQL_C_LONG, rgbvalue, longlen, pcbValue)
If Not ((r = SQL_SUCCESS) Or (r = SQL_SUCCESS_WITH_INFO)) Then
qqlong = 0
'showdberror r%, stmt&
Else
qqlong = rgbvalue
End If
Else
ret_val = ds.FetchString(colnum)
If IsNumeric(ret_val) Then
qqlong = CInt(ret_val)
Else
qqlong = 0
End If
End If
End Function
Public Function qqstring(ByVal stmt As Integer, ByVal colnum As Short) As String
Dim r As Short
Dim rgbvalue As String
Dim pcbValue As Integer
Dim retval As String
rgbvalue = Space(256)
r = SQLGetDataString(stmt, colnum, SQL_C_CHAR, rgbvalue, bufsize, pcbValue)
If Not ((r = SQL_SUCCESS) Or (r = SQL_SUCCESS_WITH_INFO)) Then
qqstring = ""
'ShowMessage("Error on") 'showerror r%, stmt&
Else
retval = GetStringFromLPSTR(rgbvalue)
Do While pcbValue > bufsize
r = SQLGetDataString(stmt, colnum, SQL_C_CHAR, rgbvalue, bufsize, pcbValue)
If Not ((r = SQL_SUCCESS) Or (r = SQL_SUCCESS_WITH_INFO)) Then
qqstring = ""
ShowMessage("Error") 'showerror r%, stmt&
Exit Function
Else
retval = retval & GetStringFromLPSTR(rgbvalue)
End If
Loop
qqstring = Trim(retval)
End If
End Function
Sub c_to_timestamp(ByVal in_date As Object, ByRef out_tt As TIMESTAMP_STRUCT)
Dim OPACDate As Object
On Error GoTo c_TTerr
out_tt.year_Renamed = Year(in_date)
out_tt.month_Renamed = Month(in_date)
out_tt.day_Renamed = VB.Day(in_date)
Exit Sub
c_TTerr:
ShowMessage("Error converting date, using default")
out_tt.year_Renamed = Year(OPACDate)
out_tt.month_Renamed = Month(OPACDate)
out_tt.day_Renamed = VB.Day(OPACDate)
Exit Sub
End Sub
Public Sub showdberror(ByVal henv As Integer, ByVal hdbcv As Integer, ByVal errnum As Short, ByVal nhstmt As Integer)
'no longer used
'
'
'
If System.Environment.UserInteractive And NoInteraction = False Then
MsgBox(Getdberror(henv, hdbcv, errnum, nhstmt))
Else
Dim log As New EventLog
log.Source = "My.N"
Dim msg As String = Getdberror(henv, hdbcv, errnum, nhstmt)
Try
log.WriteEntry(msg)
Catch ex As Exception
log.Clear()
log.WriteEntry(msg)
End Try
End If
'dim s as String = GetDbError(henv,hdbcv,errnum,nhstmt)
End Sub
Public Sub logDBError(ByVal HDB As HDBC, ByVal msg As String)
Try
Dim log As New EventLog
log.Source = HDB.LogName
Try
log.WriteEntry(msg)
Catch ex As Exception
log.Clear()
log.WriteEntry(msg)
End Try
Catch ex As Exception
'no action
End Try
End Sub
Public Sub showdberrorMsg(ByVal hdb As HDBC, ByVal henv As Integer, ByVal hdbcv As Integer, ByVal errnum As Short, ByVal nhstmt As Integer)
MsgBox(Getdberror(henv, hdbcv, errnum, nhstmt))
End Sub
Public Sub showdberror(ByVal hdb As HDBC, ByVal henv As Integer, ByVal hdbcv As Integer, ByVal errnum As Short, ByVal nhstmt As Integer)
If System.Environment.UserInteractive And NoInteraction = False Then
MsgBox(Getdberror(henv, hdbcv, errnum, nhstmt))
Else
Dim prfx As String = "OS" & vbCrLf
Dim msg As String = Getdberror(henv, hdbcv, errnum, nhstmt)
Try
For Each kp As System.Collections.Generic.KeyValuePair(Of String, StatementInfo) In hdb.OpenStatements
prfx = "OS - " & kp.Value.TimeCreated.ToString() & vbCrLf
prfx = kp.Value.StatementType.ToString() & vbCrLf
prfx = kp.Value.SQL & vbCrLf
Next
msg = prfx & msg
Catch
'no action
End Try
Dim log As New EventLog
log.Source = hdb.LogName
Try
log.WriteEntry(msg)
Catch ex As Exception
log.Clear()
log.WriteEntry(msg)
End Try
End If
'dim s as String = GetDbError(henv,hdbcv,errnum,nhstmt)
End Sub
Public Sub ShowMessage(ByVal msgstr As String)
Try
If System.Environment.UserInteractive And NoInteraction = False Then
MsgBox(msgstr)
Else
Dim log As New EventLog
log.Source = "My.N"
Try
log.WriteEntry("nbfDB Error - " & msgstr)
Catch ex As Exception
log.Clear()
log.WriteEntry("nbfDB Error - " & msgstr)
End Try
End If
Catch
' no action
End Try
End Sub
Public Function Getdberror(ByVal henv As Integer, ByVal hdbcv As Integer, ByVal errnum As Short, ByVal nhstmt As Integer) As String
Try
Dim error_mess As String
Dim host_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(henv, 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))
error_mess = error_mess & " error code " & VB6.Format(host_error)
pos = InStr(1, host_error_text.Value, Chr(0))
If pos > 0 Then
host_error_mess = Trim(Left(host_error_text.Value, pos - 1))
error_mess = host_error_mess & error_mess
End If
Return error_mess
Catch ex As Exception
Return ex.Message
End Try
End Function
Public Function GetErrorNum(ByVal henv As Integer, ByVal hdbcv As Integer, ByVal errnum As Short, ByVal nhstmt As Integer) As String
Try
Dim error_mess As String
Dim host_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(henv, hdbcv, nhstmt, sqlstate.Value, host_error, host_error_text.Value, host_error_size, ret_size)
Return host_error
Catch ex As Exception
Return 0
End Try
End Function
Public Function SqlFdate(ByVal indate As Object) As String
Dim dt_prf As String = "{ts'"
Dim dt_sfx As String = " 00:00:00'}"
If IsDBNull(indate) Then
SqlFdate = "NULL"
Else
If IsDate(indate) Then
If Year(indate) > 0 Then
SqlFdate = dt_prf & VB6.Format(indate, "yyyy-mm-dd") & dt_sfx
Else
SqlFdate = "NULL"
End If
Else
SqlFdate = "NULL"
End If
End If
End Function
End Module
Submit an article or tip