'$INCLUDE: 'VBQUERY.BI'
'$INCLUDE: 'VBDSQL.BI'
Sub ChangePrimaryWindowCaption ()
PrimaryWindow.Caption = PrimaryWindowTitle + " - " + Servername$ + "/" + DatabaseName$
End Sub
Function CheckServerConnection () As Integer
If SqlConn <> 0 Then
CheckServerConnection = 1
Else
CheckServerConnection = 0
End If
End Function
Sub DoubleQuotes (InString As String)
Rem
Rem This will replace all double quotes with ""
Rem and all single quotes with ''
Rem
DOUBLEQUOTE$ = Chr$(34) + Chr$(34)
SINGLEQUOTE$ = Chr$(39) + Chr$(39)
Static mychar As String * 1
Rem
Rem Get the length of the string coming in
Rem Set the length of TmpString to length of string coming in + 100 new chars
Rem
y% = Len(InString)
TmpString$ = Space$(y% + 100)
i% = 1
For x% = 1 To y%
mychar$ = Mid$(InString, x%, 1)
If mychar$ = Chr$(34) Then
Mid$(TmpString$, i%, 2) = DOUBLEQUOTE$
i% = i% + 1
Else
If mychar$ = Chr$(39) Then
Mid$(TmpString$, i%, 2) = SINGLEQUOTE$
i% = i% + 1
Else
mychar$ = Mid$(InString, x%, 1)
Mid$(TmpString$, i%) = mychar$
End If
End If
i% = i% + 1
Next x%
InString$ = RTrim$(TmpString$)
End Sub
Function ExecuteSQLCommand (cmd As String) As Integer
Rem
Rem This routine executes a command(s) and returns whether the
Rem execute succeeded or failed.
Rem
SQLStatus% = SUCCEED
ExecuteSQLCommand = SUCCEED
If SqlCmd(SqlConn, cmd$) = FAIL% Then
SQLStatus% = FAIL
ExecuteSQLCommand = FAIL
End If
If SqlExec(SqlConn) = FAIL% Then
SQLStatus% = FAIL
ExecuteSQLCommand = FAIL
End If
End Function
Sub FixTextLineFeeds (InString As String)
Rem
Rem This will replace all LF characters in the InString with CRLF
Rem
CRLF$ = Chr$(13) + Chr$(10)
LF$ = Chr$(10)
Rem
Rem Get the length of the string coming in
Rem Set the length of TmpString to length of string coming in + 100 new chars
Rem
y% = Len(InString)
TmpString$ = Space$(y% + 100)
i% = 1
For x% = 1 To y%
mychar$ = Mid$(InString, x%, 1)
If mychar$ = LF$ Then
Mid$(TmpString$, i%, 1) = CRLF$
i% = i% + 1
Else
mychar$ = Mid$(InString, x%, 1)
Mid$(TmpString$, i%) = mychar$
End If
i% = i% + 1
Next x%
InString$ = RTrim$(TmpString$)
End Sub
Function GetDatabases (Database_Control As Control) As Integer
Rem
Rem This routine gets the name of all the databases on the SQL Server.
Rem Fill each element in the combobox or list box which is passed into this procedure
Rem execute the command. Get each database name and fill the combobox.
Rem
If ExecuteSQLCommand("Select name from master..sysdatabases") = FAIL% Then
GetDatabases = FAIL
Exit Function
Else
If SqlResults(SqlConn) = FAIL% Then Exit Function
While SqlNextRow(SqlConn) <> NOMOREROWS%
Database_Control.AddItem SqlData(SqlConn, 1)
Wend
End If
Rem If this is a combobox we are filling, then display the first database in the list to start with
If TypeOf Database_Control Is ComboBox Then
Database_Control.Text = Database_Control.List(0)
End If
GetDatabases = SUCCEED
End Function
Function LoginToServer () As Integer
LoginToServer = SUCCEED
Rem
Rem Check to see if the connection is live, if so, then close it
Rem Set the max time to login to 30 seconds
Rem Open the new connection
Rem Change the caption of the application to reflect the server name and the database
Rem Set the max time we will wait for a SQL Server response
Rem
If SqlConn <> 0 Then SqlClose (SqlConn)
Status% = SqlSetLoginTime%(LoginTimeout%)
SqlConn = SqlOpenConnection(Servername$, LoginID$, password$, ProgramName$, ProgramName$)
If SqlConn <> 0 Then
DatabaseName$ = SqlName(SqlConn)
ChangePrimaryWindowCaption
Result% = SqlSetTime%(QueryTimeout%)
Else
DatabaseName$ = ""
Servername$ = ""
LoginToServer = FAIL
End If
End Function
Sub Logoff ()
If SqlConn <> 0 Then
SqlClose (SqlConn)
Servername$ = "[No server]"
DatabaseName$ = "[no database]"
ChangePrimaryWindowCaption
End If
End Sub
Function MakeRuleList (Rawtext As String) As String
Rem
Rem This functions takes a rule of type "IN" from sp_helptext and makes it a
Rem comma delimited list for easy use in list boxes
Rem
start% = InStr(1, Rawtext$, "'")
MakeRuleList = Mid$(Rawtext$, start%, Len(Rawtext$) - 2)
End Function
Sub ParseRule (Rulename() As String)
Rem
Rem This routine takes the comma delimeted rules,which came from the
Rem MakeRuleList procedure, removes the quotes and stores the values
Rem in an array. This is good for use in combo and list boxes.
Rem
in$ = Rulename$(0)
start% = 1
For i% = 0 To 100
endpos% = InStr(start% + 1, in$, "'")
Rulename(i%) = Mid$(in$, start% + 1, (endpos% - start%) - 1)
start% = InStr(endpos% + 1, in$, "'")
If start% = 0 Then Exit For
Next i%
End Sub
Function Process_SQL_query (cmd As String, OutputData() As String) As Long
Rem
Rem This routine will process query rows and output the total number
Rem of rows which reflects the number of items in the output array.
Rem
Rem Define array for column lengths, column positions, and column types
Rem Define structures for getting a compute column's information and getting
Rem a regular column's information
Rem
Rem Declare a local error handler for string overflows
On Error GoTo CancelQuery
Static ColValue$
Static collengths() As Long
ReDim Preserve collengths(255) As Long
Static colpositions() As Integer
ReDim Preserve colpositions(255) As Integer
Static Coltypes() As Integer
ReDim Preserve Coltypes(50) As Integer
Process_SQL_query = 0
Rem
Rem Define the new line character and the tab key
Rem Get the command from the QUERY_FIELD.
Rem Fill the command buffer. If fail, then exit the subroutine.
Rem Execute the command
Rem
NL$ = Chr$(13) + Chr$(10)
COLSEP$ = " "
If cmd$ <> "" Then
If ExecuteSQLCommand(cmd$) = FAIL% Then Exit Function
End If
outputrowcnt% = 0
Rem
Rem Get each set of results
Rem Get the number of compute columns, order by columns, and select columns
Rem Get the exact position of each column (for lining up compute columns)
Rem
Do Until ResultProcess% = NOMORERESULTS%
ResultProcess% = SqlResults(SqlConn)
If ResultProcess% = NOMORERESULTS% Or ResultProcess% = FAIL Then Exit Do
numcol% = SqlNumCols%(SqlConn)
If numcol% > 0 Then
numorder% = SqlNumOrders%(SqlConn)
colline$ = ""
coluline$ = ""
Rem
Rem Get the column name and length for each column
Rem Format and output the column headings (max 256 chars wide).
Rem
For x% = 1 To numcol%
colname$ = SqlColName(SqlConn, x%)
Coltypes(x%) = SqlColType(SqlConn, x%)
collengths(x%) = SqlColLen(SqlConn, x%)
' templen holds length of column data. truncate text and image
tmplen% = collengths(x%)
If tmplen% > 255 Then tmplen% = 255
actuallen& = Len(colname$)
If x% = 1 Then
colpositions(x%) = 1
Else
colpositions(x%) = Len(colline$) + Len(COLSEP$)
End If
If actuallen& < tmplen% Then
colline$ = colline$ + colname$ + Space$((tmplen% - actuallen&) + 1) + COLSEP$
coluline$ = coluline$ + String$(Len(colname$), "_") + Space$((tmplen% - actuallen&) + 1) + COLSEP$
Else
colline$ = colline$ + colname$ + COLSEP$
coluline$ = coluline$ + String$(Len(colname$), "_") + COLSEP$
End If
Next x%
OutputData(outputrowcnt%) = colline$
outputrowcnt% = outputrowcnt% + 1
OutputData(outputrowcnt%) = coluline$
outputrowcnt% = outputrowcnt% + 1
OutputData(outputrowcnt%) = " "
outputrowcnt% = outputrowcnt% + 1
End If 'end of numcol% > 0 test
Rem
Rem Get each row of data, and process according to type of row
Rem Output each row into the list box
Rem
RowProcess% = 99
Do Until RowProcess% = NOMOREROWS%
DataStr$ = ""
Result% = SqlNextRow(SqlConn)
If Result% = NOMOREROWS% Or Result% = FAIL Then Exit Do
Rem
Rem Process a COMPUTE Row (Available in VB Win only).
Rem In DOS, this function pops up a message box saying COMPUTE rows are not supported.
Rem
If Result% <> REGROW Then
Process_altrows Result%, OutputData(), outputrowcnt%, colpositions()
Else
Rem
Rem Process a regular row.
Rem Get the column value and length.
Rem If it is a Text column, then change the LF to CRLF if they exist
Rem Align columns even with the column headings.
Rem
For x% = 1 To numcol%
ColValue$ = SqlData(SqlConn, x%)
actuallen& = Len(ColValue$)
If actuallen& > 255 Then
ColValue$ = Left$(ColValue$, 255)
actuallen& = 255
End If
If Coltypes(x%) = SQLTEXT% Then
FixTextLineFeeds ColValue$
End If
If x% <> numcol% Then
DataStr$ = DataStr$ + ColValue$ + Space$(colpositions(x% + 1) - colpositions(x%) - actuallen&)
Else
DataStr$ = DataStr$ + ColValue$
End If
ColValue$ = ""
Next x%
OutputData(outputrowcnt%) = DataStr$
End If
outputrowcnt% = outputrowcnt% + 1
Loop 'End of row loop
Rem
Rem Output the number of rows affected by the query (if applicable)
Rem Output the sort order (if applicable)
Rem
rowcnt& = SqlCount(SqlConn)
If SqlIsCount(SqlConn) Then
DataStr$ = "(" + Str$(rowcnt&) + " rows affected)"
OutputData(outputrowcnt%) = " "
OutputData(outputrowcnt% + 1) = DataStr$
outputrowcnt% = outputrowcnt% + 2
End If
If numorder% > 0 Then
OutputData(outputrowcnt%) = " "
DataStr$ = "Sort Order: "
For y% = 1 To numorder%
ordercol$ = SqlColName(SqlConn, SqlOrderCol(SqlConn, y%))
DataStr$ = DataStr$ + " " + ordercol$
Next y%
OutputData(outputrowcnt% + 1) = DataStr$
outputrowcnt% = outputrowcnt% + 2
End If
Loop 'End of result loop
Rem
Rem Check for return parameters and return status from stored procedures at the end
Rem of every result set. Available in VBWin only.
Rem
Process_rpc_returns OutputData(), outputrowcnt%
Process_SQL_query = outputrowcnt%
Exit Function
CancelQuery:
Result% = SqlCancel%(SqlConn)
Msg$ = "Error number " + Str$(Err) + ": " + Error$ + NL$
Msg$ = Msg$ + "Query Cancelled" + NL$
MsgBox Msg$, MB_ICONEXCLAMATION, "Visual Basic Error"
Exit Function
End Function
Function UserSqlErrorHandler% (SqlConn As Integer, Severity As Integer, ErrorNum As Integer, OsErr As Integer, ErrorStr As String, OsErrStr As String)
'UserSqlErrorHander% - This function is REQUIRED for all VBDSQL applications. It
'is called by the VB-DOS interface code for DB-LIBRARY whenever a
'DB-LIBRARY error occurs. In VB-Win, it can be called from the error event handler.
'This function can do anything EXCEPT call another
'DB-LIBRARY function (with the exception of SqlDead%, which you can
'call to determine if the connection is still intact).
'
'You can return 1 of 3 values:
' INTEXIT - exit the program
' INTCANCEL - cancel the operation
' INTCONTINUE - continue the operation (can only continue on timeout read
' errors, which usually occur if a table that is locked
' is updated or read)
'
Rem
Rem Only display message if it's not a notification that there's a server error
Rem
If ErrorNum% <> SQLESMSG% Then
MsgBox ("DBLibrary Error: " + Str$(ErrorNum%) + " " + ErrorStr$)
End If
'If an operating-system error occurred, print the error string.
If OsErr% <> -1 Then
MsgBox ("Operating-System Error: " + OsErrStr$)
End If
'Exit if the error is fatal.
If Severity% = EXFATAL Then
UserSqlErrorHandler% = INTEXIT
Else
UserSqlErrorHandler% = INTCANCEL
End If
End Function
Sub UserSqlMsgHandler (SqlConn As Integer, Message As Long, State As Integer, Severity As Integer, MsgStr As String)
'UserSqlMsgHandler - This procedure is REQUIRED for VBDSQL applicaitons.
'In VB-DOS, it is called by BASIC DB-LIBRARY whenever a connected server needs to
'issue a message to the client. You can call it from the message handler event
'in VB-Win
NL$ = Chr$(13) + Chr$(10)
Rem
Rem Only display the message if it's not a general msg or a change language message
Rem
If Message& <> 5701 And Message& <> 5703 Then
Msg$ = "SQL Server Error: " + Str$(Message&) + " " + MsgStr$ + NL$
Msg$ = Msg$ + "State=" + Str$(State%) + ", Severity=" + Str$(Severity)
MsgBox Msg$
End If
End Sub
Function WarningMessage (MsgStr As String) As Integer
Rem
Rem This routine displays a warning message with a YES and NO button
Rem and returns the result.
Rem
Const MB_YESNO = 4
Const MB_ICONEXLAMATION = 48
Const IDYES = 6
Const IDNO = 7
Const DEFBUTTON2 = 256
DgDef% = MB_YESNO + MB_ICONEXCLAMATION + MB_DEFBUTTON2
Response% = MsgBox(MsgStr$, DgDef%, "System Warning")
If Response% = IDNO Then
WarningMessage = 0
Else
WarningMessage = 1
End If
End Function