DominoArea.org [Archive]

Une fonction qui permet de ce connecter a une base.
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