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 :)
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.