lundi 27 octobre 2008

vbscript excel library

'
' XL = OuvrirExcel(fichier)
' FermerExcel hXL => Enregistre & ferme Excel
' genXLHeader aRS, hXL
' genXLBody aRS, hXL
' genXLDataLine aRS, Line#, hXL
'
function OuvrirExcel(aFilename)
dim lFSO
dim lFile
dim lExcel
dim s
s = aFileName
if ucase(right(aFilename, 4)) <> ".XLS" then s = s & ".xls"
set lFSO = CreateObject("Scripting.FileSystemObject")
set lFile = lFSO.CreateTextFile(s, true)
lFile.Close
set lFile = Nothing
lFSO.DeleteFile(s)
Set lExcel = CreateObject("Excel.Application") ' instancier un Excel
lExcel.workbooks.Add ' ajouter un classeur
lExcel.Activeworkbook.SaveAs s
set OuvrirExcel = lExcel
Set lExcel = nothing
end function

sub FermerExcel(gExcel)
gExcel.ActiveWorkbook.Save
gExcel.ActiveWorkbook.Close
gExcel.Quit
set gExcel = nothing
end sub


Sub GenXLHeader(aRecordset, aExcel)
dim i
dim lColName
dim gWS
set gWS = aExcel.ActiveWorkBook.ActiveSheet
for i = 0 to aRecordset.Fields.Count - 1
if i < 26 then
lColName = chr(i + 65)
else
lColName = chr(int(i/26)+65) & chr((i mod 26)+65)
end if
gWS.Cells(1, i + 1).Value = aRecordset.Fields(i).Name
if aRecordset.Fields(i).type = 129 then
gWS.Columns(lColName & ":" & lColName).NumberFormat = "@"
elseif aRecordset.Fields(i).type = 133 then
gWS.Columns(lColName & ":" & lColName).NumberFormat = "dd/mm/yyyy"
end if
next
gWS.Rows("1:1").Font.Bold = True
set gWS = Nothing
end sub

Sub GenXLDataLine(aRecordSet, aLinNum, aExcel)
dim i
dim gWS
set gWS = aExcel.ActiveWorkBook.ActiveSheet
for i = 0 to aRecordSet.Fields.Count - 1
if aRecordSet.Fields(i).type = 129 then
gWS.Cells(aLinNum, i + 1).Value = trim(aRecordSet.Fields(i))
else
gWS.Cells(aLinNum, i + 1).Value = aRecordSet.Fields(i)
end if
next
set gWS = nothing
end sub

Sub GenXLBody(aRecordSet, aExcel)
dim l
l = 2
do while not aRecordSet.EOF
GenXLDataLine aRecordSet, l, aExcel
l = l + 1
aRecordSet.MoveNext
Loop
end sub

sub xlCursorToFile(aRecordset, aFilename)
dim lExcel
set lExcel = OuvrirExcel(aFilename)
GenXLHeader aRecordset, lExcel
GenXLBody aRecordset, lExcel
FermerExcel lExcel
end sub

Aucun commentaire: