Excel

[VastoMarine]

Concerne : Export excel

Bonjour,

Je souhaite lors de l'export vers excel des documents sélectionnes d'une vue, chaque document s'affiche dans nouvelle feuille (ou onglet) d'Excel ?

Exemple :

3 documents sélectionnés dans une vue.
Export vers excel via un bouton
Document 1 dans Feuil1
Document 2 dans Feuil2
et le dernier dans Feuil3

Merci

[Michael DELIQUE]

salut

tu trouvera un exemple dans ce code

Code : Tout sélectionner

Public Function ExportGlobalDocumentXLS(wCollection As notesDocumentCollection, wnbNomChamp As Integer,wnbChampSystem As Integer)
   
   rem cette function permet d'exporter tous tous les champs d'un document vers un fichier excel
   rem wNomchamp =  true = insertion des nom des champs dans la premeire ligne
   rem wvrChampSystem  = true = insertion des champs commençant par un "$"

   Dim Doc As NotesDocument
   Dim item As NotesITem   
   Dim lstChamp2 List As String
   Dim lstChamp3 List As String
   Dim Mess As String
   Dim vrAffiche As String
   Dim OngletXLS As String
   Dim PathFile As String
   Dim Champ As String
   
   Dim nbChamp_Sys As Integer
   Dim nbNomChamp As Integer
   Dim objXLSApp As Variant
   Dim objXLSWorkbooK As Variant
   Dim objXLSWorkSheet As Variant   
   Dim nbDoc As Long
   Dim nbLigne As Long
   Dim i As Long
   Dim J As Long
   Dim K As Long
   Dim nbColonneXLS As Long
   Dim nbOngletXLS As Integer
   Dim nbChamp As Integer
   Dim lstChamp List As Integer
   
   Dim vrItem As Variant
   
   On Error Goto CatchError
   
   If DB Is Nothing Or Session Is Nothing Then
      Set Session = New NotesSession
      Set DB = Session.CUrrentdatabase
   End If
   
   If wCollection Is Nothing Then
      Msgbox "Il n'y a aucun document à exporter.",48," ATTENTION !"
      Exit Function
   Elseif wCOllection.count=0 Then
      Msgbox "Il n'y a aucun document à exporter.",48," ATTENTION !"
      Exit Function
   End If
   
   nbDoc = Clng(wCollection.count)
   nbChamp_Sys = wnbChampSystem
   nbNomChamp = wnbNomChamp
   
   rem la liste d'un champs pouvant varier d'un document à l'autre,
   rem la fonction commence par dresser la liste exhaustive de tous les champs pour tous les documents
   
   Set Doc = wCollection.getFirstDocument
   While Not Doc Is Nothing
      vrItem = Doc.Items
      Forall Value2 In vrItem
         Champ = Ucase(Trim(Value2.name))
         If nbChamp_Sys = False Then
            If Left(Trim(Champ),1) <> "$" Then
               lstChamp2(Ucase(Trim(Champ))) = Ucase(Trim(Champ))
            End If
         Else
            lstChamp2(Ucase(Trim(Champ))) = Ucase(Trim(Champ))
         End If
         
         Champ = ""
      End Forall
      vrItem = Null
      Set Doc = wCollection.getNextDocument(Doc)
   Wend
   
   rem tri les champs par odre croissant
   Call SortingList(lstChamp2,true)
   
   nbChamp = 0
   
   rem transfert dans les listes utilisés pour la génération
   Forall Value In lstChamp2
      nbChamp = nbChamp+1
      lstChamp(Trim(Value)) = nbChamp
      lstChamp3(nbChamp) = Trim(Value)
   End Forall
   
   Erase lstChamp2
   
   vrAffiche = True
   
   rem On récupère une instance Excel ouverte.
   Set objXLSApp = Nothing
   Set objXLSApp=createobject("Excel.Application")
   objXLSApp.DisplayAlerts=False
   objXLSApp.Visible=vrAffiche
   
   rem On instancit un objet WorkBook Excel et on ouvre le fichier de mise a jour.
   Set objXLSWorkbooK=objXLSApp.Workbooks.add
   
   rem On supprime les éventuelles feuilles en trop !
   While objXLSWorkbooK.sheets.count>1
      objXLSWorkbooK.sheets(2).select
      objXLSWorkbooK.sheets(2).Delete
   Wend
   
   
   rem un ongle Excel peut contnir au maximum 256 colonne
   rem s'il ya plus de 256 colonnes la fonction génére autant d'onglet que de multiple de 256
   
   If nbCHamp > 256 Then
      
      i = nbCHamp
      nbOngletXLS = -1
      
      While i > 0
         nbOngletXLS = nbOngletXLS + 1
         i = i - 256
      Wend
      
      For i=1 To nbOngletXLS
         objXLSWorkbooK.sheets(i).select
         objXLSWorkbooK.sheets.add
      Next
      For i = 1 To objXLSWorkbooK.sheets.count
         OngletXLS = "EXPORT ONGLET N° "+Cstr(i)
         objXLSWorkbooK.sheets(i).Name=Left(OngletXLS,31)
      Next
   Else
      rem On renomme la première.
      OngletXLS = "EXPORT DU "+Format(Now,"dd-mm-yyyy")
      objXLSWorkbooK.sheets(1).select
      objXLSWorkbooK.sheets(1).Name=Left(OngletXLS,31)
   End If
   
   nbOngletXLS = objXLSWorkbooK.sheets.count
   
   rem On sélectionne la feuille de calcul qui nous intéresse.
   objXLSWorkbooK.Sheets(1).Select
   Set objXLSWorkSheet = objXLSApp.selection
   
   objXLSApp.Cells.Select
   objXLSApp.Selection.NumberFormat = "@"
   objXLSApp.Selection.HorizontalAlignment = -4131      
   
   If nbNomChamp = True Then
      
      rem Insersion du nom des champs dans la permière ligne
      If nbCHamp <= 256 Then
         For i = 1 To nbCHamp
            objXLSWorkSheet.Cells(1,i).Value = Cstr(lstChamp3(i))
         Next
      Else
         J = 0
         K = 1
         For i = 1 To nbCHamp
            J = J+1
            If J > 256 Then
               J = 1
               K = K+1
               objXLSWorkbooK.sheets(K).select
               Set objXLSWorkSheet = objXLSApp.selection
            End If
            objXLSWorkSheet.Cells(1,J).Value = Cstr(lstChamp3(i))
         Next
      End If
      nbLigne = 2
   Else
      nbLigne = 0
   End If
   
   Set Item = Nothing
   
   Set Doc = wCollection.getFirstDocument
   While Not Doc Is Nothing
      nbLigne = nbLigne +1
      If nbCHamp > 256 Then
         objXLSWorkbooK.Sheets(1).Select
         Set objXLSWorkSheet = objXLSApp.selection
         J = 0
         K = 1
         For i = 1 To nbCHamp
            J = J+1
            Champ = Cstr(lstChamp3(i))
            If nbChamp_Sys = False Then
               If Left(Trim(Champ),1) = "$" Then
                  Champ = ""
               End If
            End If
            If Trim(CHamp)<>"" Then
               
               If J > 256 Then
                  J = 1
                  K = K+1
                  objXLSWorkbooK.sheets(K).select
                  Set objXLSWorkSheet = objXLSApp.selection
               End If
               Set Item = Doc.getFirstItem(Champ)
               If Not Item Is Nothing Then
                  objXLSWorkSheet.Cells(nbLigne,J).Value = Cstr(Item.text)
               End If   
            End If
         Next
         
      Else
         vrItem = Doc.Items
         Forall Value2 In vrItem
            Champ = Ucase(Trim(Value2.name))
            If nbChamp_Sys = False Then
               If Left(Trim(Champ),1) = "$" Then
                  Champ = ""
               End If
            End If
            If Trim(Champ) <> "" Then
               Set Item = Doc.getFirstItem(Champ)
               If Not Item Is Nothing Then
                  nbColonneXLS = lstChamp(Ucase(Trim(Champ)))
                  objXLSWorkSheet.Cells(nbLigne,nbColonneXLS).Value = Item.text
               End If
            End If
            Set Item = Nothing
            Champ = ""
         End Forall
         vrItem = Null
      End If
      Set Doc = wCollection.getNextDocument(Doc)
   Wend
   
   Erase lstChamp3
   Erase lstChamp
   
   For i = 1 To nbOngletXLS
      
      objXLSWorkbooK.sheets(i).select
      Set objXLSWorkSheet = objXLSApp.selection
      
      rem mise en page de la feuille
      objXLSApp.Cells.Select
      rem objXLSApp.Range(objXLSWorkSheet.Cells(1,1), objXLSWorkSheet.Cells(nbLigne,nbColonneXLS)).Select
      objXLSApp.Selection.NumberFormat = "@"
      objXLSApp.Selection.HorizontalAlignment = -4131   
      objXLSApp.Selection.Font.Name = "Arial"
      objXLSApp.Selection.Font.Size = 9
      objXLSApp.Selection.Columns.AutoFit
      With objXLSApp.Worksheets(i)
         REM Portrait Orientation = 1, paysage Orientation = 2
         .Pagesetup.Orientation = 2
         .PageSetup.centerheader = "&8"+UCase(Trim(DB.title))+" - Export du "+Format(Now,"DD-MM-YYYY à HH:NN:SS")
         .Pagesetup.Rightheader = "&8Page &P / &T"
         .Pagesetup.CenterFooter = ""
         .Pagesetup.TopMargin = 30
         .Pagesetup.LeftMargin = 10
         .Pagesetup.RightMargin = 10
         .Pagesetup.BottomMargin = 10
         .Pagesetup.FooterMargin = 0
         .Pagesetup.HeaderMargin = 0
         .Pagesetup.CenterFooter = ""
         .Pagesetup.CenterHorizontally = True
      End With
      objXLSApp.ReferenceStyle = 1      
      
      If nbNomChamp = True Then
         rem mise en page des titres des colonnes
         objXLSApp.Rows("1:1").Select
         objXLSApp.Selection.Font.Bold = True
         objXLSApp.Selection.Font.Underline = True
      End If
      
      objXLSApp.Range("A1").Select
      
   Next
   
   objXLSWorkbooK.Sheets(1).Select
   Set objXLSWorkSheet = objXLSApp.selection
   objXLSApp.Range("A1").Select
   
   If nbChamp_Sys = True Then
      nbLigne = nbLigne-2
   End If
   
   
   If vrAffiche = False   Then
      
      rem ferme et enregistre le fichier excel
      objXLSApp.Visible=False
      objXLSApp.ActiveWorkbook.saveas PathFile ' Sauve le document
      objXLSApp.ActiveWorkBook.close
      objXLSApp.quit
      
      Select Case Trim(Cstr(nbDoc))
      Case ""
         Mess = "Zéro document exporté."
      Case "0"
         Mess = "Zéro document exporté."
      Case "1"
         Mess = "Un document exporté."
      Case Else
         Mess = Cstr(nbDoc) +" documents ont été exportés."
      End Select
      
      Msgbox Mess,64,"FIN D'EXPORTATION"
      
   End If      
   
   Set objXLSApp=Nothing
   Set objXLSWorkbooK= Nothing
   Set objXLSWorkSheet = Nothing
   
   Exit Function
CatchError:
   Erase lstChamp
   Erase lstChamp2
   Erase lstChamp3
   Set objXLSApp=Nothing
   Set objXLSWorkbooK= Nothing
   Set objXLSWorkSheet = Nothing
   MsgBox "("+Structure_Log+" : "+Cstr(GetThreadInfo (1))+" Call by "+Cstr(GetThreadInfo(10))+")"+Chr(10)+"Error " + CStr(Err) + " : "+Chr(10) + CStr(Error)+". "+Chr(10)+"Line # "+Cstr(Erl),16," ERROR !"
   Exit Function
End Function

[VastoMarine]

Merci Michael pour la solution.