Programming corner wildboy85

Saturday, May 11, 2013

recursiveness insertion in sql of an array made in vbs

recursiveness insertion in sql of an array made in vbs

the sub where the array is recursively scanned is SUB RETFOL

is will call itself each time the vbs array contain another array

it will create a new record in the sql database, related by a number to the precedent one

example:
array("test",array("subtest1","subtest2")

will give a record table in sql like this:
record 1 to 3:
id 1 - test
id 2 - subtest1 - idtoitself 1
id 3 - subtest2 - idtoitself 1

so the records related recursively to the main array are numbered to it

this script was originally created to manage folders creation

when security of ntfs started to be involved, i had to migrate the folder names to sql database for an easier management of wich security groups needed to have access to each folder

------------------------------- VBS code -------------------

'=== Ultimate dynamic web interface 2.0

'=== this script:
'=== generate dynamically a web interface to manage virtually anything
'=== control (left frame), input (middle frame), and output (bottom frame) from vbs/wsh (windows host scripts)

'=== the first version was a simple interface made by a programmer
'=== the second version have more explanations
'=== more dynamism than ever
'=== more functions to clean up main loop code
'=== easier array display coding to add stuff more easily
'=== MDB (access type database) management (creation, edition, search/edit)
'=== futur: mdb import, mdb export, sql sync, excel export

'=== by: SergeFournier(at)hotmail.com

'=== tested on windows vista 64, internet explorer 7

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objshe = CreateObject("WScript.Shell")
Set objNet = CreateObject("WScript.Network")

Const hkcr = &H80000000 'HKEY_CLASSES_ROOT
Const HKCU = &H80000001 'HKEY_CURRENT_USER
Const hklm = &H80000002 'HKEY_LOCAL_MACHINE
Const hku = &H80000003 'HKEY_USERS
Const hkcc = &H80000005 'HKEY_CURRENT_CONFIG

'=== actual drive, actual directory, and "\"
thepath=WScript.ScriptFullName
p = instrRev(thepath,"\")
basedir = left(thepath,p)
filnam = right(thepath,len(thepath)-p)

'=== windows dir
WinDir = objfso.GetSpecialFolder(0)

'=== restart the script in 32 bits if we are on a 64 bits system
'=== (databases drivers issues)
a64 = windir & "\syswow64\wscript.exe"

if objFSO.fileEXISTS(a64) and instr(lcase(wscript.fullname),"syswow64")=0 then
'=== 64 bits system
a = """" & a64 & """ """ & basedir & filnam & """"
objshe.Run a,0, false
wscript.quit
end if

Set objOutputFile = objfso.OpenTextFile(base_dir & "z_LDAP_to_sql_log_" & nom_table & ".txt", 2, true)
objOutputFile.WriteLine date & " " & time & " START"

'=== database
set tag = CreateObject ("ADODB.Recordset")
Set con_02 = CreateObject("ADODB.Connection")

'=== connexion serveur sql, sans se connecter sur une database
'=== MAIN SQL DATABASE CONNECTION
'con_02.ConnectionString = "Driver={SQL Server};Server=" & environ("stassql1") & ";Uid=sa;Pwd="
con_02.ConnectionString = "Driver={SQL Server};Server=sql.corp.stas.local"
con_02.connectiontimeout=500
con_02.Open

'=== DATABASE === sub creation

dbname = "224"

tabname = "folders_struct"

aracolnam = array( _
"nom", _
"parentfol", _
"permission", _
"categorie", _
"revision", _
"actif")

aratype = array( _
"varchar(255)", _
"int", _
"varchar(255)", _
"varchar(255)", _
"int", _
"int")

aracolunique = array()

call credb(dbname, tabname, aracolnam, aratype, aracolunique, objOutputFile, con_02, tag)

'============================================== main loop =============================================

'=== name of the user logged in window (network or not)
usenam=lcase(objnet.username)

'=== menu items on left side (control side, frame: flef)

'= arabutnam: name of button, purely programmation name, used later to execute functions in main loop
'= arabutdes: description of button, text inside it actually
'= aradepnam: departement name, each departement (Section) is separated by a space
'= aradepcol: color of departement, blue = computer, brown = accounting, etc will follow a standard on internet (vague)

'=== button at the start for control frame (flef object)
'=== you can add as many buttons as you want, it's all dynamic (extendable)

x=0
ReDim Preserve arabutnam(x): ReDim Preserve arabutdes(x): ReDim Preserve aradepnam(x): ReDim Preserve aradepcol(x)
arabutnam(x)="stasfolequ"
arabutdes(x)="STAS dossiers (equip. priv)"
aradepnam(x)="STAS"
aradepcol(x)="cccccc"

x=x+1
ReDim Preserve arabutnam(x): ReDim Preserve arabutdes(x): ReDim Preserve aradepnam(x): ReDim Preserve aradepcol(x)
arabutnam(x)="stasservice"
arabutdes(x)="STAS dossiers (service)"
aradepnam(x)="STAS"
aradepcol(x)="cccccc"

x=x+1
ReDim Preserve arabutnam(x): ReDim Preserve arabutdes(x): ReDim Preserve aradepnam(x): ReDim Preserve aradepcol(x)
arabutnam(x)="unigecfol"
arabutdes(x)="UNIGEC dossiers"
aradepnam(x)="UNIGEC"
aradepcol(x)="cccccc"

x=x+1
ReDim Preserve arabutnam(x): ReDim Preserve arabutdes(x): ReDim Preserve aradepnam(x): ReDim Preserve aradepcol(x)
arabutnam(x)="quit01"
arabutdes(x)="Quitter"
aradepnam(x)="All"
aradepcol(x)="cccccc"

'=== print button
priara = array("<input type=""button"" onClick=""javascript:print()"" value=""Print""/><br><br>")

'=== i dont remember this one
lasdep=""

'=== web interface, internet explorer

'=== set the objects before calling functions, so they are global objects/variables, accessibles in all the program
set oIE = wscript.CreateObject("InternetExplorer.Application", "IE_")
dim flef, fmid, fbot

'=== title of internet explorer window
doctit = "titre de la page"

'=== title to display inside the left frame (control frame, flef object)
maitit = "SKYNET interface<br><br>STAS "'=== title inside the left frame

'=== create the main web interface with 3 frames, objects: flef, fmid, fbot
a = crewebmai(oie, doctit, maitit, arabutnam, arabutdes, aradepnam, aradepcol)

'=== defaut menu option for certain name logged
'=== example: a certain user will use always the same function
'=== so the interface will start, by executing this function at first, not an empty frame
'=== simply enter the name of the button that should be pressed for this user when interface start

if usenam="wildboy" or usenam="fournier.serge" then
'=== defaut choice when program start
'resbutlefstr = "stristas"
end if

'=== sub to call for each button
'=== here we define a sub to be called when a button in the web page is pressed
Do While (oIE.Busy)
wscript.sleep 100
loop
do while oie.readystate<>4
wscript.sleep 100
loop

'=== set up a return value on click of each button on the left frame
'=== the returned value is the name (programmable name) of each button (arabutnam)
'=== later any action will be taken according to this value
'=== i use this method because i dont want to call a sub when a button is pressed
'=== to remain in a loop for the main program, that is standard procedure in programming (to have a main loop)

for i=0 to ubound(arabutnam)
flef.forms(0).elements(arabutnam(i)).onclick = getref("buttonlef")
next

'=== we also chek the key presse in each frame
'=== we do this cause we want "enter" key to be used instead of pressing "ok" button with the mouse
set flef.onkeypress = GetRef("Checklef")
set fmid.onkeypress = GetRef("Checkmid")
set fbot.onkeypress = GetRef("Checkbot")

'=== if bready = true, it mean they closed internet explorer, see the sub on internet explorer closing later in this code
'=== we have to chek this value often to stop the wscript.exe from interpreting this code, when internet explorer is closed
bReady=false
resbutlefstr = ""
resbutmidstr = ""
resbutbotstr = ""
reskeylef = 0
reskeymid = 0
reskeybot = 0

WScript.sleep(100) ' .1 seconds

'=== main loop, infinite
'=== unless someone press QUIT button
'=== or close internet explorer (bready = true)

do

'=== if the button named this is pressed we do this
'=== resbutlefstr: result from pressing a button in the left frame (control frame, flef object)
'=== its a string that contain the programmable name of the button that was pressed in the left frame (arabutnam)

'=== 01 ====================== U N I G E C =============================

if resbutlefstr="unigecfol" then

a = clefra(array("fmid","fbot"))

'=== 02 ================ folder generation in i drive

ara01 = array( _
"1 Communication", _
array("01 Bordereau de transmission", "02 Clients", "03 Architectes", "05 Laboratoires", "04 Entrepreneurs", "06 Fournisseurs", "07 Internes", "08 Autres"), _
"2 Gestion Commerciale", _
array("1 Offre de services","2 Facturation"), _
"3 Gestion Projet", _
array("1 Budget", "2 Échéancier", "3 Mandat","Cahier_de_projet"), _
"4 Qualité", _
array("1 Plan de qualité"), _
"6 Devis", array( _
"1 Pour soumission", _
array("Autres", "Civil-structure", "Électricité", "Mécanique"), _
"2 Pour construction", _
array("Autres", "Civil-structure", "Électricité", "Mécanique"), _
"3 Addenda", _
array("Autres", "Civil-structure", "Électricité", "Mécanique"), _
"4 Pour approbation", _
array("Autres", "Civil-structure", "Électricité", "Mécanique")), _
"7 Dessins Atelier", _
array("1 Intrants", array("Autres","Civil-structure", "Électricité", "Mécanique"), _
"2 Extrants", array("Autres","Civil-structure", "Électricité", "Mécanique")), _
"5 Rapport", _
"8 Technique", array( _
"1 Intrants", _
array("Autres", "Architectes", "Clients", "Entrepreneurs", "Fournisseurs", "Laboratoires Internes"), _
"2 Calculs", _
array("Civil-structure", "Électricité", "Mécanique"), _
"3 Estimation des travaux", _
array("Civil-structure", "Électricité", "Globale","Mécanique"), _
"4 Extrants", array( _
"Civil-structure", array("Pour construction", "Pour soumission", "Révisions antérieures"), _
"Mécanique", array("Pour construction", "Pour soumission", "Révisions antérieures"), _
"Électricité", array("Pour construction", "Pour soumission", "Révisions antérieures")), _
"5 Extrants divers", _
"6 Photos", array("Autres", "Civil-structure", "Électricité", "Mécanique")), _
"9 Construction", array( _
"1 Directives chantier", array("Civil-structure","Électricité","Mécanique"), _
"2 Ordre de changement", array("Civil-structure","Électricité","Mécanique"), _
"3 Certificats de paiement", _
"4 Liste des déficiences", array("Civil-structure","Électricité","Mécanique"), _
"5 Acceptation des travaux", _
"6 Rapports quotidiens", _
"7 Compte rendu réunions", _
"8 Autres"))

'=== 03 ===
rap01=""

for each a in priara
rap01 = rap01 & a
next

rap01 = rap01 & "<form name=form01>"
rap01 = rap01 & "<b><table width=""100%"" BORDERCOLOR=""black"" class=MsoTableGrid border=1 CELLSPACING=0 cellpadding=2 "
rap01 = rap01 & "style='border-collapse:collapse;border:none'>"
'rap01 = rap01 & "<CAPTION></CAPTION><span style='color:purple'>" & vbcrlf

'=== ara01 = liste des dossiers, jagged array
'=== con = contrat

'=== HTML display
sublvl=0
tagsublvl=0
lvl=1
call retfol(ara01,"",0,"286_unigec",0)

rap01=rap01 & "</table></form>"

'=== write all the folder structure in bottom frame
fbot.WriteLn(rap01)

'=== 04 ===

x=0
redim preserve distmp(x) :redim preserve namtmp(x) :redim preserve deftmp(x) :redim preserve typtmp(x) :redim preserve errtmp(x)
distmp(x)="Code du contrat" '===== description displayed in front of the field
namtmp(x)="text01" '===== name of variable for programming purpose
deftmp(x)="" '===== default value inside the form (the form will be 20 char long if no value here, but you can enter more)
typtmp(x)="textbox" '===== type of data: textbox password (futur: more to come)
errtmp(x)="###%% (### = client %% = contrat" '===== text to display after the form "facultatif" blue text "error" red text are special keywords

buttmp=array("ok","cancel") '===== at the end, there will be an "ok" button and a "cancel" button
tit = "UNIGEC - Structure dossier"
a = dynforgen (distmp,namtmp,deftmp,typtmp,errtmp,buttmp,tit)

do
'=== flag to tell if the input is not valid
err01=0
'=== flag to say input is done, since there might be a defaut value, we must validate if user was finished
inpdon=0
'=== "ok" button or "enter" key are the same
'=== and nothing was pressed on left frame (control frame)

if resbutlefstr="" and (resbutmidstr="ok" or reskeymid=13) then
'=== User has clicked the OK button, retrieve the values
text=fmid.form01.text01.Value '=== namtmp is the variable name used earlier,before we call the dynamic form generation for input

if len(text) < 5 then
err01=1
'=== error message for the first form (if the keyword "error" is in this string, its displayed in RED)
if len(text) < 5 then
errtmp(0)="error - must be 5 char long at least"
else
errtmp(0)="ok"
end if

'=== if the value was not good, we generate the dynamic input for again, with an error message after the form in red
a = dynforgen(distmp,namtmp,deftmp,typtmp,errtmp,buttmp,tit)
'=== there was an invalid input so we reset the key or button pressed to nothing so the loop can continue
reskeymid=0
resbutmidstr=""
else
'=== the input was validated, we flag err01 to none, and flag inpdon to exit the loop
inpdon=1
err01=0
end if
end if
wscript.sleep 100

'=== while we wait for input value, user can press "escape" key, "cancel" button or close internet explorer
if resbutmidstr="cancel" or reskeymid=27 or bready=true or resbutlefstr<>"" then
'=== if user pressed escape or cancel, we clear the frames
if resbutmidstr="cancel" or reskeymid=27 then
a = clefra(array("fmid","fbot"))
resbutmidstr="cancel"
end if
exit do
end if
'=== if there was an input error and no one used left control frame to exit, we keep asking for input
loop while err01<>0 or inpdon=0

'=== if internet explorer was not closed (bready), a button was not pressed on left frame, and no excape or cancel in middle frame
if bready=false and resbutlefstr="" and reskeymid<>27 and resbutmidstr<>"cancel" then

reskeymid=0
resbutmidstr=""

'=== cli = client number
'=== con = contrat number
'=== pat = path server and client and contrat

'=== create basic folders I K S exchange
cli=ucase(mid(text,1,3))
con=ucase(right(text,len(text)-3))

'=== b = path du i projets
b = crebasfol(cli,con)

'=== create all sub folders (pat is not empty so we create folders)

newfol = 0
dejfol = 0
errfol = 0
pattot = 0
arapat=array(pat)
pat = b

'=== get parent folder id (id of last row in database)

sql = "SELECT id FROM [224].dbo.[folders_Struct] WHERE (id = (SELECT MAX([folders_Struct].id) FROM [224].dbo.[folders_Struct]))"
objOutputFile.WriteLine date & " " & time & " find last id for parentfolder id: " & vbcrlf & sql
Set tag = con_02.Execute(sql)
if not (tag.eof) then
parfolid = tag(0).value
else
parfolid = 0
end if

sublvl=0
tagsublvl=0
lvl=1
call retfol(ara01,pat,parfolid,"286_unigec",0)

fbot.WriteLn("<br>Structure<br><br>")

fbot.WriteLn("Dossiers nouveaux: " & newfol & "<br>")
fbot.WriteLn("Dossiers déjà existants: " & dejfol & "<br>")
fbot.WriteLn("Dossiers non créés, erreur: " & errfol & "<br><br>")
'=== 05 === exchange =================

fbot.WriteLn("FIN<br>")

end if

'=== permissions security acl ntfs

' F Full control (can change permission too)
' M Modify
' X read & eXecute
' L List folder contents
' R Read
' W Write

'=== drive i: (old permissions)

'Allowed BUILTIN\Administrators Full Control This Folder Only
'Allowed \CREATEUR PROPRIETAIRE Full Control Subfolders and Files
'Allowed CORP\EMP_STAS Modify This Folder, Subfolde
'Allowed AUTORITE NT\Système Full Control This Folder, Subfolde
'Allowed CORP\Admins du domaine Full Control This Folder, Subfolde
'Allowed BUILTIN\Administrators Full Control Subfolders and Files
'Allowed CORP\EMP_STAS Modify This Folder, Subfolde

fol01="i:\135\"
ara01=array( _
"STAS-HOST-01\administrators:F", _
"corp\Admins du domaine:F", _
"CORP\EMP_UNIGEC:M", _
"CORP\EMP_STAS:M", _
"CORP\fournier.serge:F", _
"corp\Admins du domaine:F")
b=""

for each a in ara01
b=b & """" & a & """ "
next

a="cscript.exe c:\_stas\224211-informatique\xCACLS.vbs """ & fol01 & """ /T /P " & act01 & b
' & "/user admin3 /pass ******"
'err01 = objShe.Run("%COMSPEC% /c Echo Y| " & a, 2, True)
c="aef.txt"

Set objOutputFile02 = objfso.OpenTextFile("c:\_stas\" & c, 2, true)
objOutputFile02.writeline(a)
objOutputFile02.close

'=== exchange

end if

'=== creation folders - permissions folders - exchange folders

'=== 01 ============================ S T A S E Q U I P E M E N T ====================================================================

if resbutlefstr="stasfolequ" or resbutlefstr="stasservice" then

if resbutlefstr = "stasfolequ" then
cat="224_equipement"
elseif resbutlefstr = "stasservice" then
cat="224_service"
else
cat="autre"
end if

a = clefra(array("fmid","fbot"))

'=== 02 ================ folder generation in i drive

ara01 = array( _
"Achats", _
"Administration", _
"Gestion_Projet", _
array( "Communication","Budget","Echeancier","Gestion_envergure", "Qualite"), _
"EMM", _
array("ListeVerif","Mise_en_marche", _
array("Rapports","Resultats"), _
"Prog", _
array("Prog_PLC","Prog_HMI","Prog_G7","Prog_Document","Prog_Intrants"), _
"Photos"), _
"Production", _
array("Avis_Modif","RNC","Nomenclature","Cahier_de_charge"), _
"Technique", _
array("Analyse_FNC", _
"Elec_Calculs", _
array("Revisions_Anterieures"), _
"Elec_Extrants", _
array("Revisions_Anterieures"), _
"Elec_Intrants", _
array("Revisions_Anterieures"), _
"Manuels", _
"Mec_Calculs", _
array("Revisions_Anterieures"), _
"Mec_Extrants", _
array("Revisions_Anterieures"), _
"Mec_Intrants", _
array("Revisions_Anterieures"), _
"Photos", _
array("Revisions_Anterieures"), _
"Rapport", _
array("Revisions_Anterieures"), _
"Securite"), _
"Ventes", _
array("Estimation","Intrants_clients", "Soumission"))

'=== 03 ===

rap01=""
sublvl=0
tagsublvl=0
lvl=1
dirnam=array("\\corp.stas.local\stas\projets\")

for each a in priara
rap01 = rap01 & a
next

rap01 = rap01 & "<form name=form01>"
rap01 = rap01 & "<b><table width=""100%"" BORDERCOLOR=""black"" class=MsoTableGrid border=1 CELLSPACING=0 cellpadding=2 "
rap01 = rap01 & "style='border-collapse:collapse;border:none'>"
'rap01 = rap01 & "<CAPTION></CAPTION><span style='color:purple'>" & vbcrlf

'=== ara01 = folders, jagged array
'=== con = contrat

pat = ""

'=== cli = client number
'=== con = contrat number
'=== pat = path server and client and contrat

'=== create all sub folders (pat is empty so we just draw the table in html)
pattot=0
arapat=array(pat)

'=== HTML only
call retfol(ara01,"",0,"",0)

'fmid.WriteLn("Total de la matrice de path: " & pattot & "<br>")

rap01=rap01 & "</table></form>"

fbot.WriteLn(rap01)

'=== permissions security acl ntfs
'objshe.run("c:\_stas\224211-informatique\xcacls.vbs \\ZSSERVER\Zaci\Ales /T /G <domainname>\administrator:F <domainname>\Ales:F")
'objshe.run("c:\_stas\224211-informatique\subinacl /noverbose /file \\ZSSERVER\Zaci\Ales /setowner=Ales")
'objshe.run("c:\_stas\224211-informatique\subinacl /noverbose /subdirectories \\ZSSERVER\Zaci\Alex /setowner=Ales")

'=== 04 ===

x=0
redim preserve distmp(x) :redim preserve namtmp(x) :redim preserve deftmp(x) :redim preserve typtmp(x) :redim preserve errtmp(x)
distmp(x)="Code du contrat" '===== description displayed in front of the field
namtmp(x)="text01" '===== name of variable for programming purpose
deftmp(x)="" '===== default value inside the form (the form will be 20 char long if no value here, but you can enter more)
typtmp(x)="textbox" '===== type of data: textbox password (futur: more to come)
errtmp(x)="###%% (### = client %% = contrat" '===== text to display after the form "facultatif" blue text "error" red text are special keywords

buttmp=array("ok","cancel") '===== at the end, there will be an "ok" button and a "cancel" button
tit = "STAS - Structure dossier"
a = dynforgen (distmp,namtmp,deftmp,typtmp,errtmp,buttmp,tit)

do
'=== flag to tell if the input is not valid
err01=0
'=== flag to say input is done, since there might be a defaut value, we must validate if user was finished
inpdon=0
'=== "ok" button or "enter" key are the same
'=== and nothing was pressed on left frame (control frame)

if resbutlefstr="" and (resbutmidstr="ok" or reskeymid=13) then
'=== User has clicked the OK button, retrieve the values
text=fmid.form01.text01.Value '=== namtmp is the variable name used earlier,before we call the dynamic form generation for input

if len(text) < 5 then
err01=1
'=== error message for the first form (if the keyword "error" is in this string, its displayed in RED)
if len(text) < 5 then
errtmp(0)="error - must be 5 char long at least"
else
errtmp(0)="ok"
end if

'=== if the value was not good, we generate the dynamic input for again, with an error message after the form in red
a = dynforgen(distmp,namtmp,deftmp,typtmp,errtmp,buttmp,tit)
'=== there was an invalid input so we reset the key or button pressed to nothing so the loop can continue
reskeymid=0
resbutmidstr=""
else
'=== the input was validated, we flag err01 to none, and flag inpdon to exit the loop
inpdon=1
err01=0
end if
end if
wscript.sleep 100

'=== while we wait for input value, user can press "escape" key, "cancel" button or close internet explorer
if resbutmidstr="cancel" or reskeymid=27 or bready=true or resbutlefstr<>"" then
'=== if user pressed escape or cancel, we clear the frames
if resbutmidstr="cancel" or reskeymid=27 then
a = clefra(array("fmid","fbot"))
resbutmidstr="cancel"
end if
exit do
end if
'=== if there was an input error and no one used left control frame to exit, we keep asking for input
loop while err01<>0 or inpdon=0

'=== if internet explorer was not closed (bready), a button was not pressed on left frame, and no excape or cancel in middle frame
if bready=false and resbutlefstr="" and reskeymid<>27 and resbutmidstr<>"cancel" then

'=== cli = client number
'=== con = contrat number
'=== pat = path server and client and contrat

'=== create basic folders I K S exchange
cli=ucase(mid(text,1,3))
con=ucase(right(text,len(text)-3))

'=== b = path du i projets
b = crebasfol(cli,con)

'=== create all sub folders (pat is not empty so we create folders)

newfol = 0
dejfol = 0
errfol = 0
pattot = 0
arapat=array(pat)
pat = b

'=== find highest id - root folders still must be at 0
sql = "SELECT id FROM [224].dbo.[folders_Struct] WHERE (id = (SELECT MAX([folders_Struct].id) FROM [224].dbo.[folders_Struct]))"
objOutputFile.WriteLine date & " " & time & " find last id for parentfolder id: " & vbcrlf & sql
Set tag = con_02.Execute(sql)
if not (tag.eof) then
parfolid = tag(0).value
else
parfolid = 0
end if

sublvl=0
tagsublvl=0
lvl=1
call retfol(ara01,pat,parfolid,cat,0)

fbot.WriteLn("<br>Structure<br><br>")

fbot.WriteLn("Dossiers nouveaux: " & newfol & "<br>")
fbot.WriteLn("Dossiers déjà existants: " & dejfol & "<br>")
fbot.WriteLn("Dossiers non créés, erreur: " & errfol & "<br><br>")

'=== 05 === exchange

fbot.WriteLn("FIN<br>")

reskeymid=0
resbutmidstr=""

end if
end if

'===================================================================================================================================================
if resbutlefstr="test555" then

'=== this was a test with multiple button value (one for each line)
a = clefra(array("fmid","fbot"))

x=0
redim preserve distmp(x) :redim preserve namtmp(x) :redim preserve deftmp(x) :redim preserve typtmp(x) :redim preserve errtmp(x)
distmp(x)="what do you want to display" '===== description displayed in front of the field
namtmp(x)="text01" '===== name of variable for programming purpose
deftmp(x)="hello world" '===== default value inside the form (the form will be 20 char long if no value here, but you can enter more)
typtmp(x)="textbox" '===== type of data: textbox password (futur: more to come)
errtmp(x)="enter a text to display" '===== text to display after the form "facultatif" blue text "error" red text are special keywords

buttmp=array("ok","cancel") '===== at the end, there will be an "ok" button and a "cancel" button

a = dynforgen (distmp,namtmp,deftmp,typtmp,errtmp,buttmp,tit)

do
'=== flag to tell if the input is not valid
err01=0
'=== flag to say input is done, since there might be a defaut value, we must validate if user was finished
inpdon=0
'=== "ok" button or "enter" key are the same
'=== and nothing was pressed on left frame (control frame)

if resbutlefstr="" and (resbutmidstr="ok" or reskeymid=13) then
'=== User has clicked the OK button, retrieve the values
text=fmid.form01.text01.Value '=== namtmp is the variable name used earlier,before we call the dynamic form generation for input

if len(text) < 1 then
err01=1
'=== error message for the first form (if the keyword "error" is in this string, its displayed in RED)
if len(text) < 1 then
errtmp(0)="error - must be 1 char long at least"
else
errtmp(0)="ok"
end if

'=== if the value was not good, we generate the dynamic input for again, with an error message after the form in red
a = dynforgen(distmp,namtmp,deftmp,typtmp,errtmp,buttmp,tit)
'=== there was an invalid input so we reset the key or button pressed to nothing so the loop can continue
reskeymid=0
resbutmidstr=""
else
'=== the input was validated, we flag err01 to none, and flag inpdon to exit the loop
inpdon=1
err01=0
end if
end if
wscript.sleep 100

'=== while we wait for input value, user can press "escape" key, "cancel" button or close internet explorer
if resbutmidstr="cancel" or reskeymid=27 or bready=true or resbutlefstr<>"" then
'=== if user pressed escape or cancel, we clear the frames
if resbutmidstr="cancel" or reskeymid=27 then
a = clefra(array("fmid","fbot"))
resbutmidstr="cancel"
end if
exit do
end if
'=== if there was an input error and no one used left control frame to exit, we keep asking for input
loop while err01<>0 or inpdon=0

'=== if internet explorer was not closed (bready), a button was not pressed on left frame, and no excape or cancel in middle frame
if bready=false and resbutlefstr="" and reskeymid<>27 and resbutmidstr<>"cancel" then
fbot.WriteLn(text & "<br>")
end if

reskeymid=0
resbutmidstr=""

end if

if resbutlefstr="newdb" then
'=== create a new database mdb type (Access 2000)
tit="new database" '=== title to display in fmid frame (input frame)

'=== clear 2 frames (input: fmid, and result: fbot)
'=== also clear the result button name for all frames and the key pressed on all frames
a = clefra(array("fmid","fbot"))

'=== dynamic generation of input form, and control buttons in fmid (middle or up frame, called "input" frame for more clarity, fmid object)

'=== inputs to do before processing
'=== you can add more input forms, at the end, there will be an "ok" button and a "cancel" button

x=0
redim preserve distmp(x) :redim preserve namtmp(x) :redim preserve deftmp(x) :redim preserve typtmp(x) :redim preserve errtmp(x)
distmp(x)="Database name" '===== description displayed in front of the field
namtmp(x)="dbnam" '===== name of variable for programming purpose
deftmp(x)="testmdbaccess2000" '===== default value inside the form (the form will be 20 char long if no value here, but you can enter more)
typtmp(x)="textbox" '===== type of data: textbox password (futur: more to come)
errtmp(x)=".MDB enter name of DB file" '===== text to display after the form "facultatif" blue text "error" red text are special keywords

x=x+1
redim preserve distmp(x) :redim preserve namtmp(x) :redim preserve deftmp(x) :redim preserve typtmp(x) :redim preserve errtmp(x)
distmp(x)="Table name" '===== description displayed in front of the field
namtmp(x)="tabnam" '===== name of variable for programming purpose
deftmp(x)="table01" '===== default value inside the form (the form will be 20 char long if no value here, but you can enter more)
typtmp(x)="textbox" '===== type of data: textbox password (futur: more to come)
errtmp(x)="enter name of first table" '===== text to display after the form "facultatif" blue text "error" red text are special keywords

buttmp=array("ok","cancel") '===== at the end, there will be an "ok" button and a "cancel" button

a = dynforgen (distmp,namtmp,deftmp,typtmp,errtmp,buttmp,tit)

do
'=== flag to say input is done, since there might be a defaut value, we must validate if user was finished
inpdon=0
err01=0

'=== "ok" button or "enter" key are the same
'=== and nothing was pressed on left frame (control frame)

if resbutlefstr="" and (resbutmidstr="ok" or reskeymid=13) then

'=== User has clicked the OK button, retrieve the values
dbnam = fmid.form01.dbnam.Value '=== namtmp is the variable name used earlier,before we call the dynamic form generation for input
dbnam=lcase(dbnam)

tabnam = fmid.form01.tabnam.Value '=== namtmp is the variable name used earlier,before we call the dynamic form generation for input
tabnam=lcase(tabnam)

if len(dbnam) < 1 or len(tabnam)<1 then
err01=1
'=== error message for the first form (if the keyword "error" is in this string, its displayed in RED)
if len(dbnam) < 1 then
errtmp(0)="error - name must be 1 char long at least"
else
errtmp(0)="ok"
end if
if len(tabnam) < 1 then
errtmp(1)="error - name must be 1 char long at least"
else
errtmp(1)="ok"
end if

'=== if the value was not good, we generate the dynamic input for again, with an error message after the form in red
a = dynforgen(distmp,namtmp,deftmp,typtmp,errtmp,buttmp,tit)
reskeymid=0
resbutmidstr=""
else
'=== the input was validated, we flag err01 to none, and flag inpdon to exit the loop
inpdon=1
err01=0
end if

end if
wscript.sleep 100

'=== while we wait for input value, user can press "escape" key, "cancel" button or close internet explorer
if resbutmidstr="cancel" or reskeymid=27 or bready=true or resbutlefstr<>"" then
'=== if user pressed escape or cancel, we clear the frames
if resbutmidstr="cancel" or reskeymid=27 then
a = clefra(array("fmid","fbot"))
resbutmidstr="cancel"
end if
exit do
end if

'=== if there was an input error and no one used left control frame to exit, we keep asking for input
loop while err01<>0 or inpdon=0
'===
if bready=false and resbutlefstr="" and reskeymid<>27 and resbutmidstr<>"cancel" then
'=== all value were validated, we continue
dbnam = dbnam & ".mdb"

'=== chek if the file already exist
Set objFolder2 = objFSO.GetFolder(basedir)'=== dir
Set objFiles2 = objFolder2.files '=== fichiers

found=0
For Each objFile3 in objFiles2
nomfile=objfile3.name
nomfile=lcase(nomfile)
if nomfile=dbnam then
found=1
end if
next
if found=1 then
a = clefra(array("fmid"))
fbot.WriteLn("The file: <br>" & dbnam & "<br>Already exist<br><br>Please use EDIT DATABASE to manage it<br><br>")
fbot.WriteLn("FIN<br><br>")

fbot.WriteLn("LIST of table in the existing database:<br><br>")
Set objcat = CreateObject("ADOX.Catalog")
Set objcon = CreateObject("ADODB.Connection")
constr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbnam
objcon.open constr
objcat.activeconnection=(objcon)
for each tab in objcat.Tables
If tab.Type = "TABLE" Then
fbot.WriteLn("<br>TABLES:<br><br>")
fbot.WriteLn(tab.name & "<br>")
fbot.WriteLn("<br>COLUMNS:<br><br>")
for each col in tab.columns
c = lcase(col.name)
fbot.WriteLn(c & "<br>Type: " & col.type & "&nbsp&nbsp&nbspAutoincrement: " & col.Properties("AutoIncrement") & "<br>")
next
end if
next
objcon.close
set objcat=nothing
set objcon=nothing
else
a = clefra(array("fmid"))
'=== formats: jet10 = 1 Jet11 = 2 Jet20 = 3 Jet3x = 4 Jet4x = 5 (Access 2000)
Dim Catalog
fbot.WriteLn("Creation ADOX catalog (adox.dll, access required)<br><br>")

Set objcat = CreateObject("ADOX.Catalog")
format = 5
fbot.WriteLn("database creation: " & dbnam & "<br><br>")

constr="Provider=Microsoft.Jet.OLEDB.4.0;" & "Jet OLEDB:Engine Type=" & Format & ";Data Source=" & dbnam
objcat.Create constr

'=== add a table in the database
fbot.WriteLn("table creation: " & tabnam &"<br>")
Set objtab = CreateObject("ADOX.table")
objtab.name = tabnam
objcat.Tables.Append objtab
objcat.Tables.refresh

'=== add a columns in the only existing table
for each tab in objcat.Tables
If tab.Type = "TABLE" Then

fbot.WriteLn("table existing: " & tab.name & "<br>")
'=== add column in database
Set objcol = Nothing
Set objcol = CreateObject("ADOX.Column")

'typdat=202 '=== string adVarWChar
'maxlen=250
'typdat=131 '=== float adnumeric
'maxlen=10
typdat=3 '=== integer adinteger
maxlen=10

if typdat=3 then a="adinteger"
if typdat=202 then a="adVarWChar"
if typdat=131 then a="adnumeric"

colnam="codint"
objcol.name = colnam
objcol.type = typdat
if typdat = 3 or typdat = 202 then
objcol.DefinedSize = maxlen
if typdat=3 then
'=== must set parent catalog before setting autoincrement
Set objcol.ParentCatalog = objcat
objcol.Properties("AutoIncrement")=true
end if
elseif typdat = 131 then
objcol.precision = 28
objcol.numericscale = 8
end if
fbot.WriteLn("column creation: " & colnam & "<br>")
Tab.Columns.Append objcol

fbot.WriteLn("primary key creation: " & colnam & "<br>")
Set objkey = CreateObject("ADOX.key")
objkey.name="Primary"
objkey.columns.append colnam
tab.keys.append objkey

'Set aIndex = New ADOX.Index
'aIndex.Name = "ByField2"
'aIndex.Clustered = False
'aIndex.Columns.Append "Field2"
'aIndex.Columns.Append "Field1"
'aTable.Indexes.Append aIndex ' save the index

for each col in tab.columns
c = lcase(col.name)
fbot.WriteLn("column existing: " & c & "&nbsp&nbsp&nbspautoincrement status: " & objcol.Properties("AutoIncrement") & "<br>")
next

end if
next

set objcat=nothing

fbot.WriteLn("<br>You database have been created with 1 table and a defaut column named " & colnam & "<br>")
fbot.WriteLn("<br>END<br>")
end if
else
'msgbox(resbutlefstr & " " & resbutmidstr & " " & resmidkey & " " & bready)
'===
end if
reskeymid=0
resbutmidstr=""
dbnam=""
end if
'===========================
if resbutlefstr="edtdb" then
resbutlefstr = ""

a = clefra(array("fmid","fbot"))

'=== value
'=== chek if the file already exist
Set objFol01=objFSO.GetFolder(basedir)'=== dir
Set objfol02=objFol01.files '=== files

x=0
redim ara01(0)
dimnum=1
For Each objFil in objFol02
filnam=objfil.name
filnam=lcase(filnam)
if right(filnam,4)=".mdb" then
redim preserve ara01(x)
ara01(x)=filnam
x=x+1
end if
next

'=== title of the columns
aratit = array("Name of the database")

'=== array to put in table, choice button, header, middle line, bottom line, reload
a = dynbotcho(fmid, "choose the database to edit", aratit, ara01, 1 ,1, 1, 1, 1, 0,"mid")

do
wscript.sleep 100

'=== while we wait for input value (or button press), user can press "escape" key, "cancel" button or close internet explorer
if resbutmidstr="cancel" or reskeymid=27 or bready=true or resbutlefstr<>"" then
'=== if user pressed escape or cancel, we clear the frames
if resbutmidstr="cancel" or reskeymid=27 then
a = clefra(array("fmid","fbot"))
resbutmidstr="cancel"
end if
exit do
end if

loop while resbutmidstr=""

if bready=false and resbutlefstr="" and reskeymid<>27 and resbutmidstr<>"cancel" then

'=== convert the choice made with the button to a number (remove "but" from left side)
a=right(resbutmidstr,len(resbutmidstr)-3)
resbutmidstr=""
'=== get the array that contain the choice in dbnam (database name)
dbnam=ara01(a-1)

'=== open the database
Set objcat = CreateObject("ADOX.Catalog")
Set objcon = nothing
Set objcon = CreateObject("ADODB.Connection")

constr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbnam
objcon.open constr
objcat.activeconnection=(objcon)

'=== pressing left control button while in a function will call a sub make internet explorer crash
'=== so i have to put the table choice in main loop, cant do a sub

'=== choose the table to edit

a = clefra(array("fmid","fbot"))

aratit=array("Table name")
x=0
redim ara01(0)
for each tab in objcat.Tables
If tab.Type = "TABLE" Then
c = lcase(tab.name)
redim preserve ara01(x)
ara01(x)=c
x=x+1
end if
next

a = dynbotcho(fmid, "Choose the table to edit", aratit, ara01, 1 ,1, 1, 1, 1, 0, "mid")

do
wscript.sleep 100

'=== while we wait for input value (or button press), user can press "escape" key, "cancel" button or close internet explorer
if resbutmidstr="cancel" or reskeymid=27 or bready=true or resbutlefstr<>"" then
'=== if user pressed escape or cancel, we clear the frames
if resbutmidstr="cancel" or reskeymid=27 then
a = clefra(array("fmid","fbot"))
resbutmidstr="cancel"
end if
exit do
end if

loop while resbutmidstr=""

if bready=false and resbutlefstr="" and reskeymid<>27 and resbutmidstr<>"cancel" then

'=== convert the choice made with the button to a number (remove "but" from left side)
a=right(resbutmidstr,len(resbutmidstr)-3)
resbutmidstr=""
'=== get the array that contain the choice in dbnam (database name)
tabnam=ara01(a-1)

for each tab in objcat.Tables
If tab.Type = "TABLE" Then
if tabnam = lcase(tab.name) then set objtab=tab
end if
next

'sql = makque(symptom,tab,sel,whe," order by [probabilité] DESC","LIKE","%")
sql = "select * from " & tabnam
a = exesql(objcon,tag,sql)

'i=0
'For Each a In TAG.fields
'=== columns names
'if cc01<>0 then if i=0 then htmtab = htmtab & "<td><p>Select</td>"
'htmtab = htmtab & "<td><p>" & Trim(a.Name) & "</td>"
'i=i+1
'Next

if tag.eof=0 then
myarray = TAG.GetRows()
end if

aratit=array("test")
a = dynbotcho(fbot, tabnam, aratit, myarray, 1 ,1, 1, 1, 1, 1,"bot")

'=== list columns in table
'for each col in objtab.columns
' fbot.WriteLn(c & "<br>Type: " & col.type & "&nbsp&nbsp&nbspAutoincrement: " & col.Properties("AutoIncrement") & "<br>")
'next
do
wscript.sleep 100

'=== while we wait for input value (or button press), user can press "escape" key, "cancel" button or close internet explorer
if resbutbotstr="cancel" or reskeymid=27 or bready=true or resbutlefstr<>"" then
'=== if user pressed escape or cancel, we clear the frames
if resbutmidstr="cancel" or reskeymid=27 then
a = clefra(array("fmid","fbot"))
resbutmidstr="cancel"
end if
exit do
end if

loop while resbutbotstr=""

if bready=false and resbutlefstr="" and reskeymid<>27 and resbutmidstr<>"cancel" then
fbot.WriteLn(resbutbotstr)
end if
end if

end if

'========================== caca2



'msgbox("exit on left button" & resbutlefstr)
'resbutlefstr = ""
resbutmidstr = ""
resbutbotstr = ""
reskeylef = 0
reskeymid = 0
reskeybot = 0

end if

if resbutlefstr="srcdb" then

end if

if resbutlefstr="test33" then

'=== this was a test with multiple button value (one for each line)
a = clefra(array("fmid","fbot"))

fmid.WriteLn("<html><body>TEST</html></body>")
'=== bottom section
fbot.WriteLn("<html><body>TEST mid section")
fbot.WriteLn("<html><body><form method='post' name='form1'>")

butnam = "buttonbot"

for ii=0 to 10
fbot.WriteLn("<input type=""button"" style=""height:50px;font-size:14px;width:50%;"" name=""" & butnam & ii &""" value=""" & butnam & ii & """ ")
fbot.WriteLn("style=""background-color: #cccccc; color: #000000;""><br>")
next

fbot.WriteLn("</form>")
fbot.WriteLn("</html>")
fbot.WriteLn("</body>")

for ii=0 to 10
fbot.forms(0).elements(butnam & ii).onclick = getref("buttonbot")
next

'=== loop until a button is pressed on left frame or ie is closed
do
wscript.sleep 100
if resbutbotstr<>"" then
fmid.WriteLn(resbutbotstr)
resbutbotstr=""
end if
loop while resbutlefstr="" and bReady=false

'=== ie is still open and but come button was pressed on left frame
if bready=false and resbutlefstr<>"" then
'=== we remove the actions on the buttons
for ii=0 to 10
fbot.forms(0).elements(butnam & ii).onclick = nothing
next

'=== clear frames, reset button value and keyvalue
if resbutlefstr<>"quit01" then
a = clefra(array("fmid","fbot"))
end if
end if

end if

'=== desarchivage (move files from archives to temp folder and pop outlook message)
'=== here as reference onlym not working, missing a sub

if resbutlefstr= "desarchive" then
tit="Désarchivage"
'=== refresh menu (chek button = 0)
a = clefra(array("fmid","fbot"))
'=== inputs to do before processing

distmp=array("Login","Password","Numéro(s) de contrat")
namtmp=array("login","password","connum")
deftmp=array("","","")
typtmp=array("textbox","password","textbox")
errtmp=array("Facultatif","Facultatif","")
buttmp=array("ok","cancel")

a = dynforgen (distmp,namtmp,deftmp,typtmp,errtmp,buttmp,tit)

do
err01=0

if resbutlefstr="" and (resbutmidstr="ok" or reskeymid=13) then

'=== User has clicked the OK button, retrieve the values
connum = fmid.form01.connum.Value

if len(connum) < 5 then
a = "error - contrat doit avec 5 caractères"
err01=1
errtmp(2)=a
a = dynforgen (distmp,namtmp,deftmp,typtmp,errtmp,buttmp,tit)
end if
end if
wscript.sleep 100
if resbutmidstr="cancel" or reskeymid=27 then exit do
loop while (err01<>0 and resbutlefstr="") or (connum="" and resbutlefstr="")

if resbutlefstr="" and (resbutmidstr="ok" or reskeymid=13) then
'=== doing the job, all input are ok

clefra(array("fmid"))

a = desarchive2(connum,fbot)

fbot.WriteLn("done<br>")

resbutmidstr=""
reskeymid=0

elseif resbutlefstr="" and (resbutmidstr="cancel" or reskeymid=27) then
'=== nothing was pressed on left, but cancel was used or escape
a = clefra(array("fmid","fbot"))
elseif resbutlefstr<>"" then
'=== sometthing hapenned with the buton on the left side (menu/control)
a = clefra(array("fmid","fbot"))
end if

end if
'=== .1 seconds
wscript.sleep 100

'=== we loop until internet explorer was closed or the quit button was pressed
loop until bReady or resbutlefstr="quit01"

'======================
'====================== end of main loop
'======================

'=== someone pressed "quit" on left frame (control frame, flef object)

'=== at the end, if internet explorer was not closed, we close it
if bready=false then
oie.quit
set oie=nothing
end if

'=== we end wscript.exe, exiting all running code interpretation
wscript.quit

'==================================================================================================

'=== many subs

'=== if internet explorer is closed (event) we change bready value to TRUE
sub IE_onQuit()
bReady=true
end sub

'=== database creation, mdb, access 2000
function credb()
'=== formats: jet10 = 1 Jet11 = 2 Jet20 = 3 Jet3x = 4 Jet4x = 5

'=== Create Access2000 database
CreateNewMDB basedir & "test.mdb", 5

'=== list of tables to create
alltab(0) = "tab01"
alltab(1) = "components"
alltab(2) = "diagnostic"
alltab(3) = "causes"

'=== with a column for identification, numerical, autoincremental

'=== 0 creation columns
'=== 1 search in thoses columns
'=== 2 fast/short results columns
'=== 3 detail results columns

'=== columns to create (first numner is table number, second is array number, 0 = creation)
allara(0,0) = array( _
"[codeint]", _
"[test01]")

'=== columns to search in

'=== short result (What columns to display if the result should be short)

'=== detailed results (almost all columns with data)

end function

'============================================== subs and functions ====================================

Sub CreateNewMDB(FileName, Format)
Dim Catalog
Set Catalog = CreateObject("ADOX.Catalog")
Catalog.Create "Provider=Microsoft.Jet.OLEDB.4.0;" & "Jet OLEDB:Engine Type=" & Format & ";Data Source=" & FileName
End Sub

'=== frames clear content by navigating to a blank
'=== input is an array containing name of frames as "flef" = frame left
'=== this sub generate a code and execute it in a string (cc)
'=== fully dynamic programming at it's best ;)

function clefra(aara)
'Do Until .Document.ReadyState = "complete"
' DoEvents
'Loop

cc=""
for each aa in aara
cc = cc & "Do While (oIE.Busy)" & vbcrlf
cc = cc & " wscript.sleep 200" & vbcrlf
cc = cc & "Loop" & vbcrlf
cc = cc & "Do While oie.readystate<>4" & vbcrlf
cc = cc & " wscript.sleep 200" & vbcrlf
cc = cc & "Loop" & vbcrlf
cc = cc & aa & ".location.reload(true)" & vbcrlf
cc = cc & "Do While (oIE.Busy)" & vbcrlf
cc = cc & " wscript.sleep 200" & vbcrlf
cc = cc & "Loop" & vbcrlf
cc = cc & "Do While " & aa & ".ReadyState = ""Terminé"" or " & aa & ".ReadyState = ""Complete""" & vbcrlf
cc = cc & " wscript.sleep 200" & vbcrlf
cc = cc & "Loop" & vbcrlf
cc = cc & "Do While oie.readystate<>4" & vbcrlf
cc = cc & " wscript.sleep 200" & vbcrlf
cc = cc & "Loop" & vbcrlf
cc = cc & aa & ".WriteLn("" "")" & vbcrlf
cc = cc & aa & ".location.reload(true)" & vbcrlf
cc = cc & "Do While oie.readystate<>4" & vbcrlf
cc = cc & " wscript.sleep 200" & vbcrlf
cc = cc & "Loop" & vbcrlf
cc = cc & "Do While (oIE.Busy)" & vbcrlf
cc = cc & " wscript.sleep 200" & vbcrlf
cc = cc & "Loop" & vbcrlf
cc = cc & "Do While " & aa & ".ReadyState = ""Terminé"" or " & aa & ".ReadyState = ""Complete""" & vbcrlf
cc = cc & " wscript.sleep 200" & vbcrlf
cc = cc & "Loop" & vbcrlf
next

execute cc

'=== we also clear the variables used to control the action buttons and the key pressed in each frames
'=== so the action wont be taken twice (or infinitly) in the main loop

'set flef = oie.document.frames("left").document
'set fmid = oie.document.frames("middle").document
'set fbot = oie.document.frames("bottom").document

'for i=0 to ubound(arabutnam)
' flef.forms(0).elements(arabutnam(i)).onclick = getref("buttonlef")
'next

'=== we also chek the key presse in each frame
'=== we do this cause we want "enter" key to be used instead of pressing "ok" button with the mouse
'set flef.onkeypress = GetRef("Checklef")
'set fmid.onkeypress = GetRef("Checkmid")
'set fbot.onkeypress = GetRef("Checkbot")

resbutlefstr = ""
resbutmidstr = ""
resbutbotstr = ""
reskeylef = 0
reskeymid = 0
reskeybot = 0
end function

'=== form dynamically generated =========================================================================

function dynforgen (distmp, namtmp,deftmp,typtmp,errtmp,buttmp,title)

'=== generate a form for input in the input frame (fmid object)
'=== focus on the first field with no default value
'=== display suffix message in red if "error" (or "erreur" - french) keyword is in it

fmid.WriteLn("<h3><span class=SpellE>" & title & "</span></h3>")
'=== default focus on empty field (with no default value)
deffoc=0
for ii=0 to ubound(namtmp)
if deftmp(ii)="" then
if instr(lcase(errtmp(ii)),"facultatif")=0 then
fmid.WriteLn("<BODY onLoad=""document.form01." & namtmp(ii) & ".focus()"">")
deffoc=1
end if
end if
'=== no default value empty, we focus on first field
next
if deffoc=0 then
fmid.WriteLn("<BODY onLoad=""document.form01." & namtmp(0) & ".focus()"">")
end if
fmid.WriteLn("<div class=MsoNormal align=center style='text-align:center'>")
fmid.WriteLn("</div>")

fmid.WriteLn("<form name=form01>")

'=== button and error message
for ii=0 to ubound(namtmp)

fmid.WriteLn(distmp(ii) & ": ")

'=== we disable "enter" to submit form because we manage this event as a onkeypress in the parent frame of the form later
'=== we had to do this, because the web page form is not run on a server, and the web page dont have control, the VBS script outside the page have control

fmid.WriteLn("<input type=""" & typtmp(ii) & """ id=" & namtmp(ii) & " NAME=""" & namtmp(ii) & """ size=""" & max(20,len(deftmp(ii))) & """ value=""" & deftmp(ii) & """ onKeypress=""return event.keyCode!=13""")
'fmid.WriteLn("")
if instr(lcase(errtmp(ii)),"error")<>0 or instr(lcase(errtmp(ii)),"erreur")<>0 then
col="red"
else
col="blue"
end if
fmid.WriteLn("  <b><span style='color:" & col & "'>&nbsp" & errtmp(ii) & "</span></b><br style='mso-special-character:line-break'>")
next

fmid.WriteLn("<![if !supportLineBreakNewLine]><br style='mso-special-character:line-break'>")
fmid.WriteLn("<![endif]></p>")

for ii=0 to ubound(buttmp)
typ01 = "button"
fmid.WriteLn("<input type=""" & typ01 & """ name=""" & buttmp(ii) & """ value="" " & buttmp(ii) & " "">")
fmid.WriteLn("&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp&nbsp")
next

fmid.WriteLn("</div>")
fmid.WriteLn("</form>")
fmid.WriteLn("</body>")
fmid.WriteLn("</html>")

fmid.location.reload(true)

'=== wait for internet explorer to be ready after we refresh the page with the new form
for ii=0 to ubound(buttmp)
Do While (oIE.Busy)
wscript.sleep 100
loop
do while oie.readystate<>4
wscript.sleep 100
Loop
'=== value to return for each button in the form
fmid.forms(0).elements(buttmp(ii)).onclick = getref("buttonmid")
next

'=== regenerate the event that call a sub if a button is pressed
set fmid.onkeypress = GetRef("Checkmid")

'=== clear button pressed and key pressed for this frame
resbutmidstr=""
reskeymid=0
end function

'=== max
Function max(a, b)
If a > b Then max = a Else max = b
End Function

function crewebmai(oie, doctit, maitit, arabutnam, arabutdes, aradepnam, aradepcol)

'=== create an internet explorer object (oie) that will be in 3 frames (flef, fmid, fbot), acting at the main interface for all this program

oie.FullScreen = False
'.ToolBar = False
'.StatusBar = False
'.Navigate("About:Blank")
'.visible = true

oIE.left=0 ' window position
oIE.top = 0 ' and other properties
'.ParentWindow
' .resizeto 640,300
' .moveto (.screen.width
oIE.height = 500
oIE.width = 500
oIE.menubar = 1 '=== no menu
oIE.toolbar = 1
oIE.statusbar = 1
oIE.RegisterAsDropTarget = True
oie.Navigate("about:blank")
oie.document.title = doctit
oiewid = oie.document.parentwindow.screen.width
oiehei = oie.document.parentwindow.screen.height
sizwidpercent = 100
sizheipercent = 95
loswid = 100-sizwidpercent
loshei = 100-sizheipercent
newwid = oiewid*sizwidpercent*.01
newhei = oiehei*sizheipercent*.01
oie.document.parentwindow.resizeto newwid,newhei
newx = oiewid * loswid * .01 /2
newy = oiehei * (loshei/2) * .01 /2
oie.document.parentwindow.moveto newx, newy
oIE.visible = 1 '=== visible on
oie.addressbar=false

'=== we will always have 3 frames, control, input and output (flef, fmid, fbot)
'=== used an array to have a good view of the line of html and possibility to add something else easily
aratmp=array(_
"<HTML>",_
"<HEAD><TITLE>" & doctit & "</TITLE></HEAD>",_
"<FRAMESET COLS=""13%, *"">",_
"<FRAME SRC=""About:Blank"" NAME=""left"">",_
"<frameset rows=""30%,70%"">",_
"<FRAME SRC=""About:Blank"" NAME=""middle"">",_
"<body background=""" & basedir & "LOGO-STAS-FOND.jpg"">",_
"<FRAME SRC=""About:Blank"" NAME=""bottom"">",_
"</FRAMESET>",_
"</HTML>")

'oie.Navigate("About:Blank")

'=== send the array content in internet explorer to create 3 frames
for i = 0 to UBound(aratmp, 1)
oie.document.WriteLn(aratmp(i))
next
oie.refresh
Do While (oIE.Busy)
wscript.sleep 100
Loop

'=== wait till document loaded
do while oie.readystate<>4
wscript.sleep 100
Loop

'=== vista activate
'=== make internet explorer the main active window
a = objShe.AppActivate("http:/// - " & doctit & " - M")
a = objShe.AppActivate(doctit & " - M")

'=== theses objects are used to send data to the 3 different frames
'=== if you dont define them as object, the access to them is very slow when we use the names instead of the objects

'=== object used to write in a frame with writeln
set flef = oie.document.frames("left").document
set fmid = oie.document.frames("middle").document
set fbot = oie.document.frames("bottom").document

'=== object used to navigate an empty page in a frame
'set flefl = oie.document.frames("left").location
'set fmidl = oie.document.frames("middle").location
'set fbotl = oie.document.frames("bottom").location

'=== string result for a button press in a frame (lef = left frame, mid = middle frame (up))
resbutlefstr=""
resbutmidstr=""
resbutbotstr=""

reskeylef=0
reskeymid=0
reskeybot=0

'=== all the chek to be made in first page (1 at the moment, since ready have many values)

nbrbut=UBound(arabutnam, 1)
redim buttag(nbrbut)
form = "flef"

flef.WriteLn("<html><body>")
flef.WriteLn("<body background=""" & basedir & "LOGO-STAS-FOND.jpg"">")
flef.WriteLn("<h3><span class=SpellE>" & maitit & "</span></h3>")
flef.WriteLn("<form name='form1'>")

for i=0 to ubound(arabutnam)

'=== convert xls to mdb button appear for stas only

if ((usenam="wildboy" or usenam="fournier.serge" or usenam="fortin.jp" or usenam="lavoie.daniel" or usenam="doucet.gm") and arabutnam(i)="excel2mdb") or arabutnam(i)<>"excel2mdb" then

'style="background-color: #cc0000; color: #ffffff;" /
b = "<input type=""button"" style=""height:50px;font-size:14px;width:100%;"" name=""" & arabutnam(i) & """ value=""" & arabutdes(i) & """"
i2=i
if i>ubound(aradepnam) then
i2=ubound(aradepnam)
else
a=aradepnam(i2)
end if

if a<>lasdep then
'=== new departement name
flef.WriteLn( "<br>" & a & "<br>")
lasdep=a
end if
b = b & " style=""background-color: #" & aradepcol(i2) & "; color: #000000;""><br>"
flef.WriteLn(b)
end if
next

flef.WriteLn("</form>")
flef.WriteLn("</body>")
flef.WriteLn("</html>")

'=== we dont refresh this frame, its the first one

end function

'=== sub to call when something is pressed
'=== called for many buttons, return the button name or a keyboard code (Ascii)
sub buttonlef
set src = flef.parentWindow.event.srcElement
resbutlefstr = src.name
end sub

sub buttonmid
set src = fmid.parentWindow.event.srcElement
resbutmidstr = src.name
end sub

sub buttonbot
set src = fbot.parentWindow.event.srcElement
resbutbotstr = src.name
end sub

sub Checklef
reskeylef = flef.parentWindow.event.keycode
end sub

sub Checkmid
reskeymid = fmid.parentWindow.event.keycode
end sub

sub Checkbot
reskeybot = fbot.parentWindow.event.keycode
end sub

'=== chek in the actual folder if a file exist
function filsea(filname)

'=== chek also actual folder for a "Rappel_LOG" file (instr)
Set objFolder2 = objFSO.GetFolder(basedir)'=== dir
Set objFiles2 = objFolder2.files '=== fichiers

found=0 '=== fichier de rapport pas trouve
For Each objFile3 in objFiles2
nomfile =objfile3.name
nomfile= lcase(nomfile)

next

end function

'=== delete a table in a database

function tabdel()

for each tab in objcat.Tables
If tab.Type = "TABLE" Then
b=lcase(tab.name)
'=== object.delete not supported, so we delete with name
objcat.tables.delete b
fbot.WriteLn("delete: " & b & "<br>")
END IF
next

end function

'=== for reference
function dynbotcho00
i3=0
For each dia01 in choiceara
sql = makque(dia01,tab,sel,whe,"","=","")
a = exesql(objcon,tag,sql)

'=== make same array for a multiples queries
if tag.eof=0 then
'a = dynbotcho("DIAGNOSTIC",tag,0,sql,1,1,1,1) '=== 1 2 3
if ubound(choiceara)=0 and i3=0 then
a = dynbotcho("DIAGNOSTIC",tag,0,sql,1,1,1,1) '=== 1 2 3
elseif i3=0 then
'=== header
a = dynbotcho("DIAGNOSTIC",tag,0,sql,1,1,0,0) '=== 1 2 3
elseif i3<>ubound(choiceara) and i3<>0 then
'=== footer
a = dynbotcho("DIAGNOSTIC",tag,0,sql,0,1,0,0) '=== 1 2 3
elseif i3=ubound(choiceara) then
a = dynbotcho("DIAGNOSTIC",tag,0,sql,0,1,1,1) '=== 1 2 3
end if
i3 = i3 + 1
else
'=== 0 results
a = nores(sql)
end if
next
end function

function dynbotcho(ffra, ttext, aaratit, aara, cc01 ,hh, mm, ff, rr, ttxtbox,ffranam)
'=== ffra frame to use for display (object)
'=== ttext to display
'=== aara = array with what to display
'=== cc = choice button
'=== sql = sql query for debugging
'=== hh = 1 = header
'=== mm = 1 = middle
'=== bb = 1 = footer
'=== rr = 1 = reload at end
'=== ttxtbox = all data are in a textbox so we can edit them
call oieready
xmax = UBound(aara, 1) 'Returns the Number of columns --- elements in first dimension
on error resume next
'=== chek the number of elements in second dimension, if there is none, then the array is only a list with 1 column
ymax = UBound(aara, 2) 'Returns the Number of rows --- elements in second dimension

'=== number of dimensions in case there is only 1 column
if err<>0 then
dimnum=1
else
dimnum=2
end if
on error goto 0

'=== web script for buttons to return the number of the button that was pressed

'=== print button
if hh=1 then
for each a in priara
ffra.WriteLn(a)
ffra.WriteLn("<form name=form01>")
'ffra.WriteLn("<BODY onLoad=""document.form01." & namtmp(0) & ".focus()"">")
next
end if

'=== select buttons
if cc01<>0 then
'=== buttons var only if select is active
if cc01<>0 then
for yy=0 to ymax

next
end if
end if

fast=1
'=== header
if hh=1 then

htmtab = ttext & "<b><table width=""100%"" BORDERCOLOR=""black"" class=MsoTableGrid border=1 CELLSPACING=0 cellpadding=2 style='border-collapse:collapse;border:none'>"
htmtab = htmtab & "<CAPTION></CAPTION><span style='color:purple'>" & vbcrlf
if fast=1 then ffra.WriteLn(htmtab):htmtab=""
'=== tableau html
htmtab = htmtab & "<TR>"
if fast=1 then ffra.WriteLn(htmtab):htmtab=""
i=0
For Each a In aaratit
'=== columns names
if cc01<>0 then if i=0 then htmtab = htmtab & "<td><p>Select</td>"
'=== test to text box inside each field with a default value for editing
test=0
if test=0 then
htmtab = htmtab & "<td><p>" & Trim(a) & "</td>"
if fast=1 then ffra.WriteLn(htmtab):htmtab=""
else
'=== futur button to order by that column
'=== futur textbox to search in this column
htmtab = htmtab & "<td><p>" & Trim(a) & "</td>"
if fast=1 then ffra.WriteLn(htmtab):htmtab=""
end if
i=i+1
if dimnum=1 then exit for
Next
htmtab = htmtab & "</tr>"
if fast=1 then ffra.WriteLn(htmtab):htmtab=""
end if

'=== middle
if mm=1 then

'=== x is inversed when only one column
if dimnum=1 then ymax=xmax

For yy = 0 To ymax
htmtab = htmtab & "<TR>"
if dimnum=2 then
'ffra.WriteLn(yy)
For xx = 0 To xmax
'If IsNull(myarray(xx, yy)) Then myarray(xx, yy) = ""
if xx=0 and cc01<>0 then
htmtab = htmtab & "<td><p>"
htmtab = htmtab & "<input type=""button"" name=""" & "but" & trim(cstr(yy+1)) & """ value=""" & "Select " & yy+1 & """"
htmtab = htmtab & " style=""background-color: #" & "cccccc" & "; color: #000000;""><br>"
htmtab = htmtab & "</td>"
if fast=1 then ffra.WriteLn(htmtab):htmtab=""
end if

if ttxtbox=0 then
htmtab = htmtab & "<td><p>" & aara(xx, yy) & "</td>"
if fast=1 then ffra.WriteLn(htmtab):htmtab=""
else
'aa="<input type=""textbox"" style=""width:100%;"" id=""box" & xx & "_" & yy & """ NAME=""box" & xx & "_" & yy & """ size=""" & max(1,len(aara(xx, yy))) & """ value=""" & aara(xx, yy) & """ onKeypress=""return event.keyCode!=13"""
ffra.WriteLn("<td><p><input type=""textbox"" style=""width:100%;"" id=""box" & xx & "_" & yy & """ NAME=""box" & xx & "_" & yy & """ size=""" & max(1,len(aara(xx, yy))) & """ value=""" & aara(xx, yy) & """ onKeypress=""return event.keyCode!=13""></td>")
'htmtab = htmtab & "<td><p>" & aara(yy, xx) & "</td>"
'if fast=1 then ffra.WriteLn(htmtab):htmtab=""
end if
Next
else
'=== there is only 1 column
htmtab = htmtab & "<td><p>"
htmtab = htmtab & "<input type=""button"" name=""" & "but" & trim(cstr(yy+1)) & """ value=""" & "Select " & yy+1 & """"
htmtab = htmtab & " style=""background-color: #" & "cccccc" & "; color: #000000;""><br>"
htmtab = htmtab & "</td>"

if ttxtbox=0 then
htmtab = htmtab & "<td><p>" & aara(yy) & "</td>"
else
aa="<input type=""textbox"" style=""width:100%;"" id=""box" & yy & """ NAME=""box" & yy & """ size=""" & max(1,len(aara(yy))) & """ value=""" & aara(yy) & """ onKeypress=""return event.keyCode!=13"""
htmtab = htmtab & "<td><p>" & aa & "</td>"
'htmtab = htmtab & "<td><p>" & aara(yy, xx) & "</td>"
end if

end if
htmtab = htmtab & "</tr>" & vbcrlf
if fast=1 then ffra.WriteLn(htmtab):htmtab=""

Next
end if

'=== footer
if ff=1 then
htmtab = htmtab & "</table></span></b><br>"
if fast=1 then ffra.WriteLn(htmtab):htmtab=""
end if

htmtab = htmtab & "</form>"
if fast=1 then ffra.WriteLn(htmtab):htmtab=""
if fast=0 then ffra.WriteLn(htmtab)

'=== reload (will not reload if we are in middle of a muliple elements/query table)
if rr=1 then
ffra.location.reload(true)
call oieready
end if

'=== ?
if mm=1 then
For yy = 0 To ymax
if dimnum=2 then
ffra.forms(0).elements("but" & trim(cstr(yy+1))).onclick = getref("button" & ffranam)
else
'=== there is only 1 column
ffra.forms(0).elements("but" & trim(cstr(yy+1))).onclick = getref("button" & ffranam)
end if
Next
end if

set ffra.onkeypress = GetRef("Check" & ffranam)

'for i=0 to ubound(arabutnam)
' flef.forms(0).elements(arabutnam(i)).onclick = getref("buttonlef")
'next
end function

sub oieready()
do while oie.readystate<>4
wscript.sleep 100
loop
Do While (oIE.Busy)
wscript.sleep 100
Loop
end sub

'=== ssea = search string

'=== tab 0 symptoms
'=== tab 1 components
'=== tab 2 diagnostics
'=== tab 3 causes

'=== ttyp 0 search
'=== ttyp 1 fast results
'=== ttyp 2 detail results

'=== ssufix = ordere by or something at the end of query

function makque(ssea, ttab, sselect,wwhere, ssufix,ooper,wwild)
ssea = replace(ssea,"'","''")
ssea = trim(ssea)
sseaara = split(ssea," ") '=== array of all words for search

ss = "select "

ii = 0
for each aa in allara(ttab,sselect)
ss = ss & aa
if ii<>ubound(allara(ttab,1),sselect) then ss = ss & ","
ii=ii+1
next

ss = ss & " from [" & alltab(ttab) & "] where ("

'=== search word(S) in table, AND opérator
ii = 0
for each ss2 in sseaara
ii2=0
for each aa in allara(ttab,wwhere)
ss = ss & "[" & aa & "] " & ooper & " '" & wwild & ss2 & wwild & "'"

if ii2 <> UBound(allara(ttab,wwhere), 1) then ss = ss & " or "
ii2=ii2+1
next
if ii <> UBound(sseaara, 1) then ss = ss & ") and ("
ii=ii+1
next
'=== order by a column name
ss = ss & ")" & ssufix

makque = ss

end function

function exesql(objcon,tag,sql)

on error resume next
set tag = objcon.execute(SQL)
if err<>0 then
l1 = "error in query"
l2 = "query: " & sql
l3 = "error: " & err.description
l4 = "the program will now end"
fbot.WriteLn(l1 & "<BR><br>" & l2 & "<BR><br>" & l3 & "<BR><br>" & l4 & "<BR><br>")
'msgbox(l1 & vbcrlf & l2 & vbcrlf & l3 & vbcrlf & l4 & vbcrlf)
wscript.quit
end if
on error goto 0

end function

'=== sort an array in alpha order
Function sorara(aara)

For i = (UBound(aara) - 1) to 0 Step -1
For j= 0 to i
'if isarray(aara(j))=0 and isarray(aara(j+1))=0 then
If UCase(aara(j))>UCase(aara(j+1)) Then
sstrHolder = aara(j+1)
aara(j+1) = aara(j)
aara(j) = sstrHolder
End If
'end if
Next
Next
sorara=ara01
End Function

'Function fSortArray(aSortThisArray)
'Set oArrayList = CreateObject("System.Collections.ArrayList" )
'For iElement = 0 To UBound(aSortThisArray)
' oArrayList.Add aSortThisArray(iElement)
'Next
'oArrayList.Sort
'set fSortArray = oArrayList
'Set oArrayList = Nothing
'End Function

'================================================
function makfol(ffil01, array02)

if objfso.folderexists(ffil01) then
cc= errman(1,"i - le dossier existait déjà")
else
a=OBJfso.CreateFolder(ffil01)
if err.number=0 then
cc= errman(0,"i - dossier crée")
else
cc= errman(2,"i - " & err.description)
end if
end if

end function

'=== create basic folder with TEXT (client and contract)

function crebasfol(ccli,ccon)

'=== split client and contract

aa = clefra(array("fbot"))

fbot.WriteLn("Client: " & ccli & "<br><br>")
fbot.WriteLn("Contrat: " & ccon & "<br><br>")

'=== k originaux utilisation

aa = "\\corp.stas.local\stas\ORIGINAUX\Utilisation"

'==== creation client folder if necessary
bb = aa & "\" & ccli
zz = crefol(bb)

'=== creation contract folder
bb = aa & "\" & ccli & "\" & ccon
zz = crefol(bb)

'=== s administ

aa = "\\corp.stas.local\stas\administ\CLIENT"

'==== creation client folder if necessary
bb = aa & "\" & ccli
zz = crefol(bb)

'=== creation contract folder
bb = aa & "\" & ccli & "\" & ccon
zz = crefol(bb)

'=== I projets

aa = "\\corp.stas.local\stas\projets"

'==== creation client folder if necessary
bb = aa & "\" & ccli
zz = crefol(bb)

'=== creation contract folder
bb = aa & "\" & ccli & "\" & ccon
zz = crefol(bb)

crebasfol = bb

end function

function crefol(bbb)

if objfso.folderexists(bbb) then
fbot.WriteLn("le dossier existait déjà: "& bbb & "<br>")
else
on error resume next
zzz=OBJfso.CreateFolder(ucase(bbb))
if err<>0 then
fbot.WriteLn("ERROR: dossier NON crée: " & bbb & "<br>")
else
fbot.WriteLn("Dossier crée: " & bbb & "<br>")
end if
on error goto 0
end if

end function

'=== retroactive call that explore jagged array

'=== aa = folders, jagged array
'=== ccon = contract

sub retfol(aa, ppath, parentfol, categorie, revision)

'=== perentfol is a local variable, and recursiveness will make a new one every sub level
'=== when the level go back (sub return) the precedent value will be there, because it's local

'=== we put content in rap01 including a print button and a table html format

'ON ERROR RESUME NEXT

for each bb in aa

if not isarray(bb) then
bb=replace(bb," ","_")
bb=replace(bb,"é","e")
bb=replace(bb,"É","E")
bb=replace(bb,"ç","c")
bb=replace(bb,"Ç","C")
bb=replace(bb,"è","e")
bb=replace(bb,"È","E")
bb=replace(bb,"ê","e")
bb=replace(bb,"Ê","E")
bb=replace(bb,"à","a")
bb=replace(bb,"À","A")
bb=replace(bb,"û","u")
bb=replace(bb,"Û","U")

'=== if sublvl = 1 it mean we were in a sub array
'=== string(sublvl*6,"-")
ii=sublvl
rap01=rap01 & "<tr>"
do while ii>0
rap01=rap01 & "<td></td>"
ii=ii-1
loop

'=== if the ppath is nothing, we just draw the html table, no folder creation or database creation
if ppath<>"" then

'=== create subfolders
redim preserve arapat(pattot)
arapat(pattot)=bb

dd=path
for each cc in arapat
dd=dd & "\" & cc
next

'fbot.WriteLn(pat & dd & "<br>")
ee = pat & dd

'==== creation client folder if necessary
if objfso.folderexists(ee) then

'fbot.WriteLn("WARNING: le dossier existait déjà: "& ee & "<br>")
dejfol = dejfol + 1
fbot.WriteLn("simulation dossier: " & ee & "<br>")
fbot.WriteLn("simulation dossier: " & sublvl & "<br>")

else
on error resume next

'=== create folder ================================
zz=OBJfso.CreateFolder(ee)

if err<>0 then
fbot.WriteLn("ERROR: " & err.description & " ERROR DATA: " & ee & "<br>")
errfol = errfol + 1
else
newfol = newfol+1
end if
on error goto 0

fbot.WriteLn("Dossier crée: " & ee & "<br>")
end if

'=== SQL folder creation

if parentfol="" then
msgbox("par2: " & par2 & vbcrlf & "parentfol: " & parentfol)
end if

sql = "SELECT COUNT(*) As 'Count' FROM [224].dbo.folders_struct "
sql = sql & "WHERE nom like '" & bb & "' and parentfol = " & parentfol & " and categorie = '" & categorie & "'"
'objOutputFile.WriteLine date & " " & time & " does database exist? " & vbcrlf & sql
objOutputFile.WriteLine date & " " & time & " sublvl value: " & sublvl
objOutputFile.WriteLine date & " " & time & " check if element exist " & vbcrlf & sql

Set tag = Con_02.Execute(sql)

if tag("count") = 0 then

i=0
tables = ""
values = ""
for each a in aracolnam
tables = tables & aracolnam(i) & ","
if a="nom" then
values = values & "'" & bb & "',"
elseif a="parentfol" then

'=== caca
if sublvl=0 then
par2=0
parentfol=0
objOutputFile.WriteLine date & " " & time & " replaced by 0 sublvl: " & sublvl & " parentfol: " & parentfol
else
par2 = parentfol
objOutputFile.WriteLine date & " " & time & " not replaced = parentfold sublvl: " & sublvl & " parentfol: " & parentfol
end if
objOutputFile.WriteLine date & " " & time & " sublvl: " & sublvl & " parentfol: " & parentfol
values = values & par2 & ","
elseif a="categorie" then
values = values & "'" & categorie & "',"
elseif a="revision" then
values = values & revision & ","
elseif a="permission" then
values = values & "'',"
else
values = values & "''," '=== this should never happen cause an empty numeric value will bug here in sql
end if
i=i+1
next
tables = left(tables,len(tables)-1)
values = left(values,len(values)-1)
'aracol = array( _
'"nom", _
'"parentfol", _
'"permission", _
'"categorie", _
'"revision", _
'"actif")

sql = "insert into [224].dbo.folders_struct (" & tables & ") values(" & values & ")"
objOutputFile.WriteLine date & " " & time & " insert new element " & vbcrlf & sql
Set tag = Con_02.Execute(sql)

end if

'=== go get identity key for next folder or subfolder
sql = "SELECT [id],[nom],[parentfol] FROM [224].dbo.folders_struct "
sql = sql & "WHERE nom like '" & bb & "' and parentfol = " & parentfol & " and categorie = '" & categorie & "'"
objOutputFile.WriteLine date & " " & time & " get identity for parentfol" & vbcrlf & sql
Set tag = Con_02.Execute(sql)

if not tag.eof then
parentfoltmp = tag(0).value
objOutputFile.WriteLine date & " " & time & " parent folder id: " & tag(0).value
else

objOutputFile.WriteLine date & " " & time & " --- no element found - no id for next parentfol (parent folder)"
end if

end if

'=== just draw the html
rap01=rap01 & "<td>" & bb & "</td></tr>"
else
'=== the next value is an ARRAY, we recurse
sublvl=sublvl+1
pattot=pattot+1
'if parentfoltmp="" then parentfoltmp = 0
call retfol(bb,ppath,parentfoltmp,categorie, revision)

end if
next

sublvl=sublvl-1
pattot=pattot-1

end sub

'================================= database and table and columns creation sub

sub credb(dbname, tabname, aracolnam, aratype, aracolunique, logfile, sqlcon, dataset)

'=== sub to create a database in sql (2008), database name and table will be put in []
'=== dbname = database name
'=== tabname = table name
'=== aracolnam = array with all columns names
'=== aratype = type of data in each columns
'=== aracolunique = FUTUR will create the column with uynique value, even if it's nor identity
'=== logfile = txt file to log progress, error etc
'=== sqlcon = connexion SQL
'=== dataset = dataset object, contain data from sql queries

'=== put all column NAME and TYPE in a string for sql query
i=0
tables=""
for each a in aracolnam
tables = tables & aracolnam(i) & " " & aratype(i) & ","
i=i+1
next
'=== remove last extra ,
tables = left(tables,len(tables)-1)

'=== DATABASE === check if database exist
sql = "SELECT COUNT(*) As 'DBCount' FROM master.dbo.sysdatabases WHERE name = '" & dbname & "'"
logfile.WriteLine date & " " & time & " database before if exist check: " & vbcrlf & sql
Set dataset = sqlcon.Execute(sql)

if dataset("DBCount") = 0 Then

'=== create the sql database
sql = "CREATE DATABASE [" & dbname &"]"
logfile.WriteLine date & " " & time & " database before creation query: " & vbcrlf & sql
set dataset = sqlcon.execute(sql)
else
logfile.WriteLine date & " " & time & " database already exist " & nom_db
end if

'=== DATABASE === check if database exist after creating it
sql = "SELECT COUNT(*) As 'DBCount' FROM master.dbo.sysdatabases WHERE name = '" & dbname & "'"
logfile.WriteLine date & " " & time & " database after creation if exist check: " & vbcrlf & sql
Set dataset = sqlcon.Execute(sql)

if dataset("DBCount") = 0 Then
a = date & " " & time & " ERROR FATAL creating database, cannot continue" & vbcrlf & "program ending"
logfile.WriteLine a
msgbox(a)
wscript.quit
end if

'=== DATABASE === use the database by defaut in sql (just in case we forgot to always put full name in all query)
sql = "USE [" & dbname & "]"
Set dataset = sqlcon.Execute(sql)

'=== DATABASE === set permissions
'futur

'=== TABLE === chek if table exist
sql = "SELECT COUNT(*) As 'tabcount' FROM [" & dbname & "].dbo.sysObjects WHERE name = '" & tabname & "'"
Set dataset = sqlcon.Execute(sql)

if dataset("tabCount") = 0 Then

'=== no table === create table with an ID column, identity, autoincrement by 1
sql = "CREATE TABLE [" & dbname & "].dbo.[" & tabname & "] (id INT IDENTITY (1, 1) PRIMARY KEY, " & tables & ")"
logfile.WriteLine date & " " & time & " TABLE before creation query: " & vbcrlf & sql
Set dataset = sqlcon.Execute(sql)
else

'=== table exist

'=== check each column if it exist and create them if not
i=0
tables=""
for each a in aracolnam
sql = "SELECT COUNT(*) As tableCount FROm [" & dbname & "].dbo.syscolumns "
sql = sql & "WHERE ID = (SELECT ID from [" & dbname & "].dbo.sysobjects WHERE name='" & tabname & "') AND name = '" & a & "';"
objOutputFile.WriteLine date & " " & time & " QUERY to check number of column with the name: " & a & vbcrlf & sql
Set dataset = sqlcon.Execute(sql)

if dataset("tableCount") = 0 Then

'=== add column and type
objOutputFile.WriteLine date & " " & time & " QUERY to add column: " & a & vbcrlf & sql
SQL = "ALTER TABLE [" & dbname & "].dbo.[" & tabname & "] ADD " & aracolnam(i) & " " & aratype(i)
Set dataset = sqlcon.Execute(sql)
end if
'aracolnam(i) & " " & aratype(i) & ","
i=i+1

next

'=== check if there is an identity column

sql = "use ["& dbname & "]" & vbcrlf
sql = sql & "SELECT i.name AS IndexName, OBJECT_NAME(ic.OBJECT_ID) AS TableName, COL_NAME(ic.OBJECT_ID,ic.column_id) AS ColumnName "
sql = sql & "from [" & dbname & "].sys.indexes AS i "
sql = sql & "INNER JOIN [" & dbname & "].sys.index_columns AS ic "
sql = sql & "ON i.OBJECT_ID = ic.OBJECT_ID AND i.index_id = ic.index_id WHERE i.is_primary_key = 1"
objOutputFile.WriteLine date & " " & time & " identity check - check if any colum have identity status: " & vbcrlf & sql
Set dataset = sqlcon.Execute(sql)

primaryfnd=0
While Not (dataset.EOF)

'=== the query list all primary keys, we must check table name

'=== indexname, tablename, columnname
if dataset(1).value = tabname then

'=== primary key found in table but not with the name ID
primaryfnd = 1

objOutputFile.WriteLine date & " " & time & " there is a primary key in this table - primaryfnd value: " & primaryfnd

'=== column name
a = dataset(2).value
a = lcase(a)

end if
dataset.movenext
Wend

'=== if a primary key was not found we do not have to check for any ID column at all
if primaryfnd=0 then

'=== we check for a column named "ID"
logfile.WriteLine date & " " & time & " TABLE exist we check for id column"
sql = "SELECT COUNT(*) As tableCount FROm [" & nom_db & "].dbo.syscolumns "
sql = sql & "WHERE ID = (SELECT ID from [" & nom_db & "].dbo.sysobjects WHERE name='" & nom_table & "') AND name = 'id';"
objOutputFile.WriteLine date & " " & time & " QUERY to check number of column with the name 'ID': " & vbcrlf & sql
Set dataset = sqlcon.Execute(sql)

if dataset("idCount") = 0 Then

'=== there no column named "id" in the table
'=== we create it, as identity, but sql wont allow it i think
sql = "ALTER TABLE [" & dbname & "].dbo.[" & tabname & "] ADD ID INT IDENTITY (1, 1) PRIMARY KEY"
objOutputFile.WriteLine date & " " & time & " add ID column with identity tag on: " & vbcrlf & sql
Set dataset = sqlcon.Execute(sql)

else

'=== id exist, we must turn its identity flag ON, but sql wont allow it
'=== create an id column identity
'sql = "ALTER TABLE [" & dbname & "].dbo.[" & tabname & "] ADD ID INT IDENTITY (1, 1) PRIMARY KEY"
'objOutputFile.WriteLine date & " " & time & " add ID column with identity tag on: " & vbcrlf & sql
'Set dataset = sqlcon.Execute(sql)
end if

end if
'=== check if any identity column exist in table
logfile.WriteLine date & " " & time & " end of table creation ---------------------------------"

'=== create unique constraint
'=== uc_nom = name of constraint (UC stand for unique constraint)
'=== columnname = column name

'=== ALTER TABLE [224].[dbo].[groupes] ADD CONSTRAINT uc_nom unique(columnname)
end if

end sub

Sunday, April 14, 2013

vba excel passing a dynamic number of parameter to a sub

Vba excel passing a dynamic number of parameter to a sub

I always wondered, when you program a sub and pass to it 3 parameters:

sub test(name, adress, phone)
'=== process stuff
end sub

Then you call it several time in your program

call sub("wildboy", "555", "555-5555")

But then, you want to add one more parameter to the sub, but you have to change each line where you call the sub :(

I found how to bypass this with a type

Here is how i call a sub to format a range in excel and i can pass more or less parameters

Actually i pass the same number of parameters but shhh don't tell anyone

If i pass less parameters, i can always add a on error resume next to verify if the variable existe in the type
inside the sub

So i pass a variable of a certain TYPE to the sub

I can change the type number of variables without changing the call to the sub
and if i dont use a variable in the type in my sub, i just have to check if contain nothing

Of course by default, my sub must process empty variables of the type as a negative (0)

So the sub will process new variables i added to the type only if it contain something that will require a new processing in the sub without me having to change each line that call the sub in the main program
(read the precedent line twice if your head exploded the first time)

Tadaaaaaaaaaaaaaa!

First, define a type in excel vba:

'---------------- start code excel vba excel 2007 ALT F11 insert code

Type range_formatting_type
'=== call rngfor(lineinside (0 or 1), rng01, linestyle (full line, half line etc), weight (thickness), color (foreground), colorindex (background))
line_inside As Integer '=== draw separative lines inside the range (0 = false)
line_outside As Integer '=== draw line outside (0 = false)
range As Excel.range '=== range to format and draw lines
line_style As Integer '=== 0 = half line
'=== 1 = plain line
line_weight As Integer '=== thickness?
line_color As Integer '=== line color
cell_background As Integer '=== colorindex, cell background color
font_color As Integer '=== color of letters inside the cell/range
End Type
'--------------- end code

'=== Before calling the sub, define a variable of this type:

'-------------- start code
sub main()

Dim format01 As range_formatting_type

format01.line_inside = 1
format01.line_outside = 1
Set format01.range = Excel.range(Cells(1, 1), Cells(10, 10))
format01.line_style = 1
format01.line_weight = 3
format01.line_color = 1
format01.cell_background = 35 'green
format01.font_color = 0

Call rangeformatting(format01)

end sub

'-------------- then the sub

Sub rangeformatting(format01 As range_formatting_type)

'format01.line_inside = 0
'format01.line_outside = 1
'format01.range = rng01
'format01.line_style = 1
'format01.line_weight = 3
'format01.line_color = 1
'format01.cell_background = 35
'format01.font_color = 0

format01.range.Borders(xlEdgeLeft).LineStyle = format01.line_style
format01.range.Borders(xlEdgeLeft).Weight = format01.line_weight
format01.range.Borders(xlEdgeTop).LineStyle = format01.line_style
format01.range.Borders(xlEdgeTop).Weight = format01.line_weight
format01.range.Borders(xlEdgeBottom).LineStyle = format01.line_style
format01.range.Borders(xlEdgeBottom).Weight = format01.line_weight
format01.range.Borders(xlEdgeRight).LineStyle = format01.line_style
format01.range.Borders(xlEdgeRight).Weight = format01.line_weight

If format01.line_inside = 1 Then
format01.range.Borders(xlInsideVertical).LineStyle = format01.line_style
format01.range.Borders(xlInsideVertical).Weight = format01.line_weight
format01.range.Borders(xlInsideHorizontal).LineStyle = format01.line_style
format01.range.Borders(xlInsideHorizontal).Weight = format01.line_weight
Else
format01.range.Borders(xlInsideVertical).LineStyle = Excel.XlLineStyle.xlLineStyleNone
'rrng01.Borders(xlInsideVertical).Weight = 2
format01.range.Borders(xlInsideHorizontal).LineStyle = Excel.XlLineStyle.xlLineStyleNone
'rrng01.Borders(xlInsideHorizontal).Weight = 2

End If
'=== green
'col01 = &H10C010

format01.range.Borders(xlEdgeLeft).Color = format01.line_color
format01.range.Borders(xlEdgeTop).Color = format01.line_color
format01.range.Borders(xlEdgeBottom).Color = format01.line_color
format01.range.Borders(xlEdgeRight).Color = format01.line_color

format01.range.Interior.ColorIndex = format01.cell_background
End Sub

'----------------- end code

Monday, April 8, 2013

excel generating a drawing of a frame with precision

Writing about my code is a brain storming that make me think more about it

coding is like scuba diving: the more you think about it, the deeper you go

so, at our compagny, we use frames in autocad to enclose drawing with information about name, revision, ingeneer signatures etc.

but not everyone use autocad on a daily basis

so we needed to reproduce a frame, of each format: a0, a1, a2, a3 that will contain information for the floor work in a factory

we did not want multiples pages. that is why there is 4 different size

the goal is to:
take a table from sheet1 (soushe = source sheet)
generate a frame in paper format a3 (based in acrobat pdf printer)
try to fill the frame with the date contained in the source sheet
if the a3 is too small, rebuild the frame with a2, a1, and finally a0 if it is still too small to fit in one sheet

the difficulties are:
the source sheet always have multiple columns
each line can be short or long, we cannot cut the line when we put them in the destination sheet with the frame (shedes = sheet destination)
so some line will be double or even triple

the destination sheet will be pixelised
each line will have a normal height, but will be expanded in height (double heaight, triple etc.) if the line from the source sheet have too much text
but this must be done with an average of the width of the letters, as M is larger than I
and finally, is i double the height and the text still dont fit, i must add height

her is an image of the corner of the frame generated:

as you can see the line height are smaller where the frame info is

the column is a pixel large only and lots of merge are done

now my goal is to automate the filling of the line that are just above the frame

news sharepoint 2013 recursive managed term creation

Hello,

i did the conversion array vbs to sql in one table

the past few months i worked on a jagged array in vb.net 2012 (in vs 2012)

usually, a jagged array only contain arrays in vb.net
but i needed more, i needed string followed by an array to be able to use recursiveness
so the code call itself when it encounter an array, but continue when it encounter a string
if you use object type, you can do a jagged array containing string and arrays

so i used this mixed jagged array to create terms in sharepoint 2013

the array of objects looked like this: (vb.net)

the GUID in the brackets are unique GUID wich i use to create sharepoint terms
note: arapro is another array with project terms

note: arasec is an array with sectors in our enterprise
as we want to "tag" our files with the product type, the sector, if it's a model or reference, and finally, what type of realisator did it

i wanted fixed GUID because when you redo all because the term tree change, you want to preserve the link the files (or any library object) have with the term tree

Dim ara01() As Object = {"STAS {C0C329A0-1881-4C49-A5D4-0ED0E02259C5}", _
New Object() {"ProjetsStas {620BAB20-C4D1-4FD1-9782-BF981EFF4BC3}", _
New Object() {"224235_Produits {" & termGUId224235.ToString & "}", _
New Object() {"Type {7532C15C-F12B-4650-B55A-F00F17EB45A6}", _
New Object() {"Modèle {A4385F1E-69B4-4BEA-ABAA-4F40B7488E55}", "Référence {2092E26E-AB98-4581-92E4-9B658C5BD73B}"}}, _
New Object() {"Réalisateur {A7E95AD4-1827-4B46-9947-81986B69DBCD}", _
New Object() {"Ing. {44970D98-D53D-4538-ACFD-4A811299AE30}", "Produit {267A4178-C37C-486F-93C1-73DA6EE7C803}", "Mec {6FEA1110-A7D3-4C19-A037-3819436952BF}"}}, _
New Object() {"Produit {9A3E07FB-A893-47C8-8003-FBE10546E694}", arapro}, _
New Object() {"Secteur {FF26A0AF-B8EF-4542-B9A2-F3B8D35E9A23}", arasec} _
} _
} _
}

the code is recursive and call itself when it encounter an array inside the initial array

you have to create the initial term group before calling on the recusrsiveness, so the object passed to the recursive call is a sub array

code must be run on sharepoint server

Call recurterms(ara01(1)(1), term, site, lang, store)

recursive sub that create a term tree according to a jagged/string array:

---------------- vb.net vs 2012 code ---------------- recursive call to create term tree in sharepoint

Sub recurterms(aara As Object, tterm As Microsoft.SharePoint.Taxonomy.Term, ssite As Object, lang As Integer, ByRef termstore As Taxonomy.TermStore)
Dim eelelef As String
Dim eeleguid As String
Dim nnewTermId As Guid
Dim ttermbefore As Microsoft.SharePoint.Taxonomy.Term

'=== this sub is recursive
'=== aara is an array of objects that can contain a string or an array (up to infinite level of depth)
'=== tterm is a term object (not a group, not a termset)
'=== ssite if the sharepoint site (not used for now)

'=== sublvl is a GLOBAL variable so it is the same in all recursiveness
Dim tot As Integer
Dim caca As Object
For Each caca In aara
tot = tot + 1
Next

Dim ii As Integer = 0
For Each eele In aara

If Not IsArray(eele) Then
'=== skip first element because it is the name (As string) of the group that contain the sub groups (Array)
' If InStr(eele, "MSDS") <> 0 Then
'MsgBox(tterm.Name)
'End If
If Not (sublvl = 0 And ii = 0) Then
If InStr(eele, "{") <> 0 Then
eelelef = Mid(eele, 1, InStr(eele, "{") - 2) '=== left part of this element - name only
eeleguid = Mid(eele, InStr(eele, "{"), InStr(eele, "}") - InStr(eele, "{") + 1)
nnewTermId = New Guid(eeleguid)
Else
'=== generate a new guid because it was not with the name enclosed in {}
eelelef = eele
nnewTermId = Guid.NewGuid()
End If
'MsgBox(sublvl & vbCrLf & IsNothing(tterm) & vbCrLf & eelelef)
objfil03.WriteLine(New String(" ", sublvl * 3) & "sublvl:" & sublvl & "---" & eelelef)
ttermbefore = tterm.CreateTerm(eelelef, lang, nnewTermId)
'termstore.CommitAll()

End If
ii = ii + 1
Else
'=== the object is an array, we recursively call this same sub, incrementing the depth level (sublvl)
sublvl = sublvl + 1
ii = ii + 1
If IsNothing(ttermbefore) Then ttermbefore = tterm
'objfil03.WriteLine(eele.count)
Call recurterms(eele, ttermbefore, ssite, lang, termstore)
End If

Next
sublvl = sublvl - 1

End Sub

---------------------

i am not posting the whole code, as this is a job project, not a personal project

coding this was not hard, but a little long to find the right objects to use to manipulate sharepoint

(expecially the ones to apply multiple managed terme to a file i just imported from ntfs)

after this, i made another code to import files in sharepoint 2013 and tag the file with multiple managed terms

that was very tricky as i saw no such code in vb, outside sharepoint

this code is a command line compilation in vb.net 4.5 with visual studio 2012 for sharepoint 2013

i doubt anyone but a real pro will be interested in such advanced stuff

but if you are interested in the whole code, i might write an article on expert exchange

most of the codes that can do this on internet are not free, and without the source :(

the goal is to migrate all our file system in sharepoint adn use managed metadata to tag all files and be able to find them from different perspectives in the term tree (by product, by sector etc)

also sharepoitn 2013 approval and versionning major and minor are very attractives :)

we plan to do a library for each product

some view to be able to reach documents cross library

a reference library with no approval where we can see all drafts

the product library will have view to see product file and references from other library where draft can be seen

Monday, March 26, 2012

recursiveness vbs array to sql

recursiveness vbs array to sql

i always wanted to convert a jagged array to a sql database
i did it

first a jagged array is an array with array inside it
example:
ara01 = array("subject01", array("sub subject 01", "sub subject 02"))

the vbs jagged array to sql converter will:
initialise global variables for a recursive script
browse throught all elements
process the element if its not an array
call itself if a sub array is found
create a sql element (row) for each element in array, related to the array before
all that with a column unique ID in sql
all that in one table

(will post code later, it's late)