Récupérer la liste des serveurs Notes

[Michael DELIQUE]

Code : Tout sélectionner

Option Public
Option Declare

'Variable API pour le getServerList_API
Declare Function NSGetServerList% Lib "nnotes" (Byval dwPortName&, nRetServerTextList%)
Declare Function ListGetText% Lib "nnotes" (Byval dwList&, Byval nPrefixDataType%, Byval nEntryNumber%, dwRetTextPointer&, nRetTextLength%)
Declare Function OSTranslate% Lib "nnotes" (Byval nTranslateMode%, Byval dwIn&, Byval nLength%, Byval lpszOut$, Byval nOutLength%)
Declare Function OSLockObject& Lib "nnotes" (Byval nHandle%)
Declare Function OSUnlockObject% Lib "nnotes" (Byval nHandle%)
Declare Function OSMemFree% Lib "nnotes" (Byval nHandle%)

Const OS_TRANSLATE_LMBCS_TO_NATIVE = 1
Const MAX_SERVER_NAME = 256

Code : Tout sélectionner

Function GetServerList_API(wFormName As String) As Variant
   
   'renvois la liste des serveur snotes
   'Attention la function peut prendre plusieurs secondes avant de renvoyer la liste des serveurs
   
   'Déclaration des Variables   
   Dim lpszServer As String
   Dim tbServer() As String
   Dim nbHList As Integer
   Dim nbStatus As Integer
   Dim nbCount As Integer
   Dim nbLength As Integer
   Dim nbDwList As Long
   Dim nbDwHold As Long
   Dim I As Long
   
   On Error Goto ErreurGetServerList_API
   
' get a list of known servers on all ports
   nbStatus=NSGetServerList(0, nbHList)
   
' be sure our API call returned a handle to our list buffer
   If nbStatus=0 And nbHList <> 0 Then
' initialize our results array
      Redim tbServer(0)
      
' lock down our memory handle
      nbDwList=OSLockObject(nbHList)
      
      Do While nbStatus=0
' get a server in the list
         nbStatus=ListGetText(nbDwList, 0, nbCount, nbDwHold, nbLength)
         
         If nbStatus=0 And nbLength>0 Then
' intialize the string to pass to the API
            lpszServer=Space$(nbLength)
            
' translate the results to the native charset
            Call OSTranslate(OS_TRANSLATE_LMBCS_TO_NATIVE, nbDwHold, nbLength, lpszServer, MAX_SERVER_NAME)
            
'populate an array with the results
            Redim Preserve tbServer(nbCount)
            tbServer(nbCount)=lpszServer
         End If
         
         nbCount=nbCount+1
         
      Loop
      
' free our lock on the list
      Call OSUnlockObject(nbHList)
      
' free the handle allocated by NSGetServerList
      Call OSMemFree(nbHList)
      
   End If
   
' return results to caller
   Dim nmServeur As NotesName
   Select Case Ucase(Trim(wFormName))
   Case "COMMON","COMON","CN","COMMUN","COMUN","COM","CO"
      For I = Lbound(tbServer) To Ubound(tbServer)
         Set nmServeur = New NotesName(tbServer(I))
         tbServer(I) = ""
         tbServer(I) = Trim(Cstr(nmServeur.Common))
         Set nmServeur = Nothing
      Next
   Case "ABBREVIATED","ABBREVIATE","ABB","AB","A"
      For I = Lbound(tbServer) To Ubound(tbServer)
         Set nmServeur = New NotesName(tbServer(I))
         tbServer(I) = ""
         tbServer(I) = Trim(Cstr(nmServeur.Abbreviated))
         Set nmServeur = Nothing
      Next
   Case Else
      'aucun traitement les serveurs sont déja sous la form canonical
   End Select
   
   GetServerList_API=tbServer
   
   Erase tbServer
   
   Exit Function
ErreurGetServerList_API:
   Msgbox "(GetServerList_API) Erreur " + Str(Err) + " : "+Chr(10) + Cstr(Error)+". "+Chr(10)+"Ligne N° "+Cstr(Erl),16," ERREUR !"
   Erase tbServer
   GetServerList_API=tbServer
   Exit Function
End Function

[Michael DELIQUE]

il peut arriver que la fonction avec les API ne tourne pas (Une erreur sur un port fera terminer cette fonction avec seulement les serveurs trouvés). Voici un plan B qui va interroger le carnet d'adresse. Elle marche aussi bien mais est beaucoup plus longue

Code : Tout sélectionner

Function GetServerList(Byval wFormName As String)  As Variant
   
   'Déclaration des Variables   
   Dim DBCA As Notesdatabase
   Dim lstServer List As String
   Dim Collection As NotesDocumentCollection
   Dim vwServer As NotesView
   Dim Doc As NotesDocument
   Dim nmServer As NotesName
   Dim i As Long
   
   On Error Goto ErreurGetServerList
   
   Set DBCA = DBCAPublic
   If DBCA Is Nothing Then
      lstServer(0) = ""
      GetServerList = lstServer
      Erase lstServer
      Exit Function
   End If
   
   Set vwServer = DBCA.getView("($Servers)")
   
   i = -1
   If vwServer Is Nothing Then
      Set Collection = DBCA.Search({@uppercase(Form) = "SERVER"},Nothing,0)
      
      If Collection Is Nothing Then
         lstServer(0) = ""
         GetServerList = lstServer
         Erase lstServer
         Exit Function
      Elseif Collection.count = 0 Then
         lstServer(0) = ""
         GetServerList = lstServer
         Erase lstServer
         Exit Function   
      End If
      
      Set Doc = Collection.GetFirstDocument
      While Not Doc Is Nothing
         If Trim(Doc.GetItemValue("ServerName")(0) ) <>"" Then
            i = I+1
            Set nmServer = New NotesName(Doc.GetItemValue("ServerName")(0))
            Select Case Ucase(Trim(wFormName))
            Case "COMMON","COMON","CN","COMMUN","COMUN","COM","CO"
               lstServer(i) = Cstr(nmServer.Common)
            Case "ABBREVIATED","ABBREVIATE","ABB","AB","A"
               lstServer(i) = Cstr(nmServer.Abbreviated)
            Case "CANONICAL","CANONICALIZE","CAN","CANON","CA"
               lstServer(i) = Cstr(nmServer.Canonical)
            End Select
            Set nmServer = Nothing
         End If
         Set Doc = Collection.GetNextDocument(Doc)
      Wend
      
   Else
      Set Doc = vwServer.GetFirstDocument
      While Not Doc Is Nothing
         If Trim(Doc.GetItemValue("ServerName")(0) ) <>"" Then
            i = I+1
            Set nmServer = New NotesName(Doc.GetItemValue("ServerName")(0))
            Select Case Ucase(Trim(wFormName))
            Case "COMMON","COMON","CN","COMMUN","COMUN","COM","CO"
               lstServer(i) = Cstr(nmServer.Common)
            Case "ABBREVIATED","ABBREVIATE","ABB","AB","A"
               lstServer(i) = Cstr(nmServer.Abbreviated)
            Case "CANONICAL","CANONICALIZE","CAN","CANON","CA"
               lstServer(i) = Cstr(nmServer.Canonical)
            End Select
            Set nmServer = Nothing
         End If
         Set Doc = vwServer.GetNextDocument(Doc)
      Wend      
      
   End If
   
   i = 0
   Set DOc = Nothing
   Set Collection = Nothing
   Set vwServer = Nothing
   
   GetServerList = lstServer
   Erase lstServer
   
   Exit Function
ErreurGetServerList:
   Msgbox "(GetServerList) Erreur " + Str(Err) + " : " + Cstr(Error)+Chr(10)+"Ligne N° "+Cstr(Erl),16, " ERREUR !"
   lstServer(0) = ""
   GetServerList = lstServer
   Erase lstServer
   Exit Function
End Function

Function DBCAPublic As Notesdatabase
   'renvois un variable de type NotesDatabase contenant le carnet d'adresse public
   
   'Déclaration des Variables   
   Dim dbCAP As NotesDatabase
   Dim Session As NotesSession
   
   On Error Goto ErreurDBCAPublic
   
   Set session = New notesSession
   
   Forall ValueAB In session.AddressBooks   
      If ValueAB.IsPublicAddressBook Then
         Set dbCAP = ValueAB
         Exit Forall
      End If   
   End Forall
   
   If DBExists_LS(dbCAP) = False Then
      Call dbCAP.Open("","")
   End If
   
   If DBExists_LS(dbCAP)= False Then
   '   Msgbox "Le Carnet d'Adresse Public est introuvable.",16," ERREUR !"
      Set DBCAPublic = Nothing
   Else
      Set DBCAPublic = dbCAP
   End If
   
   Set dbCAP = Nothing
   
   Exit Function
ErreurDBCAPublic:
   Msgbox "(DBCAPublic) Erreur " + Str(Err) + " : "+Chr(10) + Cstr(Error)+". "+Chr(10)+"Ligne N° "+Cstr(Erl),16," ERREUR !"
   Set dbCAP = Nothing
   Set DBCAPublic = Nothing
   Exit Function
End Function

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 "(DBExists_LS) Erreur " + Str(Err) + " : "+Chr(10) + Cstr(Error)+". "+Chr(10)+"Ligne N° "+Cstr(Erl),16," ERREUR !"
   DBExists_LS = False
   Exit Function
End Function