Class ExcelReport '""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" ' La classe Lotusscript ExcelReport permet de generer des fichier Excel ' a partir de Lotus Notes ' ' Copyright (C) 2002-2004 Thierry Seunevel ' ' This program is free software; you can redistribute it and/or modify ' it under the terms of the GNU General Public License as published by ' the Free Software Foundation; either version 2 of the License, or ' (at your option) any later version. ' ' This program is distributed in the hope that it will be useful, ' but WITHOUT ANY WARRANTY; without even the implied warranty of ' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ' GNU General Public License for more details. ' ' You should have received a copy of the GNU General Public License ' along with this program; if not, write to the Free Software ' Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ' ' Pour toute question, observation, feed-back sur ce programme, contacter : ' ' tseunevel@seusoft.com ' '""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" ' Executer un Calculate a la cloture (M001) ' Pb comparaison ignorant casse (M002) ' Protection contre références erronées dans initReport (M003) ' Traitement champs valeur multiple, suivant propriété WrapText de cellule (M004) ' Utilisation fillReportLine avec Document ou ViewEntry (M005) ' saveAs returns a boolean and add a method to get the error message (M006) '""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" ' ' Propriétés ' lineField (set) Nom de la plage définissant la ligne courante, par défaut REPORTLINE ' rangeValue (get) retourne contenu plage nommée ' sheet (set) Nom de la feuille cible et source des échanges. Par défaut, 1ere ' lastError (get) Texte erreur levé par derniere exception (M006) ' Méthodes ' initHeader définition en-tete document Excel à partir document Notes ' fillReportLine définition contenu une ligne courante depuis un document notes ' closeReport clos la génération du document Excel (appel auto si besoin) ' printOut impression document Excel ' saveAs sauvegarde classeur sous le nom passé en paramètre ' preView affiche docuemnt Excel en prévisualisation ' delete détruit objet et objets associés ' new instancie objet suivant modèle dont nom est passé en parm ' insertPgBreak Insére un saut de page avant la derniere ligne inseree '""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" Private xlApp As Variant Private xlSheet As Variant Private xlRange As Variant Private xlWRange As Variant Private xlRange0 As Variant Private xlNames As Variant Private lgCol As Long Private lineCount As Integer Private colFields() As String Private nbCols As Integer Private firstCol As Long Private lineFieldName As String Private sheetName As String Private reportInitialized As Integer Private colNumberUsed As Integer Private colNumberDefined As Integer Private reportClosed As Integer Private modelRow As Integer Private errMsg As String Sub New(ModelFile As String) Set xlApp=createObject("Excel.application") xlApp.visible=False xlApp.Workbooks.Open ModelFile lineFieldName="REPORTLINE" ' nom par défaut de la ligne modèle End Sub Property Set Sheet As String '""""""""""""----------"""""""""""""""""""""""""""""""""" ' Permet d'imposer un nom pour la feuille source et cible des échanges ' par défaut, 1ere feuille du classeur utilisée '"""""""""""""""""""""""""""""""""""""""""""""""""""" sheetName=Sheet End Property Property Set lineField As String '""""""""""""-------------""""""""""""""""""""""""" ' permet d'imposer un nom pour la ligne modèle de détail ' par défaut, nom = REPORTLINE ' si *NONE, pas de ligne détail '"""""""""""""""""""""""""""""""""""""""""""""" lineFieldName=lineField End Property Property Get LastError As String '#M006 LastError = errMsg End Property Private Sub initReport() '------------------------------------------------------------------------------------ ' initialisation champs détail du modèle Excel : liste des champs de la ligne détail '------------------------------------------------------------------------------------ Dim sName As String If sheetName <> "" Then Set xlSheet = xlApp.Workbooks(1).Worksheets(sheetName) Else Set xlSheet = xlApp.Workbooks(1).Worksheets(1) End If On Error Resume Next '#M003 Set xlNames=xlApp.Workbooks(1).Names If Ucase$(LineFieldName) <>"*NONE" Then ' #M002 Set xlRange=xlNames(lineFieldName).refersToRange() If Err = 0 Then '#M003 Set xlRange0=xlRange modelRow=xlRange.Row firstCol=xlRange.column nbCols=xlRange.Columns(xlRange.Columns.Count).Column - firstCol + 1 Redim colFields(nbCols-1) Forall nm In xlNames sName = nm.Name If Instr(sName , "!") = 0 Then Set xlWRange=nm.refersToRange() If Err = 0 Then '#M003 If Ucase$(sName) <> Ucase$(lineFieldName) And xlWRange.Row = modelRow Then '#M002 If Ucase$(Mid$(sName, 2 ,4)) = "COL." Then If Isnumeric(Right$(sName, Len(sName) - 5)) Then If Ucase$(Left$(sName, 1)) = "V" Then colFields(xlwRange.Column - firstCol) = "*V" & Right$(sName, Len(sName) - 5) Else colFields(xlwRange.Column - firstCol) = "*A" & Right$(sName, Len(sName) - 5) End If colNumberUsed = True End If Else colFields(xlwRange.Column - firstCol) = sName End If End If Else Print "Error " & Err & " " & Error() & " trying to use the named range " & sName End If '#M003 End If End Forall Else Print "Error " & Err & " " & Error() & " trying to use the range " & LineFieldName End If End If Err=0 On Error Goto 000 reportInitialized=True End Sub Public Sub initHeader(aDoc As notesDocument) '"""""""-----------------""""""""""""""""""""""""" ' Initialisation de champs d'en-tete en fonction de noms de champs ' du modèle XLS, et du contenu d'un document d'entête. ' si initReport n'a pas été exécuté, exécution '"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" Dim sName As String If Not reportInitialized Then initReport Forall nm In xlNames sName = nm.Name If Instr(sName , "!") = 0 Then Set xlWRange=nm.refersToRange() If xlWRange.Row <> modelRow Then If aDoc.hasItem(sName) Then fillRange xlWRange.Cells(1, 1), aDoc.getItemValue(sName) '#M004 End If End If End If End Forall End Sub Public Function fillReportLine(vNotesObj As Variant) As Integer '#M005 '""""""""""" --------------------- """""""""""""""""""""""""""""""""" ' remplit ligne courante du document excel, retourne le numéro de ligne détail courant '------------------------------------------------------------------------------------ Dim sName As String Dim vValue If Not reportInitialized Then initReport If colNumberUsed And Not colNumberDefined Then defColNumbers vNotesObj '#M005 End If lineCount=lineCount+1 If lineCount=1 Then Set xlRange=xlRange.offset(-1,0) Else xlRange.insert ' insérer ligne pour prochain document Set xlRange=xlRange.offset(-1,0) End If xlRange0.copy(xlRange) For lgCol=1 To xlRange.Columns.count sName = colFields(lgCol-1) If sName <> "" Then If Left$(sName, 1) = "#" Then vValue = vNotesObj.ColumnValues(Cint(Right$(sName, Len(sName) -1))) Else If vNotesObj Isa "NotesDocument" Then '#M005 vValue = vNotesObj.getItemValue(sName) Else '#M005 If vNotesObj.isDocument Then '#M005 vValue = vNotesObj.Document.getItemValue(sName) '#M005 End If '#M005 End If '#M005 End If fillRange xlRange.Cells(1,lgCol), vValue '#M004 End If Next Set xlWrange=xlRange Set xlRange=xlRange.offset(1,0) fillReportLine=lineCount End Function '""""""""""-------------------------""""""""""""""""""""""""""" Public Sub insertPgBreak() xlWRange.PageBreak = 1 End Sub Public Sub closeReport '"""""""--------------------""""""""""""""""""""""""""""""""""""""""""""""" ' routine fermant l'état en cours. appelée automatiquement si besoin '"""""""""""""""""""""""""""""""""""""""""""""""""""" If lineCount>0 Then xlRange.Delete Set xlRange=xlWRange.offset(1,0) For lgCol=1 To xlWRange.Columns.count xlRange.Cells(1,lgCol).Value=xlWRange.Cells(1,lgCol).Value Next xlWRange.delete End If ReportClosed=True xlApp.Calculate ' M001 End Sub Public Sub printOut '"""""""--------------"""""""""""""""""""""""""""""""""""" ' Appel impression document closeReport appelé si besoin '"""""""""""""""""""""""""""""""""""""""""""""""""""" If Not ReportClosed Then closeReport xlSheet.printOut End Sub Public Sub preView '"""""""--------------"""""""""""""""""""""""""""""""""""" ' Appel visualisation écran (aperçu avant impression) '"""""""""""""""""""""""""""""""""""""""""""""""""""" If Not ReportClosed Then closeReport xlApp.visible=True xlSheet.printPreview End Sub Public Function saveAs(fileName As String) As Integer ' #M006 '"""""""""""-----------"""""""""""""""""""""""""""""""""""" If Not ReportClosed Then closeReport On Error Goto errSave xlSheet.SaveAs fileName saveAs = True Exit Function errSave: errMsg = "Error while saving : " & Err & " " & Error(Err) Exit Function End Function Property Get RangeValue(rgName As String) As Variant '"""""""""""""---------------------------------"""""""""""""""""""" ' lecture des valeurs contenues dans la plage nommée rgName ' si plage de + d'une cellule, retour d'un tableau '---------------------------------------------------------------------------------- Dim wRange As Variant,wResult As Variant Dim nbCols As Long,nbRows As Long, r As Integer,c As Integer, x As Integer If Not ReportInitialized Then initReport On Error Resume Next Set wRange=xlNames(rgName).refersToRange() If Err<>0 Then Exit Property On Error Goto 000 nbCols=wRange.Columns.count nbRows=wRange.Rows.count If ( nbCols * nbRows) = 1 Then wResult=wRange.Cells(1,1).Value Else Redim wResults((nbCols * nbRows)-1) For c=1 To nbCols For r=1 To nbRows wResult(x)=wRange.cells(r,c).Value x=x+1 Next Next End If RangeValue=wResult End Property Public Sub Delete '""""""""""""""""""" If Not xlSheet Is Nothing Then xlApp.activeWorkbook.close False If Not xlApp Is Nothing Then xlApp.quit Set xlApp=Nothing End Sub Private Sub defColNumbers(vObj As Variant) '#M005 '""""""""""""""""""""""""""""""""""""" Dim vw As NotesView Dim par Dim diff() As Integer, nbr As Integer, ix As Integer If vObj Isa "NotesDocument" Then '#M005 Set vw = vObj.ParentView '#M005 Else '#M005 Set vw =vObj.Parent '#M005 End If '#M005 If vw Is Nothing Then Exit Sub End If Redim diff(vw.columnCount - 1) Forall col In vw.columns If col.isHidden Then nbr = nbr + 1 diff(ix) = nbr ix = ix + 1 End Forall For ix = 0 To Ubound(colFields) If Left$(colFields(ix), 1) = "*" Then nbr = Cint(Right$(colFields(ix) ,Len(colFields(ix)) - 2)) -1 If Mid$(colFields(ix), 2, 1) = "V" Then nbr = nbr + diff(nbr) If nbr <= Ubound(diff) Then colFields(ix) = "#" & Cstr(nbr) Else colFields(ix) = "" End If End If Next colNumberDefined = True End Sub Private Sub fillRange(tgtRange As Variant, vValue As Variant) '"""""""""""""""""""""""""""""""""""""""""""""""""""""" ' Remplit cellule unique de tgtRange avec valeur champ vValue ' suivant propriété wrapText, remplace valeurs multiples/lignes multiples '"""""""""""""""""""""""""""""""""""""""""""""""""""""""" Dim strOut As String, strSep As String If Isarray(vValue) Then If tgtRange.WrapText Then strSep = Chr$(10) Else strSep = " " End If Forall st In vValue If Len(strout) > 0 Then strOut = strOut & strSep End If strOut = strOut & clean0D(Cstr(st)) End Forall Else strOut = clean0D(Cstr(vValue)) End If tgtRange.Value = strOut End Sub Private Function clean0D(strIn As String) As String '"""""""""""""""""""""""""""""""""""""""""""""""""""" ' retire caractère 0D si présent dans chaine '"""""""""""""""""""""""""""""""""""""""""""""""""""" Dim strOut As String, strWrk As String Dim ps As Integer strOut = strIn ps = Instr(strOut, Chr$(13)) While ps > 0 If ps > 1 Then strWrk = Left$(strOut, ps - 1) Else strWrk = "" End If If ps < Len(strOut) Then strWrk = strWrk & Right$(strOut, Len(strOut) - ps) End If strOut = strWrk ps = Instr(ps, strOut, Chr$(13)) Wend clean0D = strOut End Function End Class