requete sql avec oracle

Question

Salut à tous
je n'arrive pas a exécuter une requéte SQL avec une base oracle

cs_pdl · Answer

Ce n'est pourtant pas compliquer. Voici un module et un exemple d'appel du module qui va te permettre de faire tout cela très facillement.

Si un problème, tu peux toujours m'envoyer un email [mailto:p_delporte@yahoo.com?subject=ADOAccess from VBFrance p_delporte@yahoo.com]


Private Sub Form_Load()
   Dim myRs As ADODB.Recordset
   
   Call ConnectToDB("ORCL", "scott", "tigger")
   Set myRs = ExecuteQuery("select * from emp")
   
   While Not myRs.EOF
      Debug.Print myRs!empno & " " & myRs!ename
      myRs.MoveNext
   Wend
   DisconnectFromDB
   
End Sub

Rem ****************************************************************************
Rem Author : Pierre DELPORTE
Rem Creation : 12/03/1998
Rem Purpose : This library is an interface between VB and Oracle trough ADO. It
Rem           offers several means to get or store information from/into the DB.
Rem History
Rem Date       Vers. By              Comments
Rem ----------+-----+---------------+------------------------------------------
Rem 12/03/1998 01.00 Pierre DELPORTE Creation of this module
Rem 15/04/2001 01.01 Pierre DELPORTE Add Comment
Rem ****************************************************************************
Option Explicit

Public DB As New ADODB.Connection 'Public name to use for the connection to the DB
Public ConnectString As String 'Connect string
Rem ****************************************************************************
Rem Purpose : Disconnect from the DB
Rem Parameters :
Rem   IN : None
Rem  OUT : None
Rem ****************************************************************************
Sub DisconnectFromDB()
    DB.Close
End Sub
Rem ****************************************************************************
Rem Purpose : Connect to a Database
Rem Parameters :
Rem   IN : Data source : tnsname of the DB to connect to
Rem        Userid : Username to user
Rem        Password : User's password
Rem  OUT : True if connected succeeded else false
Rem ****************************************************************************
Function ConnectToDB(DSource As String, UserId As String, Password As String) As Boolean
    Dim r As Integer
    
    On Error GoTo ConnectToDBErr
    ' Create the connect string
    ConnectString = "Provider=MSDAORA;Data Source=" & DSource & ";User ID=" & UserId & ";Password=" & Password
    
    'Open the connection to the DB
    DB.Open ConnectString
    'Attribute the permissions to the connected user
    'Call FindMyRole(DB)
    ConnectToDB = True
    Exit Function
ConnectToDBErr:
    MsgBox Err.Number & " " & Err.Description
    ConnectToDB = False
    'End
End Function
Rem ****************************************************************************
Rem Purpose : Attribute persmissions to the connected user
Rem Parameters :
Rem   IN : ADODB.Connection
Rem  OUT : None
Rem ****************************************************************************
Sub FindMyRole(cn As ADODB.Connection)
Dim mySQL As String
Dim cmd As New ADODB.Command
Dim param As Parameter
Dim cmdSet As New ADODB.Command
On Error GoTo FindMyRoleError

cmd.ActiveConnection = cn
mySQL = "BEGIN ?:=f_find_my_role('AGF', ?, ?, ?); END;"
cmd.CommandText = mySQL
cmd.CommandType = adCmdText

'Set up parameters
Set param = cmd.CreateParameter("Resultat", adInteger, adParamOutput, , 0)
cmd.Parameters.Append param
Set param = cmd.CreateParameter("RoleName", adChar, adParamOutput, 80, 0)
cmd.Parameters.Append param
Set param = cmd.CreateParameter("RolePwd", adChar, adParamOutput, 80, 0)
cmd.Parameters.Append param
Set param = cmd.CreateParameter("Message", adChar, adParamOutput, 80, 0)
cmd.Parameters.Append param

cmd.Execute

cmdSet.ActiveConnection = cn
mySQL = "SET ROLE " & Trim(cmd!rolename) & " identified by " & Trim(cmd!rolepwd)
cmdSet.CommandText = mySQL
cmdSet.CommandType = adCmdText
' if a role was found then attribute it
If Not IsNull(cmd(1)) Then
    cmdSet.Execute
End If
Exit Sub
FindMyRoleError:
    
End Sub
Rem ****************************************************************************
Rem Purpose : Execute a SQL Select statement
Rem Parameters :
Rem   IN : string  - the sql select command
Rem  OUT : ADODB.Recordset
Rem ****************************************************************************
Function ExecuteQuery(SQLCmd As String) As ADODB.Recordset

On Error GoTo SQLExecuteErr
Dim rs As New ADODB.Recordset
Dim cmd As New ADODB.Command

cmd.ActiveConnection = DB
cmd.CommandText = SQLCmd 'Parse the sql command

Set rs = cmd.Execute
'If some data were found, go to the first record of the recordset
If Not rs.EOF And Not rs.BOF Then
    rs.MoveFirst
End If
'Return the recordset
Set ExecuteQuery = rs
Exit Function

SQLExecuteErr:
MsgBox Err.Number & " - " & Err.Description

End Function

Rem ****************************************************************************
Rem Purpose : Execute a SQL command like insert, update or delete
Rem Parameters :
Rem   IN : string  - the sql command
Rem  OUT : integer
Rem ****************************************************************************
Function ExecuteSQL(SQLCmd As String) As Integer
    Dim cmdSet As New ADODB.Command
    
    On Error GoTo ErrExecuteSQL
    
    cmdSet.ActiveConnection = DB
    
    cmdSet.CommandText = SQLCmd
    cmdSet.CommandType = adCmdText
    cmdSet.Execute
    
    ExecuteSQL = 0
    Exit Function
    
ErrExecuteSQL:
    ExecuteSQL = Err.Number
    MsgBox Err.Number & " " & Err.Description
End Function

Rem ****************************************************************************
Rem Purpose : Return the value of the field of the first record found or null if nothing found
Rem           if none of cname and colno are specified the value of the first column will be return
Rem           if the value of field's value to return is null then Null is return
Rem Parameters :
Rem   IN : string  - mySQL  = a valid SQL select command
Rem                  cname = a column name (optional)
Rem                  colno = the column at position n (optional)
Rem  OUT : variant
Rem ****************************************************************************

Function GetField(mySQL As String, Optional cname As String, Optional colno As Integer) As Variant

    On Error GoTo ErrGetField
    
    Dim rs As ADODB.Recordset
    Dim i As Integer
    Dim s As String
       
    If colno > 0 Then
        colno = colno - 1
    End If
    
    Set rs = ExecuteQuery(mySQL)
    If Not rs.EOF And Not rs.BOF Then
        rs.MoveFirst
        If cname = "" Then
            s = rs.Fields(colno)
            If IsNull(s) Then
                GetField = ""
            Else
                GetField = s
            End If
        Else
            s = rs.Fields(cname)
            If IsNull(s) Then
                GetField = ""
            Else
                GetField = s
            End If
        End If
    Else
        GetField = ""
    End If
    Exit Function
    
ErrGetField:
    GetField = ""
    If Err.Number <> 94 Then
        MsgBox Err.Number & " " & Err.Description
    End If
End Function
Rem ****************************************************************************
Rem Purpose : Allows you to execute a query while debugging. The output will be
Rem           print into the deugger window
Rem Parameters :
Rem   IN : string  - mySQL  = a valid SQL select command
Rem                  Separator = a string to separate the columns (optional)
Rem  OUT : integer
Rem ****************************************************************************
Function DoSelect(mySQL As String, Optional separator As String) As Integer
    On Error GoTo ErrDoSelect
    Dim rs As ADODB.Recordset
    Dim c As Integer
    Dim iReturn As Integer
    Dim i As Integer
    Dim line As String
    Dim line2 As String
    Dim nRecord As Long
    
    If separator = "" Then
        separator = " "
    End If
    
    Set rs = ExecuteQuery(mySQL)
    nRecord = 0
    'display the column names
    If Not rs.EOF And Not rs.BOF Then
        rs.MoveFirst
        line = ""
        line2 = ""
        For i = 0 To rs.Fields.Count - 1
            line = line & rpad(rs.Fields(i).Name, max(Len(rs.Fields(i).Name), FieldLength(rs.Fields(i))), " ") & separator
            line2 = line2 & String(max(Len(rs.Fields(i).Name), FieldLength(rs.Fields(i))), "-") & separator
            'Debug.Print rs.Fields(i).Name, rs.Fields(i).Precision, FieldType(rs.Fields(i)), FieldLength(rs.Fields(i))
        Next i
        Debug.Print Trim(line)
        Debug.Print Trim(line2)
    Else
        Debug.Print "No rows found"
    End If
    'display the records
    While Not rs.EOF
        line = ""
        nRecord = nRecord + 1
        For i = 0 To rs.Fields.Count - 1
            If IsNull(rs.Fields(i).Value) Then
                line = line & String(max(FieldLength(rs.Fields(i)), Len(rs.Fields(i).Name)), " ") & separator
                'Debug.Print rs.Fields(i).Name, "Null", rs.Fields(i).Precision, FieldType(rs.Fields(i))
            Else
                If rs.Fields(i).Type = 131 Then
                    line = line & lpad(rs.Fields(i).Value, max(FieldLength(rs.Fields(i)), Len(rs.Fields(i).Name))) & separator
                Else
                    line = line & rpad(rs.Fields(i).Value, max(FieldLength(rs.Fields(i)), Len(rs.Fields(i).Name))) & separator
                End If
                'Debug.Print rs.Fields(i).Name, rs.Fields(i).Value, rs.Fields(i).Precision, FieldType(rs.Fields(i))
            End If
            
        Next i
        Debug.Print RTrim(line)
        rs.MoveNext
    Wend
    
    Debug.Print nRecord & " records found"
    
    rs.Close
    'return the number of records found
    DoSelect = nRecord
    Exit Function
    
ErrDoSelect:
    Debug.Print Err.Number & " " & Err.Description
    DoSelect = 0

End Function
Rem ****************************************************************************
Rem Purpose : return the max value of arg1 or arg2
Rem Parameters :
Rem   IN : variant - arg1
Rem        variant - arg2
Rem  OUT : variant
Rem ****************************************************************************
Function max(arg1 As Variant, arg2 As Variant) As Variant
' Return the bigger number
    If arg1 > arg2 Then
        max = arg1
    Else
        max = arg2
    End If
End Function
Rem ****************************************************************************
Rem Purpose : Return the type of the field
Rem Parameters :
Rem   IN : Field  - the fieldname to determinate is type
Rem  OUT : string - the field type
Rem ****************************************************************************
Function FieldType(F As Field) As String
    
    
    Select Case F.Type
        Case adBigInt
            FieldType = "adBigInt" '20  An 8-byte signed integer
        Case adBinary
            FieldType = "adBinary" '128 A binary value
        Case adBoolean
            FieldType = "adBoolean" '11  A Boolean value
        Case adBSTR
            FieldType = "adBSTR" '8   A null-terminated character string (Unicode)
        Case adChar
            FieldType = "adChar" '129 A String value
        Case adCurrency
            FieldType = "adCurrency" '6   A currency value (8-byte signed integer scaled by 10,000)
        Case adDate
            FieldType = "adDate" '7   A Date value
        Case adDBDate
            FieldType = "adDBate" '133 A date value (yyyymmdd)
        Case adDBTime
            FieldType = "adDBTime" '134 A time value (hhmmss)
        Case adDBTimeStamp
            FieldType = "adDBTimeStamp" '135 A date-time stamp (yyyymmddhhmmss plus a fraction in billionths)
        Case adDecimal
            FieldType = "adDecimal" '14  An exact numeric value with a fixed precision and scale
        Case adDouble
            FieldType = "adDouble" '5   A double-precision floating point value
        Case adEmpty
            FieldType = "adEmpty" '0   No value was specified
        Case adError
            FieldType = "adError" '10  A 32-bit error code
        Case adGUID
            FieldType = "adGUID" '72  A globally unique identifier (GUID)
        Case adIDispatch
            FieldType = "adIDispatch" '9   A pointer to an IDispatch interface on an OLE object
        Case adInteger
            FieldType = "adInteger" '3   A 4-byte signed integer
        Case adIUnknown
            FieldType = "adIUnknow " '13  A pointer to an IUnknown interface on an OLE object
        Case adLongVarBinary
            FieldType = "adLongVarBinary" '205 A long binary value (Parameter object only)
        Case adLongVarChar
            FieldType = "adLongVarChar" '201 A long String value (Parameter object only)
        Case adLongVarWChar
            FieldType = "adLongVarWChar" '203 A long null-terminated string value (Parameter object only)
        Case adNumeric
            FieldType = "adNumeric " & F.Precision & " " & F.NumericScale '131 An exact numeric value with a fixed precision and scale
        Case adSingle
            FieldType = "adSingle" '4   A single-precision floating point value
        Case adSmallInt
            FieldType = "adSmallInt" '2   A 2-byte signed integer
        Case adTinyInt
            FieldType = "adTinyInt" '16  A 1-byte signed integer
        Case adUnsignedBigInt
            FieldType = "adUnsignedBigInt" '21  An 8-byte unsigned integer
        Case adUnsignedInt
            FieldType = "adUnsignedInt" '19  A 4-byte unsigned integer
        Case adUnsignedSmallInt
            FieldType = "adUnsignedSmallInt" '18  A 2-byte unsigned integer
        Case adUnsignedTinyInt
            FieldType = "adUnsignedTinyInt" '17  A 1-byte unsigned integer
        Case adUserDefined
            FieldType = "adUserDefined" '132 A user-defined variable
        Case adVarBinary
            FieldType = "adVarBinary" '204 A binary value (Parameter object only)
        Case adVarChar
            FieldType = "adVarChar " & F.DefinedSize '200 A String value (Parameter object only)
        Case adVariant
            FieldType = "adVariant" '12  An OLE Automation Variant
        Case adVarWChar
            FieldType = "adVarWChar" '202 A null-terminated Unicode character string (Parameter object only)
        Case adWChar
            FieldType = "adWChar" '130 A null-terminated Unicode character string
        Case Else
            FieldType = "Unknow type " & F.ActualSize & " " & F.DefinedSize & " " & F.Type & " " & F.Precision & " " & F.NumericScale
    End Select

End Function
Rem ****************************************************************************
Rem Purpose : Return the length of the field
Rem Parameters :
Rem   IN : field - the field for which we want to know its length
Rem  OUT : Integer : the length of the field
Rem ****************************************************************************
Function FieldLength(F As Field) As Integer
    Select Case F.Type
        Case adBigInt
            FieldLength = F.Precision '"adBigInt" '20  An 8-byte signed integer
        Case adBinary
            FieldLength = F.Precision '128 A binary value
        Case adBoolean
            FieldLength = F.Precision '11  A Boolean value
        Case adBSTR
            FieldLength = F.Precision '8   A null-terminated character string (Unicode)
        Case adChar
            FieldLength = F.DefinedSize '129 A String value
        Case adCurrency
            FieldLength = F.Precision '6   A currency value (8-byte signed integer scaled by 10,000)
        Case adDate
            FieldLength = F.Precision '7   A Date value
        Case adDBDate
            FieldLength = F.Precision '133 A date value (yyyymmdd)
        Case adDBTime
            FieldLength = F.Precision '134 A time value (hhmmss)
        Case adDBTimeStamp
            FieldLength = F.Precision '135 A date-time stamp (yyyymmddhhmmss plus a fraction in billionths)
        Case adDecimal
            FieldLength = F.Precision '14  An exact numeric value with a fixed precision and scale
        Case adDouble
            FieldLength = F.Precision '5   A double-precision floating point value
        Case adEmpty
            FieldLength = F.Precision '0   No value was specified
        Case adError
            FieldLength = F.Precision '10  A 32-bit error code
        Case adGUID
            FieldLength = F.Precision '72  A globally unique identifier (GUID)
        Case adIDispatch
            FieldLength = F.Precision '9   A pointer to an IDispatch interface on an OLE object
        Case adInteger
            FieldLength = F.Precision '3   A 4-byte signed integer
        Case adIUnknown
            FieldLength = F.Precision '13  A pointer to an IUnknown interface on an OLE object
        Case adLongVarBinary
            FieldLength = F.Precision '205 A long binary value (Parameter object only)
        Case adLongVarChar
            FieldLength = F.Precision '201 A long String value (Parameter object only)
        Case adLongVarWChar
            FieldLength = F.Precision '203 A long null-terminated string value (Parameter object only)
        Case adNumeric
            FieldLength = F.Precision '131 An exact numeric value with a fixed precision and scale
        Case adSingle
            FieldLength = F.Precision '4   A single-precision floating point value
        Case adSmallInt
            FieldLength = F.Precision '2   A 2-byte signed integer
        Case adTinyInt
            FieldLength = F.Precision '16  A 1-byte signed integer
        Case adUnsignedBigInt
            FieldLength = F.Precision '21  An 8-byte unsigned integer
        Case adUnsignedInt
            FieldLength = F.Precision '19  A 4-byte unsigned integer
        Case adUnsignedSmallInt
            FieldLength = F.Precision '18  A 2-byte unsigned integer
        Case adUnsignedTinyInt
            FieldLength = F.Precision '17  A 1-byte unsigned integer
        Case adUserDefined
            FieldLength = F.Precision '132 A user-defined variable
        Case adVarBinary
            FieldLength = F.Precision '204 A binary value (Parameter object only)
        Case adVarChar
            If F.DefinedSize = 75 Then
                FieldLength = F.ActualSize
            Else
                FieldLength = F.DefinedSize '200 A String value (Parameter object only)
            End If
        Case adVariant
            FieldLength = F.Precision '12  An OLE Automation Variant
        Case adVarWChar
            FieldLength = F.DefinedSize '202 A null-terminated Unicode character string (Parameter object only)
        Case adWChar
            FieldLength = F.DefinedSize '130 A null-terminated Unicode character string
        Case Else
            'FieldType = "Unknow type " & F.ActualSize & " " & F.DefinedSize & " " & F.Type & " " & F.Precision & " " & F.NumericScale
            FieldLength = 10
    End Select
    If F.NumericScale > 0 Then
        FieldLength = FieldLength + 1
    End If
End Function

Requete sql avec oracle

1 réponse

Discussions similaires