Exemple d'utilisation des bib vbscript

' ----- Activite Ateliers
'
dim fso: set fso = CreateObject("Scripting.FileSystemObject")
dim f: set f = fso.OpenTextFile("c:\lib\include.vbs", 1): ExecuteGlobal f.ReadAll: f.Close: set f = nothing

include "c:\lib\database.vbs"
include "c:\lib\texte.vbs"
include "c:\lib\html.vbs"
include "c:\lib\display.vbs"
include "c:\lib\excel.vbs"
include "c:\lib\log.vbs"

'
' pls, Modifier les paramètres
'
dim ParamAnneeDeb: ParamAnneeDeb = "2008"
dim ParamAnneeFin: ParamAnneeFin = "2009"

dim maSession, monCurseur
dim fout
dim R ' texte de la requête
dim fname: fname = "c:\temp\ActiviteAteliers " & ParamAnneeDeb & "-" & ParamAnneeFin & ".xls"

LogTo "ActiviteAteliers"
LogMe False
Log "AnneeDeb=" & ParamAnneeDeb
Log "AnneeFin=" & ParamAnneeFin
Log "fname=" & fname


R = "select fsnumdoc1||fsnumdoc2 ""N°FS"""
R = R & " , fspn ""P/N"""
R = R & " , fssn ""S/N"""
R = R & " , fsouvdat ""Ouverture"" "
R = R & " , case when year(fsferdat)=1 then null else fsferdat end ""Fermeture"""
R = R & " , sum(fptemps) ""Tps passé"""
R = R & " from amsf.frfs fs, amsf.frfp fp"
R = R & " where fsnumdoc1 = fpnumdoc1 and fsnumdoc2 = fpnumdoc2"
R = R & " and ((fsouvdat between '" & ParamAnneeDeb & "-10-01' and '" & ParamAnneeFin & "-09-30')"
R = R & " or (fsferdat between '" & ParamAnneeDeb & "-10-01' and '" & ParamAnneeFin & "-09-30')"
R = R & " or (fsouvdat < '" & ParamAnneeDeb & "-10-01' and fsferdat > '" & ParamAnneeFin & "-09-30')"
R = R & " or fsferdat is null"
R = R & " or year(fsferdat) = 1"
R = R & " )"
R = R & " and fs.fscodmag in ('WH1', 'WHA')"
R = R & " and fstype = '1'"
R = R & " and fspn in ('9543809-1', '5003706', '9550504', 'AHA1291', 'AHA1349', 'AHA1802')"
R = R & " group by fsnumdoc1||fsnumdoc2, fspn, fssn, fsouvdat, case when year(fsferdat)=1 then null else fsferdat end"
R = R & " order by 2, 3, 4"
Log "requete=" & r

OuvrirSession "maSource", "monCompte", "monPass", maSession
Log "OuvrirSession() => LEC=" & LEC & ", LED=" & LED
OuvrirQuery maSession, R, monCurseur
Log "OuvrirQuery() => LEC=" & LEC & ", LED=" & LED
xlCursorToFile monCurseur, fname
FermerQuery monCurseur
FermerSession maSession

if instr(ucase(fname), ".XLS") > 0 then fso.CopyFile fname, "\\webserver\webshare\", True
set fso = nothing
Log "Done!"

vbscript database library

'
' OuvrirSession(SOURCE, USERNAME, PASSWORD, var session)
' FermerSession(var session)
' ExecuterCommande(session, REQUETE)
' OuvrirQuery(Session, REQUETE, var curseur)
' FermerQuery(var curseur)
' DataFromSQL(Session, REQUETE)
'

dim LEC ' last err.number
dim LED ' last err.description

function OuvrirSession(aSource, aUsername, aPassword, gSession)
on error resume next
err.clear
set gSession = CreateObject("ADODB.Connection")
LEC = Err.Number: LED = Err.Description
if LEC = 0 then
gSession.Open "DSN=" & aSource & ";UID=" & aUsername & ";PWD=" & aPassword & ";"
LEC = Err.Number: LED = Err.Description
end if
OuvrirSession = LEC
end function

function FermerSession(gSession)
on error resume next
err.clear
gSession.Close
set gSession = nothing
FermerSession = LEC
end function

function ExecuterCommande(aSession, aRequete)
dim lCommande
on error resume next
Err.Clear
Set lCommande = CreateObject("ADODB.Command")
LEC = err.number: LED = err.description
if LEC = 0 then
lCommande.ActiveConnection = aSession
LEC = err.number: LED = err.description
if LEC = 0 then
lCommande.CommandText = aRequete
LEC = err.number: LED = err.description
if LEC = 0 then
lCommande.Execute
LEC = err.number: LED = err.description
end if
end if
set lCommande = Nothing
end if
ExecuterCommande = LEC
end function

function OuvrirQuery(aSession, aRequete, gCurseur)
on error resume next
err.clear
set gCurseur = CreateObject("ADODB.Recordset")
LEC = err.number: LED = err.description
if LEC = 0 then
gCurseur.Open aRequete, aSession
LEC = err.number: LED = err.description
end if
OuvrirQuery = LEC
end function

function DataFromSQL(aSession, aRequete)
dim lCurseur
OuvrirQuery aSession, aRequete, lCurseur
DataFromSQL = lCurseur.Fields(0)
FermerQuery lCurseur
end function

function FermerQuery(gCurseur)
on error resume next
err.clear
gCurseur.Close
LEC = err.number: LED = err.description
if LEC = 0 then
set gCurseur = Nothing
LEC = err.number: LED = err.description
end if
FermerQuery = LEC
end function

vbscript html library

' cvt en html sauf ligatures e
function cvhtml(a)
dim s
s = a
s = replace(s, "&", "&amp;")
s = replace(replace(s, ">", "&gt;"), "<", "&lt;")
s = replace(replace(replace(s, "Ä", "&Auml;"), "Â", "&Acirc;"), "À", "&Agrave;")
s = replace(replace(replace(s, "ä", "&auml;"), "â", "&acirc;"), "à", "&agrave;")
s = replace(replace(replace(replace(s, "Ë", "&Euml;"), "Ê", "&Ecirc;"), "È", "&Egrave;"), "É", "&Eacute;")
s = replace(replace(replace(replace(s, "ë", "&euml;"), "ê", "&ecirc;"), "è", "&egrave;"), "é", "&eacute;")
s = replace(replace(replace(replace(s, "ï", "&iuml;"), "î", "&icirc;"), "Ï", "&Iuml;"), "Î", "&Icirc;")
s = replace(replace(replace(s, "Ö", "&Ouml;"), "Ô", "&Ocirc;"), "Ó", "&Oacute;")
s = replace(replace(replace(s, "ö", "&ouml;"), "ô", "&ocirc;"), "ó", "&oacute;")
s = replace(replace(replace(replace(s, "Ü", "&Uuml;"), "Û", "&Ucirc;"), "Ú", "&Uacute;"), "Ù", "&Ugrave;")
s = replace(replace(replace(replace(s, "ü", "&uuml;"), "û", "&ucirc;"), "ú", "&uacute;"), "ù", "&ugrave;")
s = replace(replace(s, "ç", "&ccedil;"), "Ç", "&Ccedil;")
cvhtml = s
end function

function htmlHead(aTitre)
dim s
s = "<html><head>"
if trim(aTitre) <> "" then s = s & "<Title>" & cvhtml(aTitre) & "</Title>"
HtmlHead = s & vbCRLF & "<style type=""text/css"" media=""screen"">td, th {font-size:75%;}</style>" & vbCRLF
end function

function HtmlHeadToBody(aAttribs)
if trim(aAttribs) = "" then
htmlHeadToBody = "</head><body>" & vbCRLF
else
htmlHeadToBody = "</head><body " & aAttribs & ">" & vbCRLF
end if
end function

function HtmlFoot
HtmlFoot = "<br><font size=""-1"">" & cvhtml("Page générée le " & date & " à " & time) & "</font><br></body></html>" & vbCRLF
end function

function HtmlTableHeader(aRecordSet)
dim s, i
s = "<tr>"
for i = 0 to aRecordset.Fields.count - 1
s = s & tagTH(cvhtml(aRecordset.fields(i).Name) & "<!-- type:" & aRecordset.fields(i).Type & " -->")
next
HtmlTableHeader = s & "</tr>" & vbCRLF
end function

function HtmlTableLine(aRecordSet)
dim s, i, t
s = "<tr>"
for i = 0 to aRecordSet.Fields.Count - 1
t = aRecordSet.fields(i).Type
if (t = 3) or (t = 131) then
s = s & gTag("td", "align=""right""", nbspifnull(cvhtml(trim(aRecordSet.fields(i) & " "))))
else
s = s & tagTD(cvhtml(trim(aRecordSet.fields(i) & " ")))
end if
next
HtmlTableLine = s & "</tr>" & vbCRLF
end function

function nbspIfNull(s)
if s = "" then nbspIfNull = "&nbsp;" else nbspIfNull = s
end function

function gTag(tag, attribs, s)
if trim(attribs) = "" then gTag = "<" & tag & ">" & s & "</" & tag & ">" else gTag = "<" & tag & " " & attribs & ">" & s & "</" & tag & ">"
end function

function TagTH(s)
if s = "" then TagTH = "<th>&nbsp;</th>" else tagTH = "<th>" & s & "</th>"
end function

function TagTD(s)
if s = "" then TagTD = "<td>&nbsp;</td>" else tagTD = "<td>" & s & "</td>"
end function

function TagTR(s)
tagTR = gTag("tr", "", s)
end function

function tagH3(s)
tagH3 = gTag("h3", "", s)
end function

sub htmlCursorToFile(aRecordset, aFilename, aTitle)
dim lFSO
dim fout
set lFSO = CreateObject("Scripting.FileSystemObject")
set fout = lFSO.OpenTextFile(aFilename, 2, true)
fout.WriteLine htmlHead(aTitle)
fout.WriteLine htmlHeadToBody("")
fout.WriteLine "<table border>"
fout.WriteLine htmlTableHeader(aRecordset)
do while not aRecordset.EOF
fout.WriteLine htmlTableLine(aRecordset)
aRecordset.Movenext
loop
fout.WriteLine "</table>" & htmlFoot
fout.Close
set fout = nothing
set lFSO = nothing
end sub

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

vbscript display library

' gestion d'affichage
' print sert à accumuler les lignes à afficher
' EOP les affiche en une fois sur la console ou dans un dialogue

dim output: output = ""
dim nl: nl = ""

sub print(s)
output = output & nl
output = output & s
nl = vbLF
end sub

sub EOP
wscript.echo output
output = ""
nl = ""
end sub

vbscript text library

function txtHeader(aRecordset)
dim s, i
s = ""
for i = 0 to aRecordset.Fields.count - 1
if s <> "" then s = s & vbTab
s = s & aRecordset.fields(i).Name
next
txtHeader = s
end function

function txtDataLine(aRecordSet)
dim s, i, t
s = ""
for i = 0 to aRecordSet.Fields.Count - 1
if s <> "" then s = s & vbTab
s = s & trim(aRecordSet.fields(i) & " ")
next
txtDataLine = s
end function

sub txtCursorToFile(aRecordset, aFilename)
dim fout, lFSO
set lFSO = CreateObject("Scripting.FileSystemObject")
set fout = lFSO.OpenTextFile(aFilename, 2, true)
fout.Writeline txtHeader(aRecordset)
do while not aRecordset.EOF
fout.WriteLine txtDataLine(aRecordset)
aRecordset.Movenext
loop
fout.Close
set fout = nothing
set lFSO = Nothing
end sub

vbscript log library

' LogTo Filename | ""
' LogMe True | False
' Log message

dim logFSO ' un FSO pour moi tout seul
dim logF ' le fichier log
dim logfilename ' nom du log dans c:\log
dim logstatus ' true si log actif

set logFSO = CreateObject("Scripting.FileSystemObject")

sub LogMe(newStatus) ' true or false
logStatus = newStatus
end sub

sub LogTo(aFilename)
if aFileName = "" then
LogFileName = aFileName
LogMe False
else
if ucase(right(aFilename, 4)) = ".LOG" then
LogFileName = "c:\log\" & aFileName
else
LogFilename = "c:\log\" & aFileName & ".log"
end if
end if
end sub

Sub Log(s)
if logStatus then
set logF = logFSO.OpenTextFile(LogFilename, 8, -1) ' ForAppend, Unicode
logF.WriteLine date & " @ " & time & ": " & s
logF.Close
end if
end sub

vbscript include library

sub Include(fname)
dim finclude
set finclude = fso.OpenTextFile(fname, 1)
ExecuteGlobal fInclude.ReadAll
fInclude.Close
set fInclude = nothing
end sub