DominoArea.org [Archive]

cet export se base sur celui déjà existant
il export la vue courante

- il n'exporte pas les colonnes caché, les colonnes de type icone, les colonne de type compteur (c'est à dire de formule "1")

il gère en plus
- les catégories multiple, c'est à dire les catégorie contenant des \ qui crée des sous catégories dans la vue
- les entrées multiple par catégorie (quand un document se retrouve plusieurs fois sous deux catégories différente)
- les colonnes constante

pour l'utilisation :
il faut mettre ce code dans un agent de type lotus-script

et exécuter l'agent en étant dans une vue
en espérant que cela serve a quelqu'un un jour

Code : Tout sélectionner

%REM
   Agent Export CurrentView
   Created Nov 29, 2011 by Laurent Song
   Description: Comments for Agent
%END REM
Option Public
Option Declare

Sub Initialize
   Dim Session As New NotesSession
   Dim db As NotesDatabase
   Dim entry As NotesViewEntry
   Dim ColVals As Variant
   Dim LColIndex List As Integer ' liste des index des colonne dans excel : cela permet d'ajouter des colonnes en cas de catégorie multiple
   Dim LColCat List As Integer ' Liste des catégories avec le nombre de niveaux
   Dim LColSortAsc List As Boolean ' Sens du tris sur les colonnes catégorisées
   Dim rows As Integer
   Dim cols As Integer
   Dim ColumnValues () As variant
   Dim LConstant List As string
   Dim LCatMultiContent List As String
   Dim VCat As Variant
   Dim delta As Integer
   Dim maxcols As Integer
   Dim WS As New NotesUIWorkspace
   Dim Scope As String
   Dim C As NotesViewColumn
   Dim K As Integer
   Dim xlApp As Variant
   Dim xlsheet As Variant
   Dim vwNav As NotesViewNavigator
   Dim tmp As String
   Dim dataview As NotesView
   
   '***** Vous pouvez modifier le code pour qu'il fasse appel à une autre base de document
   Set db = session.CurrentDatabase
   
   Set dataview = WS.Currentview.View   ' Ouvre la vue courrante

   Set vwnav= dataview.createViewnav()

   rows = 1
   cols = 1
   maxcols=dataview.ColumnCount     ' Récupère le nombre de colonne
   ' initialisation de toutes les listes
   Call init(LColIndex, LColCat, LColSortAsc, LConstant, maxcols, dataview)
   
   Set xlApp = CreateObject("Excel.Application")' Lance Excel
   Print "Création du tableau. Veuillez patienter..."
   
   xlApp.Workbooks.Add
   xlApp.ReferenceStyle = 2
   Set xlsheet = xlApp.Workbooks(1).Worksheets(1) ' On prend la première feuille du classeur

   ' On met le titre de la vue
   xlsheet.Cells(rows,cols).Value ="Vue : " + dataview.Name + ", de la base : " + db.title +", extraction du : " + Format(Now,"mm/dd/yyyy HH:MM")

   Print "Création des entêtes de colonnes. Veuillez patienter..."

   rows=2 ' On commence à la deuxième ligne : les titres des colonnes
   For K=1 To maxcols
      Set c=dataview.columns(K-1)
      If c.Ishidden = False and c.Isicon = False And c.Formula <> "1" Then
         xlsheet.Cells(rows,cols).Value = c.title
         cols = cols + 1
      End If
   Next K

   Set entry=vwnav.GetFirstDocument
   rows=3 ' On se place sur la troisième ligne : debut des données
   ReDim ColumnValues (maxcols) As variant
   Do While Not (entry Is Nothing)
      ' il faut recomposer le tableau avec les colonnes constante, le tableau ColumnValues contient le resulat
      Call RecomposeData (LConstant, ColumnValues, entry)
      
      ' ecriture des colonnes
      For cols=0 To maxcols-1
         colvals=ColumnValues(cols)
         scope=TypeName(colvals)
         If LColIndex(cols) >=0 Then ' si on doit l'ecrire :
            If IsElement (LColCat (cols)) Then ' si c'est une categorie
               ' Cas des categorie multiple
               ' on va crée une list d'ID avec les element Par unid
               If IsArray (colvals) Then
                  If IsElement (LCatMultiContent (entry.Universalid)) Then
                     ' ce n'est pas le premire fois que l'on trouve cette entrée on va reprendre la liste qu'il reste
                     colvals = Split (LCatMultiContent (entry.Universalid), "§¤")
                  Else
                     ' C'est la premiere fois que l'on rencontre ce document, on va le trié
                     Call SortBubble (colvals)
                  End If
                  
                  ' Selon l'ordre de trie
                  If LColSortAsc(cols) Then
                     tmp = colvals (0) ' on prend le premier
                     colvals (0) = ""
                     If UBound (colvals) = 0 Then
                        Erase LCatMultiContent (entry.Universalid)
                     Else
                        LCatMultiContent (entry.Universalid)= Implode (colvals, "§¤")
                        LCatMultiContent (entry.Universalid)= Right (LCatMultiContent (entry.Universalid), Len (LCatMultiContent (entry.Universalid))-2)
                     End If
                  Else
                     tmp = colvals (UBound (colvals))
                     colvals (UBound (colvals)) = ""
                     If UBound (colvals) = 0 Then
                        Erase LCatMultiContent (entry.Universalid)
                     Else
                        LCatMultiContent (entry.Universalid)= Implode (colvals, "§¤")
                        LCatMultiContent (entry.Universalid)= Left (LCatMultiContent (entry.Universalid), Len (LCatMultiContent (entry.Universalid))-2)
                     End If
                  End If
                  
                  colvals = tmp
                  
               End If
               ' c'est une categorie avec x elements

               If InStr (colvals, "\") > 0 Then
                  
                     VCat = Split (colvals, "\")
                  If UBound (Vcat) > LColCat (cols) Then
                     ' ajouter les colones necessaire au fichier excel
                     
                     While UBound (Vcat) > LColCat (cols)
                        xlsheet.Columns(cols+LColCat (cols)).Select
                        Call xlApp.Selection.EntireColumn.Insert
                        LColCat (cols) = LColCat (cols) + 1
                     Wend
                     
                     ' decaler l'index en consequance
                     Dim subcols As Integer
                     For subcols=cols To maxcols
                        LColIndex (subcols+1) = LColIndex (subcols+1) + LColCat (cols)
                     Next
                  End If
                  delta = 0
                  ' remplissage
                  ForAll Ecat In Vcat
                     xlsheet.Cells(rows,LColIndex(cols)+delta).Value ="'" + Ecat
                     delta = delta+1
                  End ForAll
               Else
                  xlsheet.Cells(rows,LColIndex(cols)).Value ="'" + colvals
               End If
            Else
               
               ' Cas des colonne normal
               If IsArray (colvals) Then 's'il y a plusieurs element dans la ligne 
                  colvals = Implode (colvals, " ")
               End If
               
               Select Case scope
               Case "STRING"
                  xlsheet.Cells(rows,LColIndex(cols)).Value ="'" + colvals
               Case Else
                  xlsheet.Cells(rows,LColIndex(cols)).Value = colvals
               End Select
            End If
         End If
      Next cols
      Print "Import des données - Document " & rows-1 
      rows=rows+1
      Set entry = vwnav.getnextdocument(entry)
   Loop

   ' mise en page du document excel
   xlApp.Rows("1:1").Select
   xlApp.Selection.Font.Bold = True
   xlApp.Selection.Font.Underline = True
   
   xlApp.Rows("2:2").Select
   xlApp.Selection.Font.Bold = True
   xlApp.Selection.Font.Name = "Arial"
   xlApp.Selection.Font.Size = 8

   xlApp.Range(xlsheet.Cells(3,1), xlsheet.Cells(rows,maxcols)).Select
   xlApp.Selection.Font.Name = "Arial"
   xlApp.Selection.Font.Size = 8
   xlApp.Selection.Columns.AutoFit
   With xlApp.Worksheets(1)
      .PageSetup.Orientation = 2
      .PageSetup.centerheader = "Rapport"
      .Pagesetup.RightFooter = "Page &P" & Chr$(13) & "Date : &D"
      .Pagesetup.CenterFooter = ""
   End With
   xlApp.ReferenceStyle = 1

   
   xlApp.Rows("3:3").Select
   xlApp.ActiveWindow.FreezePanes = True

   xlApp.Range("A1").Select
   xlApp.Visible = True
   
   print "L'import des données de la vue est terminé."
   dataview.clear

   Set xlapp=Nothing ' Stop l'automation excel
   Set db=Nothing
End Sub

%REM
   Sub index
   Description: Comments for Sub
%END REM
Sub init (LColIndex List As Integer, LColCat List As Integer, LColSortAsc List As Boolean, LConstant List As String, max As Integer, dataview As NotesView)
   Dim i As Integer
   Dim K As Integer
   Dim L As Integer
   Dim c As NotesViewColumn
   
   For i = 0 To max-1
      LColIndex(i) = i+1
   Next
   
   
   For K=0 To max-1
      Set c=dataview.columns(K)      
      If c.Iscategory Then
         LColCat (K) = 0
         If c.Issortdescending Then
            LColSortAsc(K) = False
         Else
            LColSortAsc(K) = True
         End If
      End If
      If c.Ishidden Or c.Isicon Or c.formula = "1" Then
         LColIndex(K) = -1000
         For L=K+1 To max-1
            LColIndex(L) = LColIndex(L) -1
         Next
      End If
      If c.Isconstant Then
         ' on va noter ou elle est
         LConstant (K) = c.Formula
      End If
   Next
End Sub



%REM
   Sub RecomposeData
   Description: Comments for Sub
%END REM
Sub RecomposeData (LConstant List As String, ColumnValues () As variant, entry As NotesViewEntry)
   Dim i As Integer
   
   
   i = 0
   ForAll elemColVal In entry.ColumnValues
      While IsElement (LConstant(i))
         ColumnValues (i) = LConstant(i)
         i = i + 1
      Wend
      ColumnValues (i) = elemColVal
      i = i + 1
   End ForAll
End Sub
Sub SortBubble(vrTable As Variant)
   
   'Tri à bulle par ordre croissant
   
   'Déclaration Variables
   Dim nbUBound As Long
   Dim nbLbound As Long
   Dim i As Long
   Dim J As Long
   Dim vrValue As Variant
   
   On Error GoTo ErreurHandle
   
   nbLbound = LBound(vrTable)
   nbUBound = UBound(vrTable)
   
   If nbUBound = nbLbound Then
      'si 1 seule donnée pas de traitement
      Exit Sub
   ElseIf nbUBound = (nbLbound+1) Then
      'si uniquement 2 données
      If  vrTable(nbLbound) >  vrTable(nbUBound) Then
         vrValue = vrTable(nbUBound)
         vrTable(nbUBound) = vrTable(nbLbound)
         vrTable(nbLbound) = vrValue
         vrValue = Null
      End If
      Exit Sub
   End If
   
   'Tri du tableau
   For i=nbLbound To nbUBound-1
      J = i
      While (J>=i)
         If vrTable(J+1) < vrTable(J) Then
            vrValue = vrTable(J)
            vrTable(J) = vrTable(J+1)
            vrTable(J+1) = vrValue
         End If
         J = J-1
      Wend
   Next
   vrValue = Null
   
   Exit Sub
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 !"
   Exit Sub
End Sub