toutes les améliorations et remarques sont les bienvenus
- Code : Tout sélectionner
Function DBOpen (Byval wServer As String,wPathFile As String, Byval wRepliqueID As String) As NotesDatabase
' si la base est inaccessible renvois nothing
' Cette function ouvre une base notes si elle ne la trouve pas, elle recherche une replique en local ou sur les autres serveurs du cluster
'Déclaration Variable
Dim DBCible As NotesDatabase
Dim Path As String
Dim File As String
Dim PathFile As String
Dim RepliqueID As String
Dim i As Integer
Dim Char As String
On Error Goto ErreurHandle
'en cas d'impossibilité d'accès on zap l'erreur
On Error 4060 Resume Next
On Error 4185 Resume Next
On Error 4164 Resume Next
If Session Is Nothing Then
Set Session = New NotesSession
End If
PathFile = Trim(wPathFile)
If Left(PathFile,1) = "\" Then
PathFile = Right(PathFile,Len(PathFile)-1)
End If
If Instr(PathFile,"\") = 0 Then
Path = ""
File = PathFile
Else
Path = Strleftback(PathFile,"\")
If Trim(Path)<>"" Then
If Right(Trim(Path),1)<>"\" Then
Path = Trim(Path)+"\"
End If
End If
File = Strrightback(PathFile,"\")
End If
Select Case Len(Trim(wRepliqueID))
case 0
RepliqueID = ""
Case 1 To 15
' si le répliqueid fait moins de 16 caracteres il n'est pas valide
Print Cstr(Getthreadinfo (1))+" Invalid Replique ID ("+Len(Trim(wRepliqueID))+" < 16 ) : "+Trim(wRepliqueID)
RepliqueID = ""
Case 16
'l'id de réplique ne doit pas contenir de ":"
If Instr(wRepliqueID,":")>0 Then
Print Cstr(Getthreadinfo (1))+" Invalid Replique ID (':' Found & Replique ID = 16 Characteres) : "+Trim(wRepliqueID)
RepliqueID = ""
Else
RepliqueID = Ucase(Trim(wRepliqueID))
End If
Case 17
'enleve le ":" qui se trouve parfois au milieux de l'id de réplique
RepliqueID = Ucase(Left(Trim(wRepliqueID),8)+Right(Trim(wRepliqueID),8))
If Instr(RepliqueID,":")>0 Then
'controle qu'on a pas un ':' qui trainne
Print Cstr(Getthreadinfo (1))+" Invalid Replique ID (':' Found) : "+Trim(RepliqueID)
RepliqueID = ""
End If
Case Else
' si le réplique id fait plus de 17 caracteres il n'est pas valide
Print Cstr(Getthreadinfo (1))+" Invalid Replique ID ("+Len(Trim(wRepliqueID))+" > 17 ) : "+Trim(wRepliqueID)
RepliqueID = ""
End Select
If Trim(File) = "" Then
If Trim(RepliqueID) = "" Then
'si c'est 2 variables ne sont pas renseigné la connexion est impossible
Set DBOpen = Nothing
Exit Function
End If
End If
'ouverture sur le server
'If Session.IsOnServer = True Then
If Trim(wServer)<>"" Then
If Trim(File)<>"" Then
'ouvre la base via le chemin et le nom de la base
'ouverture via l'objet notessession
Set DBCible = Session.GetDatabase(wServer,PathFile,False)
'test que l'objet est bien instancié
If Not DBCible Is Nothing Then
If DBCible.IsOpen = False Then
Call DBCible.Open("","")
End If
'teste si la base est ouverte
If DBExists_LS(DBCible) = True Then
Set DBOpen = DBCible
Set DBCible = Nothing
Exit Function
End If
End If
'ouverture via l'objet Notesdatabase
Set DBCible = New NotesDatabase(wServer ,PathFile)
'test que l'objet est bien instancié
If Not DBCible Is Nothing Then
If DBCible.IsOpen = False Then
Call DBCible.Open("","")
End If
'teste si la base est ouverte
If DBExists_LS(DBCible) = True Then
Set DBOpen = DBCible
Set DBCible = Nothing
Exit Function
End If
End If
End If
End If
'ouvre la base via son id de réplique
If Trim(wRepliqueID)<>"" Then
Set DBCible = New NotesDatabase("","")
Call DBCible.OpenByReplicaID( wServer, RepliqueID )
'test que l'objet est bien instancié
If Not DBCible Is Nothing Then
If DBCible.IsOpen = False Then
Call DBCible.Open("","")
End If
'teste si la base est bien ouverte
If DBExists_LS(DBCible) = True Then
Set DBOpen = DBCible
Set DBCible = Nothing
Exit Function
End If
End If
End If
'cherche à ouvrir la base sur d'autre seveur du cluster via le chemin et le nom de fichier
If Trim(File)<>"" Then
Set DBCible = New NotesDatabase("","")
'test que l'objet est bien instancié
If DBCible.OpenWithFailover( wServer,Trim(File)) = True Then
If Not DBCible Is Nothing Then
If DBCible.IsOpen = False Then
Call DBCible.Open("","")
End If
'teste si la base est ouverte
If DBExists_LS(DBCible) = True Then
Set DBOpen = DBCible
Set DBCible = Nothing
Exit Function
End If
End If
End If
End If
'End If
'ouverture en local (soit parceque l'ouverture sur le server a échoué, soit parceque le traitement est en local
'ouvre la base via le chemin et le nom de la base
If Trim(File)<>"" Then
'ouverture via l'objet notessession
Set DBCible = Session.GetDatabase("",PathFile,False)
'test que l'objet est bien instancié
If Not DBCible Is Nothing Then
If DBCible.IsOpen = False Then
Call DBCible.Open("","")
End If
'teste si la base est ouverte
If DBExists_LS(DBCible) = True Then
Set DBOpen = DBCible
Set DBCible = Nothing
Exit Function
End If
End If
'ouverture via l'objet Notesdatabase
Set DBCible = New NotesDatabase("" ,PathFile)
'test que l'objet est bien instancié
If Not DBCible Is Nothing Then
If DBCible.IsOpen = False Then
Call DBCible.Open("","")
End If
'teste si la base est ouverte
If DBExists_LS(DBCible) = True Then
Set DBOpen = DBCible
Set DBCible = Nothing
Exit Function
End If
End If
End If
'ouvre la base via son id de réplique
If Trim(RepliqueID)<>"" Then
Set DBCible = New NotesDatabase("","")
Call DBCible.OpenByReplicaID( "", RepliqueID )
'test que l'objet est bien instancié
If Not DBCible Is Nothing Then
If DBCible.IsOpen = False Then
Call DBCible.Open("","")
End If
'teste si la base est bien ouverte
If DBExists_LS(DBCible) = True Then
Set DBOpen = DBCible
Set DBCible = Nothing
Exit Function
End If
End If
End If
Set DBOpen = Nothing
Set DBCible = Nothing
Exit Function
ErreurHandle:
Msgbox "("+Cstr(Getthreadinfo (1))+" Call by "+Cstr(Getthreadinfo(10))+")"+Chr(10)+"Erreur " + Str(Err) + " : "+Chr(10) + Cstr(Error)+". "+Chr(10)+"Ligne N° "+Cstr(Erl),16," ERREUR !"
Set DBCible = Nothing
Set DBOpen = Nothing
Exit Function
End Function
la foncton DBExists_Ls ce trouve ici=> viewtopic.php?f=35&t=10711
