DominoArea.org [Archive]

une version générique qui devrais t'aider

Code : Tout sélectionner

Public Sub ExportViewToExcel(wNameView As String,wCollection As NotesDocumentCollection)
   
        'wNameView contien le nom de la vue à traiter.
   
        'Déclaration des Variables
   Dim Doc As NotesDocument
   Dim vwView As NotesView
   Dim NameView As String
   Dim Selection As String
   Dim vwEntry As NotesViewEntry
   Dim vwViewColonne  As NotesViewColumn
   Dim vwNav As NotesViewNavigator
   Dim nbLigneTotal As Integer
   Dim nbColonneTotal As Integer
   Dim nbColonne As Integer
   Dim i As Long
   Dim objXLSApp As Variant
   Dim objXLSWorkbooK As Variant
   Dim objXLSWorkSheet As Variant
   Dim nbLigneXLS As Long
   Dim nbColonneXLS As Long
   Dim OngletXLS As String
   Dim t As String
   Dim lstDoc List As String
   Dim nbCollection As Integer
   'Dim UIWork As NotesUIWorkspace
   
   On Error Goto ErreurHandle
   
   Set UIWork = New NotesUIWorkSpace
   
   If DB Is Nothing Or Session Is Nothing Then
      Set Session = New NotesSession
      Set DB = Session.CUrrentdatabase
   End If
   
        'connexion à la vue a exporter
   If Trim(wNameView) = "" Then
      Set vwView = UIWork.CurrentView.View
   Else
      Set vwView = DB.getView(wNameView)
   End If
   
   If vwView Is Nothing Then
      Error 9999,"vwView is Nothing"
      Exit Sub
   End If
   
   nbCollection = False
   If Not wCollection Is Nothing Then
      If wCollection.Count > 0 Then
         Set Doc = wCollection.GetFirstDocument
         While Not Doc Is Nothing
            lstDoc(Ucase(Trim(Doc.UniversalID))) = Ucase(Trim(Doc.UniversalID))
            Set Doc = wCollection.GetNextDocument(Doc)
         Wend
         nbCollection = True
      End If
   End If
   
   NameView = vwView.Name
   
        'récupération du navigateur de vue
   Set vwNav = Nothing
   Set vwNav = vwView.createViewnav()
   
   If vwNav Is Nothing Then
      Msgbox "Le navigateur vue ''"+Trim(NameView)+"'' est introuvable.",16,"ERREUR !"
      Exit Sub
   End If
   
   nbLigneTotal = vwView.AllEntries.count
   nbColonneTotal = (vwview.ColumnCount-1)
   t = " / "+Cstr(nbLigneTotal)
   
         'On récupère une instance Excel ouverte.
   Set objXLSApp = Nothing
   Set objXLSApp=createobject("Excel.Application")
   objXLSApp.DisplayAlerts=False
   objXLSApp.Visible=True
        'On instancit un objet WorkBook Excel et on ouvre le fichier de mise a jour.
   Set objXLSWorkbooK=objXLSApp.Workbooks.add
   
     'On supprime les éventuelles feuilles en trop !
   While objXLSWorkbooK.sheets.count>1
      objXLSWorkbooK.sheets(2).select
      objXLSWorkbooK.sheets(2).Delete
   Wend
   
        'elimination des caratères interdit dans l'onglet de la feuille excel
   OngletXLS = NameView+", "+Format(Now,"DD-MM-YYYY HH-NN-SS")
   OngletXLS = Replace(OngletXLS,"/","")
   OngletXLS = Replace(OngletXLS,"\","")
   OngletXLS = Replace(OngletXLS,"?","")
   OngletXLS = Replace(OngletXLS,"*","")
   OngletXLS = Replace(OngletXLS,"[","")
   OngletXLS = Replace(OngletXLS,"]","")
   OngletXLS = Replace(OngletXLS,"}","")
   OngletXLS = Replace(OngletXLS,"{","")
   OngletXLS = Replace(OngletXLS,":","")
   
        'On renomme la première.
   objXLSWorkbooK.sheets(1).select
   objXLSWorkbooK.sheets(1).Name=Left(OngletXLS,31)
   
        'On sélectionne la feuille de calcul qui nous intéresse.
   objXLSWorkbooK.Sheets(1).Select
   Set objXLSWorkSheet = objXLSApp.selection
   
   nbColonneXLS = 1
   nbLigneXLS = 1
   
        'on renseigne la premiere ligne avec le titre des colonnes
'        Print  "Insert Colonne"
   For nbColonne =0 To  nbColonneTotal
      Set vwViewColonne=vwView.Columns(nbColonne)
      Selection = vwViewColonne.title
      If Trim(Selection) = "" Then
         Selection = "          "  '"Sans Titre"
      End If
      objXLSWorkSheet.Cells(nbLigneXLS,nbColonneXLS).Value = Selection
      nbColonneXLS = nbColonneXLS + 1
      Set vwViewColonne = Nothing
      Selection = ""
   Next
   
   nbColonneXLS = 1
   nbColonne =0
   nbLigneXLS = 2
   i = 0
   
        'remplissage de la feuille xls avec les données de la vue
   
   
   If nbCollection = False Then
      Set vwEntry=vwNav.GetFirstDocument
      Do While Not (vwEntry Is Nothing)
         nbLigneXLS = nbLigneXLS + 1
         For nbColonne =0 To         nbColonneTotal
            i = i+1
                '                Print  Cstr(i)+T
            objXLSWorkSheet.Cells(nbLigneXLS,nbColonneXLS).Value= vwEntry.ColumnValues(nbColonne)
            nbColonneXLS = nbColonneXLS+1
         Next
         nbColonneXLS = 1
         Set vwEntry = vwNav.getnextdocument(vwEntry)
      Loop
   Else
      Set vwEntry=vwNav.GetFirstDocument
      Do While Not (vwEntry Is Nothing)
         If Iselement ( lstDoc(Ucase(Trim(vwEntry.Document.UniversalID)))) = True Then
            nbLigneXLS = nbLigneXLS + 1
            For nbColonne =0 To         nbColonneTotal
               i = i+1
                        '                Print  Cstr(i)+T
               objXLSWorkSheet.Cells(nbLigneXLS,nbColonneXLS).Value= vwEntry.ColumnValues(nbColonne)
               nbColonneXLS = nbColonneXLS+1
            Next
         End If
         nbColonneXLS = 1
         Set vwEntry = vwNav.getnextdocument(vwEntry)
      Loop
   End If
   
   Erase lstDoc
   nbColonneXLS = 0
   nbColonne =0
   nbLigneXLS = 0
   i = 0
   Set vwView = Nothing
   Set vwNav = Nothing
   Set vwViewColonne = Nothing
   Set vwEntry= Nothing
   
        '**************************Mise en page des données excel
'        mise en page des titres des colonnes
   objXLSApp.Rows("1:1").Select
   objXLSApp.Selection.Font.Bold = True
   objXLSApp.Selection.Font.Underline = True
   
        'mise en page de la feuille
   objXLSApp.Cells.Select
'        objXLSApp.Range(objXLSWorkSheet.Cells(1,1), objXLSWorkSheet.Cells(nbLigneXLS,nbColonneXLS)).Select
   objXLSApp.Selection.Font.Name = "Arial"
   objXLSApp.Selection.Font.Size = 9
   objXLSApp.Selection.Columns.AutoFit
   With objXLSApp.Worksheets(1)
        '        .PageSetup.Orientation = 1
      .PageSetup.centerheader = NameView+", "+Format(Now,"DD-MM-YYYY HH:NN:SS")
      .Pagesetup.RightFooter = "Page &P" & Chr$(13) '+ "Date : &D"
      .Pagesetup.CenterFooter = ""
   End With
   
   objXLSApp.ReferenceStyle = 1
   objXLSApp.Range("A1").Select
   objXLSApp.Visible=True
   Set objXLSApp=Nothing '  l'automation excel
   Set objXLSWorkbooK= Nothing
   
   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

Bonjour

J'ai fait plusieurs tests sur ce code et là vraiment je bloque.

Quand tu as dit :

" concernant
Sheet.Cells(ligne,colonne) = colvals
colvals est un variant, regarde en débug ce qu'il contient a mon avis le pb vient de là "


J'ai fais des tests pour voir ce que contenait la variable "colvals" et je me suis appercue que quand l'extraction se plante, cette variable est vide.

Si tu as une idée de la manière dont je pourrais modifier ce code ce serait vraiment sympa.

Merci

tu peux tester si elle est vide

if isempty(colvals) = true then

else

end if