DominoArea.org [Archive]

Salut,

Dans Outils/Référence il faut sélectionner Lotus Domino Objects. Petite histoire de ce code il fallait extraire des données des docs normaux et réponses sans avoir accès au Design de la base donc sans faire de vue/agent/etc. Le code prend le premier document d'une vue regarde si c'est un doc père le traite et regarde si il y des doc fils et récupère les valeurs et les mets dans les cellules approprié. Le code est paramètrable donc vous pouvez traiter autant de champs que vous voulez, il récupère aussi les valeurs des champs multi-valué, vous pouvez lui dire si vous travaillez sur base en local ou serveur, si il doit ou nom traiter les docs fils.

Code : Tout sélectionner

Option Explicit
' Paramètres des objets Notes nécessaire
Private Const asServeur = "SERVEUR"
Private Const asBase = "REP/BASE.NSF"
Private Const asVue = "MaVue"

' Nombre de champs à traiter, permet de rajouter des champs sans touche au reste du code,
' il suffit juste de rajouter => fld_Champs(X) = "NomChamps" pour que le nouveau champs soit pris en compte
Private Const iNombreChamps = 14
' Traitement sur une base local ou serveur
Private Const bLocal = False
' Est ce que le code traite des documents Fils
Private Const bFils = True
' Séparateur de tableau pour les champs multivalué
Private Const Sep = "; "

Public Sub Traitement()
    ' Variables VBA
    Dim iLigne As Integer
    Dim iCompteur As Integer
    Dim sValeur(iNombreChamps) As String
    Dim fld_Champs(iNombreChamps) As String
    Dim iCompteurArray As Integer
   
    ' Variables Lotus Notes
    Dim Session As New NotesSession
    Dim db As NotesDatabase
    Dim vue As NotesView
    Dim dPere As NotesDocument
    Dim cFils As NotesDocumentCollection
    Dim dFils As NotesDocument
   
    ' En cas d'ereur on passe à la gestion des erreurs de la routine
    On Error GoTo err_Traitement
   
    ' Nom des champs ou l'on prend la valeur
    ' Norme fld_Champs(1) = colonne A, fld_Champs(2) = colonne B, etc
    fld_Champs(1) = "fld_Champs1"
    fld_Champs(2) = "fld_Champs2"
    fld_Champs(3) = "fld_Champs3"
    fld_Champs(4) = "fld_Champs4"
    fld_Champs(5) = "fld_Champs5"
    fld_Champs(6) = "fld_Champs6"
    fld_Champs(7) = "fld_Champs7"
    fld_Champs(8) = "fld_Champs8"
    fld_Champs(9) = "fld_Champs9"
    fld_Champs(10) = "fld_Champs10"
    fld_Champs(11) = "fld_Champs11"
    fld_Champs(12) = "fld_Champs12"
    fld_Champs(13) = "fld_Champs13"
    fld_Champs(14) = "fld_Champs14"
    ' Place l'entête, ici j'utilise les noms de champs
    For iCompteur = 1 To iNombreChamps
        Worksheets("Feuil1").Cells(1, iCompteur).Value = fld_Champs(iCompteur)
    Next iCompteur
    ' Désigne la ligne de départ
    ' Ici on part à 2 car la première sont les entêtes de colonne
    iLigne = 2
    ' Vérification d'un traitement local ou non de la base Notes
    If bLocal Then
        ' Demande le mot de passe
        Session.Initialize
    Else
        ' Demande le mot de passe pour accèder au serveur.
        Session.InitializeUsingNotesUserName
    End If
    ' Test si l'objet est bien chargé en mémoire
    If Not (Session Is Nothing) Then
        ' Essai d'ouvrir la base
        Set db = Session.GetDatabase(asServeur, asBase, False)
        If Not db.IsOpen() Then
            ' Si la base n'est pas ouverte on réessai
            Call db.Open
            If Not db.IsOpen() Then
                MsgBox "Impossible d'ouvrir la base sur le serveur spécifié", vbCritical + vbOKOnly, "Erreur de connection à la base"
                Resume Fin
            End If
        End If
        ' Charge en mémoire la vue de travail
        Set vue = db.GetView(asVue)
        ' Test si la vue est ouverte
        If vue Is Nothing Then
            MsgBox "Impossible d'ouvrir la vue de la base", vbCritical + vbOKOnly, "Erreur d'ouverture de la vue de travail"
            Resume Fin
        End If
        ' Récupère le premier document père de la vue
        Set dPere = vue.GetFirstDocument
        ' Boucle jusqu'au dernier doc père
        Do While (Not dPere Is Nothing)
            If Not dPere.IsResponse Then
                ' Boucle sur les champs du doc père
                For iCompteur = 1 To iNombreChamps
                    sValeur(iCompteur) = dPere.GetItemValue(fld_Champs(iCompteur))(0)
                    ' Regarde si c'est un champs multivalué
                    If UBound(dPere.GetItemValue(fld_Champs(iCompteur))) > 0 Then
                        ' Boucle sur le reste des valeurs du champs
                        For iCompteurArray = 1 To UBound(dPere.GetItemValue(fld_Champs(iCompteur)))
                            ' Ajoute les valeurs sépararé par le séparateur définit en constante
                            sValeur(iCompteur) = sValeur(iCompteur) & Sep & dPere.GetItemValue(fld_Champs(iCompteur))(iCompteurArray)
                        Next iCompteurArray
                    End If
                Next iCompteur
                ' Test si on veut travailler sur des doc fils
                If bFils Then
                    ' Récupère les docs fils
                    Set cFils = dPere.Responses
                    ' Collection vide ou pas ?
                    If cFils.Count > 0 Then
                        ' Récupère le premier fils de la collection
                        Set dFils = cFils.GetFirstDocument
                        Do While (Not dFils Is Nothing)
                            ' Boucle sur les champs du doc fils
                            For iCompteur = 1 To iNombreChamps
                                ' Test si le champs existe dans le doc fils
                                If dFils.HasItem(fld_Champs(iCompteur)) Then
                                    ' Test si le champs n'est pas vide
                                    If dFils.GetItemValue(fld_Champs(iCompteur))(0) <> "" Then
                                        ' Test si la valeur du fils et du père sont différente
                                        If dPere.GetItemValue(fld_Champs(iCompteur))(0) <> dFils.GetItemValue(fld_Champs(iCompteur))(0) Then
                                            ' Ajoute la valeur
                                            sValeur(iCompteur) = dFils.GetItemValue(fld_Champs(iCompteur))(0)
                                            ' Regarde si c'est un champs multivalué
                                            If UBound(dFils.GetItemValue(fld_Champs(iCompteur))) > 0 Then
                                                ' Boucle sur le reste des valeurs du champs
                                                For iCompteurArray = 1 To UBound(dFils.GetItemValue(fld_Champs(iCompteur)))
                                                    ' Ajoute les valeurs séparé par le séparateur définit en constante
                                                    sValeur(iCompteur) = sValeur(iCompteur) & Sep & dFils.GetItemValue(fld_Champs(iCompteur))(iCompteurArray)
                                                Next iCompteurArray
                                            End If
                                        End If
                                    End If
                                End If
                            Next iCompteur
                            ' Document fils suivant
                            Set dFils = cFils.GetNextDocument(dFils)
                        Loop
                    End If
                End If
                ' Traitement des valeurs trouvé dans la feuille Excel
                For iCompteur = 1 To iNombreChamps
                    Worksheets("Feuil1").Cells(iLigne, iCompteur).Value = sValeur(iCompteur)
                Next iCompteur
                ' Passe à la ligne suivante
                iLigne = iLigne + 1
            End If
            ' document père suivant
            Set dPere = vue.GetNextDocument(dPere)
        Loop
    End If

Fin:
    Set dFils = Nothing
    Set cFils = Nothing
    Set dPere = Nothing
    Set vue = Nothing
    Set db = Nothing
    Set Session = Nothing
    Exit Sub
   
err_Traitement:
    MsgBox "Erreur " + Str(Err) + " : " + Chr(10) + CStr(Error) + ". ", vbCritical + vbOKOnly, " ERREUR !"
    Resume Fin
End Sub