Générer l'URL web (HTTP) d'un document

[Michael DELIQUE]

Code : Tout sélectionner

Public Function HttpURL_LS(wDoc As NotesDocument,wServer As String, wnbUNID As Integer, wnbLocal As Integer) As String
   
   'wnbUNID = true passe l'id de replique au lieux du pathfile de la base
   'wnbLocal = true autorise la creation si la base est en local
   
   'Déclaration Variable
   Dim DBURL As NotesDatabase
   Dim nmServer As NotesName
   Dim Server As String
   
   On Error Goto ErreurHandle
   
   HttpURL_LS = ""
   
   If wDoc Is Nothing Then
      Error 9999,"wDoc is nothing"
      Exit Function
   End If
   
   Set DBURL = wDoc.ParentDatabase
   
   If DBExists_LS(DBURL) = False Then
      Error 9999, "DBURL is Nothing"
      Exit Function
   End If
   
   If Trim(wServer) = "" Then
      If wnbLocal = False Then
         If Trim(DBURL.Server) = "" Then
            Error 9999,"DBUrl is local"
            Exit Function
         End If
      End If
   End If
   
   If Trim(wServer) = "" Then
      If Trim(DBURL.Server) = "" Then
         Server = "127.0.0.1"
      Else
         Set nmServer = New NotesName(DBURL.Server)
         Server = nmServer.Common
         Set nmServer = Nothing
      End If
   Else
      Set nmServer = New NotesName(Trim(wServer))
      Server = nmServer.Common
      Set nmServer = Nothing
   End If
   
   If wnbUNID = True Then
      HttpURL_LS = "http://"+ Server +"/"+DBURL.filepath+"/0/"+ wDoc.Universalid +"?opendocument"
   Else
      HttpURL_LS= "http://"+ Server +"/__"+Cstr(DBURL.ReplicaID)+".NSF/0/"+ wDoc.Universalid +"?opendocument"      
   End If
   
   Set DBURL = Nothing
   Server = ""
   
   Exit Function
ErreurHandle:
   Msgbox "("+Cstr(Getthreadinfo (1))+")"+Chr(10)+"Erreur " + Str(Err) + " : "+Chr(10) + Cstr(Error)+". "+Chr(10)+"Ligne N° "+Cstr(Erl),16," ERREUR !"
   HttpURL_LS = ""
   Exit Function
End Function

Code : Tout sélectionner

Public Function DBExists_LS(wdb As NotesDatabase) As Integer
   'teste si une base de donnée est accéssible
'   renvoi true si elle est accéssible
' renvoi false si elle n'est pas accessible
   
   On Error Goto ErreurDBExists_LS
   
   'teste si la variable est renseigné
   If wDB Is Nothing Then
      DBExists_LS = False
      Exit Function
   Else
      'teste si la base est ouverte
      If wDB.IsOpen = True Then
      'teste si la base existe réelement il faut que la date de crétation existe ainsi que l'id de réplique
         If Trim(Cstr(wDB.Created)) = "" Or Trim(Cstr(wDB.ReplicaID)) = "" Then
            DBExists_LS = False
            Exit Function
         End If
      Else
         DBExists_LS = False
         Exit Function
      End If
   End If
   
   DBExists_LS = True
   
   Exit Function
ErreurDBExists_LS:
   Msgbox "("+Cstr(Getthreadinfo (1))+")"+Chr(10)+"Erreur " + Str(Err) + " : "+Chr(10) + Cstr(Error)+". "+Chr(10)+"Ligne N° "+Cstr(Erl),16," ERREUR !"
   DBExists_LS = False
   Exit Function
End Function