odbcerrors.frm

《VB6数据库开发指南》所有的例程的源码

VERSION 5.00
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmODBCErrors 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "ODBC Error"
   ClientHeight    =   3090
   ClientLeft      =   1080
   ClientTop       =   1470
   ClientWidth     =   6120
   BeginProperty Font 
      Name            =   "MS Sans Serif"
      Size            =   8.25
      Charset         =   0
      Weight          =   700
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   Moveable        =   0   'False
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   3090
   ScaleWidth      =   6120
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  'CenterScreen
   Begin ComctlLib.TreeView outErrors 
      Height          =   2415
      Left            =   90
      TabIndex        =   0
      Top             =   90
      Width           =   5925
      _ExtentX        =   10451
      _ExtentY        =   4260
      _Version        =   393217
      Indentation     =   35
      Appearance      =   1
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      _Nodes          =   "ODBCErrors.frx":0000
   End
   Begin VB.CommandButton cmdQuit 
      Caption         =   "&OK"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   4920
      TabIndex        =   1
      Top             =   2640
      Width           =   1095
   End
End
Attribute VB_Name = "frmODBCErrors"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'NOTE:  This form requires the Windows Common Controls (specifically, TreeView)
'to be added to the project.

Private Sub cmdQuit_Click()
    Unload Me
End Sub
Public Function ODBCError(strErrType As String, lng_hEnv As Long, lng_hDbc As Long, lng_hStmt As Long, intFuncResult As Integer, strCallingMsg As String) As Integer
    Dim strSQLState As String * 16, strErrMsg As String * 511
    Dim strTemp As String
    Dim lngDSError As Long
    Dim intErrMsgLen As Integer, intResult As Integer, intTemp As Integer
    Dim I As Integer
    
    ODBCError = intFuncResult
    strSQLState = Space$(16): strErrMsg = Space$(SQL_MAX_MESSAGE_LENGTH - 1)
    
    outErrors.Nodes.Clear
    outErrors.Nodes.Add , , "CallingMsg", strCallingMsg
    
    Select Case intFuncResult
        Case SQL_ERROR
            strTemp = "SQL_ERROR"
        Case SQL_INVALID_HANDLE
            strTemp = "SQL_INVALID_HANDLE"
        Case SQL_NO_DATA_FOUND
            strTemp = "SQL_NO_DATA_FOUND"
        Case SQL_SUCCESS
            strTemp = "SQL_SUCCESS"
        Case SQL_SUCCESS_WITH_INFO
            strTemp = "SQL_SUCCESS_WITH_INFO"
        Case Else
            strTemp = "Unidentified error code"
    End Select
    
    outErrors.Nodes.Add "CallingMsg", tvwChild, "FuncResult", "Function call result: " & strTemp
    
    I = 1
    Do
        Select Case strErrType
            Case "Env"
                intResult = SQLError(lng_hEnv, SQL_NULL_HDBC, SQL_NULL_HSTMT, strSQLState, lngDSError, strErrMsg, Len(strErrMsg), intErrMsgLen)
            Case "Dbc"
                intResult = SQLError(lng_hEnv, lng_hDbc, SQL_NULL_HSTMT, strSQLState, lngDSError, strErrMsg, Len(strErrMsg), intErrMsgLen)
            Case "Stmt"
                intResult = SQLError(lng_hEnv, lng_hDbc, lng_hStmt, strSQLState, lngDSError, strErrMsg, Len(strErrMsg), intErrMsgLen)
        End Select
        
        If intErrMsgLen > 0 Then
            With outErrors.Nodes
                .Add "CallingMsg", tvwChild, "strSQLState", "strSQLState: " & strSQLState
                .Add "CallingMsg", tvwChild, "DSNError", "Data Source Error #: " & CStr(lngDSError)
                .Add "CallingMsg", tvwChild, "ErrLine1", ParseError(strErrMsg, 1)
                .Add "CallingMsg", tvwChild, "ErrLine2", ParseError(strErrMsg, 2)
                .Add "CallingMsg", tvwChild, "ErrLine3", ParseError(strErrMsg, 3)
                .Add "CallingMsg", tvwChild, "ErrLine4", ParseError(strErrMsg, 4)
            End With
        End If
    Loop Until intResult <> SQL_SUCCESS
    
    outErrors.Nodes("CallingMsg").Expanded = True
    Me.Show vbModal
    
End Function
Private Function ParseError(ByVal strMessage As String, intPlace As Integer)
    Dim strText As String
    Dim intLPos As Integer, intRPos As Integer
    Dim intCurrentPos As Integer, I As Integer
    
    Static Brackets(1 To 4, 1 To 2) As Integer
    Static blnMsgType As Boolean
    
    strMessage = Trim$(strMessage)
    
    If strMessage <> "" Then
        intCurrentPos = 1
        If intPlace = 1 Then
            For I = 1 To 3
                Brackets(I, 1) = InStr(intCurrentPos, strMessage, "[")
                Brackets(I, 2) = InStr(intCurrentPos, strMessage, "]")
                intCurrentPos = Brackets(I, 2) + 1
            Next
            blnMsgType = (Brackets(3, 1) <> 0)
        End If
        
        If Brackets(intPlace, 1) > 0 Then
            intLPos = Brackets(intPlace, 1) + 1
            intRPos = Brackets(intPlace, 2) - 1
            strText = Mid(strMessage, intLPos, intRPos - intLPos + 1)
        Else
            strText = Right(strMessage, Len(strMessage) - Brackets(intPlace - 1, 2))
        End If
        
        Select Case intPlace
            Case 1
                ParseError = "Driver Vendor: " & strText
            Case 2
                ParseError = "ODBC Identifier: " & strText
            Case 3
                ParseError = IIf(blnMsgType, "Data Source: ", "") & strText
            Case 4
                ParseError = "Error: " & strText
            Case Else
                ParseError = ""
        End Select
        
    End If
End Function