Gestion oracle

Commenter

Contenu du snippet

Gérer des requêtes Oracles avec Vb, utiliser des fonctions pour exécuter des ordres SQL et formater des chaînes.

Source / Exemple : 


Option Compare Database
Option Explicit

'arg1 : chaine contenant l'ordre SQL a executer en SQL direct
Public Function lance_Requete_directe(SQL_src As Variant)

Dim VarNow As Date
Dim conOcOracle As Connection
Dim wrkODBC As Workspace
Dim Qdf As QueryDef
Dim APP As Application

VarNow = Now
On Error GoTo lance_Requete_directe_Err
       
    DoCmd.SetWarnings (False)
    ' Crée un objet Workspace ODBCDirect et ouvre un objet Connection.
    Set wrkODBC = CreateWorkspace("", "admin", "", dbUseODBC)
    wrkODBC.LoginTimeout = 3600
    
    Set conOcOracle = wrkODBC.OpenConnection("mon_dsn", , , 
"ODBC;DATABASE=ma_base ;UID=utilisateur;PWD=mon_pwd;DSN=mon_dsn")
    conOcOracle.QueryTimeout = 10000
 
'Application.SetOption "Intervalle d'actualisation ODBC (sec)", 30000
'MsgBox GetOption("Intervalle d'actualisation ODBC (sec)")
    Set Qdf = conOcOracle.CreateQueryDef("")
    With Qdf
    
        .ODBCTimeout = 0
        .Prepare = dbQUnprepare
        
        .SQL = SQL_src
        .Execute
         
        .SQL = "commit"
        .Execute
    End With

    Qdf.close
    conOcOracle.close
    wrkODBC.close
    
lance_Requete_directe_Exit:
    Exit Function

lance_Requete_directe_Err:
    MsgBox Error$
    Resume lance_Requete_directe_Exit

End Function

'--------------------------------------------------------------------------------

Option Compare Database
Option Explicit

Sub Afficher_progression(texte_progression)
    SysCmd acSysCmdSetStatus, texte_progression
End Sub

Sub Initialiser_Progression()
    SysCmd acSysCmdClearStatus
End Sub

'--- Efface une table et gère les erreurs si elle n'existe pas ---
Sub effacer_table(Nom_Base, Nom_table)
Dim Tbl As TableDef

On Error GoTo Table_a_effacer_n_existe_pas
    Nom_Base.TableDefs.Refresh
   
   If Nom_table <> "" And Nom_table = "nom_de_table" Then
        Nom_Base.TableDefs.delete (Nom_table)
    End If
    
    If Nom_table <> "" And Nom_table <> "nom_de_table" Then
        Nom_Base.TableDefs.delete (Nom_table)
    End If
   
    On Error GoTo 0
    
    Nom_Base.TableDefs.Refresh
    
   Exit Sub
            
Table_a_effacer_n_existe_pas:
    Resume Next
    
End Sub
'----------------------------------------------------------------
Sub effacer_requete(Nom_Base, Nom_Requete)
Dim Tbl As TableDef

On Error GoTo Requete_a_effacer_n_existe_pas
    
    Nom_Base.QueryDefs.Refresh
    Nom_Base.QueryDefs.delete (Nom_Requete)
    On Error GoTo 0
    
    Nom_Base.QueryDefs.Refresh
    
   Exit Sub
            
Requete_a_effacer_n_existe_pas:
    Resume Next
    
End Sub
'Est utilise pour completer par des " " ou des "0" ou ... les chaines 
qui doivent
'Avoir une longueur donnee Par Ex "1" peu devenir "00001"
Public Function Complete_Chaine(A_Completer As String, Nombre_Complet 
As Integer, Cadre_a As String, Optional Complement As String = " ") As 
String
'Sauvegarde de la procedure pour alignement 3/6/2002
Dim i As Integer

    If Cadre_a = "G" Then
        If Len(A_Completer) >= Nombre_Complet Then
            'Si c'est trop long on coupe
            A_Completer = Left(A_Completer, Nombre_Complet)
        Else
            For i = Len(A_Completer) + 1 To Nombre_Complet
                A_Completer = A_Completer & Complement
            Next
        End If
    ElseIf Cadre_a = "D" Then
        For i = Len(A_Completer) + 1 To Nombre_Complet
            A_Completer = Complement & A_Completer
        Next
    End If

Complete_Chaine = Format(A_Completer, ">")

End Function

Sub sauve_Complete_Chaine()
Dim szTmp As String

    If Cadre_a = "G" Then
        If Len(A_Completer) >= Nombre_Complet Then
            'Si c'est trop long on coupe
            A_Completer = Left(A_Completer, Nombre_Complet)
        Else
            szTmp = String(Nombre_Complet - Len(A_Completer), 
Asc(Complement))
            A_Completer = A_Completer & szTmp
        End If
    ElseIf Cadre_a = "D" Then
        'For I = Len(A_Completer) + 1 To Nombre_Complet
        '    A_Completer = Complement & A_Completer
        'Next
        szTmp = String(Nombre_Complet + 1, Asc(Complement))
        A_Completer = szTmp & A_Completer
        
    End If

Complete_Chaine = A_Completer 'Format(Left(A_Completer, 
Nombre_Complet), ">")
End Sub

Public Function FormaterChaine(pstr As String, plng As Long, _
                                pcad As String) As String

'-------------------------------------------------------------
'format une chaîne passée en paramètre en la complétant par
'des blancs et en la cadrant à gauche ou à droite
'-------------------------------------------------------------
Dim LongCh As Long      'longueur de la chaîne résultat
Dim CompCh As String    'chaîne de blancs pour cadrage
Dim res As String       'résultat de cette fonction

'----- longueur de la chaîne de remplissage
If Len(pstr) > plng Then
    LongCh = Len(pstr)
Else
    LongCh = plng
End If
CompCh = Space(LongCh)

'----- cadrage
Select Case pcad
Case "G"
    res = Left$((pstr & CompCh), LongCh)
Case Else
    res = Right$((CompCh & pstr), LongCh)
End Select

FormaterChaine = res

End Function

Conclusion :


si bug rencontré, contacter moi ou poster moi un message :)

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.