Classe ODBC

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Odbc"
Attribute VB_Creatable = True
Attribute VB_Exposed = True
Option Explicit

'------------------------------------------------------------------------------------------------------
' Private Property
'------------------------------------------------------------------------------------------------------
Private User As New dbUser
Private henv As Long, hdbc As Long, hstmt As Long
Private dummy As Long
Private intNbCols As Integer
Private Type udtField
     v(256) As Byte
End Type
Private udtFields() As udtField
Private clsEOF As Boolean
Private clsBOF As Boolean
Private clsRecordSet As Boolean

'------------------------------------------------------------------------------------------------------
' Public Property
'------------------------------------------------------------------------------------------------------
Public Fields As New Collection

Public Property Get LHenv() As Long
    LHenv = henv
End Property

Public Property Get LHdbc() As Long
    LHdbc = hdbc
End Property

Public Property Get Id()
    Id = User.Id
End Property

Public Property Get Column(icol As Integer)
    Column = fWzBytesToStr(udtFields(icol).v())
End Property

Public Property Get Count()
    Count = intNbCols
End Property

Public Property Get EOF() As Boolean
    EOF = clsEOF
End Property
Public Property Get BOF() As Boolean
    BOF = clsBOF
End Property
Public Function Connect(Optional DSN As Variant) As Long
Dim strConnect  As String
Dim pcbConnStrOut As Integer
    If IsMissing(DSN) Then DSN = "GrhW01db"
     dummy = SQLAllocEnv(henv)
    If dummy = SQL_SUCCESS Or dummy = SQL_SUCCESS_WITH_INFO Then
        dummy = SQLAllocConnect(henv, hdbc)
        If dummy = SQL_SUCCESS Or dummy = SQL_SUCCESS_WITH_INFO Then
            strConnect = "DSN=" & DSN & ";UID=" & User.Id + ";PWD=" & User.Pw + ";APP=GersWhin;"
            dummy = SQLDriverConnect(hdbc, frmODBC.hWnd, strConnect, Len(strConnect), strConnect, Len(strConnect), pcbConnStrOut, SQL_DRIVER_PROMPT)
            Unload frmODBC
        End If
    End If
    Connect = dummy
End Function

Public Function Disconnect() As Long
     dummy = SQLDisconnect(hdbc)
    If dummy = 0 Then
        dummy = SQLFreeConnect(hdbc)
        If dummy = 0 Then
             dummy = SQLFreeEnv(henv)
        End If
    End If
    Disconnect = dummy
End Function

Public Function ExecAsyncQuery(Query As String) As Long
Dim lngHstmt As Long
Dim SQLState As String
Dim NativeError As Long
Dim buffer As String * 512
Dim OutLen As Integer
Dim MsgErr As String
Dim intTextStart As Integer
    
    '
    ' Cree un handle de statment
    '
    dummy = SQLAllocStmt(hdbc, lngHstmt)
    If dummy <> SQL_SUCCESS Then
        ExecAsyncQuery = dummy
        Exit Function
    Else
        '
        ' Place les options pour affectuer une requete asynchrone
        '
        dummy = SQLSetStmtOption(lngHstmt, SQL_ASYNC_ENABLE, SQL_ASYNC_ENABLE_ON)
        dummy = SQLSetStmtOption(lngHstmt, SQL_QUERY_TIMEOUT, 600)
    End If
    '
    ' Attend que la requete soit executee
    '
    Do
        DoEvents
        dummy = SQLExecDirect(lngHstmt, Query, Len(Query))
        DoEvents
    Loop While dummy = SQL_STILL_EXECUTING
    Select Case dummy
        Case SQL_SUCCESS, SQL_SUCCESS_WITH_INFO
            ExecAsyncQuery = SQL_SUCCESS
        Case Else
            ExecAsyncQuery = dummy
            dummy = SQLError(henv, hdbc, lngHstmt, SQLState, NativeError, buffer, 512, OutLen)
            If SQLState = "S1T00" Then
                MsgErr = "Execution asynchrone d'une requˆte." & vbCrLf
                MsgErr = MsgErr & "Impossible d'ex‚cuter le traitement demand‚." & vbCrLf & "Time-Out expir‚." & vbCrLf
                MsgErr = MsgErr & "Veuillez relancer le traitement ult‚rieurement."
                MsgBox MsgErr, vbExclamation Or vbOKOnly
            Else
                If NativeError >= 50000 Then
                    MsgBox ErrorText(buffer), vbCritical
                Else
                    MsgBox Left(buffer, OutLen) & vbCrLf & GetError(), vbCritical
                End If
            End If
    End Select
    dummy = SQLFreeStmt(lngHstmt, SQL_DROP)
End Function

Public Function GetError(Optional h As Variant) As String
Dim SQLState As String
Dim NativeError As Long
Dim buffer As String * 512
Dim OutLen As Integer
Dim MsgErr As String
Dim hs As Long
    If IsMissing(h) Then
        hs = hstmt
    Else
        hs = h
    End If

    MsgErr = ""
    SQLState = Space(200)
    dummy = SQLError(henv, hdbc, hs, SQLState, NativeError, buffer, 512, OutLen)
    Do While dummy = SQL_SUCCESS Or dummy = SQL_SUCCESS_WITH_INFO And Len(MsgErr) <= 1024 MsgErr="MsgErr" & Left$(Trim$(SQLState), Len(Trim$(SQLState)) 1) & " " & NativeError & " " & Left$(buffer, OutLen) + Chr(13) + Chr(10) dummy="SQLError(henv," hdbc, hs, SQLState, NativeError, buffer, 512, OutLen) Loop GetError="MsgErr" End Function Public Function TestConnect(DSN As String) As Integer 'MISSION: Tester une connexion sur SQLServer. 'ENTREES: DSN : Data Source Name. 'SORTIES: 1 : si connexion Ok. ' Code Erreur: si une erreur s'est produite. Dim henv As Long 'Handle d'environnement Dim hdbc As Long 'Handle de connexion dummy="SQLAllocEnv(henv)" If dummy="SQL_SUCCESS" Or dummy="SQL_SUCCESS_WITH_INFO" Then dummy="SQLAllocConnect(henv," hdbc) If dummy="SQL_SUCCESS" Or dummy="SQL_SUCCESS_WITH_INFO" Then dummy="SQLConnect(hdbc," DSN, Len(DSN), User.Id, Len(User.Id), User.Pw, Len(User.Pw)) End If End If TestConnect="dummy" dummy="SQLDisconnect(hdbc)" dummy="SQLFreeConnect(hdbc)" dummy="SQLFreeEnv(henv)" End Function Public Function ErrorText(Optional vnterror As Variant) As String Dim intNumStart As Integer, strErrorText As String Dim i As Integer Dim j As Integer ' 'Recherche le code erreur … l'int‚rieur du message ODBC. ' If IsMissing(vnterror) Then DBEngine.Errors.Refresh vnterror="DBEngine.Errors(0).Description" End If i="0::" j="0" i="InStr(vnterror," "]") While i <> 0
        j = i
        i = InStr(j + 1, vnterror, "]")
    Wend
    ErrorText = Mid$(vnterror, j + 1)
End Function

Public Function fGetTextField(strSQL As String, Optional inHenv As Variant, Optional inHdbc As Variant, Optional inDSN As Variant) As Variant
Dim henv As Long
Dim hdbc As Long
Dim hstmt As Long
Dim NumCols As Integer
Dim strText As String * 16384
Dim lngOctetLu As Long
Dim vntTexte As Variant
Dim DSN As String
    
    If IsMissing(inDSN) Then
        DSN = "GrhW01db"
    Else
        DSN = CStr(inDSN)
    End If
    
    If IsMissing(inHenv) Then
        dummy = SQLAllocEnv(henv)
        If dummy <> SQL_SUCCESS And dummy <> SQL_SUCCESS_WITH_INFO Then
            fGetTextField = Null
            MsgBox GetError()
            Exit Function
        End If
    Else
        henv = CLng(inHenv)
    End If
    
    If IsMissing(inHdbc) Then
        dummy = SQLAllocConnect(henv, hdbc)
        If dummy <> SQL_SUCCESS And dummy <> SQL_SUCCESS_WITH_INFO Then
            fGetTextField = Null
            MsgBox GetError()
            Exit Function
        End If
        dummy = SQLConnect(hdbc, DSN, Len(DSN), User.Id, Len(User.Id), User.Pw, Len(User.Pw))
    Else
        hdbc = CLng(inHdbc)
    End If
    
    dummy = SQLAllocStmt(hdbc, hstmt)
    If dummy <> SQL_SUCCESS And dummy <> SQL_SUCCESS_WITH_INFO Then
        fGetTextField = Null
        MsgBox GetError(hstmt)
        Exit Function
    End If
    dummy = SQLExecDirect(hstmt, strSQL, Len(strSQL))
    If dummy <> SQL_SUCCESS Then
        fGetTextField = Null
        Exit Function
   End If
    If SQLNumResultCols(hstmt, NumCols) <> SQL_SUCCESS Then
        fGetTextField = Null
        Exit Function
    End If
    Do   'Repeat this loop until all result rows are fetched
      If SQLFetch(hstmt) <> SQL_SUCCESS Then
        Exit Do
      End If
      dummy = SQLGetData(hstmt, 1, SQL_C_CHAR, ByVal strText, 16383, lngOctetLu)
      If dummy = SQL_SUCCESS Or dummy = SQL_SUCCESS_WITH_INFO Then
        If lngOctetLu = SQL_NULL_DATA Then
           vntTexte = Null
        Else
          If dummy = SQL_SUCCESS_WITH_INFO Or dummy = SQL_SUCCESS Then
             vntTexte = Mid(strText, 1, 16383)
             Do While dummy = SQL_SUCCESS_WITH_INFO 'Or dummy = SQL_SUCCESS
                  strText = Space(16383)
                 dummy = SQLGetData(hstmt, 1, SQL_C_CHAR, ByVal strText, 16384, lngOctetLu)
                 If dummy = SQL_SUCCESS Or dummy = SQL_SUCCESS_WITH_INFO Then
                    vntTexte = vntTexte & Mid(strText, 1, 16383)
                 End If
             Loop
           End If
         End If
      End If
    Loop
    FreeStmt , hstmt
    
    If IsMissing(inHdbc) Then
        dummy = SQLDisconnect(hdbc)
        dummy = SQLFreeConnect(hdbc)
    End If
    If IsMissing(inHenv) Then
        dummy = SQLFreeEnv(henv)
    End If
    
    
    fGetTextField = vntTexte

End Function

Public Function AllocStmt(Optional ByRef h As Variant) As Long
Dim hh As Long
    If IsMissing(h) Then
        AllocStmt = SQLAllocStmt(hdbc, hstmt)
    Else
        AllocStmt = SQLAllocStmt(hdbc, hh)
        h = hh
    End If
    clsRecordSet = False
End Function

Public Function ExecDirect(strSQL As String, Optional h As Variant) As Long
Dim hs As Long, i As Integer
Dim objField As Object
    If IsMissing(h) Then
        hs = hstmt
    Else
        hs = h
    End If
    dummy = SQLExecDirect(hs, strSQL, Len(strSQL))
    If dummy = SQL_SUCCESS Or dummy = SQL_SUCCESS_WITH_INFO Then
        'Get the number of columns in the result set
        dummy = SQLNumResultCols(ByVal hs, intNbCols)
        
        'Cr‚ation et initialisation d'une Collection qui recevra les colonnes lors du SQLFetch.
        'Seulement dans le cas d'un RecordSet.
        If clsRecordSet Then
            For i = 1 To Count
                Set objField = New Field
                With objField
                    .DisplaySize = ColAttributes(i, SQL_COLUMN_DISPLAY_SIZE)
                    .Label = ColAttributes(i, SQL_COLUMN_LABEL)
                    .Length = ColAttributes(i, SQL_COLUMN_LENGTH)
                    .Name = ColAttributes(i, SQL_COLUMN_NAME)
                End With
                Fields.Add objField, objField.Name
            Next i
        End If
    End If
    ExecDirect = dummy
End Function

Public Function Fetch(Optional h As Variant) As Long
Dim hs As Long
    If IsMissing(h) Then
        hs = hstmt
    Else
        hs = h
    End If
    Fetch = SQLFetch(hs)
End Function

Public Function FreeStmt(Optional Method As Variant, Optional h As Variant) As Long
Dim fOption As Integer
Dim hs As Long
    If IsMissing(h) Then
        hs = hstmt
    Else
        hs = h
    End If
    If IsMissing(Method) Then Method = SQL_DROP
    fOption = Method
    FreeStmt = SQLFreeStmt(hs, fOption)
        
    'Initialise la Collection des Field.
    Set Fields = Nothing
End Function

Public Function GetData(ByVal icol As Integer, Optional h As Variant) As Variant
Const cbValueMax = 256
Dim rgbValue As String * cbValueMax, pcbValue As Long
Dim a As Variant
Dim hs As Long
    If IsMissing(h) Then
        hs = hstmt
    Else
        hs = h
    End If

    dummy = SQLGetData(hs, icol, SQL_C_CHAR, ByVal rgbValue, cbValueMax, pcbValue)
    If dummy = SQL_SUCCESS Then
        If pcbValue = SQL_NULL_DATA Then
            a = Null
        Else
            a = Trim(Left(rgbValue, pcbValue))
        End If
    End If

    GetData = a
End Function

Private Function BindCol(icol As Integer, Optional h As Variant) As Long
Dim l As Long
Dim hs As Long
    If IsMissing(h) Then
        hs = hstmt
    Else
        hs = h
    End If
    dummy = SQLBindCol(ByVal hs, icol, SQL_C_CHAR, Fields(icol).v(0), 255, l)
End Function

Public Function BindCols(Optional h As Variant) As Long
Dim i As Integer
Dim hs As Long
    If IsMissing(h) Then
        hs = hstmt
    Else
        hs = h
    End If

    'Redim the temp buffer to be equal to number of columns
    ReDim udtFields(intNbCols)

    'Bind Columns to temp buffer and store Column Names
    For i = 1 To intNbCols
        ' Bind the columns to a memory address
        dummy = BindCol(i)
    Next i

End Function

Public Function ExtendedFetch(Optional h As Variant) As Variant
Dim pcbValue As Long, intRowStatus As Integer
Dim hs As Long
    If IsMissing(h) Then
        hs = hstmt
    Else
        hs = h
    End If
    ExtendedFetch = SQLExtendedFetch(hs, SQL_FETCH_NEXT, 1, pcbValue, intRowStatus)
End Function

Public Function SetStmtOption(ByVal fOption As Integer, ByVal vParam As Long, Optional h As Variant) As Integer
Dim hs As Long
    If IsMissing(h) Then
        hs = hstmt
    Else
        hs = h
    End If
    SetStmtOption = SQLSetStmtOption(hs, fOption, vParam)
End Function

Public Function Create(strId As String, Optional vntPw As Variant, Optional DSN As Variant) As Boolean
    With User
        .Create strId, vntPw
    End With
    If IsMissing(DSN) Then DSN = "GrhW01db"
    dummy = Connect(CStr(DSN))
    If dummy = SQL_SUCCESS Or dummy = SQL_SUCCESS_WITH_INFO Then
        Create = True
    Else
        Me.Error
        Create = False
    End If
End Function

Private Sub Class_Terminate()
'    FreeStmt
'    Disconnect
    Set User = Nothing
    Set Fields = Nothing
End Sub

Public Function NativeSQL(ByVal InputQry As String, ByRef OutPutQry As String) As String
Dim pcbSqlStr As Long
    NativeSQL = SQLNativeSql(hdbc, InputQry, Len(InputQry), OutPutQry, Len(OutPutQry), pcbSqlStr)
End Function

Public Function Prepare(ByVal strQry As String, Optional h As Variant) As Long
Dim hs As Long
    If IsMissing(h) Then
        hs = hstmt
    Else
        hs = h
    End If
    Prepare = SQLPrepare(hs, strQry, Len(strQry))
End Function

Public Sub Error(Optional h As Variant)
    MsgBox GetError(h), vbCritical
End Sub

Public Function TestQry(ByVal qry As String) As Long
    qry = "Set Noexec On" & vbCrLf & qry & vbCrLf & " Set Noexec Off"
    TestQry = ExecDirect(qry)
End Function

Public Function Kill()
    Disconnect
End Function

Public Function Execute(ByVal strQuery As String, Optional h As Variant) As Variant
Dim hs As Long
    If IsMissing(h) Then
        hs = hstmt
    Else
        hs = h
    End If
    If AllocStmt(hs) = SQL_SUCCESS Then
        If ExecDirect(strQuery, hs) = SQL_SUCCESS Then
            Execute = SQL_SUCCESS
        Else
            Me.Error
            Execute = SQL_ERROR
        End If
        FreeStmt
    Else
        Me.Error
        Execute = SQL_ERROR
    End If
End Function

Private Function ColAttributes(icol As Integer, Optional fDescType As Variant, Optional h As Variant) As Variant
Dim hs As Long
'Dim lTemp As Long
'Dim pcbValue As Integer
Dim intRowStatus As Long
Const cbValueMax = 256
Dim rgbValue As String * cbValueMax, pcbValue As Integer

    If IsMissing(h) Then
        hs = hstmt
    Else
        hs = h
    End If
    If IsMissing(fDescType) Then fDescType = SQL_COLUMN_DISPLAY_SIZE
    
    dummy = SQLColAttributes(ByVal hs, icol, fDescType, ByVal rgbValue, cbValueMax, pcbValue, intRowStatus)
'''Declare Function SQLColAttributes Lib "odbc32.dll" (ByVal hstmt As Long, ByVal iCol As Integer, ByVal fDescType As Integer, rgbDesc As Any, ByVal cbDescMax As Integer, pcbDesc As Integer, pfDesc As Long) As Integer

    #If DebugVersion = 1 Then
        Debug.Print "1", pcbValue, intRowStatus
        Debug.Print "2", StrConv(rgbValue, vbUnicode)
        Debug.Print "3", Trim(rgbValue)
    #End If
    
    Select Case fDescType
        Case SQL_COLUMN_DISPLAY_SIZE, SQL_COLUMN_LENGTH
            ColAttributes = intRowStatus
        Case Else
            ColAttributes = Trim(rgbValue)
    End Select

End Function

Public Function MoveNext(Optional h As Variant) As Long
Dim hs As Long, i As Integer
    If Fetch(h) = SQL_SUCCESS Then
        For i = 1 To Count
            Fields.Item(i).Value = GetData(i)
        Next i
        MoveNext = SQL_SUCCESS
    Else
        MoveNext = SQL_ERROR
        clsEOF = True
    End If
End Function

Public Function OpenRecordSet(ByVal strQuery As String, Optional h As Variant) As Variant
    If AllocStmt(h) = SQL_SUCCESS Then
        clsRecordSet = True
        If ExecDirect(strQuery, h) = SQL_SUCCESS Then
            clsEOF = False
            clsBOF = False
            OpenRecordSet = MoveNext(h)
        Else
            Me.Error
            OpenRecordSet = SQL_ERROR
        End If
    Else
        Me.Error
        OpenRecordSet = SQL_ERROR
        clsEOF = True
        clsBOF = True
    End If
End Function

Public Function CloseRecordSet()
    FreeStmt
End Function