' ---------------------------------------------------------- ' Script d'affichage explicite des fichiers ADM ' Syntaxe: ' showadm[.vbs] ' Ce script fait appel à un Contrôle ActiveX de chargement ' et déchargemenr de ruche (jcb.ocx) ' ' JC BELLAMY © 2003 ' ---------------------------------------------------------- On Error resume next Const SW_HIDE=0 Const SW_SHOWNORMAL=1 Const HKEY_USERS = &H80000003 Const navOpenInNewWindow = &H1 Const navNoHistory = &H2 Const navNoReadFromCache = &H4 Const navNoWriteToCache = &H8 Const navAllowAutosearch = &H10 Const navBrowserBar = &H20 Const navHyperlink = &H40 Const xlDiagonalDown = 5 Const xlDiagonalUp = 6 Const xlEdgeLeft = 7 Const xlEdgeTop = 8 Const xlEdgeBottom = 9 Const xlEdgeRight =10 Const xlContinous = 1 Const xlThin = 2 Const xlThick = 4 Const xlDouble =&HFFFFEFE9 Const xlAutomatic =&HFFFFEFF7 Const xlInsideVertical = 11 Const xlNone =&HFFFFEFD2 Const xlUnderlineStyleNone =&HFFFFEFD2 Const xlCenter =&HFFFFEFF4 Const xlBottom =&HFFFFEFF5 Const xlContext =&HFFFFEC76 Const xlSolid = 1 Const msoFalse = 0 Const msoScaleFromTopLeft = 0 Const xlR1C1 =&HFFFFEFCA ColorBack="""#FFFFD8""" ColorBorderL = """#66CCCC""" ColorBorderD = """#006666""" ' ================== couleurs EXCEL ================== Black = 1 Brown = 53 OliveGreen = 52 DarkGreen = 51 DarkGreenBlue = 49 DarkBlue = 11 Indigo = 55 Grey80 = 56 DarkRed = 9 Orange = 46 LightBrown = 12 Green = 10 GreenBlue = 14 Blue = 5 GrayBlue = 47 Gray50 = 16 Red = 3 LightOrange = 45 LimeGreen = 43 MarineGreen = 50 WaterGreen = 42 LightBlue = 41 Violet = 13 Gray40 = 48 Pink = 7 Gold = 44 Yellow = 6 BrigthGreen = 4 Turquoise = 8 SkyBlue = 33 Plum = 54 Grey25 = 15 SalmonPink = 38 Brown = 40 LightYellow = 36 LightGreen = 35 LightTurquoise= 34 MediumBlue = 37 Lavender = 39 White = 2 ColorBGTitre=DarkBlue ColorFGTitre=White ColorBGCategory=Blue ColorFGCategory=White ColorBGStrat1=Turquoise ColorFGStrat1=Black ColorBGStrat2=SkyBlue ColorFGStrat2=Black ColorBGComment=DarkBlue ColorFGComment=White FGCatSel="white" FGCatSelLink="white" FGCatSelVisited="white" FGCatSelActive="white" FGCatSelHover="white" BGCatSel="blue" BGCatSelLink="blue" BGCatSelVisited="blue" BGCatSelActive="blue" BGCatSelHover="black" FGCatNotSel="blue" FGCatNotSelLink="blue" FGCatNotSelVisited="blue" FGCatNotSelActive="blue" FGCatNotSelHover="white" BGCatNotSel=ColorBack BGCatNotSelLink=ColorBack BGCatNotSelVisited=ColorBack BGCatNotSelActive=ColorBack BGCatNotSelHover="black" BGProgressON="blue" BGProgressOFF=ColorBack FGStratON="white" FGStratONLink="lightblue" FGStratONVisited="lightblue" FGStratONActive="lightblue" FGStratONHover="lightblue" BGStratON="red" FGStratOFF="black" FGStratOFFLink="blue" FGStratOFFVisited="blue" FGStratOFFActive="blue" FGStratOFFHover="blue" BGStratOFF=ColorBack ForReading=1 ForWriting=2 ForAppending=8 TristateUseDefault = -2 'Ouvre le fichier avec la valeur par défaut du système. TristateTrue = -1 'Ouvre le fichier comme de l'Unicode. TristateFalse = 0 'Ouvre le fichier comme de l'ASCII. quote=chr(34) LevelMax=0 ADMClass=array("machine","user") DisplayADMClass=array("Machine","Utilisateur") KeyClass=Array("HKEY_LOCAL_MACHINE","HKEY_CURRENT_USER") nClass=UBound(ADMClass)-LBound(ADMClass)+1 Dim stack(),TabLine(),TabCat() Dim CurLevel,Root,CurParent,CurPolicy,CurPart,CurValue,CatIndex,CatIndexPrec Dim MasterKeyCat,MasterKeyPol,Line0 Dim nItem,NL,FlagColor,NLprev,NLLast NLLast=1 Set net = Wscript.CreateObject("WScript.Network") Set shell = WScript.CreateObject("WScript.Shell") Set fso = WScript.CreateObject("Scripting.FileSystemObject") Set dictVar = WScript.CreateObject("Scripting.Dictionary") computer=Ucase(net.ComputerName) user=UCase(net.UserName) jcbCOM="jcb.tools" TestCOMExists jcbCOM,"jcb.ocx" TestCOMExists "COMCTL.ListViewCtrl","comctl32.ocx" TestCOMExists "Excel.Application","" Set tools = wscript.CreateObject(jcbCOM,"event_") KeyAppli="HKEY_LOCAL_MACHINE\SOFTWARE\jcb\showadm\" ' =================== Version de l'OS =================== ' Certaines clefs (et fonctionnalités) n'existent que sous XP KeyVer="HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\" XP=false PN=ReadKey(keyver,"ProductName","") If PN="Microsoft Windows XP" Then XP=true Titre="Stratégies définies dans les fichiers ADM de " & Computer ficInit = GetPath() & "showadm.html" ficLog = GetPath() & "showadm.log" ficVBS = GetPath() & "runreg.vbs" ' =================== Création du 2ème VBS ================================== Set tv = fso.CreateTextFile(ficVBS, True) tv.writeline "set Args = Wscript.arguments" tv.writeline "if args.count<2 then wscript.quit" tv.writeline "Set shell = WScript.CreateObject(""WScript.Shell"")" tv.writeline "Set net = Wscript.CreateObject(""WScript.Network"")" tv.writeline "SelectedKey=args(0) & ""\"" & args(1)" tv.writeline "p=instrrev(SelectedKey,""\"")" tv.writeline "SelectedKey=left(SelectedKey,p-1)" tv.writeline "KeyMem=""HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Applets\Regedit\LastKey""" tv.writeline "Shell.RegWrite keyMem, SelectedKey" tv.writeline "Computer=Ucase(net.ComputerName)" tv.writeline "Set ProcessSet=GetObject(""winmgmts:{impersonationLevel=impersonate}!//"" & Computer).InstancesOf(""Win32_process"")" tv.writeline "for each Process in ProcessSet" tv.writeline " If InStr(1,Process.Name, ""regedit.exe"", vbTextCompare)>0 Then" tv.writeline " result=Process.terminate(0)" tv.writeline " exit for" tv.writeline " End If" tv.writeline " next" tv.writeline "Shell.Run ""REGEDIT"",1,false" tv.close dim ficadm(),ficadmdef ficadmdef=array("system.adm","inetres.adm","conf.adm") nfadm=0 nfadmdef=3 ' =================== Préparation du 1er formulaire HTML =================== Set ts = fso.CreateTextFile(ficInit, True) ts.writeline header ts.writeline TitreHTML ts.writeline ScriptBtn ts.writeline "
" ts.writeline "" sPath=KeyAppli & "admfiles" If tools.KeyExists(spath & "\") Then nfadm=cint(tools.RegRead(sPath & "\" ,"","REG_SZ")) redim ficadm(nfadm) For i = 1 To nfadm ficadm(i-1)=tools.RegRead(spath &"\",i,"REG_SZ") Next else nfadm=0 For i = 1 To nfadmdef nomfic=shell.ExpandEnvironmentStrings("%systemroot%") & "\inf\" & ficadmdef(i-1) If fso.fileExists(nomfic) Then nfadm=nfadm+1 redim ficadm(nfadm) ficadm(i-1)=nomfic End If Next end if ts.writeline "" ts.writeline "" ts.writeline "" ts.writeline "" ts.writeline "" ts.writeline "" ts.writeline "" ts.writeline "" ts.writeline "" ts.writeline "" ts.writeline "
Fichier(s) ADM :
" ts.writeline "" ts.writeline "
 " ts.writeline "
JCB © 2003 
" ts.writeline "
" ts.writeline "" ts.writeline "" ts.Close ' =================== Affichage avec IE =================== Dim oIE codeRet=RunIE(600,350) If coderet<=0 Then If coderet=0 Then oIE.Quit wscript.quit end if set objbtn=oIE.Document.All("Btn") objbtn.innerHtml="" shell.RegWrite KeyAppli & "admfiles\",nfadm nfexist=0 For i = 1 To nfadm If not fso.fileExists(ficadm(i-1)) Then Msgbox "Fichier " & ficadm(i-1) & " non trouvé",vbExclamation,"Stratégies" else nfexist=nfexist+1 shell.RegWrite KeyAppli & "admfiles\" & i,ficadm(i-1) End If Next If nfexist=0 Then Msgbox "Aucun fichier ADM défini",vbExclamation,"Stratégies" wscript.quit End If oIE.Quit ' =================== Création dictionnaire des libellés =================== For nf = 1 To nfadm CreateDict(ficadm(nf-1)) Next Titre="Stratégies ADM sur " & Computer set tlog=fso.CreateTextFile(ficLog, True) tlog.close ' =================== Code VBA commun =================== CodeModule=Array( _ "CellName = Target.AddressLocal", _ "If InStr(CellName, "":"") > 0 Then Exit Sub", _ "p = InStrRev(CellName, ""$"")", _ "NL = Mid(CellName, p + 1)", _ "key = Cells(NL, 4).Value", _ "If InStr(1,key, ""Software\"", vbTextCompare) = 1 Then", _ " br = Cells(" & nfadm+2 & ", 2).Value", _ " cmd=""cscript """"" & FicVBS & """"" "" & chr(34) & br & chr(34) & "" "" &chr(34) & key & chr(34)", _ " ret = Shell(cmd, vbMinimizedFocus)", _ " End If", _ "End Sub") Phase="" ' =================== Affichage des paramètres avec EXCEL =================== on error goto 0 Set oXL = WScript.CreateObject("EXCEL.application") ' Version numérique d'Excel Version=oXL.Application.Version ' Modification sécurité ExcelKey="HKEY_CURRENT_USER\Software\Microsoft\Office\" & Version & "\Excel\" SecurityKey=ExcelKey & "Security\" shell.RegWrite SecurityKey & "Level", 2, "REG_DWORD" shell.RegWrite SecurityKey & "AccessVBOM", 1, "REG_DWORD" OptionsKey=ExcelKey & "Options\" shell.RegWrite OptionsKey & "DefSheets", 2, "REG_DWORD" oXL.quit Set oXL = WScript.CreateObject("EXCEL.application") oXL.Visible = True oXL.Workbooks.Add With oXL.ActiveWorkbook.Styles("Normal").Font .Name = "Verdana" .Size = 8 .Bold = False .Italic = False .Underline = xlUnderlineStyleNone .Strikethrough = False .ColorIndex = xlAutomatic End With For numclass = 1 To nClass oXL.Sheets("Feuil" & NumClass).Select oXL.Sheets("Feuil" & NumClass).Name = DisplayADMClass(numclass-1) oXL.ActiveWindow.DisplayGridlines = False Cellule 1,1,"Stratégies définies dans les fichiers ADM :",true,false,12 For nf = 1 To nfadm Cellule 1+nf,2, ficadm(nf-1),true,false,10 next Cellule 2+nfadm,1,"Branche",false,false,10 Cellule 2+nfadm,2,KeyClass(numClass-1),true,false,10 Cellule 4+nfadm,1,"Catégories",false,true,9 Cellule 4+nfadm,2,"Stratégies",false,true,9 Cellule 4+nfadm,3,"Types",false,true,9 Cellule 4+nfadm,4,"Clefs",false,true,9 FillColor 1,1,4+nfadm,4,ColorBGTitre,ColorFGTitre NLStrat=Scan(numclass-1) If NLStrat>0 Then NLprev=0 PrintTreeCat 4+nfadm, Root,"" FillColor NLprev,1,NLLast,1,colorBGTitre,colorFGTitre Else NLLast=5+nfadm End If Cellule NLLast,1,"JCB © 2003",false,true,8 oXL.Columns("B:D").Select oXL.Selection.Columns.AutoFit oXL.Range("A1:A1").Select oXL.Rows(5+nfadm & ":" & 5+nfadm).Select oXL.ActiveWindow.FreezePanes = True Next SizeCode=Ubound(CodeModule)+2 Set WBCodeMod = oXL.ActiveWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule WBCodeMod.insertlines 1, "Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)" For i = 0 To Ubound(CodeModule) WBCodeMod.insertlines i+2, CodeModule(i) Next WBCodeMod.insertlines SizeCode+1,"Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)" For i = 0 To Ubound(CodeModule) WBCodeMod.insertlines i+SizeCode+2, CodeModule(i) Next ExcelFile=getpath() & "Showadm.xls" If fso.FileExists(ExcelFile) Then fso.DeleteFile ExcelFile, true oXL.ActiveWorkbook.SaveAs ExcelFile oXL.ACtiveWorkbook.Saved = True wscript.quit '************************** sous-programmes ************************* Sub Cellule(NumL,NumC,chaine,casse,italic,size) oXL.Cells(NumL,NumC).Value = Chaine If casse or size<>0 Then Coords=CellName(NumL,NumC) oXL.Range(Coords & ":" & Coords).Select If casse Then oXL.Selection.Font.Bold = True If italic Then oXL.Selection.Font.Italic = True If size<>0 Then oXL.Selection.Font.Size = size End If End Sub '-------------------------------------------------------------------- Function CellName(NumL,NumC) If NumC<=26 Then anumc=chr(64+NumC) Else n1=int(NumC/26) n2=NumC-n1*26 anumc=chr(64+n1) & chr(64+n2) End If CellName=anumc & NumL End Function '-------------------------------------------------------------------- Sub FillColor(NL1,NC1,NL2,NC2,colorBG,colorFG) oXL.Range(CellName(NL1,NC1) & ":" & CellName(NL2,NC2)).Select With oXL.Selection.Interior .ColorIndex = colorBG .Pattern = xlSolid .PatternColorIndex = xlAutomatic End With oXL.Selection.Font.ColorIndex = colorFG End Sub '-------------------------------------------------------------------- Sub CreateDict(curficadm) Fileformat=TristateFalse If tools.GetTextFileType(curficadm)=1 Then Fileformat=TristateTrue set tadm=fso.OpenTextFile(curficadm, ForReading, false, FileFormat) Section="" While not tadm.AtEndOfStream ligne=tadm.ReadLine Select Case ligne Case "[strings]" Section="strings" Case else if Section="strings" then p=InStr(Ligne,"=") If p>0 Then Name=trim(lcase(left(ligne,p-1))) Value=removequote(trim(mid(ligne,p+1))) Value=replace(Value,"""","'") If not dictVar.exists(Name) Then dictVar.Add Name,Value End If end if End Select Wend tadm.close End Sub '-------------------------------------------------------------------- Sub PrintTreeCat(byref NL, byref CurCat,byval PrecCat) dim j,k,ind CurName=CurCat.Name ind=CurCat.IndexCat If CurName<>"root" then If PrecCat<>"" Then NomCat=PrecCat & " * " & CurName else NomCat=CurName end if If CurName<>"root" and CurCat.nPol>0 Then If NLPrev>0 Then FillColor NLprev,1,NLLast,1,colorBGTitre,colorFGTitre NL=NL+1 NLPrev=NL+1 Cellule NL,1,NomCat,true,false,10 oXL.Range(CellName(NL,1) & ":" & CellName(NL,4)).Select oXL.Selection.Borders(xlDiagonalDown).LineStyle = xlNone oXL.Selection.Borders(xlDiagonalUp).LineStyle = xlNone oXL.Selection.Borders(xlInsideVertical).LineStyle = xlNone With oXL.Selection.Borders(xlEdgeTop) .LineStyle = xlDouble .Weight = xlThin .ColorIndex = xlAutomatic End With With oXL.Selection.Borders(xlEdgeBottom) .LineStyle = xlDouble .Weight = xlThin .ColorIndex = xlAutomatic End With With oXL.Selection.Borders(xlEdgeRight) .LineStyle = xlDouble .Weight = xlThin .ColorIndex = xlAutomatic End With With oXL.Selection.Borders(xlEdgeLeft) .LineStyle = xlDouble .Weight = xlThin .ColorIndex = xlAutomatic End With With oXL.Selection.Interior .ColorIndex = ColorBGCategory .Pattern = xlSolid End With oXL.Selection.Font.ColorIndex=ColorFGCategory FlagColor=false nStrat=CurCat.nPol If nStrat>0 Then For np= 1 To nStrat First=true NL=NL+1 set Curpol=CurCat.TabPolicy(np) nPartAct=Curpol.GetPartAct() TitrePol=CurPol.Name Cellule NL,2, TitrePol,false,false,0 Comments=CurPol.Explain If CurPol.Supported<>"" Then Comments=CurPol.Supported & VBCRLF & Comments If Comments<>"" Then With oXL.Range(CellName(NL,2)) .AddComment .Comment.Visible = True .Comment.Text Comments .Comment.Shape.Select True oXL.Selection.Font.Bold = False oXL.Selection.ShapeRange.ScaleWidth 2, msoFalse, msoScaleFromTopLeft k=len(Comments)/200 If k<1 then k=1 oXL.Selection.ShapeRange.ScaleHeight k, msoFalse, msoScaleFromTopLeft oXL.Selection.ShapeRange.SetShapesDefaultProperties .Comment.Visible = false End With End If If CurPol.ValueName<>"" Then AddStrat First, NL,3,"REG_DWORD",CurPol.KeyName & "\" & CurPol.ValueName For npa = 1 To Curpol.nPart set CurPart=Curpol.TabPart(npa-1) If CurPart.TypePart<>"TEXT" Then Select Case CurPart.TypePart Case "EDITTEXT" KeyType="REG_SZ" Case "NUMERIC" KeyType="REG_DWORD" Case "DROPDOWNLIST" KeyType="REG_DWORD" Case "LISTBOX" KeyType="REG_SZ" Case "CHECKBOX" KeyType="REG_DWORD" End select AddStrat First,NL,3,KeyType,CurPart.KeyName & "\" & CurPart.ValueName end if next next end if end if k=CurCat.nChild If k>0 Then For j = 1 To k set ChildCat=CurCat.Child(j) If CurName<>"root" Then Prefixe=NomCat Else Prefixe="" PrintTreeCat NL,ChildCat, Prefixe Next End If End Sub '-------------------------------------------------------------------- Sub AddStrat(byref First,byref NL,byval NC,KeyType,KeyName) If First Then First=false FlagColor=not FlagColor else NL=NL+1 end if Cellule NL,NC,KeyType,false,false,8 Cellule NL,NC+1,KeyName,false,false,0 If FlagColor Then ColorBG=ColorBGStrat1 ColorFG=ColorFGStrat1 Else ColorBG=ColorBGStrat2 ColorFG=ColorFGStrat2 End If FillColor NL,NC-1,NL,NC+1,ColorBG,ColorFG NLLast=NL End Sub '-------------------------------------------------------------------- Sub TestCOMExists(name,module) err.Clear on error resume next ' Vérification d'installation d'un objet COM dummy = shell.RegRead("HKCR\" & name & "\") if err.number<>0 then ' contrôle ActiveX non enregistré If module<>"" Then pathmodule=getpath()& module If not fso.fileExists(pathmodule) Then Mess= "Le contrôle ActiveX " & name & " est requis." & VBCRLF Mess=Mess & "Il est contenu dans le fichier " & module & VBCRLF Mess=Mess & "Or ce fichier n'a pas été trouvé." & VBCRLF MsgBox Mess, vbExclamation wscript.quit End If err.clear shell.Run "regsvr32.exe " & quote & pathmodule & quote, SW_SHOWNORMAL,true dummy = shell.RegRead("HKCR\" & name & "\") End If if err.number<>0 then Mess = "Le contrôle ActiveX " & name & " n'a pas pu être enregistré" MsgBox Mess, vbExclamation wscript.quit end if end if on error goto 0 End Sub '-------------------------------------------------------------------- Function ReadKey(key,valueName,typeval) If typeval="" Then typeval="REG_SZ" If not tools.KeyExists(key & "\" & valueName) Then Select Case typeval Case "REG_SZ" ReadKey="" Case else ReadKey=0 End Select exit function End If ReadKey=tools.RegRead(Key,valueName,typeval) End Function '-------------------------------------------------------------------- Function RunIE(W,H) RunIE=1 ' Ouverture d'Internet Explorer Set oIE = WScript.CreateObject("InternetExplorer.Application") Do While (oIE.Busy) WScript.Sleep 100 Loop oIE.navigate ficInit oIE.Height = H oIE.Width = W oIE.MenuBar = 0 oIE.ToolBar = 0 oIE.StatusBar = 1 oIE.Top=(oIE.Document.ParentWindow.Screen.Height-oIE.Height)/2 oIE.Left=(oIE.Document.ParentWindow.Screen.Width-oIE.Width)/2 oIE.Visible = 2 shell.AppActivate Titre DisplayListeADM ' Attente d'action sur le bouton ou fermeture de la fenêtre Do WScript.Sleep 100 selectFile=oIE.Document.Script.CheckSelFile() If selectFile<>0 Then oIE.Document.Script.ResetFile lviewdlgadmlist DisplayListeADM End If Check=oIE.Document.Script.CheckVal() Loop While (Check = 0) ' Si on ferme directement IE sans passer par un bouton, ' cela provoque une erreur qui est détectée et alors ' on quitte le script If Err <> 0 Then RunIE=-1 Err.Clear else If Check=-1 Then RunIE=0 end if End Function '-------------------------------------------------------------------- Sub DisplayListeADM Liste=GetStrFromADMList("
") Set objSPANlist = oIE.Document.All("ListADM") objSPANlist.InnerHTML=Liste End Sub '-------------------------------------------------------------------- Sub lviewdlgadmlist liste=GetStrFromADMList(VBCRLF) tools.cleardialog1 tools.addglobal1 liste tools.SetParamFile "","Fichiers modèles(*.adm)|*.adm|Tous les fichiers(*.*)|*.*","adm",Titre & " - Fichier modèle" result = tools.Show1("Définition des fichiers modèles","Fichiers ADM",true) If result Then GetADMListFromStr(tools.GetListe1) End Sub '-------------------------------------------------------------------- Function GetStrFromADMList(NL) liste="" For i = 1 To nfadm If liste<>"" Then liste=liste & NL liste=liste & ficadm(i-1) next GetStrFromADMList=Liste End Function '-------------------------------------------------------------------- Sub GetADMListFromStr(liste) nfadm=0 redim ficadm(0) lVBCRLF = Len(vbCrLf) Do p = InStr(liste, vbCrLf) If p > 0 Then Item = Left(liste, p - 1) liste = Mid(liste, p + lVBCRLF) Else Item = liste End If nfadm=nfadm+1 redim preserve ficadm(nfadm) ficadm(nfadm-1)=Item Loop Until p = 0 End Sub '-------------------------------------------------------------------- Function Header s="" & Titre & "" & VBCRLF s=s & "" header=s End Function '-------------------------------------------------------------------- Function TitreHTML s="

" & Titre & "

" & VBCRLF s=s & "" & VBCRLF s=s & "" & VBCRLF s=s & "
Système d'exploitation : " & PN & "
" TitreHTML=s End Function '-------------------------------------------------------------------- Function ScriptBtn s="" ScriptBtn=s End Function '-------------------------------------------------------------------- Function FormatStrL(ch,lmax) l=len(ch) If l0 Then ligne=Trim(left(ligne,psc-1)) If left(ligne,1)="#" Then ligne=lcase(mid(ligne,2)) If instr(ligne,"if version")=1 Then LevelOK=LevelOK+1 Redim preserve OK(LevelOK) OK(LevelOK)=false ligne=ligne & " then OK(LevelOK)=true" execute ligne else If ligne="endif" Then LevelOK=LevelOK-1 If LevelOK<0 then LevelOK=0 Redim preserve OK(LevelOK) End if End If else ' On ne traite que ce qui concerne la version en cours If OK(LevelOK) Then Select Case ligne Case "CLASS USER" Phase="user" Case "CLASS MACHINE" Phase="machine" Case "[strings]" Phase="strings" Case else Select Case Phase Case ADMClass(NumClass) nbparam=SplitLigne(ligne) If nbparam>0 Then ke=GetNumParam("END") 'test de "END xxxx" sur la même ligne If ke>0 Then newline 0,ke-1 newline ke,nbparam-1 Else newline 0,nbparam-1 End If end if Case else End Select End select End if end if wend tadm.close Next NumCat=0 For numL = 0 To nl-1 Analyse(NumL) Next Scan=NL End Function '-------------------------------------------------------------------- Sub Analyse(numL) Set Line0=TabLine(numL) name=Line0.param(0) If Line0.nbParam>=2 Then Value=Line0.param(1) Else Value="" End If value=ExplainValue(value) Select Case ucase(name) Case "CATEGORY" CurLevel=CurLevel+1 PushStack(name) Index=GetCat(CurLevel,Value) If Index=0 Then Set CurCat=new Category CurCat.DefCat CurParent,Value,CurLevel CurCat.Parent.AddCat CurCat CurCat.KeyName=MasterKeyCat else Set CurCat=TabCat(Index) End If Set CurParent=CurCat Case "POLICY" PushStack(name) Set CurPolicy=new Policy CurPolicy.DefPol CurParent,Value CurParent.AddPol CurPolicy CurPolicy.KeyName=MasterKeyCat MasterKeyPol=MasterKeyCat Case "EXPLAIN" Value=Replace(Value,"\n\n","\n") Value=Replace(Value,"\n",chr(10)) Select Case Stack(nItem) Case "CATEGORY" CurParent.Explain=Value Case "POLICY" CurPolicy.Explain=Value End Select Case "KEYNAME" CurKey=RemoveQuote(Value) CurHelp="" Select Case Stack(nItem) Case "CATEGORY" CurParent.KeyName=CurKey MasterKeyCat=CurKey MasterKeyPol=CurKey Case "POLICY" CurPolicy.KeyName=CurKey MasterKeyPol=CurKey Case "PART" CurPart.KeyName=CurKey End Select Case "PART" PushStack(name) Set CurPart=CurPolicy.AddPart(value,Line0.param(2)) CurPart.ScanPart CurPart.KeyName=MasterKeyPol Case "VALUENAME" CurValue=RemoveQuote(Value) Select Case Stack(nItem) Case "POLICY" CurPolicy.ValueName=CurValue Case "PART" CurPart.ValueName=CurValue End Select Case "SUPPORTED" CurComment=RemoveQuote(Value) Select Case Stack(nItem) Case "POLICY" CurPolicy.Supported=CurComment Case "PART" CurPart.Supported=CurComment End Select Case "ITEMLIST" CurPart.nbItem=0 Case "NAME" CurPart.AddItem Case "MIN" CurPart.Valmin=getval("MIN") If CurPart.Valmax="" Then CurPart.Valmax=getval("MAX") If CurPart.Default="" Then CurPart.Default=getval("DEFAULT") Case "MAX" CurPart.Valmax=getval("MAX") If CurPart.Valmin="" Then CurPart.Valmin=getval("MIN") If CurPart.Default="" Then CurPart.Default=getval("DEFAULT") Case "DEFAULT" CurPart.Default=value Case "VALUEON" If value="NUMERIC" Then CurValue=GetVal("NUMERIC") Else CurValue=value Select Case Stack(nItem) Case "POLICY" CurPolicy.CurValueON=CurValue Case "PART" CurPart.CurValueON=CurValue End Select Case "VALUEOFF" If value="NUMERIC" Then CurValue=GetVal("NUMERIC") Else CurValue=value Select Case Stack(nItem) Case "POLICY" CurPolicy.CurValueOFF=CurValue Case "PART" CurPart.CurValueOFF=CurValue End Select Case "VALUEPREFIX" CurPart.Prefixe=RemoveQuote(Value) Case "END" Select Case Value Case "CATEGORY","POLICY","PART" PopStack If Value="CATEGORY" Then CurLevel=CurLevel-1 Set CurParent=CurParent.Parent End If End select End select End sub '-------------------------------------------------------------------- Function ExplainValue(ch) ExplainValue=ch pee=instr(ch,"!!") If pee=1 Then ExplainValue=dictVar.item(mid(lcase(ch),3)) End Function '-------------------------------------------------------------------- Sub PushStack(item) nItem=nItem+1 redim preserve Stack(nItem) Stack(nItem)=ucase(item) End Sub '-------------------------------------------------------------------- Sub PopStack nItem=nItem-1 redim preserve Stack(nItem) End Sub '-------------------------------------------------------------------- Function GetLevel Select Case Stack(nItem) Case "CATEGORY" GetLevel=1 Case "POLICY" GetLevel=2 Case "PART" GetLevel=3 End Select End Function '-------------------------------------------------------------------- Function SplitLigne(ligne) Line0.RAZ pv=instr(ligne,";") If pv>0 Then ligne=trim(left(ligne,pv-1)) If ligne<>"" Then ligne=trim(Replace(ligne,chr(9)," ")) Isquote=false ch="" cprev=" " For m = 1 To len(ligne) c=mid(ligne,m,1) Select Case c Case " " If Isquote Then ch=ch & c else If cprev<>" " Then Line0.AddParam(ch) ch="" end if end if Case """" Isquote=not Isquote Case else ch=ch & c End Select cprev=c Next Line0.AddParam(ch) end if SplitLigne=Line0.nbParam End Function '-------------------------------------------------------------------- Function GetVal(ch) GetVal="" trouve=false For i = 0 To Line0.nbparam-1 If Line0.param(i)=ch Then trouve=true exit for End If Next If trouve and Line0.nbparam>i Then GetVal=Line0.param(i+1) End Function '-------------------------------------------------------------------- Function GetLines(cols,s) ch=s ligne="" nl=1 fin=false do p=instr(ch," ") If p=0 Then p=len(ch) suite=left(ch,p) If len(ligne)+len(suite)>cols Then nl=nl+1 ligne="" End If ligne=ligne & suite If p" & VBCRLF For np= 1 To CurCat.nPol suffixePol= index & "_" & np set Curpol=CurCat.TabPolicy(np) nPartAct=Curpol.GetPartAct() s = s & "" & VBCRLF s= s & "
" & CurPol.Name & "
" & VBCRLF If CurPol.Supported<>"" Then s=s & "Conditions requises : " & CurPol.Supported & "
" & VBCRLF If nPartAct=0 Then s= s & "" & CurPol.KeyName & "\" & CurPol.ValueName & "

" & VBCRLF For npa = 1 To Curpol.nPart suffixePart=suffixePol & "_" & npa set CurPart=Curpol.TabPart(npa-1) If CurPart.Supported<>"" Then s=s & "Conditions requises : " & CurPart.Supported & "
" & VBCRLF If CurPart.TypePart<>"TEXT" Then s= s & "" & CurPart.KeyName & "\" & CurPart.ValueName & "
" & VBCRLF End If s = s & CurPart.LibPart Select Case CurPart.TypePart Case "TEXT" Case "EDITTEXT","NUMERIC" If not IsColumn(CurPart.LibPart) Then s = s & ":" strval=CurPart.Default If CurPart.TypePart="NUMERIC" Then s=s & "Valeur numérique " & strval If CurPart.Valmin<>"" Then s=s & " Min=" & CurPart.Valmin If CurPart.Valmax<>"" Then s=s & " Max=" & CurPart.Valmax else s=s & "Valeur alphanumérique " & strval End If Case "DROPDOWNLIST" s = s & "Choix dans une liste :
" For nit= 0 To CurPart.nbItem-1 Selected="" If nit=cint(CurPart.value) Then Selected=" (par défaut)" s= s & CurPart.ItemList(nit) & Selected & "
" & VBCRLF Next Case "LISTBOX" s = s & "Choix multiple
" Case "CHECKBOX" s = s & "Case à cocher
" End Select s = s & "
" Next s= s & "" & VBCRLF s= s & "" & VBCRLF s= s & "" & VBCRLF Next s=s & "" GetStrat=s End Function '-------------------------------------------------------------------- Function GetCat(level,Curname) For nc= 1 To NumCat Set CurCat=TabCat(nc) If CurCat.Name=Curname and CurCat.level=level Then GetCat=nc exit function End If Next GetCat=0 End Function '-------------------------------------------------------------------- Class Category public Name public IndexCat public Explain public Level public Parent public nChild public Child() public nPol public TabPolicy() public Keyname Private Sub Class_Initialize IndexCat=0 Explain="" nChild=0 nPol=0 Keyname="" End Sub Public Sub DefCat(Byref CurParent,Curname,CurLevel) Set Parent=CurParent Name=CurName Level=CurLevel if LevelMax"TEXT" then npartAct=npartAct+1 Next GetPartAct=npartAct End Function ' End class '-------------------------------------------------------------------- Class Part Public TypePart Public LibPart Public KeyName Public ValueName Public Supported Public Value Public Defined Public ValMin Public ValMax Public Default Public CurValueON Public CurValueOFF Public Prefixe Public nbItem Public ItemList(),ValueItem(),DefaultItem() Public ExplicitValue Private Sub Class_Initialize TypePart="" LibPart="" KeyName="" Supported="" ValueName="" ValMin="" ValMax="" Default="" CurValueON=1 CurValueOFF=0 Prefixe="" nbItem=0 Defined=false ExplicitValue=false End Sub Public Sub ScanPart Select Case TypePart Case "TEXT" Case "EDITTEXT" default="" Case "NUMERIC" ValMin=getval("MIN") ValMax=getval("MAX") default=getval("DEFAULT") Case "DROPDOWNLIST" nbItem=0 Case "LISTBOX" nbItem=0 If GetVal("LISTBOX")="EXPLICITVALUE" Then ExplicitValue=true Case "CHECKBOX" CurValueON="1" CurValueOFF="0" End Select End Sub Public Sub AddItem nbItem=nbItem+1 redim preserve ItemList(nbItem),ValueItem(nbItem),DefaultItem(nbItem) ItemList(nbItem-1)=ExplainValue(Line0.Param(1)) If Line0.nbParam>3 Then k=3 If Line0.Param(3)="NUMERIC" Then k=4 ValueItem(nbItem-1)=Line0.Param(k) DefaultItem(nbItem-1)="" If Line0.nbParam>k+1 Then If Line0.Param(k+1)="DEFAULT" Then Value=nbItem-1 end if End If End Sub Public Sub PutListe(s) nbItem=0 redim ItemList(0),ValueItem(0) If Len(s) = 0 Then Exit Sub Dim ValDlg ValDlg=Split(s,VBCRLF) nElem=Ubound(Valdlg)-LBound(ValDlg)+1 If ExplicitValue Then nbItem=int(nElem/2) else nbItem=nElem redim preserve ItemList(nbItem),ValueItem(nbItem) For k = 0 To nbItem-1 If ExplicitValue Then ItemList(k)=Valdlg(2*k) ValueItem(k)=Valdlg(2*k+1) Else ItemList(k)=Prefixe & cstr(k+1) ValueItem(k)=Valdlg(k) End If Next End Sub Public Function GetListe s="" For k = 0 To nbItem-1 If s<>"" Then s=s & VBCRLF If ExplicitValue Then s=s & ItemList(k) & VBCRLF s=s & ValueItem(k) Next GetListe=s End Function Public Function GetState GetState=0 If Defined Then GetState=1 End Function End Class '-------------------------------------------------------------------- Class Line Public nbparam Public Param() Private Sub Class_Initialize nbparam=0 End Sub Public Sub RAZ nbparam=0 redim Param(0) End Sub Public Sub AddParam(ch) nbparam=nbparam+1 redim preserve Param(nbparam) Param(nbparam-1)=ch End Sub Public Sub CopyParam(ideb,ifin) nbparam=ifin-ideb+1 redim Param(nbparam) For i = ideb To ifin k=i-ideb Param(k)=Line0.Param(i) Next End Sub End Class '-------------------------------------------------------------------- ' Fonction de récupération du répertoire courant Function GetPath() Dim path path = WScript.ScriptFullName GetPath = Left(path, InStrRev(path, "\")) End Function '-------------------------------------------------------------------- Sub WriteLog(ch) set tlog=fso.OpenTextFile(ficlog,ForAppending, true) tlog.writeline ch tlog.close End Sub