VBSQLGEN.BAS

'$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