Page 1 sur 1
Classe Excel
Publié:
16 Fév 2007 à 12:12par 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