Tricks of the Windows Gam…ming Gurus (2nd Edition)/Disc2.iso/msdn_vcb/samples/vc98/sdk/dbmsg/sql/vbsql/vbsqlgen.bas

BASIC Source File | 1996-04-03 | 12.5 KB | 488 lines

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