Classe Excel

[billbock]

Code : Tout sélectionner

Class Excel 'SLV1
   
Declare Property Set E_Visible As Integer
Declare Property Set E_DisplayAlerts As Integer
Declare Property Set E_NewFile As Integer
Declare Property Set E_NameFile As String
Declare Property Get E_FileName As String
Declare Property Set E_NameSaveFile As String
Declare Property Get E_SaveFileName As String
   
   Private P_EXCEL As Integer
   Private P_NewFile As Integer
   Private P_strFileName As String
   Private P_strSaveFileName As String
   Private EO As Variant
   Private EODoc As Variant
   Private vxlsFeuilles As Variant
   Private vxlsFeuille As Variant
   
     '-----------------------------------------
   'New Instance of the Class
   '-----------------------------------------
   Sub New
      Print "Initialisation de la classe Excel"   
   End Sub
   
   '------------------------------------------------------------------------
   'Properties to Set the visible the object EXCEL
   '------------------------------------------------------------------------
   Property Set E_Visible As Integer
      If E_Visible = 0 Then
         Me.P_EXCEL = False
      Elseif E_Visible =1 Then
         Me.P_EXCEL = E_Visible
      Else
         Me.P_EXCEL = False
      End If     
   End Property
   
   '-------------------------------------------------------------------------------
   'Properties to get the name of the template to Open
   '-------------------------------------------------------------------------------
   Property Set E_NameFile As String
      'If Dir$(E_NameFile) <> "" Then
      P_strFileName = E_NameFile
      'Else         
      '   ManageError 0,"Ce modéle : "+ E_NameFile +" de document n'a pu être trouvé", "Avertissements"
      'End If
   End Property
   
   '---------------------------------------------   
   'Put the selection in bold font
   '---------------------------------------------
   Public Function Be_Bold_Cell(D_Cel As Integer,F_Cel As Integer,D1_Cel As Integer,F1_Cel As Integer)
      Dim vSelection As Variant      
      Set vSelection = vxlsFeuille.Range(D_Cel &":"& F_Cel,D1_Cel &":"& F1_Cel)
      vSelection.Font.Bold = True
   End Function
   
   '## STZ ##############################################
   '-------------------------------------------------------------------------------
   'Select a range in specified worksheet with int coordinates
   '-------------------------------------------------------------------------------
   Public Sub SetHeaderFooter (psSheetName As String, psPart As String, psValue As String)
      
      Set vxlsFeuilles =  EO.Sheets
      vxlsFeuilles(psSheetName).Activate
      Set vxlsFeuille = vxlsFeuilles(psSheetName)
      Select Case psPart
      Case "LeftHeader":
         vxlsFeuille.PageSetup.LeftHeader = psValue
      Case "CenterHeader":
         vxlsFeuille.PageSetup.CenterHeader = psValue
      Case "RightHeader":
         vxlsFeuille.PageSetup.RightHeader = psValue
      Case "LeftFooter":
         vxlsFeuille.PageSetup.LeftFooter = psValue
      Case "CenterFooter":
         vxlsFeuille.PageSetup.CenterFooter = psValue
      Case "RightFooter":
         vxlsFeuille.PageSetup.RightFooter = psValue
      End Select
   End Sub
   
   '------------------------------------------------------------------------
   'Property to Display alerts or not
   '------------------------------------------------------------------------
   Property Set E_DisplayAlerts As Integer
      EO.DisplayAlerts = E_DisplayAlerts
   End Property
   
   '-------------------------------------------------------------------------------
   'Select a range in specified worksheet with int coordinates
   '-------------------------------------------------------------------------------
   Public Function SelectRangeXY (psSheetName As String, piLDeb As Integer, piCDeb As Integer, _
   piLFin As Integer, piCFin As Integer) As Variant
      
      Set vxlsFeuilles =  EO.Sheets
      vxlsFeuilles(psSheetName).Activate
      Set vxlsFeuille = vxlsFeuilles(psSheetName)
      Set SelectRangeXY = vxlsFeuille.Range(Cstr(piLDeb) +":"+ Cstr(piCDeb),Cstr(piLFin) +":"+ Cstr(piCFin))
      
   End Function
   
   '-------------------------------------------------------------------------------
   'Select a range in specified worksheet with XL coordinates
   '-------------------------------------------------------------------------------
   Public Function SelectRange (psSheetName As String, psRange As String) As Variant
      
      Set vxlsFeuilles =  EO.Sheets
      vxlsFeuilles(psSheetName).Activate
      Set vxlsFeuille = vxlsFeuilles(psSheetName)
      Set SelectRange = vxlsFeuille.Range(psRange)
      
   End Function
   
   '-------------------------------------------------------------------------------
   'Copy cells from one range to another
   '-------------------------------------------------------------------------------
   Public Sub CopyRange (pvarRangeFrom As Variant, pvarRangeTo As Variant)
      Call pvarRangeFrom.Copy (pvarRangeTo)
      ' Call pvarRangeFrom.Copy
      ' Call pvarRangeTo.PasteSpecial ()
   End Sub
   
   '-------------------------------------------------------------------------------
   'Delete specified worksheet
   '-------------------------------------------------------------------------------
   Public Sub DeleteWorksheet (psSheetName As String)
      Set vxlsFeuilles =  EO.Sheets
      vxlsFeuilles(psSheetName).Activate
      Set vxlsFeuille = vxlsFeuilles(psSheetName)
      Call vxlsFeuille.Delete
   End Sub
   
   '-------------------------------------------------------------------------------
   'Put Icon in Cell
   '-------------------------------------------------------------------------------
   Public Sub PutIcon (psSheetName As String, pintCellX As Integer, pintCellY As Integer, _
   plngDeltaX As Long, plngDeltaY As Long, _
   psParamSheetName As String, psIconName As String)
      '## Copy Icon
      Set vxlsFeuilles =  EO.Sheets
      vxlsFeuilles(psParamSheetName).Activate
      Set vxlsFeuille = vxlsFeuilles(psParamSheetName)
      Call vxlsFeuille.Shapes(psIconName).Copy
      
      '## Paste Icon
      vxlsFeuilles(psSheetName).Activate
      Set vxlsFeuille = vxlsFeuilles(psSheetName)
      Call vxlsFeuille.Paste
      vxlsFeuille.Shapes(vxlsFeuille.Shapes.Count).Top = vxlsFeuille.Cells(pintCellX, pintCellY).Top  + plngDeltaY
      vxlsFeuille.Shapes(vxlsFeuille.Shapes.Count).Left = vxlsFeuille.Cells(pintCellX, pintCellY).Left  + plngDeltaX
      
   End Sub
   
   '-----------------------------------------------------------------------------------------   
   'Function that sets the cell pattern on a specified sheet
   '-----------------------------------------------------------------------------------------
   Public Sub SetCellPattern ( sSheetName As String, L_Cel As Integer,C_Cel As Integer,_
   lngPattern As Long, lngRed As Long, lngGreen As Long, lngBlue As Long)
      Dim varColor As Variant
      
      Set vxlsFeuilles =  EO.Sheets
      vxlsFeuilles(sSheetName).Activate
      Set vxlsFeuille = vxlsFeuilles(sSheetName)
      
      varColor = lngBlue*65536+256*lngGreen+lngRed
      If L_Cel > 0 And C_Cel > 0 Then
         vxlsFeuille.Cells(L_Cel,C_Cel).Interior.PatternColor = varColor
         vxlsFeuille.Cells(L_Cel,C_Cel).Interior.Pattern = lngPattern
      End If
   End Sub
   
   '## /STZ ##############################################
   
     '-------------------------------------------------------------------------------
   'Properties to get the name of the file to be saved
   '-------------------------------------------------------------------------------
   Property Set E_NameSaveFile As String
%REM
      If Dir$(E_NameSaveFile)<> "" Then
         P_strSaveFileName = E_NameSaveFile            
         If (ManageError(1,"Ce document: "+ E_NameSaveFile +" existe déja." + Chr(13) + "Voulez le supprimer", "Sauvegarde du document " + E_NameSaveFile)) Then
         P_strSaveFileName = E_NameSaveFile         
      Else
         E_NameSaveFile = ""
         End If
      Else
%END REM
      P_strSaveFileName = E_NameSaveFile         
   'End If
   End Property
   
   '---------------------------------------------------
   'Get the path of Excel.exe
   '---------------------------------------------------
   Property Get E_AppPath As String
      E_AppPath = EO.Path
   End Property
   
   '---------------------------------------------------
   'Get the name of file to be saved
   '---------------------------------------------------
   Property Get E_SaveFileName As String
      E_SaveFileName = P_strSaveFileName
   End Property
   
   '---------------------------------------------
   'Get the name of file template
   '---------------------------------------------
   Property Get E_FileName As String
      E_FileName = P_strFileName
   End Property
   
   '--------------------------------------------------
   'Properties to Set if it's a new file
   '--------------------------------------------------
   Property Set E_NewFile As Integer
      If E_NewFile = 0 Then
         P_NewFile = 0
      Elseif E_NewFile = 1 Then
         P_NewFile = 1
      Else
         P_NewFile = 0
      End If
   End Property   
   
   '-----------------------------------------------------------------------------------------   
   'Function that place one value on The first Page in Excel
   '-----------------------------------------------------------------------------------------
   Public Function PlaceOneValue(L_Cel As Integer,C_Cel As Integer,vValue As Variant)
      Set vxlsFeuilles =  EO.Sheets
      
      vxlsFeuilles(1).Activate
      Set vxlsFeuille = vxlsFeuilles(1)
      If L_Cel > 0 And C_Cel > 0 Then
         If Isarray (vValue) Then
            If Cstr (vValue (0)) <> "" Then vxlsFeuille.Cells (L_Cel,C_Cel).Value = Trim$ (vValue(0))
         Else
            If Cstr (vValue) <> "" Then vxlsFeuille.Cells (L_Cel,C_Cel).Value = Trim$ (vValue)
         End If
      Else
         
      End If
   End Function
   
   '-----------------------------------------------------------------------------------------   
   'Function that place one value on the sheet in Excel
   '-----------------------------------------------------------------------------------------
   Public Function SheetPlaceOneValue(sSheetName As String, L_Cel As Integer,C_Cel As Integer,vValue As Variant)
      Set vxlsFeuilles =  EO.Sheets
      
      vxlsFeuilles(sSheetName).Activate
      Set vxlsFeuille = vxlsFeuilles(sSheetName)
      If L_Cel > 0 And C_Cel > 0 Then
         If Isarray(vValue) Then
            If Cstr(vValue(0)) <> "" Then vxlsFeuille.Cells(L_Cel,C_Cel).Value = Trim$(vValue(0))
         Else
            If Cstr(vValue) <> "" Then vxlsFeuille.Cells(L_Cel,C_Cel).Value = Trim$(vValue)
         End If
      Else
         
      End If
   End Function
   
   '-----------------------------------------------------------------------------------------   
   'Function that sets the cell colour on a specified sheet
   '-----------------------------------------------------------------------------------------
   Public Sub SetCellColor (sSheetName As String, L_Cel As Integer,C_Cel As Integer,lngRed As Long, lngGreen As Long, lngBlue As Long)
      Dim varColor As Variant
      Set vxlsFeuilles =  EO.Sheets
      
      vxlsFeuilles(sSheetName).Activate
      Set vxlsFeuille = vxlsFeuilles(sSheetName)
      varColor = lngBlue*65536+256*lngGreen+lngRed
      If L_Cel > 0 And C_Cel > 0 Then vxlsFeuille.Cells(L_Cel,C_Cel).Interior.Color = varColor
   End Sub
   
   '-----------------------------------------------------------------------------------------   
   'Function that place values on The first Page in Excel
   '-----------------------------------------------------------------------------------------
   Public Function PlaceFullValue(L_CelDebut As Integer,C_CelFin As Integer,vValue As Variant)
      Dim Cpt As Long      
      Set vxlsFeuilles =  EO.Sheets
      
      vxlsFeuilles(1).Activate
      Set vxlsFeuille = vxlsFeuilles(1)
      If L_CelDebut > 1 And C_CelFin > 0 And vValue(0) <> "" And Isarray(vValue)Then      
         For Cpt = 0 To Ubound(vValue)         
            vxlsFeuille.Cells(L_CelDebut,C_CelFin+Cpt).Value = Trim$(vValue(Cpt))
         Next         
      Else
         
      End If
   End Function
   
   '---------------------------------------
   'Close Excel with Save
   '---------------------------------------
   Public Sub QuitExcelWithSave
      If Not(EO Is Nothing) Then      
         If E_SaveFileName <> "" Then      
            Set vxlsFeuilles =  EO.Sheets
            vxlsFeuilles(1).Activate
            Set vxlsFeuille = vxlsFeuilles(1)
            vxlsFeuille.Saveas(E_SaveFileName)
            EO.Quit
         Else
            'EO.SaveWorkspace
            EO.Quit
         End If         
      End If      
   End Sub
   
    '---------------------------------------
   'Save Excel As
   '---------------------------------------
   Public Sub SaveExcelAs
      If Not(EO Is Nothing) Then      
         If E_SaveFileName <> "" Then      
            Set vxlsFeuilles =  EO.Sheets
            vxlsFeuilles(1).Activate
            Set vxlsFeuille = vxlsFeuilles(1)
            'vxlsFeuille.SaveAs(P_strSaveFileName)'E_SaveFileName)
            vxlsFeuille.SaveAs(E_SaveFileName)
         End If         
      End If      
   End Sub
   
   '---------------------------------------------
   'Launch of Excel Application
   '---------------------------------------------
   Private Sub MSExcelApplication
      Dim strVersion As String
      Set EO = CreateObject("Excel.Application")
      strVersion  = EO.Version
      Select Case Left(strVersion,1)
        '--------------------------      
      'Version Excel 7.0   
      '---------------------------   
      Case "7"
         Print "Version 7.0 de Excel"
         If (P_EXCEL) Then
            EO.Visible=True
         End If
         
      Case "8"
         EO.DisplayStatusBar = True
         EO.StatusBar = "Veuillez patienter..."
         Print "Version 8.0 de Excel"
         If (P_EXCEL) Then
            EO.Visible=True
         End If         
         Set EODoc = EO.Workbooks
         If (P_NewFile) Then
            EODoc.Add            
         Else
            EODoc.Add(E_FileName)            
         End If
      Case "9"
         EO.DisplayStatusBar = True
         EO.StatusBar = "Veuillez patienter..."         
         Print "Version 9.0 de Excel"
         If (P_EXCEL) Then
            EO.Visible=True
         End If         
         Set EODoc = EO.Workbooks
         If (P_NewFile) Then
            EODoc.Add            
         Else
            EODoc.Add(E_FileName)            
         End If         
      End Select         
   End Sub
   
   '---------------------   
   'Manage Error
   '---------------------
   Private Function ManageError(iType As Integer,strMessage As String,strTitle As String) As Variant
      Dim iRet As Long      
      ManageError  = False      
      Select Case iType
      Case 0
         iRet = Messagebox (strMessage, 0+16+0+0+4096,strTitle)   
         If Not(EO Is Nothing) Then
            EO.Quit
         End If   
      Case 1
         iRet = Messagebox (strMessage, 1+16+0+0+4096,strTitle)   
         If iREt = 1 Then
            Kill P_strSaveFileName
            ManageError = True            
         Else
            P_strSaveFileName = ""            
            ManageError = False            
         End If
      End Select
      
   End Function
   
   '-----------------------   
   'Main Function
   '-----------------------
   Public Function LaunchExcel
      Call MSExcelApplication
   End Function
   
End Class

Code : Tout sélectionner