Scripts pour Administrateurs systemes

Cette page a pour but de fournir des exemples de scripts en VB, VBScript ou ASP
facilement réutilisables pour les administrateurs systèmes

Active directory
Autre
Asp
Bbcode
Excel
Exchange
Files
Html
Javascript
Javascript/files
Network
Ntfs
Perl
Php/base
Php/divers
Php/fichiers
Php/tableau
Powershell
Registre
Sql
Sql scripting

Version du 4 novembre 2011

Active Directory - Ajouter/supprimer un user AD à un groupe AD
Public Function AddDelUserToGroupAD(ByVal Operation, ByVal UserAD, ByVal GroupeAD, ByVal AdLogin, ByVal AdPassword, ByVal DebugMode)

'Ex Version du 8 aout 2010

'ne retourne rien si tout est ok

'Retourne un message d'erreur si problème

'Operation :

Add : pour ajouter un user a un groupe

Del

: pour supprimer un user d'un groupe

'DebugMode

0 : ne fait rien

>0 : affiche des information de debuggage

'L erreur -2147019886 dignifie que le compte fait deja partie du groupe

Const ADS_SECURE_AUTHENTICATION = 1 'Requests secure authentication. When this flag is set, Active Directory will use Kerberos, and possibly NTLM, to authenticate the client.

Const ADS_USE_ENCRYPTION = 2 'Requires ADSI to use encryption for data exchange over the network.

Const ADS_PROPERTY_APPEND = 3

Const ADS_PROPERTY_DELETE = 4

Dim Position

AddDelUserToGroupAD = "Begin of AddDelUserToGroupAD function" 'Par défaut

'Si le chemin du groupe ne commence pas par LDAP on l ajoute

Position = Instr(1,Lcase(GroupeAD),"ldap://")

If Position = 0 Then

GroupeAD = "LDAP://" & GroupeAD

End If

'On retire le LDAP:// du debut du chemin du compte du user

If Left(Lcase(UserAD),7) = "ldap://" Then

UserAD = Mid(UserAD,8)

End If

'On retire le nom du serveur si il a été précisé au niveau du chemin du compte user

Position = Instr(1,UserAD,"/")

If Position > 0 Then

UserAD = Mid(UserAD,Position + 1)

End If

Set objDSO = GetObject("LDAP:")

AddDelUserToGroupAD = "Operation unknow (not add or del)"

Operation = Lcase(Trim(Operation))

If Operation = "add" Then

AddDelUserToGroupAD = "Try to connect to " & GroupeAD & " group for adding operation"

Err.Clear

On Error Resume Next

'Ajout du user au groupe

If Len(AdLogin) > 0 Then

'Set objGroup = objDSO.OpenDSObject(GroupeAD, Login, MotDePasse, ADS_USE_ENCRYPTION OR ADS_SECURE_AUTHENTICATION) 'Le cryptage ne fonctionne pas forcement. A tester

Set objGroup = objDSO.OpenDSObject(GroupeAD, AdLogin, AdPassword, ADS_SECURE_AUTHENTICATION)

Else

Set objGroup = GetObject(GroupeAD)

End If 'If Len(AdLogin) > 0 Then

On Error Goto 0

If (Err.number = 0) Then

AddDelUserToGroupAD = "Connection to " & GroupeAD & " group ok"

Err.Clear

On Error Resume Next

objGroup.PutEx ADS_PROPERTY_APPEND, "member", Array(UserAD)

objGroup.SetInfo

Set objGroup = Nothing

If (Err.number = 0) Or (Err.number = -2147019886) Then

AddDelUserToGroupAD = ""

Else

AddDelUserToGroupAD = "Error for adding user to " & GroupeAD & " group (" & Err.number & " " & Err.Description & ")"

End If

On Error Goto 0

End If

End If 'If Operation = "add" Then

If Operation = "del" Then

AddDelUserToGroupAD = "Try to connect to " & GroupeAD & " group for deleting operation"

Err.Clear

On Error Resume Next

'Ajout du user au groupe

If Len(AdLogin) > 0 Then

'Set objGroup = objDSO.OpenDSObject(GroupeAD, Login, MotDePasse, ADS_USE_ENCRYPTION OR ADS_SECURE_AUTHENTICATION) 'Le cryptage ne fonctionne pas forcement. A tester

Set objGroup = objDSO.OpenDSObject(GroupeAD, AdLogin, AdPassword, ADS_SECURE_AUTHENTICATION)

Else

Set objGroup = GetObject(GroupeAD)

End If 'If Len(AdLogin) > 0 Then

On Error Goto 0

If (Err.number = 0) Then

Err.Clear

On Error Resume Next

objGroup.PutEx ADS_PROPERTY_DELETE, "member", Array(UserAD)

objGroup.SetInfo

NumeroErreur = Err.number

Set objGroup = Nothing

On Error Goto 0

If (NumeroErreur = 0) Or (NumeroErreur = -2147019886) Then

AddDelUserToGroupAD = ""

Else

AddDelUserToGroupAD = "Error for deleting user to " & GroupeAD & " group (" & Err.number & " " & Err.Description & ")"

End If

End If 'If Operation = "add" Then

Set objDSO = Nothing

End Function

Active Directory - Appliquer un filtre avec une opération Booléenne dans une requete LDAP
'Trouve sur le document suivant
'http://support.microsoft.com/kb/269181/en-us
'Ce document a pour titre How to query Active Directory by using a bitwise filter

'Le document suivant a pour titre 'Search Filter Syntax'
'http://msdn.microsoft.com/en-us/library/aa746475%28VS.85%29.aspx

'Il faut utiliser une ruleOID dans la requete LDAP. Il y en a 2 :
' Opération ET logique : 1.2.840.113556.1.4.803 qui est le LDAP_MATCHING_RULE_BIT_AND rule
' Opération OR logique : 1.2.840.113556.1.4.804 qui est le LDAP_MATCHING_RULE_BIT_OR rule

'Exemple :

Set oNSP = GetObject("LDAP://Win2000Server/rootdse")
Set oConfig = GetObject("LDAP://Win2000Server/" & oNSP.get("DefaultNamingContext"))

Set oConn = CreateObject("ADODB.Connection")
oConn.Provider = "ADSDSOObject"
oConn.Open ""

'Requete pour exporter les users dont le compte est desactive
strQuery = "<" & oConfig.ADsPath & ">;(&(objectCategory=person)(objectClass=User)(userAccountControl:1.2.840.113556.1.4.803:=2));name,objectClass;subtree"

'L inverse, soit une requete pour exporter les users dont le compte n est pas desactive
strQuery = "<" & oConfig.ADsPath & ">;(&(objectCategory=person)(objectClass=User)(!(userAccountControl:1.2.840.113556.1.4.803:=2)));name,objectClass;subtree"

Set oRS = oConn.Execute(strQuery)
While Not oRS.EOF

MsgBox oRS.Fields("name")

oRS.MoveNext
Wend

MsgBox "done"

Set oConn = Nothing
Set oRS = Nothing
Set oConfig = Nothing
Set oNSP = Nothing

Active Directory - Connection a un objet de l AD avec un Credential different
'Connection à un objet de l AD avec un login\mot de passe différent
Const ADS_SECURE_AUTHENTICATION = 1 'Requests secure authentication. When this flag is set, Active Directory will use Kerberos, and possibly NTLM, to authenticate the client.
Const ADS_USE_ENCRYPTION = 2 'Requires ADSI to use encryption for data exchange over the network.

Dim Login
Dim MotDePasse
Dim NomServeurAD
Dim CheminLDAP

Login = InputBox("Entrez le login ayant des droits sur l AD","Login","")
MotDePasse = InputBox("Entrez le mot de passe","Mot de passe","")
NomServeurAD = InputBox("Entrez le nom du serveur Active Directory","Nom du Serveur","")

CheminLDAP = "LDAP://" & NomServeurAD & "/OU=Utilisateurs,OU=,dc=votredomaine,dc=com"

Set objDSO = GetObject("LDAP:")
Set objOU = objDSO.OpenDSObject(CheminLDAP, Login, MotDePasse, ADS_SECURE_AUTHENTICATION)

'Exemple d utilisation de l objet
'Set objUser = objOU.Create("User", "cn=Nom Prenom")
'objUser.Put "sAMAccountName", "Login"
'objUser.displayName = "Nom Prenom"
'etc ...
'objUser.SetInfo
'Set objUser = Nothing

Set objOU = Nothing
Set objDSO = Nothing

Active Directory - Afficher le schéma d'un user dans l'AD
Const ForReading = 1
Const ForWritting = 2
Const ForAppending = 8

CheminScriptActuel = Left(wscript.scriptfullname,Len(wscript.scriptfullname)-Len(wscript.scriptname)-1)
CheminFichier = CheminScriptActuel & "\" & "ZZSchemaUserAD.txt"

Wscript.Echo "La reponse sera dans le fichier """ & CheminFichier & """"

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.OpenTextFile(CheminFichier, ForWritting, True)

Set objUserClass = GetObject("LDAP://schema/user")
Set objSchemaClass = GetObject(objUserClass.Parent)

objTextFile.WriteLine("*************************************")
objTextFile.WriteLine("Valeurs obligatoires")
objTextFile.WriteLine("*************************************")
For Each strAttribute in objUserClass.MandatoryProperties
objTextFile.WriteLine(strAttribute)
Next

objTextFile.WriteLine("")
objTextFile.WriteLine("")
objTextFile.WriteLine("*************************************")
objTextFile.WriteLine("Valeurs optionnelles")
objTextFile.WriteLine("*************************************")
For Each strAttribute in objUserClass.OptionalProperties
objTextFile.WriteLine(strAttribute)
Next

WScript.Echo "Termine"
objTextFile.Close
Set objTextFile = Nothing
Set objFSO = Nothing

Active Directory - Connection a un serveur AD et enumeration des objets
'http://msdn.microsoft.com/library/en-us/adsi/adsi/enumeration.asp
Dim Container as IADsContainer
Dim Child as IADs

Set Container = GetObject("LDAP://MyServer/DC=MyDomain,DC=Fabrikam,DC=com")

For Each Child in Container
Debug.Print Child.Name
Next Child

Active Directory - Creation d un groupe
Const DebugMode = 1
Wscript.echo CreationGroupeAD("LDAP://OU=MonOU,DC=MonDomaine","NomGroupe",2,"test desc","test note","MyADLogin","MyADPassword", DebugMode)

Public Function CreationGroupeAD(ByVal CheminLDAPConteneur, ByVal NomGroupe, ByVal TypeGroupe, ByVal DescriptionGroupe, ByVal NotesGroupe, ByVal AdLogin, ByVal AdPassword, ByVal DebugMode)

'Version du 18/06/2007

'Retourne 1 si le groupe a été créé

'Retourne 0 si le groupe n a pas été créé

'Valeurs de TypeGroupe

'2 pour un groupe Global

'4 pour un groupe local de domaine

'8 pour un groupe Universel

Dim NumeroErreur

Dim objGroup

Dim Position

CreationGroupeAD = 0

Const ADS_GROUP_TYPE_GLOBAL_GROUP = &h2

Const ADS_GROUP_TYPE_LOCAL_GROUP = &h4

Const ADS_GROUP_TYPE_UNIVERSAL_GROUP = &h8

Const ADS_GROUP_TYPE_SECURITY_ENABLED = &h80000000

Const ADS_SECURE_AUTHENTICATION = 1 'Requests secure authentication. When this flag is set, Active Directory will use Kerberos, and possibly NTLM, to authenticate the client.

Const ADS_USE_ENCRYPTION = 2 'Requires ADSI to use encryption for data exchange over the network.

Const ADS_PROPERTY_APPEND = 3

Const ADS_PROPERTY_DELETE = 4

If DebugMode > 0 Then

Wscript.echo "CheminLDAPConteneur : " & CheminLDAPConteneur

Wscript.echo "NomGroupe : " & NomGroupe

Wscript.echo "AdLogin : " & AdLogin

End If

If (Len(CheminLDAPConteneur) > 0) And (Len(NomGroupe) > 0) Then

Set objDSO = GetObject("LDAP:")

'Position = Instr(1,Lcase(CheminLDAPConteneur),"ldap://")

'If Position = 0 Then

'CheminLDAPConteneur = "LDAP://" & CheminLDAPConteneur

'End If

Err.Clear

On Error Resume Next

If Len(AdLogin) > 0 Then

'Set objGroup = objDSO.OpenDSObject(GroupeAD, Login, MotDePasse, ADS_USE_ENCRYPTION OR ADS_SECURE_AUTHENTICATION) 'Le cryptage ne fonctionne pas forcement. A tester

Set objOU = objDSO.OpenDSObject(CheminLDAPConteneur, AdLogin, AdPassword, ADS_SECURE_AUTHENTICATION)

Else

Set objOU = GetObject(CheminLDAPConteneur)

End If 'If Len(AdLogin) > 0 Then

NumeroErreur = Err.number

If DebugMode > 0 Then

Wscript.echo "Err.Description : " & Err.Description

End If

On Error Goto 0

If (NumeroErreur = 0) Then

Set objGroup = objOU.Create("Group", "CN=" & NomGroupe)

objGroup.Put "sAMAccountName", NomGroupe

objGroup.Put "groupType", hex(TypeGroupe) Or ADS_GROUP_TYPE_SECURITY_ENABLED

Err.Clear

On Error Resume Next

objGroup.SetInfo

NumeroErreur = Err.number

On Error Goto 0

If DebugMode > 0 Then

Wscript.echo "Err.Description : " & Err.Description

End If

If (NumeroErreur = 0) Then

CreationGroupeAD = 1

DescriptionGroupe = Trim(DescriptionGroupe)

If Len(DescriptionGroupe) > 0 Then

objGroup.Description = DescriptionGroupe

objGroup.SetInfo

End If 'If Len(DescriptionGroupe) > 0 Then

If Len(NotesGroupe) > 0 Then

objGroup.Info = NotesGroupe

objGroup.SetInfo

End If

Else

If DebugMode > 0 Then

Wscript.echo "Error during group creation of " & NomGroupe

Wscript.echo "NumeroErreur : " & NumeroErreur

End If

Else

If DebugMode > 0 Then

Wscript.echo "Error during connection to " & CheminLDAPConteneur

Wscript.echo "NumeroErreur : " & NumeroErreur

End If

End If 'If (NumeroErreur = 0) Then

End If

Set objDSO = Nothing

End Function

Active Directory - Deplacer/Renommer un compte
'Exemple :

Dim CheminLDAPObjetADeplacer

Dim CheminLDAPConteneurCible

Dim DescriptionErreur

CheminLDAPObjetADeplacer = "LDAP://CN=MonObjetADeplacer,OU=UneOUTartampion,DC=Fabrikam,DC=Com"

CheminLDAPConteneurCible = "LDAP://OU=ZeOuCible,DC=Fabrikam,DC=Com"

CheminLDAPObjetADeplacer = ModifierCheminLDAP(CheminLDAPObjetADeplacer,"",2)

CheminLDAPConteneurCible = ModifierCheminLDAP(CheminLDAPConteneurCible,"",2)

If DeplacerObjet(CheminLDAPObjetADeplacer, CheminLDAPConteneurCible,"",DescriptionErreur) = 1 Then

Msgbox "Objet deplacé"

End If

Public Function DeplacerObjet(ByVal CheminLDAPObjetADeplacer, ByVal CheminLDAPConteneurCible, ByVal NouveauNomObjet, ByRef OptionDescriptionErreur)

'Version du 23 janvier 2007

'Permet de déplacer un objet et éventuellement de le renommer

'Retourne 0 si le compte n a pas été déplacé

'Retourne 1 si le compte a bien été déplacé ou si il est déjà à l endroit demandé

'Exemple :

'Dim CheminLDAPObjetADeplacer

'Dim CheminLDAPConteneurCible

'Dim OptionDescriptionErreur

'CheminLDAPObjetADeplacer = "LDAP://CN=MonObjetADeplacer,OU=UneOUTartampion,DC=Fabrikam,DC=Com"

'CheminLDAPConteneurCible = "LDAP://OU=ZeOuCible,DC=Fabrikam,DC=Com"

'CheminLDAPObjetADeplacer = ModifierCheminLDAP(CheminLDAPObjetADeplacer,"",2)

'CheminLDAPConteneurCible = ModifierCheminLDAP(CheminLDAPConteneurCible,"",2)

'If DeplacerObjet(CheminLDAPObjetADeplacer, CheminLDAPConteneurCible,"",OptionDescriptionErreur) = 1 Then

Msgbox "Objet deplacé"

'End If

Dim objOUCible

Dim NumeroErreur

Dim Position

Dim TypeObjet 'Type de l'objet, soit une OU, un conteneur etc

'Par défaut on considere que cela n a pas fonctionne

DeplacerObjet = 0

OptionDescriptionErreur = ""

'Si on doit aussi renommer l objet

'On recherche son type

If Len(NouveauNomObjet) > 0 Then

TypeObjet = ""

'On retire l éventuelle LDAP:// ou le nom de serveur

Position = InstrRev(CheminLDAPObjetADeplacer,"/")

If Position > 0 Then

TypeObjet = Mid(CheminLDAPObjetADeplacer,Position+1)

End If 'If Position > 0 Then

'On recherche la position du premier signe Egal

'Et on récupère ce qui est avant

Position = Instr(TypeObjet,"=")

If Position > 0 Then

TypeObjet = Left(TypeObjet,Position-1)

TypeObjet = UCASE(TypeObjet)

End If 'If Position > 0 Then

End If 'If Len(NouveauNomObjet) > 0 Then

On Error Resume Next

'Connection à la cible

Set objOUCible = GetObject(CheminLDAPConteneurCible)

'Déplacement effectif

If Len(NouveauNomObjet) = 0 Then

objOUCible.MoveHere CheminLDAPObjetADeplacer, vbNullString

Else 'Déplacement effectif et renommage

objOUCible.MoveHere CheminLDAPObjetADeplacer, TypeObjet & "=" & NouveauNomObjet

End If

NumeroErreur = Err.number

OptionDescriptionErreur = Err.Description

On Error Goto 0

'Si le déplacement a réussit

If NumeroErreur = 0 Then

'On retourne 1 pour signaler la réussite

DeplacerObjet = 1

End If 'If NumeroErreur = 0 Then

Set objOUCible = Nothing

End Function

Active Directory - Ecrire une propriété d un objet AD
Public Function EcrireProprieteObjetAD(ByVal CheminLDAP, ByVal AttributAD, ByVal ValeurAEcrire)

'Version du 25 septembre 2008

'Retourne 1 si Ok

'Retourne 0 si NonOk

Dim MonObjAD

Dim NumErreur

Dim MaValeur

EcrireProprieteObjetAD = 0 'Retour par défaut

Const EnteteLDAP = "LDAP://"

If Left(Lcase(CheminLDAP),Len(EnteteLDAP)) <> Lcase(EnteteLDAP) Then

CheminLDAP = EnteteLDAP & CheminLDAP

End If

Err.Clear

On Error Resume Next

'Msgbox "On traite" & VbCrLf & CheminLDAP & " avec " & AttributAD & " et " & ValeurAEcrire

Set MonObjAD = GetObject(CheminLDAP)

MonObjAD.Put AttributAD, ValeurAEcrire

MonObjAD.SetInfo

NumErreur = Err.number

On Error Goto 0

Set MonObjAD = Nothing

'Si il n'y a pas eu d erreur, on donne un retour positif

If NumErreur = 0 Then

EcrireProprieteObjetAD = 1

End If

End Function

Active Directory - Extraire des donnees de l AD - ancienne fonction a eviter. Preferer 'RequeteLDAP sur un AD'

Dim objFSO
Dim objTextFile
Dim CheminFichier

Dim Mavariable
Dim UnTableau

'Déclaration des constantes
Const ForReading = 1
Const ForWritting = 2
Const ForAppending = 8

CheminFichier = "d:\MonFichier.txt" 'Déclaration du chemin et du nom du fichier

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.OpenTextFile(CheminFichier, ForWritting, True)

Mavariable = ExtractAD("LDAP://DC=MonDomaine,DC=Com", "User", "distinguishedName,sn,givenName,sAMAccountName")
If IsArray(Mavariable) = True Then

For Each UneLigne In Mavariable

'Wscript.Echo UneLigne

UnTableau = Split(UneLigne, ";")

MonResultat = UnTableau(1) & ", " & UnTableau(2) & " (" & UnTableau(3) & ")"

If (Trim(Len(UnTableau(1))) > 0) And (Trim(Len(UnTableau(2))) > 0) Then

objTextFile.WriteLine (MonResultat) 'On ecrit la date et l'heure dans le fichier

End If

'Cells(CompteurLigne, 1).FormulaR1C1 = Trim(UneLigne)

'CompteurLigne = CompteurLigne + 1

Next
End If

objTextFile.Close 'Fermeture du fichier

Set objTextFile = Nothing
Set objFSO = Nothing

Public Function ExtractAD(ByVal CheminLDAP, ByVal TypeObjetDemande, ByVal ChampsDemandes)

'Version du 12 janvier 2009 : On exclut des résultats les tableaux composés de vbVariant

'Version du 28 octobre 2008 : support de plusieurs OU passées en parametres

'Version du 06 décembre 2006

'http://support.microsoft.com/kb/q187529/

'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/adsi/adsi/searching_with_activex_data_objects_ado.asp

'Retourne une chaine vide si rien n'est trouve

'Retourne un tableau si on a des résultats

'Exemple

'Dim Mavariable

'Mavariable = ExtractAD("LDAP://OU=UneOU,OU=Mon,DC=Domaine,DC=COM", "User", "sAMAccountName,cn,ObjectSID")

'If IsArray(Mavariable) = True Then

'For Each Test In Mavariable

'MsgBox Test

'Next

'End If

Dim UneLigne

Dim NombreTotal

Dim ResultatAMettreSousFormeDeTableau

Dim TableauOU

Dim TableauResultat

Dim LigneDeTableau

Dim UneOU

Dim SousLigneDeTableau

Dim NumErreur

Const Separateur = "#!"

'Par defaut le retour est vide

ExtractAD = ""

ChampsDemandes = Trim(ChampsDemandes)

TypeObjetDemande = Trim(TypeObjetDemande)

'Si il n'y a pas de champs demandés d'indiqué

If Len(ChampsDemandes) = 0 Then

ChampsDemandes = "sAMAccountName,cn"

End If

'Si il n'y a pas de type demandé

If Len(TypeObjetDemande) = 0 Then

TypeObjetDemande = "User"

End If

Set MaConnection = CreateObject("ADODB.Connection") 'New ADODB.Connection

MaConnection.Provider = "ADSDSOObject"

'MaConnection.Properties("User ID") = stUser

'MaConnection.Properties("Password") = stPass

'MaConnection.Properties("Encrypt Password") = True

MaConnection.Open "ADs Provider"

TableauOU = Split(CheminLDAP, ";")

NombreTotal = 0

ResultatAMettreSousFormeDeTableau = ""

For Each UneOU In TableauOU

Set MonRecordset = MaConnection.Execute("<" & UneOU & ">;(objectCategory=" & TypeObjetDemande & ");" & ChampsDemandes)

'On Error Resume Next

While MonRecordset.EOF = False

NombreTotal = NombreTotal + 1

Affichage = ""

'On ecrit la valeur de chaque champs du Recordset

For Compteur = 0 To (MonRecordset.Fields.Count - 1)

Err.Clear

On Error Resume Next

Resultat = MonRecordset.Fields(Compteur).Value

NumErreur = Err.Number

On Error GoTo 0

If NumErreur <> 0 Then

Resultat = ""

End If

TypeVariable = VarType(Resultat)

If (TypeVariable > 1) And (TypeVariable <> 9) And (TypeVariable <> 8204) Then 'Si la variable est initialisée, qu'elle n'est pas Null, que ce n'est pas un tableau avec des vbVariant

'Wscript.Echo "Le type de " & MonRecordset.Fields(Compteur).name & " est " & VarType(Resultat)

If IsArray(Resultat) = False Then

Affichage = Affichage & Resultat

Else

UneLigne = ""

'Si on arrive à lire correctement le tableau

If TesterLectureTableau(Resultat) = 1 Then

For Each LigneDeTableau In Resultat

'Si la ligne du tableau n'est pas elle même une ligne de tableau

If IsArray(LigneDeTableau) = False Then

UneLigne = UneLigne & InterpreterResultat(LigneDeTableau)

Else

If TesterLectureTableau(LigneDeTableau) = 1 Then

For Each SousLigneDeTableau In LigneDeTableau

UneLigne = UneLigne & InterpreterResultat(SousLigneDeTableau)

End If 'If TesterLectureTableau(LigneDeTableau) = 1 Then

End If

End If 'If TesterLectureTableau(Resultat) = 1 Then

Affichage = Affichage & UneLigne

'Affichage = Affichage & Resultat(0)

End If

End If '(TypeVariable > 1) AND (TypeVariable <> 9)

'On inscrit un point virgule pour marquer la fin du champ

Affichage = Affichage & ";"

Affichage = Left(Affichage, Len(Affichage) - 1)

ResultatAMettreSousFormeDeTableau = ResultatAMettreSousFormeDeTableau & Affichage & Separateur

MonRecordset.MoveNext

Wend

Set MonRecordset = Nothing

'Si on a un résultat

If Len(ResultatAMettreSousFormeDeTableau) > 0 Then

ResultatAMettreSousFormeDeTableau = Left(ResultatAMettreSousFormeDeTableau, Len(ResultatAMettreSousFormeDeTableau) - Len(Separateur))

TableauResultat = Split(ResultatAMettreSousFormeDeTableau, Separateur)

ExtractAD = TableauResultat

End If

MaConnection.Close

'cn nom detaille dans l'ad

'displayName nom detaille dans les proprietes

'givenname prenom

'name nom detaille

'sn le nom

End Function

Public Function InterpreterResultat(ByVal MonResultat)

'Si le résultat est un héxadécimal, on le traite différemment

'Sinon rien ne change

'Si on est face à un hexadecimal

If VarType(MonResultat) = 17 Then

'On force le résultat à être sous forme Hexadécimal.

'Il ne sera pas convertit automatiquement en décimal par le système

'Si l'hexadécimal est de longueur 1, on rajoute un 0 pour qu'il soit sur 2

If Len(Hex(MonResultat)) = 1 Then

MonResultat = "0" & Hex(MonResultat)

Else

MonResultat = Hex(MonResultat)

End If

'On retourne le résultat

InterpreterResultat = MonResultat

End Function

Public Function TesterLectureTableau(ByRef MonTableauATester)

Dim UneLigne

Dim Compteur

Dim NumErreur

'Version du 06 Décembre 2006

'Retourne 1 si on arrive à lire correctement le tableau, sinon retourne 0

MonTableauATester = 0 'Par défaut

Err.Clear

On Error Resume Next

Compteur = 0

For Each UneLigne In MonTableauATester

NumErreur = Err.Number

'Si la lecture n'a pas fonctionné

If NumErreur <> 0 Then

'On considère que le test est un échec

On Error Goto 0

TesterLectureTableau = 0

Exit Function

End If

If Compteur > 3 Then

Exit For

End If 'If Compteur > 3 Then

Compteur = Compteur + 1

On Error Goto 0

'Si on a pu lire correctement le début du tableau

If NumErreur = 0 Then

'On retourne un résultat positif

TesterLectureTableau = 1

End If

End Function

Active Directory - lire/interpréter le accountExpires (date d expiration d un compte) après une requete LDAP
'Interpretation de la valeur brut de accountExpires suite à une requete LDAP
Const Depart = "31/12/1600 01:00:00"

Dim MaValeur
Dim DateExpirationFormatBrut

DateExpirationFormatBrut = InputBox("Entrez la date d expiration au format brut de l AD","Date d expiration","128001564000000000")
DateExpirationFormatBrut = Left(DateExpirationFormatBrut, Len(DateExpirationFormatBrut) - 7)

MaValeur = CCur(DateExpirationFormatBrut)
MaValeur = MaValeur / 60
MsgBox DateAdd("n", MaValeur, Depart)

Active Directory - Lire le SID d'un compte
'Vu sur
'http://www.microsoft.com/technet/scriptcenter/resources/qanda/dec04/hey1203.mspx

strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set objAccount = objWMIService.Get("Win32_UserAccount.Name='Lelogin',Domain='ledomaine'")
Wscript.Echo objAccount.SID

Active Directory - Lire une propriété d un objet AD
Public Function LireProprieteObjetAD(ByVal CheminLDAP, ByVal AttributAD)

'Version du 25 septembre 2008

Dim MonObjAD

Dim NumErreur

Dim MaValeur

Const EnteteLDAP = "LDAP://"

If Left(Lcase(CheminLDAP),Len(EnteteLDAP)) <> Lcase(EnteteLDAP) Then

CheminLDAP = EnteteLDAP & CheminLDAP

End If

Err.Clear

On Error Resume Next

Set MonObjAD = GetObject(CheminLDAP)

MaValeur = MonObjAD.Get(AttributAD)

On Error Goto 0

Set MonObjAD = Nothing

'On retourne la valeur

LireProprieteObjetAD = MaValeur

End Function

Active Directory - Liste des attributs des objets de l AD
'Liste dispo sur ce lien
'http://msdn2.microsoft.com/en-us/library/ms675090.aspx
'Categorie de MSDN :
'MSDN Library>Win32 and COM Development> Administration Management>Directory Services Overview>Directories>Active Directory Schema>Attributes>All Attributes

Active Directory - Lister les groupes d un user
Public Function SeekUserMemberInAd(ByVal ADLogin, ByVal CheminUNCAD)

'Version du 7 septembre 2006

'Utilisation

'UnTableau = SeekUserMemberInAd("LDAP://CN=DUPONT Jean,OU=Utilisateurs,DC=MonDomaine,DC=COM", "LDAP://NomServeur/DC=MonDomaine,DC=COM")

'For Each UneLigne In UnTableau

'Msgbox UneLigne

'Next

'http://support.microsoft.com/kb/q187529/

'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/adsi/adsi/searching_with_activex_data_objects_ado.asp

Const ADS_SECURE_AUTHENTICATION = 1 'Requests secure authentication. When this flag is set, Active Directory will use Kerberos, and possibly NTLM, to authenticate the client.

Const ADS_USE_ENCRYPTION = 2 'Requires ADSI to use encryption for data exchange over the network.

Const ADS_SCOPE_SUBTREE = 2

Dim objConnection

Dim objCommand

Dim objRecordSet

Dim Liste

Dim Position

SeekUserMemberInAd = "" 'Valeur par défaut

'On retire le LDAP:// du debut

If Left(Lcase(ADLogin),7) = "ldap://" Then

ADLogin = Mid(ADLogin,8)

End If

'On retire le nom du serveur si il a été précisé

Position = Instr(1,ADLogin,"/")

If Position > 0 Then

ADLogin = Mid(ADLogin,Position + 1)

End If

Set objConnection = CreateObject("ADODB.Connection")

Set objCommand = CreateObject("ADODB.Command")

objConnection.Provider = "ADsDSOObject"

'objConnection.Properties("User ID") = ""

'objConnection.Properties("Password") = ""

objConnection.Properties("Encrypt Password") = TRUE

objConnection.Properties("ADSI Flag") = 1 'ADS_SECURE_AUTHENTICATION

objConnection.Open "Active Directory Provider"

Set objCommand.ActiveConnection = objConnection

objCommand.Properties("Page Size") = 1000

objCommand.Properties("Searchscope") = 2 'ADS_SCOPE_SUBTREE

objCommand.CommandText = "SELECT distinguishedName FROM '" & CheminUNCAD & "' WHERE objectCategory='group' and member='" & ADLogin & "'"

Set objRecordSet = objCommand.Execute

If objRecordSet.BOF = False Then

objRecordSet.MoveFirst

End If

Liste = ""

Do While objRecordSet.EOF = False

Liste = Liste & objRecordSet(0).Value & ";"

objRecordSet.MoveNext

Loop

Liste = Left(Liste,Len(Liste)-1)

SeekUserMemberInAd = Split(Liste,";")

'cn nom detaille dans l'ad

'displayName nom detaille dans les proprietes

'givenname prenom

'name nom detaille

'sn le nom

End Function

Active Directory - Lister les membres d un groupe
Public Function MembresGroupeAD(ByVal CheminGroupeAD)

'Version du 7 septembre 2006

'Utilisation

'UnTableau = MembresGroupeAD("LDAP://CN=MonGroupe,OU=MonOU,DC=fabrikam,DC=com")

'For Each UneLigne In UnTableau

'Msgbox UneLigne

'Next

Set objGroup = GetObject(CheminGroupeAD)

objGroup.GetInfo

MembresGroupeAD = objGroup.GetEx("member")

End Function

Active Directory - Lister les membres d un groupe V2
Dim PartieNomGroupe
Dim MonDomaine
Dim CheminFichier

PartieNomGroupe = Inputbox("Entrez une partie du nom du groupe recherche comme compta.","Nom groupe","compta")
MonDomaine = Inputbox("Entrez le domaine","Nom du domaine","DC=DomaineName,DC=COM")

CheminFichier = Trim(InputBox("Entrez le chemin complet du fichier de sortie","Chemin complet du fichier",""))

Call ExtraireMembresGroupe(PartieNomGroupe, MonDomaine, 1, CheminFichier)
Msgbox "Operation Terminee"

Public Function ExtraireMembresGroupe(ByVal PartieNomGroupe, ByVal NomDomaineLDAP, ByVal OutPutFormat, ByVal CheminFichier)

'Version du 17/12/2009 : add OutPutFormat and output file path

'Ex Version du 31/03/2008

'OutPutFormat values :

1 : GroupName, Full Domain Name, sAMAccountName, distinguishedName

2 : sAMAccountName, distinguishedName

'http://www.microsoft.com/technet/scriptcenter/guide/sas_ads_emwf.mspx

Dim NumeroErreur

Dim NumeroLigne

Dim GroupName

Dim PreviousGroupName

Dim objFSO

Dim objTextFile

'Déclaration des constantes

Const ForReading = 1

Const ForWritting = 2

Const ForAppending = 8

CheminScriptActuel = Left(wscript.scriptfullname,Len(wscript.scriptfullname)-Len(wscript.scriptname)-1)

CheminFichier = Trim(CheminFichier)

If Len(CheminFichier) = 0 Then

CheminFichier = CheminScriptActuel & "\ZZMonExtractDeGroupes.txt" 'Déclaration du chemin et du nom du fichier

End If

Set objFSO = CreateObject("Scripting.FileSystemObject")

Set objTextFile = objFSO.OpenTextFile(CheminFichier, ForWritting, True)

Set MaConnection = CreateObject("ADODB.Connection") 'New ADODB.Connection

MaConnection.Provider = "ADSDSOObject"

MaConnection.Open "ADs Provider"

Const DebugMode = 0 'A 1 pour debugger

If DebugMode = 1 Then

Wscript.Echo "Recherche de " & PartieNomGroupe & " dans " & MonDomaine

End IF

'Il faut ajouter un < après Execute("

Set MonRecordset = MaConnection.Execute("<LDAP://" & NomDomaineLDAP & ">;(&(objectCategory=group)(name=*" & PartieNomGroupe & "*));sAMAccountName,distinguishedName;subtree")

While MonRecordset.EOF = False

PreviousGroupName = ""

GroupName = ""

Lemplacement = ""

GroupName = MonRecordset.Fields(0).Value

Lemplacement = MonRecordset.Fields(1).Value

If DebugMode = 1 Then

Wscript.Echo "Traitement du groupe " & GroupName & " situe dans " & Lemplacement

End If

Set objGroup = GetObject("LDAP://" & Lemplacement)

objGroup.GetInfo

Err.Clear

On Error Resume Next

MembresGroupeAD = objGroup.GetEx("member")

NumeroErreur = Err.Number

On Error Goto 0

If NumeroErreur = 0 Then

On Error Resume Next

For Each UnMembre In MembresGroupeAD

Err.Clear

Set ObjMembre = GetObject("LDAP://" & UnMembre)

NumeroErreur = Err.Number

NumeroLigne = 0

If NumeroErreur = 0 Then

NumeroLigne = NumeroLigne + 1

'Wscript.Echo(" " & ObjMembre.Name)

'objTextFile.WriteLine(" " & ObjMembre.Name)

If Cstr(OutPutFormat) = "2" Then

'Si on attaque un nouveau groupe, on insere une ligne vierge

If Len(PreviousGroupName) > 0 Then

If GroupName <> PreviousGroupName Then

objTextFile.WriteLine ""

objTextFile.WriteLine "Group Name : " & GroupName

End If

Else 'Si c est le tout premier groupe qui est listé

objTextFile.WriteLine "Group Name : " & GroupName

End If

Select Case Cstr(OutPutFormat)

Case "1"

objTextFile.WriteLine(GroupName & VbTab & NomDomaineLDAP & VbTab & ObjMembre.sAMAccountName & VbTab & ObjMembre.DisplayName)

Case "2"

objTextFile.WriteLine(ObjMembre.sAMAccountName & VbTab & ObjMembre.DisplayName)

End Select

Set ObjMembre = Nothing

PreviousGroupName = GroupName

End If

On Error Goto 0

Set objGroup = Nothing

MonRecordset.MoveNext

'objTextFile.WriteLine("")

Wend

MaConnection.Close

objTextFile.Close 'Fermeture du fichier

Set objTextFile = Nothing

Set objFSO = Nothing

End Function

Active Directory - Lister tous les users d'un domaine AD
'http://www.microsoft.com/technet/scriptcenter/guide/sas_ads_emwf.mspx
Set MaConnection = CreateObject("ADODB.Connection") 'New ADODB.Connection
MaConnection.Provider = "ADSDSOObject"
MaConnection.Open "ADs Provider"

'Il faut ajouter un < après Execute("
Set MonRecordset = MaConnection.Execute("LDAP://DC=MonDomaine,DC=COM>;(objectCategory=User);sAMAccountName,cn;subtree")
While MonRecordset.EOF = False

Affichage = ""

For Compteur = 0 To (MonRecordset.Fields.Count - 1)

If IsArray(MonRecordset.Fields(Compteur).Value) = False Then

Affichage = Affichage & MonRecordset.Fields(Compteur).Value & ";"

End If

Wscript.Echo(Affichage)

MonRecordset.MoveNext
Wend

MaConnection.Close

Active Directory - Modifier en masse un attribut sur les objets de l AD
Public Sub ModifierEnMasseUnAttribut()

'Version du 8 fevrier 2007

Dim CheminLDAPDeLobjet

Dim MonObjUser

Dim MonRecordset

Set MaConnection = CreateObject("ADODB.Connection") 'New ADODB.Connection

MaConnection.Provider = "ADSDSOObject"

MaConnection.Open "ADs Provider"

Set MonRecordset = MaConnection.Execute("<LDAP://OU=MonOU,DC=MonDomaine,DC=Sub,DC=Com>;(objectCategory=User);sAMAccountName,cn,distinguishedName;subtree")

While MonRecordset.EOF = False

CheminLDAPDeLobjet = ""

CheminLDAPDeLobjet = MonRecordset.Fields("distinguishedName").Value

Set MonObjUser = GetObject("LDAP://" & CheminLDAPDeLobjet)

MonObjUser.Put "TelephoneNumber", "TestTelephone"

MonObjUser.SetInfo

Set MonObjUser = Nothing

MonRecordset.MoveNext

Wend

MaConnection.Close
End Sub

Active Directory - Modifier un chemin LDAP pour retirer le nom de serveur et le LDAP://
Public Function ModifierCheminLDAP(ByVal CheminLDAP, ByVal OptionNomServeur, ByVal TypeOperation)

'Version du 27 juin 2007

'Modifie un chemin LDAP

'Le chemin LDAP est mis à Nue. On retire le LDAP:// du debut ainsi que l eventuel nom du serveur

'Ensuite suivant les options demandées, on ajoute ou on remet en place ce qui est demandé

'Valeurs de TypeOperation. C est du binaire. les valeurs peuvent se cumuler

'1 : Mettre LDAP:// au debut

'2 : Mettre le nom du serveur

'4 : Mettre l objet de type CN. Si on ne met pas cette option CN=UnObjet,OU=UnEOU,DC=Robert,DC=COM devient OU=UnEOU,DC=Robert,DC=COM

'Anciennes operations

'1 : Retire le nom de serveur et le LDAP du debut

'2 : s'assure que cela commence bien par LDAP:// au debut

'Ex :

'LDAP://ZeZerveur/CN=UnObjet,OU=UnEOU,DC=Robert,DC=COM devient CN=UnObjet,OU=UnEOU,DC=Robert,DC=COM

'CN=UnObjet,OU=UnEOU,DC=Robert,DC=COM devient LDAP://CN=UnObjet,OU=UnEOU,DC=Robert,DC=COM

'Retirer

'Msgbox ModifierCheminLDAP("LDAP://ZeServeur/CN=UnObjet,OU=UnEOU,DC=Robert,DC=COM","",1)

'Ajouter

'Msgbox ModifierCheminLDAP("CN=UnObjet,OU=UneOU,DC=Robert,DC=COM","MonServeur",2)

Dim Position1

Dim Position2

Dim PositionEgale 'Position du premier caractere =

Dim PositionSlach 'Position du premier caractere /

Dim PositionVirgule 'Position d une virgule

Dim CaractereDeDepart 'Numero du caractere de depart pour une recherche

Dim MaVariable

Dim ChaineLDAPANue 'Contient la chaine LDAP à nue, soit sans le LDAP:// et sans le nom du serveur

Dim ChaineLDAPPresente 'Si la chaine LDAP:// est présente, alors cette variable passe à 1. sinon elle est a 0

Dim NomServeurPresent 'Si le nom du serveur est présent, alors cette variable passe à 1. sinon elle est a 0

Dim NomDuServeur 'Contient eventuellement le nom du serveur présent dans la chaine

Dim NomLeLobjet 'Contient le nom de l objet du chemin LDAP. Ainsi NomLeLobjet contiendra CN=UnObjet pour LDAP://CN=UnObjet,OU=UnEOU,DC=Robert,DC=COM

ModifierCheminLDAP = CheminLDAP

CheminLDAP = Trim(CheminLDAP)

ChaineLDAPANue = CheminLDAP

OptionNomServeur = Trim(OptionNomServeur)

If IsNumeric(TypeOperation) = True AND Len(ChaineLDAPANue) > 2 Then

'_______________________________________________________________
'Decomposition

'Detection de la chaine LDAP://

ChaineLDAPPresente = 0

If Left(Lcase(ChaineLDAPANue),7) = "ldap://" Then

ChaineLDAPPresente = 1

ChaineLDAPANue = Mid(ChaineLDAPANue,8)

End If

'Detection du nom du serveur

'LDAP://NomServeur/CN=ae/ff aeffacer,OU=Domaine,DC=COM

NomServeurPresent = 0

'En se basant sur une chaine LDAP dépourvue du LDAP:// du début

'Si un nom de serveur est présent, le caractère / est obligatoirement avant le premier =

PositionEgale = Instr(1,ChaineLDAPANue,"=")

PositionSlach = Instr(1,ChaineLDAPANue,"/")

'Si un / est présent

If PositionSlach > 0 Then

'Si le premier / est présent avant le premier =, alors un nom de serveur est présent

'NomServeur/CN=ae/ff aeffacer,OU=Domaine,DC=COM

If PositionSlach < PositionEgale Then

NomServeurPresent = 1

NomDuServeur = Left(ChaineLDAPANue,PositionSlach-1) 'On retient le nom du serveur

ChaineLDAPANue = Mid(ChaineLDAPANue,PositionSlach+1) 'On retire le nom du serveur

End If

End If 'If PositionSlach > 0 Then

'On isole l objet de type CN

PositionVirgule = Instr(1,ChaineLDAPANue,",")

If PositionVirgule > 0 Then

'Si le premier objet n'est pas un conteneur, on le retire

'Ainsi CN=UnObjet,OU=UnEOU,DC=Robert,DC=COM devient OU=UnEOU,DC=Robert,DC=COM

If Left(LCase(ChaineLDAPANue),2) = "cn" Then

NomLeLobjet = Left(ChaineLDAPANue,PositionVirgule-1)

ChaineLDAPANue = Mid(ChaineLDAPANue,PositionVirgule+1)

End If

End If 'If PositionVirgule > 0 Then

CheminLDAP = ChaineLDAPANue

'_______________________________________________________________
'Reconstitution

'4 : Mettre l'objet de type CN

If (TypeOperation AND 4) = 4 Then

CheminLDAP = NomLeLobjet & "," & CheminLDAP

End If 'If TypeOperation AND 4 = 4 Then

'2 : Mettre le nom du serveur

If (TypeOperation AND 2) = 2 Then

'Si on a indiqué un nom de serveur en paramètres

If Len(OptionNomServeur) > 0 Then

CheminLDAP = OptionNomServeur & "/" & CheminLDAP

Else 'Si il n y a pas de nom de serveur en paramètres mais qu il y en avait un dans le chemin LDAP de base, on le remet

If NomServeurPresent = 1 Then

CheminLDAP = NomDuServeur & "/" & CheminLDAP

End If 'If NomServeurPresent = 1 Then

End If 'If Len(OptionNomServeur) > 0 Then

End If 'If TypeOperation AND 2 = 2 Then

'1 : Mettre LDAP:// au debut

If (TypeOperation AND 1) = 1 Then

CheminLDAP = "LDAP://" & CheminLDAP

End If 'If TypeOperation AND 1 = 1 Then

'On retourne le résultat

ModifierCheminLDAP = CheminLDAP

End If 'If IsNumeric(TypeOperation) = True AND Len(ChaineLDAPANue) > 2 Then

End Function

Active Directory - parser des lignes () pour une requete LDAP
Public Function ParseLineForLDAPRequest(ByVal LineToParse, ByVal ParseCaracter)

'24 february version

'A line is parse with a special caracter

'for each line, a trim command is use

'then, each line is parse with a space

'Tipically, if in a <textarea></textarea> you have

'line1partA line1partB

' line2partA line1partB

'Result will be

'(|(&(displayName=*line1partA*)(displayName=*line1partB*))(&(displayName=*line2partA*)(displayName=**)(displayName=*line1partB*)))

Dim ArraySearchedUsers

Dim ArrayOneSearchedUser

Dim SearchedUsers

Dim SearchedUserString

Dim OneSearchedUser

Dim Part

ParseLineForLDAPRequest = ""

ArraySearchedUsers = Split(LineToParse, ParseCaracter)

SearchedUsers = ""

'Pour chaque utilisateur recherche

For Each OneSearchedUser In ArraySearchedUsers

OneSearchedUser = Trim(OneSearchedUser)

OneSearchedUser = Replace(OneSearchedUser, " ", " ")

ArrayOneSearchedUser = Split(OneSearchedUser, " ")

SearchedUserString = ""

For Each Part In ArrayOneSearchedUser

SearchedUserString = SearchedUserString & "(displayName=*" & Part & "*)"

SearchedUserString = "(&" & SearchedUserString & ")"

If Len(Replace(OneSearchedUser, " ","")) > 2 Then

SearchedUsers = SearchedUsers & SearchedUserString

End If

If Len(SearchedUsers) > 0 Then

ParseLineForLDAPRequest = "(|" & SearchedUsers & ")"

End If

End Function

Active Directory - Recherche et Extract de données dans l AD

Dim objFSO
Dim objTextFile
Dim CheminFichier
Dim CheminScriptActuel

Dim NombreResultats
Dim MonResultat
Dim UnResultat
Dim ChampsDemandes

'Déclaration des constantes
Const ForReading = 1
Const ForWritting = 2
Const ForAppending = 8

CheminScriptActuel = Left(wscript.scriptfullname,Len(wscript.scriptfullname)-Len(wscript.scriptname)-1)
CheminFichier = CheminScriptActuel & "\ZZMonFichier.txt" 'Déclaration du chemin et du nom du fichier
CheminFichier = Trim(InputBox("Entrez le chemin complet du fichier","Chemin complet du fichier",CheminFichier))

If Len(CheminFichier) > 0 Then

Set objFSO = CreateObject("Scripting.FileSystemObject")

Set objTextFile = objFSO.OpenTextFile(CheminFichier, ForWritting, True)

ChampsDemandes = "Name, Cn"

MonResultat = RechercheObjetDansAD("dup", "user", "DC=MonDomaine,DC=Net,DC=World", 0, ChampsDemandes, NombreResultats)

'Si on a un tableau en sortie, c est qu on a un resultat

If IsArray(MonResultat) = True Then

For Each UnResultat In MonResultat

objTextFile.WriteLine(UnResultat) 'On ecrit la date et l'heure dans le fichier

IlEst = UnResultat

'MsgBox UnResultat

End If

objTextFile.Close 'Fermeture du fichier

Set objTextFile = Nothing

Set objFSO = Nothing
Else

Msgbox "Operation annulee"
End If 'CheminFichier

Public Function RechercheObjetDansAD(ByVal NomObjet, ByVal TypeObjet, ByVal CheminUNCAD, ByVal RechercheExact, ByVal ChampsDemandes, ByRef NombreResultats)

'Version du 30 janvier 2009 - on recupere le vartype pour savoir si la valeur d un champ posera un probleme d interpretation ou non

'On recupere aussi les champs qui sont des tableaux

'Version du 28 janvier 2009 - Si NomObjet est vide, on retourne toutes les possibilités

'Version du 22 fevrier 2008 - Ajout en retour de la variable NombreResultats

'Version du 19 fevrier 2008

'Ex Version du 15 mai 2007

'Depend de la fonction TesterLectureTableau

'Retourne un tableau avec les chemin des différents Objets trouvés

'Retourne une chaine vide si rien trouve

'Valeurs possibles de RechercheExact :

' 0 pour retourne tout ce qui contient le nom demandé

' 1 pour que cela soit exactement la demande

'ChampsDemandes

' contient les différents champs demandés séparés par une virgule

' si vide, le champ distinguishedName est alors paramétré par défaut

'http://support.microsoft.com/kb/q187529/

'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/adsi/adsi/searching_with_activex_data_objects_ado.asp

Const ADS_SECURE_AUTHENTICATION = 1 'Requests secure authentication. When this flag is set, Active Directory will use Kerberos, and possibly NTLM, to authenticate the client.

Const ADS_USE_ENCRYPTION = 2 'Requires ADSI to use encryption for data exchange over the network.

Const ADS_SCOPE_SUBTREE = 2

Const UnSeparateurDeLigne = "é@("

Const UnSeparateurDeChamps = ";"

Dim objConnection

Dim objCommand

Dim objRecordSet

Dim Position

Dim NumeroErreur

Dim Continuer

Dim MesCommandes

Dim TableauCommandes

Dim UneLigneComplete

Dim UnChamp 'Nom d un des champ demandé

Dim MesResultats

Dim TableauResultats

Dim ResultatTemporaire

Dim UneCommandeText

Dim ResultatTrouve 'A 1 si on a trouve un resultat

Dim CompteurChamps

RechercheObjetDansAD = "" 'Valeur par défaut

ResultatTrouve = 0

'Test de la valeur RechercheExact

'Elle doit etre à 0 ou 1

If IsNumeric(RechercheExact) = False Then

RechercheExact = 1

Else

If (RechercheExact > 1) Or (RechercheExact < 0) Then

RechercheExact = 1

End If

ChampsDemandes = Trim(ChampsDemandes)

If Len(ChampsDemandes) = 0 Then

ChampsDemandes = "distinguishedName"

End If

Err.Clear

On Error Resume Next

'Creation des objets

Set objConnection = CreateObject("ADODB.Connection")

Set objCommand = CreateObject("ADODB.Command")

objConnection.Provider = "ADsDSOObject"

'objConnection.Properties("User ID") = ""

'objConnection.Properties("Password") = ""

objConnection.Properties("Encrypt Password") = True

objConnection.Properties("ADSI Flag") = 1 'ADS_SECURE_AUTHENTICATION

objConnection.Open "Active Directory Provider"

Set objCommand.ActiveConnection = objConnection

objCommand.Properties("Page Size") = 1000

objCommand.Properties("Searchscope") = 2 'ADS_SCOPE_SUBTREE

NumeroErreur = Err.Number

On Error GoTo 0

'Si la création des objets a fonctionné

If NumeroErreur = 0 Then

TableauOU = Split(CheminUNCAD, ";")

NombreTotal = 0

ResultatTrouve = 0

NombreResultats = 0

MesResultats = ""

'ResultatAMettreSousFormeDeTableau = ""

For Each UneOU In TableauOU

'Si NomObjet est sous la forme UnDomaine\UnNom, on retire ce qui est avant le \

Position = InStr(1, NomObjet, "\")

If Position > 0 Then

NomObjet = Mid(NomObjet, Position + 1)

End If

'Ajout eventuel de LDAP:// devant UneOU

If Left(LCase(UneOU), 7) <> "ldap://" Then

UneOU = "LDAP://" & UneOU

End If

'Suivant le type d'objet recherché

MesCommandes = ""

If Len(NomObjet) = 0 Then

MesCommandes = "SELECT " & ChampsDemandes & " FROM '" & UneOU & "' WHERE objectCategory='" & TypeObjet & "'"

Else

Select Case LCase(TypeObjet)

Case "group"

If RechercheExact = 1 Then

MesCommandes = "SELECT " & ChampsDemandes & " FROM '" & UneOU & "' WHERE objectCategory='Group' and Name='" & NomObjet & "'"

Else

MesCommandes = "SELECT " & ChampsDemandes & " FROM '" & UneOU & "' WHERE objectCategory='Group' and Name='*" & NomObjet & "*'"

End If

Case "user"

If RechercheExact = 1 Then

MesCommandes = "SELECT " & ChampsDemandes & " FROM '" & UneOU & "' WHERE objectCategory='User' and sAMAccountName='" & NomObjet & "'"

Else

MesCommandes = "SELECT " & ChampsDemandes & " FROM '" & UneOU & "' WHERE objectCategory='User' and sAMAccountName='*" & NomObjet & "*'"

End If

Case Else

If RechercheExact = 1 Then

MesCommandes = "SELECT " & ChampsDemandes & " FROM '" & UneOU & "' WHERE objectCategory='Group' and Name='" & NomObjet & "'"

MesCommandes = MesCommandes & ";" & "SELECT " & ChampsDemandes & " FROM '" & UneOU & "' WHERE objectCategory='User' and sAMAccountName='" & NomObjet & "'"

Else

MesCommandes = "SELECT " & ChampsDemandes & " FROM '" & UneOU & "' WHERE objectCategory='Group' and Name='*" & NomObjet & "*'"

MesCommandes = MesCommandes & ";" & "SELECT " & ChampsDemandes & " FROM '" & UneOU & "' WHERE objectCategory='User' and sAMAccountName='*" & NomObjet & "*'"

End If

End Select

End If

TableauCommandes = Split(MesCommandes, ";")

For Each UneCommandeText In TableauCommandes

objCommand.CommandText = UneCommandeText

'Execution de la requete

Err.Clear

On Error Resume Next

Set objRecordSet = objCommand.Execute

'Msgbox objRecordSet.Recordcount

NumeroErreur = Err.Number

On Error GoTo 0

'Si la requete a fonctionne

If NumeroErreur = 0 Then

'Si on a des reponses

NombreResultats = NombreResultats + objRecordSet.RecordCount 'Ajout du nombre de resultats trouves

If objRecordSet.RecordCount > 0 Then

ResultatTrouve = 1

If objRecordSet.BOF = False Then

objRecordSet.MoveFirst

End If

Do While objRecordSet.EOF = False

TableauChampsDemandes = Split(ChampsDemandes, ",")

UneLigneComplete = ""

'Pour tous les champs a recuperer

For CompteurChamps = 0 To UBound(TableauChampsDemandes)

'Recuperation d un champ

UnChamp = TableauChampsDemandes(CompteurChamps)

'Recuperation de la valeur du champ demande

Err.Clear

On Error Resume Next

ResultatdUnChamp = objRecordSet.Fields(UnChamp).Value

NumErreur = Err.Number

On Error GoTo 0

'Si il y a eu une erreur lors de la recuperation du champ demande

If NumErreur <> 0 Then

'On retourne un resultat vide

ResultatdUnChamp = ""

Else 'Si on a bien recupere une valeur pour le champ demande

'Recuperation du type de la variable

TypeVariable = VarType(ResultatdUnChamp)

'Si ce n est pas une variable a probleme

If (TypeVariable > 1) And (TypeVariable <> 9) And (TypeVariable <> 8204) Then 'Si la variable est initialisée, qu'elle n'est pas Null, que ce n'est pas un tableau avec des vbVariant

'On ne fait rien / On garde la valeur contenue dans ResultatdUnChamp

Else 'Si c est une variable a probleme

If TypeVariable = 8204 Then 'Si c est un tableau avec des vbVariant

'On tente quand meme de recuperer un resultat

ResultatTemporaire = ""

'If TesterLectureTableau(ResultatdUnChamp) = 1 Then

For Each LigneTableauVbVariant In ResultatdUnChamp

ResultatTemporaire = ResultatTemporaire & LigneTableauVbVariant

ResultatdUnChamp = Replace(ResultatTemporaire, ";", " ")

'Else

ResultatdUnChamp = ""

'End If

Else 'Si c est une variable a probleme et que ce n est pas un tableau

ResultatdUnChamp = ""

End If

End If 'If (TypeVariable > 1) And (TypeVariable <> 9) And (TypeVariable <> 8204) Then

End If 'If NumErreur <> 0 Then

UneLigneComplete = UneLigneComplete & ResultatdUnChamp & UnSeparateurDeChamps

Next 'For CompteurChamps = 0 To UBound(TableauChampsDemandes)

'Suppression du dernier séparateur

UneLigneComplete = Left(UneLigneComplete, Len(UneLigneComplete) - Len(UnSeparateurDeChamps))

'MesResultats = MesResultats & "LDAP://" & objRecordSet(CompteurChamps).Value & UnSeparateurDeLigne

MesResultats = MesResultats & UneLigneComplete & UnSeparateurDeLigne

objRecordSet.MoveNext

Loop 'Do While objRecordSet.EOF = False

End If 'If objRecordSet.Recordcount = 1 Then

End If 'If NumeroErreur = 0 Then

Next 'For Each UneCommandeText In TableauCommandes

Next 'For Each UneOU In TableauOU

If ResultatTrouve = 1 Then

'Suppression du dernier séparateur, si il existe

If Right(MesResultats, Len(UnSeparateurDeLigne)) = UnSeparateurDeLigne Then

MesResultats = Left(MesResultats, Len(MesResultats) - Len(UnSeparateurDeLigne))

End If

TableauResultats = Split(MesResultats, UnSeparateurDeLigne)

'On retourne le résultat

RechercheObjetDansAD = TableauResultats

Else 'Si il n y a pas de resultat, on retourne une chaine vide, ce qui fait qu on ne retourne pas de tableau

RechercheObjetDansAD = ""

End If

End If 'If NumeroErreur = 0 Then

'cn nom detaille dans l'ad

'displayName nom detaille dans les proprietes

'givenname prenom

'name nom detaille

'sn le nom

End Function

Active Directory - Renommer un groupe AD
Public Function RenommerGroupeAD(ByVal CheminLDAPGroupe, ByVal NouveauNom, ByRef ErreurDesc)

'Version du 25/09/2009

'En entrée :

'CheminLDAPGroupe : attend une chaine du type : CN=NomDuGroupe,OU=MonOU,Dc=Mon,DC=Domaine,DC=Com

'NouveauNom : nouveau nom du groupe. Exemple : LeNouveauNom

'ErreurDesc : Si il y a une erreur, cette variable retourne sa description

'Retourne 1 si le nom du groupe a été modifié

'Retourne 0 si non

Dim NumeroErreur

Dim objGroup

Dim ObjParent

Dim OldsAMAccountName

RenommerGroupeAD = 0

If (Len(CheminLDAPGroupe) > 0) Then

'Connexion au groupe

Err.Clear

On Error Resume Next

Set objGroup = GetObject("LDAP://" & CheminLDAPGroupe)

NumeroErreur = Err.Number

ErreurDesc = "Impossible de se connecter au groupe."

On Error GoTo 0

If (NumeroErreur = 0) Then

'Connexion à l 'objet parent du groupe

Err.Clear

On Error Resume Next

Set ObjParent = GetObject(objGroup.Parent)

NumeroErreur = Err.Number

ErreurDesc = "Impossible de se connecter a l objet parent du groupe."

On Error GoTo 0

If (NumeroErreur = 0) Then

'Renommage du sAMAccountName du groupe

Err.Clear

On Error Resume Next

OldsAMAccountName = objGroup.sAMAccountName

objGroup.sAMAccountName = NouveauNom

objGroup.SetInfo

NumeroErreur = Err.Number

ErreurDesc = "Impossible de renommer le sAMAccountName du groupe."

On Error GoTo 0

If (NumeroErreur = 0) Then

'Renommage du CN du groupe

Err.Clear

On Error Resume Next

Call ObjParent.MoveHere("LDAP://" & objGroup.distinguishedName, "cn=" & NouveauNom)

NumeroErreur = Err.Number

ErreurDesc = "Impossible de renommer le CN du groupe."

'ErreurDesc = "Impossible de renommer le CN du groupe : " & Err.Desciption

On Error GoTo 0

If (NumeroErreur = 0) Then

RenommerGroupeAD = 1

Else

'Si le renommage du CN n'a pas fonctionné, on remet l'ancien sAMAccountName

Err.Clear

On Error Resume Next

objGroup.sAMAccountName = OldsAMAccountName

objGroup.SetInfo

'Si la remise en place de l'ancien sAMAccountName n'a pas fonctionné, le sAMAccountName et le CN ne seront plus cohérent.

'Cependant c'est peu probable, car si on est ici, c'est qu'on a déjà réussit à renommer le sAMAccountName

On Error GoTo 0

End If 'If (NumeroErreur = 0) Then

Set ObjParent = Nothing

End If 'If (NumeroErreur = 0) Then

End If 'If (Len(CheminLDAPGroupe) > 0) Then

End Function

Active Directory - Requete LDAP sur un AD

Dim LDAPPath
Dim ADFilter
Dim ADFields
Dim AdLogin
Dim AdPassword
Dim SortField
Dim ResultLimit
Dim TableauResultRecherche
Dim UnResultat
Dim NumberOfResults
Dim ErrorMessage

LDAPPath = "LDAP://DC=OneDomain,DC=COM"
ADFilter = "(&(sAMAccountName=OneLogin)(objectCategory=person)(!(userAccountControl:1.2.840.113556.1.4.803:=2)))"
ADFields = "displayName, sAMAccountName, mail"
AdLogin = "OneDomain\Account"
AdPassword = "YourPassword"
SortField = "displayName"
ResultLimit = 1000

Call AdExtractRequest(LDAPPath, ADFilter, ADFields, AdLogin, AdPassword, SortField, ResultLimit, TableauResultRecherche, NumberOfResults, ErrorMessage, 0)
If NumberOfResults > 0 Then

For Each UnResultat In TableauResultRecherche

Wscript.echo UnResultat(0) & " " & UnResultat(1)

Next
End If

Public Function AdExtractRequest(ByVal LDAPPath, ByVal ADFilter, ByVal ADFields, ByVal AdLogin, ByVal AdPassword, ByVal SortField, ByVal ResultLimit, ByRef MonTableauDynamiquePourResultat, ByRef NumberOfResults, ByRef ErrorMessage, ByVal DebugMode)

'25 february version

'20 february version

'18 february version

'AdExtractRequest

Return an array if there is a result

Return -1 if there is an issue

'ADFilter

Example

ADFilter = "(&(objectCategory=person)(mail=*))"

'ADFields

Example

ADFields = "name,displayName,objectClass,mail"

'AdLogin and AdPassword

if login is NULL, current user is used

'SortField

Field to sort

'ResultLimit

Max number of results

'MonTableauDynamiquePourResultat

Array with results

'NumberOfResults

Return the number of results

'ErrorMessage

return an error message if something wrong

'DebugMode : if greater than 0, debug mode on

Const ADS_SECURE_AUTHENTICATION = 1

Const ADS_USE_ENCRYPTION = 2

Const ADS_SCOPE_SUBTREE = 2

Const FirstLineIsColumnName = 0

'Good link :

'http://technet.microsoft.com/en-us/library/ee692830.aspx

'ADSI Flag

'A set of flags that specify the binding authentication options. The default is 0. Flags commonly used in connecting to Active Directory include (values are shown in parentheses):

'ADS_SECURE_AUTHENTICATION (1). Requests secure authentication.

'ADS_USE_ENCRYPTION (2). Requires ADSI to use encryption for data exchange over the network.

'ADS_USE_SIGNING (40). Verifies data integrity. The ADS_SECURE_AUTHENTICATION flag must also be set to use signing.

'ADS_USE_SEALING (80). Encrypts data using Kerberos. The ADS_SECURE_AUTHENTICATION flag must also be set to use sealing.

Dim ADStringParameters

Dim ErrorNumber

Dim objConnection

Dim objCommand

'Dim MonTableauDynamiquePourResultat()

Dim TableauNbrLignes

Dim CompteurChamps

Dim CompteurLignes

Dim TableauResultatUneLigne

Dim IlYaPlusieursColonnes

'Par défaut, on efface et on redimensionne le tableau

Redim MonTableauDynamiquePourResultat(0)

ADStringParameters = ADFilter & ";" & ADFields & ";subtree"

ErrorMessage = "Begin of function"

AdExtractRequest = "-1" 'Default value

NumberOfResults = 0

If DebugMode > 0 Then

Wscript.Echo "LDAP path : " & LDAPPath

Wscript.Echo "Filter : " & Filter

Wscript.Echo "Parameters : " & ADStringParameters

End If

'These command don t permit a "Set MonRecordset = objOU.Execute" method

'Set objDSO = GetObject("LDAP:")

'Set objOU = objDSO.OpenDSObject(LDAPPath, AdLogin, AdPassword, ADS_SECURE_AUTHENTICATION)

If (Len(LDAPPath) > 0) And (Len(ADFilter) > 0) And (Len(ADFields) > 0) Then

Set objConnection = CreateObject("ADODB.Connection") 'New ADODB.Connection

Set objCommand = CreateObject("ADODB.Command")

objConnection.Provider = "ADSDSOObject"

'If a login is specified

If Len(AdLogin) > 0 Then

objConnection.Properties("User ID") = AdLogin

objConnection.Properties("Password") = AdPassword

'objConnection.Properties("Encrypt Password") = True

'objConnection.Properties("ADSI Flag") = 1

End If

ErrorMessage = "Connection test"

If DebugMode > 0 Then

Wscript.Echo ErrorMessage

End If

Err.Clear

On Error Resume Next

'objConnection.Open "ADs Provider"

objConnection.Open "Active Directory Provider"

ErrorNumber = Err.number

On Error Goto 0

If (ErrorNumber = 0) Then

ErrorMessage = "Connected"

If DebugMode > 0 Then

Wscript.Echo ErrorMessage

End If

Set objCommand.ActiveConnection = objConnection

'objCommand.Properties("Page Size") = 1000

If IsNumeric(ResultLimit) = True Then

objCommand.Properties("Size Limit") = ResultLimit

End If

'objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE

objCommand.Properties("Sort On") = SortField '"DisplayName"

'objCommand.CommandText = "SELECT Name FROM 'LDAP://dc=fabrikam,dc=com' WHERE objectCategory='user'"

ErrorMessage = "Execute request"

If DebugMode > 0 Then

Wscript.Echo ErrorMessage

End If

Err.Clear

On Error Resume Next

'Set MonRecordset = objConnection.Execute("<" & LDAPPath & ">;(&(objectCategory=person)(objectClass=User)(!(userAccountControl:1.2.840.113556.1.4.803:=2)));name,displayName,objectClass,mail;subtree")

'Set MonRecordset = objCommand.Execute("<" & LDAPPath & ">;" & ADStringParameters)

objCommand.CommandText = "<" & LDAPPath & ">;" & ADFilter & ";" & ADFields & ";subtree"

Set MonRecordset = objCommand.Execute

'Set MonRecordset = objConnection.Execute("<" & LDAPPath & ">;" & ADStringParameters)

ErrorNumber = Err.number

On Error Goto 0

If (ErrorNumber = 0) Then

CompteurLignes = 0

'This command doesnt work : MonRecordset.RecordCount

If MonRecordset.BOF = False Then MonRecordset.MoveFirst

TableauNbrLignes = 0

While Not MonRecordset.EOF

TableauNbrLignes = TableauNbrLignes + 1

MonRecordset.MoveNext

Wend

If DebugMode > 0 Then

'Response.Write("Number of results : " & TableauNbrLignes & "<BR>")

End If

Redim TableauResultatUneLigne(MonRecordset.fields.Count - 1)

If MonRecordset.fields.Count > 1 Then

IlYaPlusieursColonnes = 1

Else

IlYaPlusieursColonnes = 0

End If

'Definition de la taille du tableau qui va contenir le resultat

'Ne pas perdre de vue que les tableaux sont en base 0, c'est pour cela que l'on retire 1 au resultat final

'Si on a des resultats

If TableauNbrLignes > 0 Then

TableauNbrLignes = TableauNbrLignes -1 'Cause the array is based 0

If DebugMode > 0 Then

'Wscript.echo("TableauNbrLignes : " & TableauNbrLignes & " (de base 0)")

End If

If FirstLineIsColumnName = 1 Then

TableauNbrLignes = TableauNbrLignes + 1

If DebugMode > 0 Then

Wscript.echo("TableauNbrLignes : ajout d une ligne pour le nom des colonnes : " & TableauNbrLignes & "<BR>")

End If

Redim MonTableauDynamiquePourResultat(TableauNbrLignes)

If MonRecordset.BOF = False Then MonRecordset.MoveFirst

'Si on demande a mettre le nom des colonnes en premiere ligne

If FirstLineIsColumnName = 1 Then

ErrorMessage = "Traitement du nom des colonnes"

If DebugMode > 0 Then

Wscript.Echo ErrorMessage

End If

For CompteurChamps = 0 To MonRecordset.fields.Count - 1

TableauResultatUneLigne(CompteurChamps) = MonRecordset.fields(CompteurChamps).Name

MonTableauDynamiquePourResultat(CompteurLignes) = TableauResultatUneLigne

CompteurLignes = CompteurLignes + 1

ErrorMessage = "Nom des colonnes stockée"

If DebugMode = 1 Then

Wscript.Echo ErrorMessage

End If

End If 'If FirstLineIsColumnName = 1 Then

ErrorMessage = "Requete result"

If DebugMode > 0 Then

Wscript.Echo ErrorMessage

End If

While Not MonRecordset.EOF

For CompteurChamps = 0 To MonRecordset.fields.Count - 1

TableauResultatUneLigne(CompteurChamps) = MonRecordset.fields(CompteurChamps).Value

'Response.Write("une reponse : " & MonRecordset.fields(CompteurChamps).Value & "<BR>")

'Response.Write("TableauResultatUneLigne IsArray : " & IsArray(TableauResultatUneLigne) & "<BR>")

MonTableauDynamiquePourResultat(CompteurLignes) = TableauResultatUneLigne

'Response.Write("MonTableauDynamiquePourResultat IsArray : " & IsArray(MonTableauDynamiquePourResultat) & "<BR>")

If DebugMode > 0 Then

'wscript.echo MonRecordset.Fields("displayName") & " " & MonRecordset.Fields("company") & " " & MonRecordset.Fields("mail")

wscript.echo MonRecordset.Fields("displayName")

'wscript.echo vbtab & MonRecordset.Fields("company")

wscript.echo vbtab & MonRecordset.Fields("mail")

End If

MonRecordset.MoveNext

CompteurLignes = CompteurLignes + 1

NumberOfResults = NumberOfResults + 1

ErrorMessage = "Line number : " & CompteurLignes

Wend

Set MonRecordset = Nothing

'We return the array result to the function

AdExtractRequest = MonTableauDynamiquePourResultat

Else 'If there is no results

ErrorMessage = "there is no results"

If DebugMode > 0 Then

Wscript.Echo ErrorMessage

End If

End If 'If TableauNbrLignes > 0 Then

Else

ErrorMessage = "Error during LDAP execution request. Error number " & ErrorNumber & ". " & Err.Description

If DebugMode > 0 Then

Wscript.Echo ErrorMessage

End If

End If 'If (ErrorNumber = 0) Then

Else

ErrorMessage = "Error during connection to " & LDAPPath & ". Error number " & ErrorNumber & ". " & Err.Description

If DebugMode > 0 Then

Wscript.Echo ErrorMessage

End If

End If 'If (ErrorNumber = 0) Then

Set objCommand = Nothing

Set objConnection = Nothing

Else

ErrorMessage = "Missing a parameter"

End If 'If (Len(LDAPPath) > 0) And (Len(ADFilter) > 0) And (Len(ADFields) > 0) Then

AdExtractRequest = ""

End Function

Active Directory - Requete SQL sur un domaine AD
CheminScriptActuel = Left(wscript.scriptfullname,Len(wscript.scriptfullname)-Len(wscript.scriptname)-1)
CheminFichierReponse = CheminScriptActuel & "\" & "ZZExportAD.txt"

Call Start(CheminFichierReponse)

Public Sub Start(ByVal CheminFichierReponse)

'Version du 26 avril 2005

'http://support.microsoft.com/kb/q187529/

'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/adsi/adsi/searching_with_activex_data_objects_ado.asp

Const ForReading = 1

Const ForWriting = 2

Const ForAppending = 8

Set objFSO = CreateObject("Scripting.FileSystemObject")

Set objTextFile = objFSO.OpenTextFile(CheminFichierReponse, ForWriting, True)

Set MaConnection = CreateObject("ADODB.Connection") 'New ADODB.Connection

MaConnection.Provider = "ADSDSOObject"

'MaConnection.Properties("User ID") = stUser

'MaConnection.Properties("Password") = stPass

'MaConnection.Properties("Encrypt Password") = True

MaConnection.Open "ADs Provider"

Set MonRecordset = MaConnection.Execute("<LDAP://DC=MonDomaine,DC=Com>;(objectCategory=User);sAMAccountName,cn,description,profilePath,homeDrive,homeDirectory,lastLogon,lastLogoff,whenChanged,scriptPath;subtree") '

NombreTotal = 0

NombreModifAccent = 0

'On affichage le nom des champs

Affichage = "Domaine;"

For Compteur=0 To MonRecordset.Fields.count-1

Affichage = Affichage & MonRecordset.fields(Compteur).name & ";"

Affichage = Affichage & "DateInfo;"

objTextFile.WriteLine (Affichage)

'On Error Resume Next

While MonRecordset.EOF = False

NombreTotal = NombreTotal + 1

Affichage = ""

'On ecrit la valeur de chaque champs du Recordset

For Compteur = 0 To (MonRecordset.Fields.Count - 1)

TypeVariable = VarType(MonRecordset.Fields(Compteur).Value)

If (TypeVariable > 1) AND (TypeVariable <> 9) AND (TypeVariable < 8193) Then 'Si la variable est initialisée, qu'elle n'est pas Null et qu'elle n'est pas sous la forme d'un objet ou autre chose bizarre

'Wscript.Echo "Le type de " & MonRecordset.Fields(Compteur).name & " est " & VarType(MonRecordset.Fields(Compteur).Value)

If IsArray(MonRecordset.Fields(Compteur).Value) = False Then

Affichage = Affichage & MonRecordset.Fields(Compteur).Value '& " (" & MonRecordset.Fields(Compteur).name & ")"

Else

Resultat = MonRecordset.Fields(Compteur).Value

'Affichage = Affichage & "Tableau "

Affichage = Affichage & Resultat(0)

End If

End If '(TypeVariable > 1) AND (TypeVariable <> 9)

'On inscrit un point virgule pour marquer la fin du champ

Affichage = Affichage & ";"

'On ajoute la date de l'info

Affichage = Affichage & Now & ";"

objTextFile.WriteLine (Affichage)

MonRecordset.MoveNext

Wend

objTextFile.Close

MaConnection.Close

Set objTextFile = Nothing

Set objFSO = Nothing

Wscript.Echo NombreTotal & " entrées"

'cn nom detaille dans l'ad

'displayName nom detaille dans les proprietes

'givenname prenom

'name nom detaille

'sn le nom

End Sub

Active Directory - Supprimer un user AD d un groupe AD
Public Function DeleteUserToGroupAD(ByVal UserAD, ByVal GroupeAD)

'Version du 23 octobre 2006

'Retourne 0 si echec

'Retourne 1 si Ok ou déjà absent

'L erreur -2147019886 dignifie que le compte fait deja partie du groupe

Const ADS_PROPERTY_APPEND = 3

Const ADS_PROPERTY_DELETE = 4

Dim Position

Dim NumeroErreur

DeleteUserToGroupAD = 0 'Par défaut on considère un echec

'Si le chemin du groupe ne commence pas par LDAP on l'ajoute

Position = Instr(1,Lcase(GroupeAD),"ldap://")

If Position = 0 Then

GroupeAD = "LDAP://" & GroupeAD

End If

'On retire le LDAP:// du debut du chemin du user

If Left(Lcase(UserAD),7) = "ldap://" Then

UserAD = Mid(UserAD,8)

End If

'On retire le nom du serveur si il a été précisé

Position = Instr(1,UserAD,"/")

If Position > 0 Then

UserAD = Mid(UserAD,Position + 1)

End If

Set objGroup = GetObject(GroupeAD)

Err.Clear

On Error Resume Next

objGroup.PutEx ADS_PROPERTY_DELETE, "member", Array(UserAD)

objGroup.SetInfo

NumeroErreur = Err.number

Set objGroup = Nothing

On Error Goto 0

If (NumeroErreur = 0) Or (NumeroErreur = -2147019886) Then

DeleteUserToGroupAD = 1

End If

End Function

Active Directory - Trouver le chemin d un objet
Public Function SeekCheminObjetAD(ByVal NomObjet, ByVal TypeObjet, ByVal CheminUNCAD, ByVal LoginAD, ByVal MotDePasseAD, ByRef MessageErreur)

'Version du 20 octobre 2008 : Possibilite de mettre un login/mdp AD

'Ex Version du 19 fevrier 2008

'Ex Version du 15 mai 2007

'Dim CheminObjetAD

'CheminObjetAD = SeekCheminObjetAD("MonNomDeGroupe", "Group", "LDAP://MonNomDeServeurAD/DC=ROBERT,DC=COM", "", "")

'CheminObjetAD = SeekCheminObjetAD("MonDomaine\MonCompte", "User", "LDAP://MonNomDeServeurAD/DC=ROBERT,DC=COM", "", "")

'Retourne le chemin de l'objet si 1 seul et unique résultat

'Retourne une chaine vide si rien trouve

'La variable MessageErreur retourne la description d une erreur eventuelle

'Si l objet recherche est un groupe, on recherche par rapport au champ Name

'Si l objet recherche est un user, on recherche par rapport au champ sAMAccountName

'Si l objet recherche n'est pas precise, on fait 2 recherches, une par champ

'http://support.microsoft.com/kb/q187529/

'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/adsi/adsi/searching_with_activex_data_objects_ado.asp

Const ADS_SECURE_AUTHENTICATION = 1 'Requests secure authentication. When this flag is set, Active Directory will use Kerberos, and possibly NTLM, to authenticate the client.

Const ADS_USE_ENCRYPTION = 2 'Requires ADSI to use encryption for data exchange over the network.

Const ADS_SCOPE_SUBTREE = 2

Dim objConnection

Dim objCommand

Dim objRecordSet

Dim Position

Dim NumeroErreur

Dim Continuer

Dim MesCommandes

Dim TableauCommandes

Dim UneCommandeText

Dim ResultatTrouve 'A 1 si on a trouve un resultat

SeekCheminObjetAD = "" 'Valeur par défaut

MessageErreur = "" 'Valeur par défaut

ResultatTrouve = 0

Position = InStr(1, NomObjet, "\")

If Position > 0 Then

NomObjet = Mid(NomObjet, Position + 1)

End If

If Left(LCase(CheminUNCAD), 7) <> "ldap://" Then

CheminUNCAD = "LDAP://" & CheminUNCAD

End If

Err.Clear

On Error Resume Next

'Creation des objets

Set objConnection = CreateObject("ADODB.Connection")

Set objCommand = CreateObject("ADODB.Command")

objConnection.Provider = "ADsDSOObject"

If Len(LoginAD) > 0 Then

objConnection.Properties("User ID") = LoginAD

objConnection.Properties("Password") = MotDePasseAD

End If 'If Len(LoginAD) > 0 Then

objConnection.Properties("Encrypt Password") = True

objConnection.Properties("ADSI Flag") = 1 'ADS_SECURE_AUTHENTICATION

objConnection.Open "Active Directory Provider"

Set objCommand.ActiveConnection = objConnection

objCommand.Properties("Page Size") = 1000

objCommand.Properties("Searchscope") = 2 'ADS_SCOPE_SUBTREE

NumeroErreur = Err.Number

On Error GoTo 0

'Si la création des objets a fonctionné

If NumeroErreur = 0 Then

'Suivant le type d'objet recherché

MesCommandes = ""

Select Case LCase(TypeObjet)

Case "group"

MesCommandes = "SELECT distinguishedName FROM '" & CheminUNCAD & "' WHERE objectCategory='Group' and Name='" & NomObjet & "'"

Case "user"

MesCommandes = "SELECT distinguishedName FROM '" & CheminUNCAD & "' WHERE objectCategory='User' and sAMAccountName='" & NomObjet & "'"

Case Else

MesCommandes = "SELECT distinguishedName FROM '" & CheminUNCAD & "' WHERE objectCategory='Group' and Name='" & NomObjet & "'"

MesCommandes = MesCommandes & ";" & "SELECT distinguishedName FROM '" & CheminUNCAD & "' WHERE objectCategory='User' and sAMAccountName='" & NomObjet & "'"

End Select

TableauCommandes = Split(MesCommandes, ";")

For Each UneCommandeText In TableauCommandes

If ResultatTrouve = 0 Then

objCommand.CommandText = UneCommandeText

'Execution de la requete

Err.Clear

On Error Resume Next

Set objRecordSet = objCommand.Execute

'Msgbox objRecordSet.Recordcount

NumeroErreur = Err.Number

On Error GoTo 0

'Si la requete a fonctionne

If NumeroErreur = 0 Then

'Si on a bien une seule réponse

If objRecordSet.RecordCount = 1 Then

ResultatTrouve = 1

If objRecordSet.BOF = False Then

objRecordSet.MoveFirst

End If

'Msgbox objRecordSet.Fields("Name").Value

SeekCheminObjetAD = "LDAP://" & objRecordSet(0).Value

End If 'If objRecordSet.Recordcount = 1 Then

Else

MessageErreur = "Erreur num " & Err.Number & " : " & Err.Description

End If 'If NumeroErreur = 0 Then

End If 'If ResultatTrouve = 0 Then

Next 'For Each UneCommandeText In TableauCommandes

Else

MessageErreur = "Erreur num " & Err.Number & " : " & Err.Description

End If 'If NumeroErreur = 0 Then

'cn nom detaille dans l'ad

'displayName nom detaille dans les proprietes

'givenname prenom

'name nom detaille

'sn le nom

End Function

Active Directory - Utiliser un compte différent pour lancer une requete SQL sur l'AD
Const ADS_SCOPE_SUBTREE = 2

Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"

objConnection.Properties("User ID") = "fabrikam\kenmyer"
objConnection.Properties("Password") = "A2sXrco1Fq1#om!"
objConnection.Properties("Encrypt Password") = TRUE
objConnection.Properties("ADSI Flag") = 3

objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection

objCommand.Properties("Page Size") = 1000
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE

objCommand.CommandText = _
"SELECT Name FROM 'LDAP://DC=fabrikam,DC=com' WHERE " _
& "objectCategory='user'"
Set objRecordSet = objCommand.Execute

objRecordSet.MoveFirst
Do Until objRecordSet.EOF
Wscript.Echo objRecordSet.Fields("Name").Value
objRecordSet.MoveNext
Loop

Active Directory - Utiliser un compte différent pour se connecter à l'AD
Const ADS_SECURE_AUTHENTICATION = 1 'Requests secure authentication. When this flag is set, Active Directory will use Kerberos, and possibly NTLM, to authenticate the client.
Const ADS_USE_ENCRYPTION = 2 'Requires ADSI to use encryption for data exchange over the network.

Dim CheminLDAP 'Chemin de l'objet AD
Dim NomServeurAD
Dim Login
Dim MotDePasse
Dim objNetwork

CheminLDAP = InputBox("Entrez le nom chemin de l'objet AD. Exemple : " & VbCrLf & "CN=Robert,Ou=Users,DC=ZeSite,DC=COM","Objet","CN=objet user,OU=Nom Ou,DC=Nom Domaine")
NomServeurAD = InputBox("Nom du serveur AD","Nom Serveur AD","NomDuServeur")

Set objNetwork = CreateObject("Wscript.Network")
Login = objNetwork.UserDomain & "\" & objNetwork.UserName
Set objNetwork = Nothing

Login = InputBox("Entrez le domaine\login à utiliser","Login",Login)
MotDePasse = InputBox("Entrez le mot de passe","Mot de passe","")

CheminLDAP = "LDAP://" & NomServeurAD & "/" & CheminLDAP

Set objDSO = GetObject("LDAP:")
'Set objUser = objDSO.OpenDSObject(CheminLDAP, Login, MotDePasse, ADS_USE_ENCRYPTION OR ADS_SECURE_AUTHENTICATION) 'Le cryptage ne fonctionne pas forcement. A tester
Set objUser = objDSO.OpenDSObject(CheminLDAP, Login, MotDePasse, ADS_SECURE_AUTHENTICATION)
Wscript.Echo "Etat activation : " & objUser.AccountDisabled

Set objUser = Nothing
Set objDSO = Nothing

Active Directory - Verifier si un chemin est bien au format LDAP
Public Function IsFormatLDAP(ByVal MonCheminAVerifier, ByRef NomServeur, ByRef CheminSansLDAPNiServeur)

'Version du 27 juin 2007

'Retourne 1 si le chemin entré est au format LDAP, sinon retourne 0

'Retourne des valeurs optionnelles si le chemin est bien de type LDAP, comme :

'NomServeur : le nom du serveur si il a été indiqué dans le chemin LDAP

'CheminSansLDAPNiServeur : un chemin LDAP sans LDAP:// au début si le nom du serveur si il a été spécifié

Dim Position

Dim TableauObjetsLDAP

Dim UnObjetLDAP

Dim ObjetLDAPTrouve

Const ListeObjetsLDAP = "CN;OU;DC"

IsFormatLDAP = 0

ObjetLDAPTrouve = 0

NomServeur = ""

CheminSansLDAPNiServeur = ""

If Len(MonCheminAVerifier) > 0 Then

Position = InStr(1, MonCheminAVerifier, "\")

'Un chemin LDAP ne peut contenir de caractère \

If Position = 0 Then

If Left(LCase(MonCheminAVerifier), 7) = "ldap://" Then

MonCheminAVerifier = Mid(MonCheminAVerifier, 8)

End If

'Si le chemin LDAP contient un caractère / après épuration du ldap://, c est que l on a precise un nom de serveur

Position = InStr(1, "/", MonCheminAVerifier)

If Position > 0 Then

NomServeur = Left(MonCheminAVerifier, Position - 1)

MonCheminAVerifier = Mid(MonCheminAVerifier, Position + 1)

End If

'On retourne le chemin LDAP sans LDAP:// si nom de serveur

CheminSansLDAPNiServeur = MonCheminAVerifier

'Un chemin LDAP contient au moins un signe = précédé d un type d objet comme OU ou DC

TableauObjetsLDAP = Split(ListeObjetsLDAP, ";")

For Each UnObjetLDAP In TableauObjetsLDAP

Position = InStr(1, MonCheminAVerifier, UnObjetLDAP & "=")

If Position > 0 Then

ObjetLDAPTrouve = 1

Exit For

End If

If ObjetLDAPTrouve = 1 Then

IsFormatLDAP = 1

End If

End If 'If Position = 0 Then

End If 'If Len(MonCheminAVerifier) > 0 Then

End Function

AUTRE - Afficher le chemin du repertoire System32
Const SYSTEM32 = &H25&
Dim CheminSystem32

Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(SYSTEM32)
Set objFolderItem = objFolder.Self
CheminSystem32 = objFolderItem.Path
Wscript.Echo CheminSystem32

Set objFolderItem = Nothing
Set objFolder = Nothing
Set objShell = Nothing

AUTRE - Afficher les journaux d evenements
'Trouve sur
'http://www.microsoft.com/technet/scriptcenter/guide/sas_log_pnzm.mspx
strComputer = "."
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colLoggedEvents = objWMIService.ExecQuery("SELECT * FROM Win32_NTLogEvent WHERE Logfile = 'System'")
For Each objEvent in colLoggedEvents

Wscript.Echo "Category: " & objEvent.Category

Wscript.Echo "Computer Name: " & objEvent.ComputerName

Wscript.Echo "Event Code: " & objEvent.EventCode

Wscript.Echo "Message: " & objEvent.Message

Wscript.Echo "Record Number: " & objEvent.RecordNumber

Wscript.Echo "Source Name: " & objEvent.SourceName

Wscript.Echo "Time Written: " & objEvent.TimeWritten

Wscript.Echo "Event Type: " & objEvent.Type

Wscript.Echo "User: " & objEvent.User
Next

AUTRE - Afficher et filtrer les journaux d evenements (date heure type etc)
Dim TotalEventCounts
Dim ReturnStatus
Dim CheckEventLogStatus

CheckEventLogStatus = CheckEventLog("MyNameServer", "Application", "SQLSERVERAGENT", "Type <> 'Information'", 1, ReturnStatus, TotalEventCounts)

'Message de retour en fonction du retour de la fonction
If (TotalEventCounts = 0) And (TotalEventCounts = 0) Then

msg = "All is right"
Else

threshold_critical = Args("critical")

msg = CheckEventLogStatus
End If

Public Function CheckEventLog(ByVal ComputerNameList, ByVal LogName, ByVal SourceName, ByVal FilterComplement, ByVal DayDuration, ByRef ReturnStatus, ByRef TotalEventCounts)

'11 juin 2010 Version

'Need to run on 2003 or XP

'ReturnStatus :

0 : all is right

1 : warning

2 : critical

Dim OneComputerName
Dim MyQuery
Dim MyQueryFilter

Dim EventCounts

Dim OneEventCode
Dim OneEventMessage
Dim OneEventTimeinfo

Const CONVERT_TO_LOCAL_TIME = True

'Default values

CheckEventLog = "Start CheckEventLog Function"

TotalEventCounts = 0

ReturnStatus = 0

Set dtmStartDate = CreateObject("WbemScripting.SWbemDateTime")
Set dtmEndDate = CreateObject("WbemScripting.SWbemDateTime")

DateToCheck = Now() 'CDate("26/03/2010")
dtmStartDate.SetVarDate DateAdd("d", -DayDuration, DateToCheck), CONVERT_TO_LOCAL_TIME
dtmEndDate.SetVarDate DateToCheck, CONVERT_TO_LOCAL_TIME

MyQuery = "Select * from Win32_NTLogEvent"
MyQueryFilter = "Where TimeWritten >= '" & dtmStartDate & "' and TimeWritten < '" & dtmEndDate & "'"

Select Case LCase(LogName)
Case "application"
MyQueryFilter = MyQueryFilter & " and Logfile = 'Application'"
End Select

If Len(SourceName) > 0 Then
MyQueryFilter = MyQueryFilter & " and SourceName = '" & SourceName & "'"
End If

If Len(FilterComplement) > 0 Then
MyQueryFilter = MyQueryFilter & " and " & FilterComplement
End If

'Finalize the Query
MyQuery = MyQuery & " " & MyQueryFilter

CheckEventLog = "No event(s) found" 'Default value
For Each OneComputerName In Split(ComputerNameList, ";")
OneComputerName = Trim(OneComputerName)
Err.Clear()
On Error Resume Next
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & OneComputerName & "\root\cimv2")
If (Err.number = 0) Then

On Error Goto 0

Err.Clear()

On Error Resume Next

Set colLoggedEvents = objWMIService.ExecQuery(MyQuery)

If (Err.number = 0) Then

On Error Goto 0

EventCounts = colLoggedEvents.Count

If EventCounts > 0 Then

TotalEventCounts = TotalEventCounts + EventCounts

CheckEventLog = CheckEventLog & OneComputerName & ":" & EventCounts & " event(s) found(s)"

For Each OneEvent In colLoggedEvents

OneEventCode = OneEvent.EventCode & " " & OneEvent.SourceName & " " & OneEvent.Type

OneEventMessage = OneEvent.Message

OneEventTimeinfo = OneEvent.TimeWritten

CheckEventLog = CheckEventLog & Left(OneEventMessage,15)

End If

Set colLoggedEvents = Nothing

Else 'If we can t send a request

CheckEventLog = OneComputerName & " : can t send a request"

ReturnStatus = 2

End If 'If (Err.number = 0) Then

Else 'If we can t connect to the computer

CheckEventLog = OneComputerName & " : can t connect"

ReturnStatus = 2
End If

Set objWMIService = Nothing

Next

'objEvent.Category
'objEvent.ComputerName
'objEvent.EventCode
'objEvent.Message
'objEvent.RecordNumber
'objEvent.SourceName
'objEvent.TimeWritten
'objEvent.Type
'objEvent.User

End Function

AUTRE - Ajustement dynamique du TimeOut durant les longues boucles en ASP
'Déclaration des variables
Dim TimeOutOriginal
Dim TimeOutDeBase
Dim DateDepart
Dim DateFin

'Cette partie de code est à placer avant le début d'une boucle, par exemple juste avant une boucle for qui peut être très longue à executer
'On note le TimeOut de base et l'heure de lancement de la procédure
TimeOutOriginal = Server.ScriptTimeout
TimeOutDeBase = TimeOutOriginal + 60 'On ajoute par défaut 1 minutes au TimeOut
Server.ScriptTimeout = TimeOutDeBase
DateDepart = Now

'Cette partie est à placer juste avant la fin de la boucle, par exemple avant un Next d'une boucle FOR
'Ajustement du TimeOut
DateFin = Now
Difference = DateDiff("s",DateDepart,DateFin,2,1) 'On calcul le nombre de secondes passées depuis le lancement de la fonction
Server.ScriptTimeout = (TimeOutDeBase + Difference)

AUTRE - Changer la casse d 'un nom/Prénom
Public Function CasseNomPrenom(ByVal MonNomPrenom, ByVal Mode)

'Version du 9 janvier 2008

'Ex Version du 11 dec 2006

'Change la casse d'un nom ou prenom

'Passe ce qui suit un caractère de séparation en majuscule.

'Le reste est lit en minuscule

Dim Compteur

Dim MonCaractere

Dim TableauCaracteresSeparation

Dim UnCaractereDeSeparation

Dim PasserEnMaj 'A 1 si on doit passer le caractere en MAJ

Const ListeCaracteresSeparation = " ;-;_;';,;."

TableauCaracteresSeparation = Split(ListeCaracteresSeparation, ";")

CasseNomPrenom = MonNomPrenom

MonNomPrenom = Trim(MonNomPrenom) 'On retire les espaces du début et de fin

MonNomPrenom = LCase(MonNomPrenom) 'On passe tout en minuscule

If Len(MonNomPrenom) > 2 Then

CasseNomPrenom = MonNomPrenom

MonNomPrenom = UCase(Left(MonNomPrenom, 1)) & LCase(Mid(MonNomPrenom, 2))

For Compteur = 2 To (Len(MonNomPrenom) - 1)

MonCaractere = Mid(MonNomPrenom, Compteur, 1)

PasserEnMaj = 0

For Each UnCaractereDeSeparation In TableauCaracteresSeparation

If MonCaractere = UnCaractereDeSeparation Then

PasserEnMaj = 1

Exit For

End If 'If MonCaractere = UnCaractereDeSeparation Then

If PasserEnMaj = 1 Then

MonNomPrenom = Left(MonNomPrenom, Compteur) & UCase(Mid(MonNomPrenom, Compteur + 1, 1)) & Mid(MonNomPrenom, Compteur + 2)

End If 'If PasserEnMaj = 1 Then

CasseNomPrenom = MonNomPrenom

End If 'If Len(MonNomPrenom) > 2 Then

End Function

AUTRE - Compression avec Winzip
'Version du 9 février 2004

'Les options pour créer un .ZIP
'winzip32 [-min] action [options] filename[.zip] files
'-min specifies that WinZip should run minimized. If -min is specified, it must be the first command line parameter.
'-a for add
'-f for freshen
'-u for update
'-m for move. You must specify one (and only one) of these actions.

'options
'-r corresponds to the Include subfolders checkbox
'-p WinZip will store folder information for all files added, not just for files from subfolders
'-ex, -en, -ef, -es, and -e0 determine the compression method: eXtra, Normal, Fast, Super fast, and no compression. The default is "Normal". -hs includes hidden and system files. Use -sPassword to specify a case-sensitive password. The password can be enclosed in quotes, for example, -s"Secret Password".
'filename.zip Chemin et nom du fichier ZIP a créer
'files : Is a list of one or more files, or the @ character followed by the filename containing a list of files to add, one filename per line. Wildcards (e.g. *.bak) are allowed.

Dim ProgWinZip 'Chemin de l'executable WinZip
Dim Options 'Options de compressions Winzip
Dim Source 'Chemin du répertoire ou fichier source à compresser
Dim FichierDest 'Le chemin du fichier Zip qui sera créé

ProgWinZip = "C:\Program Files\WinZip\WINZIP32.EXE"
Options = "-min -a -r -p -ex"
Source = "D:\MonRepertoire"
FichierDest = "D:\MonFichierZIP.zip"

'Creation de l'objet Shell
Set ObjShell = WScript.CreateObject("WScript.Shell")

Commande = """" & ProgWinZip & """" & " " & Options & " """ & FichierDest & """ """ & Source & """" 'Préparation de la ligne de commande a éxecuter
ObjShell.Run Commande,1,True

'Destruction de l'objet Shell
Set ObjShell = Nothing

AUTRE - Compter le nombre de chiffres
Public Function CompterLesChiffres(ByVal ValeurAExaminer, ByVal Options)

'Version du 11 mars 2008

'Retourne le nombre de chiffres présents dans une variable

Dim NbrDeChiffres

Dim Position

Dim UnCaractere

NbrDeChiffres = 0

ValeurAExaminer = Trim(ValeurAExaminer)

If Len(ValeurAExaminer) > 0 Then

For Position = 1 To Len(ValeurAExaminer)

UnCaractere = Mid(ValeurAExaminer, Position, 1)

If IsNumeric(UnCaractere) = True Then

NbrDeChiffres = NbrDeChiffres + 1

End If

Else

NbrDeChiffres = 0

End If 'If Len(ValeurAExaminer) > 0 Then

CompterLesChiffres = NbrDeChiffres

End Function

AUTRE - Compter le nombre d occurences d une chaine
Public Function CompterNbrOccurences(ByVal ChaineAExaminer, ByVal ChaineACompter)

'Version du 12 octobre 2009

'Retourne le nombre de ChaineACompter présents dans ChaineAExaminer

Dim NbrOccurences

Dim Position

Dim UnCaractere

NbrOccurences = 0

If Len(ChaineAExaminer) > 0 Then

For Position = 1 To Len(ChaineAExaminer)

UnCaractere = Mid(ChaineAExaminer, Position, Len(ChaineACompter))

If Lcase(UnCaractere) = Lcase(ChaineACompter) Then

NbrOccurences = NbrOccurences + 1

End If

Else

NbrOccurences = 0

End If 'If Len(ChaineAExaminer) > 0 Then

CompterNbrOccurences = NbrOccurences

End Function

AUTRE - Connaitre le chemin du répertoire du script actuellement lancé
'On récupère le nom du répertoire dans une variable
CheminScriptActuel = Left(wscript.scriptfullname,Len(wscript.scriptfullname)-Len(wscript.scriptname)-1)

AUTRE - Conversion Decimale - Binaire (Fonction VB)

Msgbox ConvertDecBin(17)

Public Function ConvertDecBin(ByVal MonNombreDec As Integer) As String

'Version du mardi 5 avril 2005

Dim ResteADiviser

Dim ResultatDivision

Dim ResultatFinal As String

Dim ChiffreAVirgule As Boolean

ResteADiviser = MonNombreDec

ResultatDivision = ResteADiviser / 2

ResteADiviser = Int(ResultatDivision)

'Le reste de la division (0 ou 1) vient à gauche du résultat final

'Si le résultat de la division est un chiffre a virgule, le reste est un 1 sinon c'est un 0

If ResultatDivision <> Int(ResultatDivision) Then

ChiffreAVirgule = True

ResultatFinal = 1 & ResultatFinal

Else

ChiffreAVirgule = False

ResultatFinal = 0 & ResultatFinal

End If

Loop While ResteADiviser > 1

'Le reste à Diviser représente le bit de poid fort

ResultatFinal = ResteADiviser & ResultatFinal

'On retourne le résultat

ConvertDecBin = ResultatFinal

End Function

AUTRE - Conversion Hexadécimale - Décimale - Methode 1
'Fonctionne sous Excel
MonChiffreDecimal = CDec("&h" & MonChiffreHexadecimal)

AUTRE - Conversion Hexadécimale - Décimale - Methode 2
Public Function Hexa2Decimal(ByVal MonHexa)

'Version du 05 décembre 2006

'On rentre un hexadécimal et on ressort un décimal

Dim Compteur

Dim UnChiffreHexa

Dim UnChiffreDecimal

Dim ChiffreAAjouter

Dim Total

Dim Puissance

Hexa2Decimal = "" 'Par défaut

Total = 0

Puissance = 0

For Compteur = Len(MonHexa) To 1 Step -1

UnChiffreHexa = Mid(MonHexa, Compteur, 1)

'On convertit le chiffre Hexa en chiffre décimal

Select Case LCase(UnChiffreHexa)

Case "f"

UnChiffreDecimal = 15

Case "e"

UnChiffreDecimal = 14

Case "d"

UnChiffreDecimal = 13

Case "c"

UnChiffreDecimal = 12

Case "b"

UnChiffreDecimal = 11

Case "a"

UnChiffreDecimal = 10

Case Else

UnChiffreDecimal = CInt(UnChiffreHexa)

End Select

ChiffreAAjouter = UnChiffreDecimal * (16 ^ Puissance)

Puissance = Puissance + 1

Total = Total + ChiffreAAjouter

Hexa2Decimal = Total

End Function

AUTRE - Conversion d'un SID au format brut en SID en format String
Public Function SIDBrutToSIDString(ByVal MonSID)

'Version du 20 fevrier 2007

'Convertit un SID qui est en format brut en un SID sous forme S-1-5-21 etc ....

'Exemple :

'010500000000000515000000B93E0E19C1406A2E0363450075060000

'Devient

'S-1-5-15-420363961-778715329-4547331-1653

'Realise avec l'aide des explications trouvées sur

'http://blogs.msdn.com/oldnewthing/archive/2004/03/15/89753.aspx

'Signification des chiffres

'S-1- version number (SID_REVISION)

'-5- SECURITY_NT_AUTHORITY

'-21- SECURITY_NT_NON_UNIQUE

'-...-...-...- these identify the machine that issued the SID

'72713 unique user id on the machine

Dim MonResultat

Dim NombreDeMoins

Dim ChiffreTempo

SIDBrutToSIDString = MonSID

MonSID = Trim(MonSID)

If Len(MonSID) > 0 Then

MonResultat = "S-"

'Extraction du premier chiffre

MonResultat = MonResultat & CLng(Left(MonSID, 2))

MonSID = Mid(MonSID, 3)

'Extraction du nombre de -

NombreDeMoins = CLng(Left(MonSID, 2))

MonSID = Mid(MonSID, 3)

'Extraction de 12

MonResultat = MonResultat & "-" & CLng(Left(MonSID, 12))

MonSID = Mid(MonSID, 13)

'Extraction de 8

ChiffreTempo = Left(MonSID, 8)

ChiffreTempo = PermutterPourSID(ChiffreTempo)

ChiffreTempo = Hexa2Decimal(ChiffreTempo)

'ChiffreTempo = CDec("&H" & ChiffreTempo)

MonSID = Mid(MonSID, 9)

MonResultat = MonResultat & "-" & ChiffreTempo

For Compteur = 1 To NombreDeMoins

If Len(MonSID) = 0 Then

Exit For

End If

'Extraction de 8

ChiffreTempo = Left(MonSID, 8)

ChiffreTempo = PermutterPourSID(ChiffreTempo)

ChiffreTempo = Hexa2Decimal(ChiffreTempo)

'ChiffreTempo = CDec("&H" & ChiffreTempo)

MonSID = Mid(MonSID, 9)

MonResultat = MonResultat & "-" & ChiffreTempo

SIDBrutToSIDString = MonResultat

End If 'If Len(MonSID) > 0 Then

End Function

Public Function PermutterPourSID(ByVal Meschiffres)

'Version du 30 nov 2006

'Inverse les lettres par paire de 2

Dim LeResultat

PermutterPourSID = Meschiffres

LeResultat = ""

If Len(Meschiffres) > 0 Then

Do While Len(Meschiffres) > 1

LeResultat = Left(Meschiffres, 2) & LeResultat

If Len(Meschiffres) >= 2 Then

Meschiffres = Mid(Meschiffres, 3)

End If

Loop

If Len(Meschiffres) = 1 Then

LeResultat = Meschiffres & LeResultat

End If

PermutterPourSID = LeResultat

End If

End Function

Public Function Hexa2Decimal(ByVal MonHexa)

'Version du 05 décembre 2006

'On rentre un hexadécimal et on ressort un décimal

Dim Compteur

Dim UnChiffreHexa

Dim UnChiffreDecimal

Dim ChiffreAAjouter

Dim Total

Dim Puissance

Hexa2Decimal = "" 'Par défaut

Total = 0

Puissance = 0

For Compteur = Len(MonHexa) To 1 Step -1

UnChiffreHexa = Mid(MonHexa, Compteur, 1)

'On convertit le chiffre Hexa en chiffre décimal

Select Case LCase(UnChiffreHexa)

Case "f"

UnChiffreDecimal = 15

Case "e"

UnChiffreDecimal = 14

Case "d"

UnChiffreDecimal = 13

Case "c"

UnChiffreDecimal = 12

Case "b"

UnChiffreDecimal = 11

Case "a"

UnChiffreDecimal = 10

Case Else

UnChiffreDecimal = CInt(UnChiffreHexa)

End Select

ChiffreAAjouter = UnChiffreDecimal * (16 ^ Puissance)

Puissance = Puissance + 1

Total = Total + ChiffreAAjouter

Hexa2Decimal = Total

End Function

AUTRE - Conversion String en numerique
Public Function ConvertirEnNumerique(ByVal MonChiffre)

'Version du 16 avr 2008

'Il arrive que la fontion Cum ou Clong fonctionne mal. Celle ci la remplace

Dim Position

Dim Puissance

Dim UnChiffreTexte

Dim UnChiffreNumerique

Dim LeChiffreFinal

If IsNumeric(MonChiffre) = True Then

LeChiffreFinal = 0

Puissance = 0

MonChiffre = CStr(MonChiffre)

For Position = (Len(MonChiffre)) To 1 Step -1

UnChiffreTexte = Mid(MonChiffre, Position, 1)

Select Case CStr(UnChiffreTexte)

Case "0"

UnChiffreNumerique = 0

Case "1"

UnChiffreNumerique = 1

Case "2"

UnChiffreNumerique = 2

Case "3"

UnChiffreNumerique = 3

Case "4"

UnChiffreNumerique = 4

Case "5"

UnChiffreNumerique = 5

Case "6"

UnChiffreNumerique = 6

Case "7"

UnChiffreNumerique = 7

Case "8"

UnChiffreNumerique = 8

Case "9"

UnChiffreNumerique = 9

End Select

LeChiffreFinal = LeChiffreFinal + (UnChiffreNumerique * (10 ^ Puissance))

Puissance = Puissance + 1

ConvertirEnNumerique = LeChiffreFinal

End If

End Function

AUTRE - Creation et lancement de la ligne de commande a faire passer a l utilitaire RunAs afin de lancer un script
'Version du 14 fev 2007
'Creation et lancement de la ligne de commande a faire passer a l utilitaire RunAs afin de lancer un script

'Exemple de commande RunAs correctement forme :
'RunAs /User:"domaine\login" "cscript.exe \"C:\Documents and Settings\UnCompte\Bureau\UnScript.vbs\""

Dim CheminScriptActuel
Dim Parametres
Dim LogicielALancer
Dim LeDomaine
Dim LeLogin

Parametres = ""

CheminScriptActuel = Left(wscript.scriptfullname,Len(wscript.scriptfullname)-Len(wscript.scriptname)-1)
Set Shell = CreateObject("Wscript.Shell")
Set objNetwork = CreateObject("Wscript.Network")

LogicielALancer = InputBox("Entrez le chemin du script a lancer","Logiciel",CheminScriptActuel & "\")
LeDomaine = InputBox("Entrez le Domaine du compte à utiliser","Domaine","PMR_EXT")
LeLogin = InputBox("Entrez le login à utiliser","Domaine",objNetwork.UserName)
Parametres = Trim(InputBox("Entrez les parametres eventuels","Parametres",""))

CompteEmprunt = LeDomaine & "\" & LeLogin
Commande = "RunAs /User:""" & CompteEmprunt & """ ""cscript.exe \""" & LogicielALancer & "\"""

If Len(Parametres) > 0 Then

Commande = Commande & " " & Parametres
End If
Commande = Commande & """"

Set objNetwork = Nothing

If Len(Commande) > 0 Then

tt = inputbox("","",Commande)

Wscript.echo "Lancement de la commande " & Commande

Shell.run Commande,1,true 'On relance le script avec un RunAs
End If
Set Shell = Nothing

AUTRE - Ecrire dans le presse papier - Premiere Methode
'Ce code fonctionne dans une page ASP dans la partie VbScript
'Aide sur http://msdn.microsoft.com/workshop/author/dhtml/reference/objects/clipboarddata.asp
CodeRetour = window.ClipboardData.SetData("Text","J ai ecrit dans le presse papier !")

AUTRE - Ecrire dans le presse papier - Seconde Methode
'Cette méthode fonctionne dans un script VBS (par exemple)
'Aide sur http://msdn.microsoft.com/library/default.asp?url=/workshop/author/dhtml/reference/methods/setdata.asp
Set objIE = CreateObject("InternetExplorer.Application")
objIE.Navigate("about:blank") 'Initialisation obligatoire sinon ca marche pas
CodeRetour = objIE.document.parentwindow.clipboardData.SetData("Text","J ai ecrit dans le presse papier !") 'On ecrit du texte dans le presse papier
Set objIE = Nothing

AUTRE - Eliminer les caracteres
Public Function EliminerCaracteres(ByVal MonMot, ByVal Mode)

'Version du 12 aout 2011 : Correction d un probleme dans la chaine des caracteres du 4eme bit

'Version du 24 février 2010 : Prise en charge des caractères !? avec le 8eme bit

'Le point est maintenant considéré comme un caractere de separation (bit 3 et 4)

'Prise en charge des parentheses, des !? etc ...

'Ex Version du 9 janvier 2008

'Ex Version du 04 Décembre 2006

Dim Liste

Dim ListeDeBase

Dim CompteurListe

Dim CaractereRecherche

Dim CaractereRemplacement

'En Binaire

'Bit 1 (1) pour que les accentuations des lettres disparaissent

'Bit 2 (2) pour des caractères qui servent généralement à faire des espaces sans en être. Les remplaces réellement par des espaces

'Exemple : _ - + = & :

'Bit 3 (4) pour que des caractères de séparations soient remplacés par un espace

'Exemple : , ' `

'Bit 4 (8) pour que des caractères de séparations soient remplacés par rien

'Exemple : , ' `

'Bit 5 (16) pour que les espaces soient remplacés par rien

'Bit 6 (32) pour que les espaces soient remplacés par -

'Bit 7 (64) pour que les espaces soient remplacés par _

'Bit 8 (128) pour que les caractères d expression soient remplacés par un espace

'Exemple : !?%*~

'Bit 9 (256) pour que les parenthèses et autre soient remplacés par un espace

'Exemple : ()[]{}\/

'Bit 10 (512) pour que les caractères # et ; soient remplacés par un espace

'Pour tout retirer même les espaces mettre 27 (1 2 8 16) (pour un login par exemple)

'Pour un format Email (pas de caractères spéciaux et un - à la place d'un espace) mettre 43 (1 2 8 32)

'Pour un Nom dans un annuaire, mettre 7 (1 2 4)

'Pour un Prenom dans un annuaire, mettre 39 (1 2 4 32)

'Chaque couple de possibilité est séparé par un #

Const ListeLettres = "à;a#â;a#ä;a#ã;a#é;e#è;e#ê;e#ë;e#î;i#ï;i#ì;i#ô;o#ö;o#ò;o#õ;o#û;u#ü;u#ù;u#ç;c" '1

Const Caracteres02 = "_; #-; #+; #=; #&; #:; " '2

Const Caracteres03 = ",; #'; #`; #.; " '4

Const Caracteres04 = ",;#';#`;#.;" '8

Const Caracteres05 = " ;" '16

Const Caracteres06 = " ;-" '32

Const Caracteres07 = " ;_" '64

Const Caracteres08 = "!; #?; #%; #*; #~; " '128

Const Caracteres09 = "(; #); #|; #[; #]; #{; #}; #""; #/; #\; " '256

Const Caracteres10 = ";, |#, " '512

ListeDeBase = ""

EliminerCaracteres = MonMot

If IsNumeric(Mode) = True Then

If (1 AND Cint(Mode)) = 1 Then

ListeDeBase = ListeDeBase & ListeLettres & "#"

End If

If (2 AND Cint(Mode)) = 2 Then

ListeDeBase = ListeDeBase & Caracteres02 & "#"

End If

If (4 AND Cint(Mode)) = 4 Then

ListeDeBase = ListeDeBase & Caracteres03 & "#"

End If

If (8 AND Cint(Mode)) = 8 Then

ListeDeBase = ListeDeBase & Caracteres04 & "#"

End If

If (16 AND Cint(Mode)) = 16 Then

ListeDeBase = ListeDeBase & Caracteres05 & "#"

End If

If (32 AND Cint(Mode)) = 32 Then

ListeDeBase = ListeDeBase & Caracteres06 & "#"

End If

If (64 AND Cint(Mode)) = 64 Then

ListeDeBase = ListeDeBase & Caracteres07 & "#"

End If

If (128 AND Cint(Mode)) = 128 Then

ListeDeBase = ListeDeBase & Caracteres08 & "#"

End If

If (256 AND Cint(Mode)) = 256 Then

ListeDeBase = ListeDeBase & Caracteres09 & "#"

End If

'On retire le dernier caractère

If Len(ListeDeBase) > 0 Then

ListeDeBase = Left(ListeDeBase,Len(ListeDeBase)-1)

End If

If Len(MonMot) > 0 Then

Liste = Split(ListeDeBase,"#")

For CompteurListe = LBound(Liste) To UBound(Liste)

CaractereRecherche = Split(Liste(CompteurListe), ";")(0)

CaractereRemplacement = Split(Liste(CompteurListe), ";")(1)

MonMot = Replace(MonMot, CaractereRecherche, CaractereRemplacement)

EliminerCaracteres = MonMot

'Pour pouvoir également remplacer les caracteres qui nous ont servit à parser

If (512 AND Cint(Mode)) = 512 Then

Liste = Split(Caracteres10,"|")

For CompteurListe = LBound(Liste) To UBound(Liste)

CaractereRecherche = Split(Liste(CompteurListe), ",")(0)

CaractereRemplacement = Split(Liste(CompteurListe), ",")(1)

MonMot = Replace(MonMot, CaractereRecherche, CaractereRemplacement)

End If

EliminerCaracteres = MonMot

End If 'If Len(MonMot) > 0 Then

Else

Msgbox Mode & " n'est pas un chiffre"

End If 'If IsNumeric(Mode) = True Then

End Function

AUTRE - Eliminer les caracteres consecutifs identiques
Public Function DeleteConsecutiveCaracteres(ByVal MaChaineDeCaracteres, ByVal DualCaracter)

'24 february 2010 version

'For example

'DeleteConsecutiveCaracteres("11a111bc11def1g", "1")

'return

'1a1bc1def1g

Dim Counter

Dim RestToAnalyse

Dim ActualCouple

'Default Value

DeleteConsecutiveCaracteres = MaChaineDeCaracteres

If Len(MaChaineDeCaracteres) > 1 Then

Counter = 1

ActualCouple = Mid(MaChaineDeCaracteres, Counter, 2)

'Si les 2 caracteres qui se suivent sont identiques

'On en supprime un des 2, ce qui revient à avancer de 1

If ActualCouple = DualCaracter & DualCaracter Then

'Si c est le tout debut de la chaine

If Counter > 1 Then

MaChaineDeCaracteres = Left(MaChaineDeCaracteres, Counter - 1) & Mid(MaChaineDeCaracteres, Counter + 1)

Else

MaChaineDeCaracteres = Mid(MaChaineDeCaracteres, Counter + 1)

End If

Else 'Sinon, on avance de 1

Counter = Counter + 1

End If

RestToAnalyse = Mid(MaChaineDeCaracteres, Counter)

Loop While Len(RestToAnalyse) > 1

DeleteConsecutiveCaracteres = MaChaineDeCaracteres

End If 'If Len(MaChaineDeCaracteres) > 1 Then
End Function

AUTRE - Eliminer les accents (fonction VB)
MonMot = EliminerCaracteres(MonMot)

Public Function EliminerCaracteres(ByVal MonMot)

'Version du 2 octobre 2006

Dim Liste

Dim CompteurListe

Dim CaractereRecherche

Dim CaractereRemplacement

If Len(MonMot) > 0 Then

Liste = Split("à;a#â;a#ä;a#é;e#è;e#ê;e#ë;e#î;i#ï;i#ì;i#ô;o#ö;o#ò;o#û;u#ü;u#ù;u# ;#_;#-;","#")

For CompteurListe = LBound(Liste) To UBound(Liste)

CaractereRecherche = Split(Liste(CompteurListe), ";")(0)

CaractereRemplacement = Split(Liste(CompteurListe), ";")(1)

MonMot = Replace(MonMot, CaractereRecherche, CaractereRemplacement)

EliminerCaracteres = MonMot

End If 'If Len(MonMot) > 0 Then

End Function

AUTRE - Envoyer un Email avec Outlook en Vb

Set objOutlook = CreateObject("Outlook.Application")

Set objSession = objOutlook.GetNamespace("MAPI") 'Création de l'objet de gestion des message
Set ObjMessage = objOutlook.CreateItem(0) 'Ajout d'un item pour le message
'objSession.Logon 'Connection à Outlook

With ObjMessage

'.SenderName = "Expediteur@lolo.com"

.To = "Destinataire@lolo.com"

.CC = ""

.Subject = "Mon sujet"

.Body = "Mon message"

'.Attachments.Add "c:\toto.txt" 'Chemin d'une piece attachée

'.Send 'Commande pour envoyer le mail

.Save 'Commande pour enregistrer le mail
End With

Set objOutlook = Nothing

AUTRE - Executer un programme avec la méthode RUN (fonction)
Public Function LancerExecutableWScriptShellRun(ByVal CheminExecutable, ByVal Arguments, ByVal ModeExecution, ByVal AttendreExecutable)

'Version du 30 septembre 2009 : Retour d un eventuel message d erreur

'Ex Version du 04 avril 2008

'Ex Version du 26 mars 2008

'Ex Version du 5 mars 2008

'LancerExecutableWScriptShellRun ne retourne rien si il n y a pas eu de probleme, sinon retourne un message d erreur

'Valeurs de ModeExecution :

' 0 : Cache et active une autre fenetre

' 1 : active la fenêtre de l executable et l affiche normalement

' 2 : active et minimise la fenetre

' 3 : active et maximise la fenetre

' 4 : ne touche pas a la fenetre active, affiche a la taille la plus recente

' 5 : active la fenetre active, affiche a la taille la plus recente

' 6 :

' 7 : ne touche pas a la fenetre active, minimise la fenetre

' 8

' 9

' 10

'Valeurs de AttendreExecutable

' True

' False

Dim Commande

Dim ObjShell

Dim NumeroErreur

Dim VariableBidon

LancerExecutableWScriptShellRun = "" 'Valeur par defaut

Select Case Cstr(ModeExecution)

Case "1", "2", "3", "4", "5", "6", "7", "8", "9", "10"

VariableBidon = 2

Case Else

ModeExecution = 1

End Select

Select Case AttendreExecutable

Case True

VariableBidon = 2

Case False

VariableBidon = 2

Case Else

AttendreExecutable = True

End Select

Commande = CheminExecutable

If Len(Arguments) > 0 Then

Commande = Commande & " """ & Arguments & """"

'Commande = """" & Commande & " """ & Arguments & """" & """"

'MsgBox Commande

End If

'Creation de l'objet Shell

Err.Clear

On Error Resume Next

Set ObjShell = WScript.CreateObject("WScript.Shell")

NumeroErreur = Err.number

On Error Goto 0

If NumeroErreur = 0 Then

'object.Run(strCommand, [intWindowStyle], [bWaitOnReturn])

'1 pour activer la fenêtre et l'afficher normalement

'Commande = "%windir%\notepad.exe" 'Préparation de la ligne de commande a éxecuter

Err.Clear

On Error Resume Next

ObjShell.Run Commande, ModeExecution, AttendreExecutable

NumeroErreur = Err.number

On Error Goto 0

If NumeroErreur = 0 Then

LancerExecutableWScriptShellRun = ""

End If

'Destruction de l'objet Shell

Set ObjShell = Nothing

Else

LancerExecutableWScriptShellRun = "Impossible de lancer la commande """ & Commande & """ car l appel de la fonction WScript.Shell ne fonctionne pas"

End If 'If NumeroErreur = 0 Then

End Function

AUTRE - Executer un programme avec la méthode EXEC (fonction)
Dim TableauResult
Dim MessageErreur 'Message en cas d erreur

MessageErreur = LancerExecutableWScriptShellExec("C:\MonExecutable.exe", "-d parametre", 1, TableauResult, 1500, "MonFichierDeLog.txt", 1)

If MessageErreur <> "" Then

Wscript.echo "Erreur : " & MessageErreur
Else

Wscript.echo "Execution terminee et Ok."
End If

Public Function LancerExecutableWScriptShellExec(ByVal CheminExecutable, ByVal Arguments, ByVal RecupererFluxDeSortie, ByRef MonTableauDynamiquePourResultat, ByVal MethodeAttenteProgramme, ByVal FichierDeLog , ByVal TestPresenceExecutable)

'Version du 01 mars 2010 : Ajout du parametre RecupererFluxDeSortie et correction de bugs

'Version du 26 fevrier 2010 : Recuperation du flux de sortie du programme execute

'Version du 06 octobre 2009 : Ajout d un test eventuel de la presence de l executable

'Version du 30 septembre 2009 : Initial

'Depend de la fonction EcrireLog

'LancerExecutableWScriptShellExec ne retourne rien si il n y a pas eu de probleme, sinon retourne un message d erreur

'CheminExecutable

Chemin complet de l executable a lancer

si c est uniquement le nom de l executable qui est precise, la fonction TestPresenceExecutable ne peut être utilisee.

'Arguments

Arguments a passer a l executable

'RecupererFluxDeSortie

a 1 pour recuperer le flux d information de sortie envoye par l application

'MonTableauDynamiquePourResultat

Tableau retournant ce qu a donne en sortie le programme lance

Ne fonctionne que si on attend la fin du programme, avec ou sans TimeOut

'Valeurs de MethodeAttenteProgramme

' 0 : On lance le programme et on le laisse vivre sa vie, on n attend pas apres, on continue.

' 1 : On lance le programme et on attend indefiniement apres sa fin.

' >1 : TimeOut avec une valeur en secondes. Par exemple 2 signifie que l on killera le programme apres 2 secondes.

' Une valeur en lettre fait planter le programme.

'Valeurs de FichierDeLog : juste le nom du fichier de log, pas de chemin complet. Par exemple : MonLog.txt

'Valeurs de TestPresenceExecutable

' 1 : Test de la presence de l executable. Il faut un chemin d acces a l executable comme : C:\Monexe.exe

' autre que 1 : pas de test

'MSDN :

'http://msdn.microsoft.com/en-us/library/ateytk4a(VS.85).aspx

Const DebugMode = 1

Dim Commande

Dim ObjShell

Dim ObjExec 'Objet representant l executable lance

Dim NumeroErreur

Dim AttendreFinProgramme 'True si on attend la fin du programme

Dim DateHeureFinProgramme 'Date/Heure apres laquelle le programme sera ferme si il tourne encore

Dim CheminScriptActuel

Dim CheminDuFichierDeLog

Dim objFSO

Dim ExecutablePresent

Dim UneLigneDeResultat

Dim LignesTableauResultat

LancerExecutableWScriptShellExec = "" 'Valeur par defaut

Commande = CheminExecutable

'Par défaut, on efface et on redimensionne le tableau

Redim MonTableauDynamiquePourResultat(0)

'Si on a demandé un fichier de log

FichierDeLog = Trim(FichierDeLog)

If DebugMode > 0 Then

Wscript.echo "FichierDeLog : " & FichierDeLog

End If

If Len(FichierDeLog) > 0 Then

'On récupère le nom du répertoire dans une variable

CheminScriptActuel = Left(wscript.scriptfullname,Len(wscript.scriptfullname)-Len(wscript.scriptname)-1)

CheminDuFichierDeLog = CheminScriptActuel & "\" & FichierDeLog

Call EcrireLog("===============================================================================", CheminDuFichierDeLog, True)

End If

'Test de la presence de l executable

ExecutablePresent = 1 'Valeur par defaut

Set objFSO = CreateObject("Scripting.FileSystemObject")

If DebugMode > 0 Then

Wscript.echo "ExecutablePresent : " & ExecutablePresent

End If

If TestPresenceExecutable = 1 Then

If objFSO.FileExists(CheminExecutable) = True Then

ExecutablePresent = 1

Else

ExecutablePresent = 0

End If 'If objFSO.FileExists(CheminExecutable) = False Then

End If 'If TestPresenceExecutable = 1 Then

Set objFSO = Nothing

'Si l executable est present

If ExecutablePresent = 1 Then

'On ajoute les arguments qui seront passes a l executable

If Len(Arguments) > 0 Then

Commande = """" & Commande & """ " & Arguments

'Wscript.echo "Commande : " & Commande

End If

If DebugMode > 0 Then

Wscript.echo "Commande : " & Commande

End If

'Creation de l'objet Shell

Err.Clear

On Error Resume Next

Set ObjShell = WScript.CreateObject("WScript.Shell")

NumeroErreur = Err.number

On Error Goto 0

If NumeroErreur = 0 Then

'object.Run(strCommand, [intWindowStyle], [bWaitOnReturn])

Call EcrireLog("Lancement de la commande suivante :", CheminDuFichierDeLog, True)

Call EcrireLog(Commande, CheminDuFichierDeLog, True)

Err.Clear

On Error Resume Next

Set ObjExec = ObjShell.Exec (Commande)

NumeroErreur = Err.number

On Error Goto 0

If NumeroErreur = 0 Then

Call EcrireLog("Lancement OK", CheminDuFichierDeLog, True)

Call EcrireLog("ProcessID : " & ObjExec.ProcessID, CheminDuFichierDeLog, True)

LancerExecutableWScriptShellExec = ""

End If

Select Case MethodeAttenteProgramme

Case 0

AttendreFinProgramme = False

Call EcrireLog("Pas d attente de la fin d execution du programme", CheminDuFichierDeLog, True)

Case 1

AttendreFinProgramme = True

DateHeureFinProgramme = ""

Call EcrireLog("Attente infinie de la fin d execution du programme", CheminDuFichierDeLog, True)

Case Else

AttendreFinProgramme = True

DateHeureFinProgramme = DateAdd("s", MethodeAttenteProgramme, Now)

Call EcrireLog("Attente de la fin d execution du programme pendant " & MethodeAttenteProgramme & " secondes, soit jusqu au " & DateHeureFinProgramme, CheminDuFichierDeLog, True)

'Wscript.Echo "Le programme sera tue a " & DateHeureFinProgramme

End Select

If DebugMode > 0 Then

Wscript.echo "AttendreFinProgramme : " & AttendreFinProgramme

End If

If AttendreFinProgramme = True Then

'Wscript.Echo "On attend la fin du programme"

'Pour tous les lignes réenvoyées en sortie par l'executable (ce qui est normalement affiché dans la fenêtre de commande DOS

Call EcrireLog("Sortie(s) du programme :", CheminDuFichierDeLog, True)

If DebugMode > 0 Then

Wscript.echo "RecupererFluxDeSortie : " & RecupererFluxDeSortie

Wscript.echo "Sortie(s) du programme :"

End If

Do While ObjExec.Status = 0

'Si on recupere le flux de sortie du programme

If RecupererFluxDeSortie = 1 Then

Do While Not ObjExec.StdOut.AtEndOfStream

If DebugMode > 1 Then

Wscript.echo "Recuperation du flux de sortie"

End If

'On récupère la ligne

UneLigneDeResultat = ObjExec.StdOut.ReadLine()

If DebugMode > 0 Then

Wscript.echo "UneLigneDeResultat : " & UneLigneDeResultat

End If

Call EcrireLog(" " & UneLigneDeResultat, CheminDuFichierDeLog, True)

LignesTableauResultat = LignesTableauResultat & UneLigneDeResultat & CHR(1)

'Wscript.Echo LignesTableauResultat

If IsDate(DateHeureFinProgramme) Then

'Si on a attend le TimeOut, on ferme le programme

If DateHeureFinProgramme <= Now Then

LancerExecutableWScriptShellExec = "TimeOut de " & MethodeAttenteProgramme & " atteind. Programme ferme."

Call EcrireLog("TimeOut de " & MethodeAttenteProgramme & " atteind. Programme ferme.", CheminDuFichierDeLog, True)

Call ObjExec.Terminate()

End If

Else

If DebugMode > 1 Then

Wscript.echo "DateHeureFinProgramme non atteind : " & DateHeureFinProgramme

End If

End If 'If IsDate(DateHeureFinProgramme) Then

Loop 'Do While Not ObjExec.StdOut.AtEndOfStream

End If 'If RecupererFluxDeSortie = 1 Then

If DebugMode > 1 Then

Wscript.echo "Attente de 1 seconde"

End If

WScript.Sleep 1000 'Attente de 1 seconde

'Wscript.echo ObjExec.Status

If DebugMode > 1 Then

Wscript.echo "ObjExec.Status : " & ObjExec.Status

End If

'Si on ne recupere pas le flux de sortie du programme

If RecupererFluxDeSortie <> 1 Then

'Valeurs présumées de Status :

' 0 : Job en cours d execution

' 1 : Job Termine

If ObjExec.Status = 0 Then

'Si on a parametre un TimeOut

If IsDate(DateHeureFinProgramme) Then

'Si on a atteind le TimeOut, on ferme le programme

If DateHeureFinProgramme <= Now Then

LancerExecutableWScriptShellExec = "TimeOut de " & MethodeAttenteProgramme & " atteind. Programme ferme."

Call EcrireLog("TimeOut de " & MethodeAttenteProgramme & " atteind. Programme ferme.", CheminDuFichierDeLog, True)

Call ObjExec.Terminate()

End If

End If 'If ObjExec.Status = 0 Then

End If 'If RecupererFluxDeSortie <> 1 Then

Loop 'Do While ObjExec.Status = 0

If DebugMode > 0 Then

Wscript.echo "Programme " & CheminExecutable & " termine."

End If

Call EcrireLog("Programme " & CheminExecutable & " termine.", CheminDuFichierDeLog, True)

If Len(LignesTableauResultat) > 0 Then

LignesTableauResultat = Left(LignesTableauResultat, (Len(LignesTableauResultat) - Len(CHR(1))))

End If

If DebugMode > 0 Then

Wscript.echo "Code de sortie : " & ObjExec.ExitCode

End If

Call EcrireLog("Code de sortie : " & ObjExec.ExitCode, CheminDuFichierDeLog, True)

'Un code de sortie different de 0 indique un probleme

If ObjExec.ExitCode <> 0 Then

End If

MonTableauDynamiquePourResultat = Split(LignesTableauResultat, CHR(1))

End If 'If AttendreFinProgramme = True Then

'Destruction des objets

Set ObjExec = Nothing

Set ObjShell = Nothing

Else

LancerExecutableWScriptShellExec = "Impossible de lancer la commande """ & Commande & """ car l appel de la fonction WScript.Shell ne fonctionne pas"

End If 'If NumeroErreur = 0 Then

Else

LancerExecutableWScriptShellExec = "Impossible de lancer la commande """ & Commande & """ car l executable n a pas ete trouve."

Call EcrireLog("Impossible de lancer la commande """ & Commande & """ car l executable n a pas ete trouve."

, CheminDuFichierDeLog, True)

End If 'If ExecutablePresent = 1 Then

End Function

Public Function EcrireLog(ByVal MessageDeLogPourHistorique, ByVal CheminFichierDeLog, ByVal MettreDateHeure)

'Version du 30 septembre 2009

'Valeur de CheminFichierDeLog : Chemin complet du fichier de log. Exemple : D:\MonFichier.Txt

'Valeurs de MettreDateHeure :

' True : Mettre la date et l heure dans le log

' False : Rien

Dim objFSO

Dim objTextFile

Dim NumeroErreur

'Déclaration des constantes

Const ForReading = 1

Const ForWritting = 2

Const ForAppending = 8

If Len(CheminFichierDeLog) > 0 Then

Set objFSO = CreateObject("Scripting.FileSystemObject")

On Error Resume Next

'Si on a demande l ajout de la date et l heure

If MettreDateHeure = True Then

MessageDeLogPourHistorique = Now & " : " & MessageDeLogPourHistorique

End If

'Ecriture dans le fichier de log

Set objTextFile = objFSO.OpenTextFile(CheminFichierDeLog, ForAppending, True)

objTextFile.WriteLine(MessageDeLogPourHistorique)

objTextFile.Close 'Fermeture du fichier

NumeroErreur = Err.Number

On Error Goto 0

Select Case NumeroErreur

Case 0

'Wscript.Echo ""

Case Else

Wscript.Echo "ERREUR lors de l ecriture dans le fichier de log. Erreur numero " & NumeroErreur

End Select

Set objTextFile = Nothing

Set objFSO = Nothing

End If 'If Len(CheminFichierDeLog) > 0 Then

End Function

AUTRE - Executer un programme en VB avec ShellExecute
Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _

ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
toto = ShellExecute(0, vbNullString, CheminExecutable, Arguments, "c:\", 1)

AUTRE - Executer un programme en VB et attendre sa fin
Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Function LancerExecutable(ByVal CheminExecutable, ByVal Arguments)

'Version du 31/10/2006

'http://docvb.free.fr/apidetail.php?idapi=140

Const vbHide = 0 'Window is hidden and focus is passed to the hidden window

Const vbNormalFocus = 1 'Window has focus and is restored to its original size and position.

Const vbMinimizedFocus = 2 'Window is displayed as an icon with focus.

Const vbMaximizedFocus = 3 'Window is maximized with focus.

Const vbNormalNoFocus = 4 'Window is restored to its most recent size and position. The currently active window remains active.

Const vbMinimizedNoFocus = 6 'Window is displayed as an icon. The currently active window remains

Const PROCESS_QUERY_INFORMATION = 1024 '&H400

Const STILL_ACTIVE = &H103

Dim NumeroHandle

Dim hProcess

'Commande = """" & CheminExecutable & """"

Commande = CheminExecutable

If Len(Arguments) > 0 Then

Commande = Commande & " """ & Arguments & """"

Commande = """" & Commande & " """ & Arguments & """" & """"

End If

NumeroHandle = Shell(Commande, vbNormalFocus)

hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, NumeroHandle)

' Retourne le status du processus en cours

GetExitCodeProcess hProcess, RetVal

' Les 2 lignes suivantes sont recommandées pour éviter de faire

' travailler le système avec GetExitCodeProcess

DoEvents

Sleep 100

Loop While RetVal = STILL_ACTIVE

CloseHandle (hProcess)

End Function

AUTRE - Executer un script sur une machine distante
'http://msdn.microsoft.com/en-us/library/xk7bxb0d%28VS.85%29.aspx
Dim Controller, RemoteScript
Set Controller = WScript.CreateObject("WSHController")
Set RemoteScript = Controller.CreateScript("remote1.js")
RemoteScript.Execute

Do While RemoteScript.Status <> 2

WScript.Sleep 100
Loop

AUTRE - Forcer l utilisation de Cscript.exe a la place de Wscript.exe
Sub DetectExeType()

'Version du 10 juillet 2008

Dim ScriptHost

Dim ShellObject

Dim CurrentPathExt

Dim EnvObject

Dim RegCScript

Dim RegPopupType ' This is used to set the pop-up box flags.

' I couldn't find the pre-defined names

RegPopupType = 32 + 4

On Error Resume Next

ScriptHost = WScript.FullName

ScriptHost = Right(ScriptHost, Len(ScriptHost) - InStrRev(ScriptHost, "\"))

If (UCase(ScriptHost) = "WSCRIPT.EXE") Then

WScript.Echo ("This script does not work with WScript.")

' Create a pop-up box and ask if they want to register cscript as the default host.

Set ShellObject = WScript.CreateObject("WScript.Shell")

' -1 is the time to wait. 0 means wait forever.

RegCScript = ShellObject.PopUp("Would you like to register CScript as your default host for VBscript?", 0, "Register CScript", RegPopupType)

If (Err.Number <> 0) Then

ReportError ()

WScript.Echo "To run this script using CScript, type: ""CScript.exe " & WScript.ScriptName & """"

WScript.Quit (GENERAL_FAILURE)

WScript.Quit (Err.Number)

End If

' Check to see if the user pressed yes or no. Yes is 6, no is 7

If (RegCScript = 6) Then

ShellObject.RegWrite "HKEY_CLASSES_ROOT\VBSFile\Shell\Open\Command\", "%WINDIR%\System32\CScript.exe //nologo ""%1"" %*", "REG_EXPAND_SZ"

ShellObject.RegWrite "HKEY_LOCAL_MACHINE\SOFTWARE\Classes\VBSFile\Shell\Open\Command\", "%WINDIR%\System32\CScript.exe //nologo ""%1"" %*", "REG_EXPAND_SZ"

' Check if PathExt already existed

CurrentPathExt = ShellObject.RegRead("HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Session Manager\Environment\PATHEXT")

If Err.Number = &H80070002 Then

Err.Clear

Set EnvObject = ShellObject.Environment("PROCESS")

CurrentPathExt = EnvObject.Item("PATHEXT")

End If

ShellObject.RegWrite "HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Session Manager\Environment\PATHEXT", CurrentPathExt & ";.VBS", "REG_SZ"

If (Err.Number <> 0) Then

ReportError ()

WScript.Echo "Error Trying to write the registry settings!"

WScript.Quit (Err.Number)

Else

WScript.Echo "Successfully registered CScript"

End If

Else

WScript.Echo "To run this script type: ""CScript.Exe adsutil.vbs <cmd> <params>"""

End If

Dim ProcString

Dim ArgIndex

Dim ArgObj

Dim Result

ProcString = "Cscript //nologo " & WScript.ScriptFullName

Set ArgObj = WScript.Arguments

For ArgIndex = 0 To ArgCount - 1

ProcString = ProcString & " " & Args(ArgIndex)

'Now, run the original executable under CScript.exe

Result = ShellObject.Run(ProcString, 0, True)

WScript.Quit (Result)

End If

End Sub

AUTRE - Filtrage de tableau

Dim MonTableauFiltre
Dim MonTableau (3)

MonTableau(0) = "Sunday"
MonTableau(1) = "Monday"
MonTableau(2) = "Tuesday"
MonTableauFiltre = Filter(MonTableau, "es")

Wscript.Echo MonTableauFiltre(0)

AUTRE - Générer tous les mots possible et inimaginables
Dim TableauDictionnaire()
Dim Tableau02()
Dim MaxLongeurMot

Alphabet = "abcdefghijklmnopqrstuvwxyz_-"
MaxLongeurMot = 3

'Création d'un tableau représentant le dictionnaire qui contient tous les mots possible et inimaginable
'Au départ ce tableau ne contient que l'alphabet de base
ReDim TableauDictionnaire(Len(Alphabet))
For CompteurLigneDico = 1 To UBound(TableauDictionnaire)

TableauDictionnaire(CompteurLigneDico) = Mid(Alphabet, CompteurLigneDico, 1)
Next

Call Test(Alphabet, TableauDictionnaire, 0, MaxLongeurMot)

Public Sub Test(ByRef Alphabet, ByVal TableauDictionnaire, LongueurActuelleDuMot, MaxLongeurMot)

'MaxLongeurMot : Longueur Maximale d'un mot. Si il est a 3, la boucle ne génèrera pas de mots de plus de 3 caractères

Dim DictionnaireDesMotsDeLongeurN()

ReDim DictionnaireDesMotsDeLongeurN(0)

'Si on a atteind la longueur max d'un mot

If LongueurActuelleDuMot >= MaxLongeurMot Then

Exit Sub 'On Sort de la boucle

End If

'On prend le contenu actuel du dictionnaire et pour chaque ligne

'on essaye ajout toutes les combinaisons possible permises par l'alphabet de base

LongueurActuelleDuMot = LongueurActuelleDuMot + 1

For CompteurLettresAlphabet = 1 To Len(Alphabet) 'Pour toutes les lettres de l'alphabet

For CompteurLigneDico = 1 To UBound(TableauDictionnaire)

'On ajoute une ligne au tableau du dictionnaire pour qu'il puisse recevoir une nouvelle combinaison

ReDim Preserve DictionnaireDesMotsDeLongeurN(UBound(DictionnaireDesMotsDeLongeurN) + 1)

DictionnaireDesMotsDeLongeurN(UBound(DictionnaireDesMotsDeLongeurN)) = Mid(Alphabet, CompteurLettresAlphabet, 1) & TableauDictionnaire(CompteurLigneDico)

'Affichage de la nouvelle combinaison, soit la dernière ligne du tableau

Wscript.echo DictionnaireDesMotsDeLongeurN(UBound(DictionnaireDesMotsDeLongeurN))

'Appel recursif de la fonction

Call Test(Alphabet, DictionnaireDesMotsDeLongeurN, LongueurActuelleDuMot, MaxLongeurMot)

End Sub

AUTRE - Générer tous les mots possible et inimaginables en PHP
<?

set_time_limit (172800);

//Chiffres de 48 à 57
//Majuscules de 65 à 90
//Minuscules de 97 à 122

/*

//Affichage de la table Ascii

for($i=1;$i<256;$i++){

echo $i." : ".chr($i)."<BR>";

}
*/

$AlphaDebut = 33;
$AlphaFin = 123;

//Création d'un tableau représentant le dictionnaire qui contient tous les mots possible et inimaginable
//Au départ ce tableau ne contient que l'alphabet de base
for($i=$AlphaDebut;$i<$AlphaFin;$i++){

$TableauDictionnaire[]=chr($i);

}

Test($TableauDictionnaire, 1, 10);
echo "C'est termine<BR>";

function Test($TableauDictionnaire, $LongueurActuelleDuMot, $MaxLongeurMot){

$AlphaDebut = 33;

$AlphaFin = 123;

$MotRecherche = "1dcc929467981f0ed69e30bdd79bba2c";

//Initialisation de la variable qui va contenir les mots de longueur $LongueurActuelleDuMot

//$DictionnaireDesMotsDeLongeurN

$LongueurActuelleDuMot = $LongueurActuelleDuMot+1;

//Si on a atteind la longueur max d'un mot

If ($LongueurActuelleDuMot < $MaxLongeurMot){

echo "<HR>";

echo "Le mot a une longueur actuelle de ".$LongueurActuelleDuMot."<BR>";

for($i=$AlphaDebut;$i<$AlphaFin;$i++){ //Pour toutes les lettres de l'alphabet

foreach($TableauDictionnaire as $UneLigne){ //Pour toutes les lignes du dico

//$TailleDico = sizeof($TableauDictionnaire);

//echo "Le tableau à une taille de ".$TailleDico."<BR>";

//echo $TableauDictionnaire[$TailleDico-1]."<BR>";

//$DerniereValeurDico = $TableauDictionnaire[$TailleDico-1];

//On ajoute une ligne au tableau du dictionnaire pour qu'il puisse recevoir une nouvelle combinaison

$LeMot = chr($i).$UneLigne;

$DictionnaireDesMotsDeLongeurN[] = $LeMot;

If (MD5($LeMot) == $MotRecherche){

echo "<B>Trouve !</B><BR>";

echo "Le nouveau mot est ".$LeMot."<BR>";

exit;

}

//Appel recursif de la fonction

Test($DictionnaireDesMotsDeLongeurN, $LongueurActuelleDuMot, $MaxLongeurMot);

}//If ($LongueurActuelleDuMot < $MaxLongeurMot){

}

?>

AUTRE - Generer une liste de nombres aleatoires uniques
Dim NbrAleatoire 'Un nombre aléatoire

'Générer un nombre aléatoire entre 1 et 22
NbrAleatoire = Int((22 * Rnd) + 1)

'Générer un nombre aléatoire entre 1 et 8
NbrAleatoire = Int((8 * Rnd) + 1)

'Générer un nombre aléatoire entre 0 et 10
NbrAleatoire = Int(10 * Rnd)

AUTRE - Generer un tableau de nombres aleatoires uniques
Dim TableauDeChiffres
Dim MaLigne

Call GenererChiffres(NumLigneFin, TableauDeChiffres)

For Each MaLigne In TableauDeChiffres

Debug.Print MaLigne
Next

Public Function GenererChiffres(ByVal NombreChiffresAGenerer, ByRef TableauResultat)

'Version du Vendredi 29 avril 2005

'On sort un tableau de nombres aléatoires uniques allant de 1 à ....

'Le résultat est stocké dans un tableau dynamique passé en paramètres nommé TableauResultat

GenererChiffres = False 'Valeur par défaut. A False si on a pas réussit à générer le resultat demandé

ReDim TableauResultat(1 To 1) 'On initialise et parametre le tableau dynamique

Dim NombreExiste 'A True si le nombre a déjà été généré

'Tant que l'on a pas généré autant de chiffres qu'il y a de lignes

While UBound(TableauResultat) < NombreChiffresAGenerer + 1

NbrAleatoire = Int((NombreChiffresAGenerer * Rnd) + 1) 'On sort un nombre aléatoire allant de 1 à ....

'On regarde si le nombre généré a déjà été prit

NombreExiste = False

For Each MaLigne In TableauResultat

If NbrAleatoire = MaLigne Then

NombreExiste = True

Exit For

End If

'Si on a bien généré un nouveau chiffre

If NombreExiste = False Then

TableauResultat(UBound(TableauResultat)) = NbrAleatoire 'On ajoute le nombre générique au tableau

ReDim Preserve TableauResultat(1 To UBound(TableauResultat) + 1) 'On ajoute une ligne au tableau

End If

Wend

'On supprime la dernière ligne du tableau qui est en trop

ReDim Preserve TableauResultat(1 To (UBound(TableauResultat) - 1))

GenererChiffres = True 'On indique que tout est ok

End Function

AUTRE - Include en VbScript
'Fonction a mettre dans le script
Sub Include(sInstFile)

'Version du 18/06/2007

On Error Resume Next

Dim oFSO, f, s

Set oFSO = CreateObject("Scripting.FileSystemObject")

If oFSO.FileExists(sInstFile) Then

Set f = oFSO.OpenTextFile(sInstFile)

s = f.ReadAll

f.Close

ExecuteGlobal s

End If

Set oFSO = Nothing

Set f = Nothing
End Sub

AUTRE - Lancer une connection WMI avec une authentification différente
'Exemple de Script
'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/wmisdk/wmi/creating_processes_remotely.asp

'Infos sur la méthode SWbemLocator.ConnectServer :
'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/wmisdk/wmi/swbemlocator_connectserver.asp

strComputer = "NomDeLaMachine"

'Exemple de connection avec l'authentification courante
'Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
'Set colSWbemObjectSet = objWMIService.ExecQuery("Select * from Win32_Process")
'For Each objProcess in colSWbemObjectSet
'

Wscript.Echo "Process Name: " & objProcess.Name
'Next
'Set colSWbemObjectSet = Nothing
'Set objWMIService = Nothing

'Le même exemple de connection avec une authentification différente
strDomain = "NomDuDomaine"
strUser = "Login"
strPassword = "MotDePasse"

Set objSWbemLocator = CreateObject("WbemScripting.SWbemLocator")
Set objSWbemServices = objSWbemLocator.ConnectServer(strComputer,"root\cimv2",strUser,strPassword,"MS_409","ntlmdomain:" + strDomain)
Set colSwbemObjectSet = objSWbemServices.ExecQuery("Select * from Win32_Process")

For Each objProcess in colSWbemObjectSet

Wscript.Echo "Process Name: " & objProcess.Name
Next

Set colSwbemObjectSet = Nothing
Set objSWbemServices = Nothing
Set objSWbemLocator = Nothing

AUTRE - Lire le contenu du presse papier
'L'exemple est inspiré de la page suivante
'http://www.microsoft.com/technet/scriptcenter/resources/qanda/dec04/hey1215.mspx
'Exemple de copie de texte dans le presse papier (Clipboard) en Java)
'http://www.htmlgoodies.com/beyond/clipboard.html

'Creation d'un objet Internet Explorer
Set objIE = CreateObject("InternetExplorer.Application")

objIE.Navigate("about:blank") 'Initialisation obligatoire sinon ca marche pas
ValeurPressePapier = objIE.document.parentwindow.clipboardData.GetData("text") 'Recupération du texte qui est dans le presse papier
Wscript.Echo ValeurPressePapier 'Affichage
Set objIE = Nothing

AUTRE - List Available Updates
Set objSearcher = CreateObject("Microsoft.Update.Searcher")
Set objResults = objSearcher.Search("Type='Software'")
Set colUpdates = objResults.Updates

For i = 0 to colUpdates.Count - 1
Wscript.Echo "Title: " & colUpdates.Item(i).Title
For Each strArticle in colUpdates.Item(i).KBArticleIDs
Wscript.Echo "KB article: " & strArticle
Next
Wscript.Echo "Microsoft Security Response Center severity: " & colUpdates.Item(i).MsrcSeverity

For Each strUpdate in colUpdates.Item(i).BundledUpdates
Wscript.Echo "Bundled update: " & strUpdate
Next

Set objCategories = colUpdates.Item(i).Categories

For z = 0 to objCategories.Count - 1
Wscript.Echo "Category name: " & objCategories.Item(z).Name
Wscript.Echo "Category ID: " & objCategories.Item(z).CategoryID
For Each strChild in objCategories.Item(z).Children
Wscript.Echo "Child category: " & strChild
Next
Wscript.Echo "Category description: " & _
objCategories.Item(z).Description
Wscript.Echo "Category order: " & objCategories.Item(z).Order
Wscript.Echo "Category type: " & objCategories.Item(z).Type
Next

Set objIdentity = colUpdates.Item(i).Identity
Wscript.Echo "Update ID: " & objIdentity.UpdateID
Wscript.Echo "Release notes: " & colUpdates.Item(i).ReleaseNotes

Wscript.Echo
Next

AUTRE - List Installed Updates
Set objSession = CreateObject("Microsoft.Update.Session")
Set objSearcher = objSession.CreateUpdateSearcher
intHistoryCount = objSearcher.GetTotalHistoryCount

Set colHistory = objSearcher.QueryHistory(1, intHistoryCount)

For Each objEntry in colHistory
Wscript.Echo "Operation: " & objEntry.Operation
Wscript.Echo "Result code: " & objEntry.ResultCode
'Wscript.Echo "Exception: " & objEntry.Exception
Wscript.Echo "Date: " & objEntry.Date
Wscript.Echo "Title: " & objEntry.Title
Wscript.Echo "Description: " & objEntry.Description
'Wscript.Echo "Unmapped exception: " & objEntry.UnmappedException
Wscript.Echo "Client application ID: " & objEntry.ClientApplicationID
Wscript.Echo "Server selection: " & objEntry.ServerSelection
Wscript.Echo "Service ID: " & objEntry.ServiceID
i = 1
For Each strStep in objEntry.UninstallationSteps
Wscript.Echo i & " -- " & strStep
i = i + 1
Next
'Wscript.Echo "Uninstallation notes: " & objEntry.UninstallationNotes
'Wscript.Echo "Support URL: " & objEntry.SupportURL
Wscript.Echo
Next

AUTRE - Lister les imprimantes avec WMI
'http://msdn.microsoft.com/library/en-us/wmisdk/wmi/win32_printer.asp
strComputer = InputBox("Entrez le nom du Pc","Nom du poste","")
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")

Set colPrintJobs = objWMIService.ExecQuery("Select * from Win32_Printer")

For Each objPrintJob in colPrintJobs

Message = objPrintJob.Name & ";" & Trim(objPrintJob.Description) & ";" & Trim(objPrintJob.location) & ";" & objPrintJob.Caption & ";" & objPrintJob.DriverName & ";" & objPrintJob.PortName

Wscript.echo Message
Next

AUTRE - Lister les imprimantes avec WMI V2
'Version du 10 avril 2008
'Liste les imprimantes et propriétés d un serveur d impression

strComputer = InputBox("Entrez le nom du Serveur","Nom du Serveur","")
If Len(strComputer) > 0 Then

Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")

Set MesImprimantes = objWMIService.ExecQuery("Select * from Win32_Printer")

Wscript.echo "DeviceID;ShareName;Comment;Location;Priority;DriverName;PortName"

For Each UneImprimante in MesImprimantes

Wscript.echo UneImprimante.DeviceID & ";" & UneImprimante.ShareName & ";" & UneImprimante.Comment & ";" & UneImprimante.Location & ";" & UneImprimante.Priority & ";" & UneImprimante.DriverName & ";" & UneImprimante.PortName

'Wscript.echo UneImprimante.Comment

Next
End If

AUTRE - Lister les logiciels installés
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.CreateTextFile("d:\ZListeLogicielInstalles.txt", True)

strComputer = "."
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colSoftware = objWMIService.ExecQuery("Select * from Win32_Product")

objTextFile.WriteLine "Caption" & vbtab & "Description" & vbtab & "Identifying Number" & vbtab & _
"Install Date" & vbtab & "Install Location" & vbtab & _
"Install State" & vbtab & "Name" & vbtab & _
"Package Cache" & vbtab & "SKU Number" & vbtab & "Vendor" & vbtab & "Version"

For Each objSoftware in colSoftware

objTextFile.WriteLine objSoftware.Caption & vbtab & _

objSoftware.Description & vbtab & _

objSoftware.IdentifyingNumber & vbtab & _

objSoftware.InstallDate & vbtab & _

objSoftware.InstallLocation & vbtab & _

objSoftware.InstallState & vbtab & _

objSoftware.Name & vbtab & _

objSoftware.PackageCache & vbtab & _

objSoftware.SKUNumber & vbtab & _

objSoftware.Vendor & vbtab & _

objSoftware.Version

Next

objTextFile.Close
Set objTextFile = Nothing

AUTRE - Popup : Poser une question et récupérer la réponse (VBS)
Dim ObjShell
Dim CodeRetour

Set ObjShell = WScript.CreateObject("WScript.Shell")

CodeRetour = ObjShell.Popup("Do you feel alright?", 10, "Ca va toi ?", 4 + 32)

Select Case CodeRetour

case 6 'Si la réponse est OUI

WScript.Echo "Cool !"

case 7 'Si la réponse est NON

WScript.Echo "Pas cool !"
End Select

AUTRE - Msgbox avec une question du type oui/non
If Msgbox("voulez vous ?",vbYesNo, "Question ?") = vbyes Then

Msgbox "Oui"
Else

Msgbox "Non"
End If

AUTRE - Rmtshare
'Suppression d'un partage
rmtshare \\NomServeur\NomPartage /delete

'Création d'un partage
rmtshare "\\NomServeur\NomPartage=CheminLocaldupartage" /Unlimited

AUTRE - Recuperer des arguments passes en parametres dans un script - solution basique
Dim MonArgument

Wscript.Arguments(0)

If Wscript.Arguments.Count >= 1 Then

MonArgument = Wscript.Arguments(0)

MonArgument = Trim(MonArgument)
End If 'If Wscript.Arguments.Count >= 1 Then

AUTRE - Recuperer des arguments passes en parametres dans un script - solution avancee
'Parse the command line.
call ParseCommand()

Function ParseCommand()

' Parses the command line and fills the script variables

' with the appropriate values.

Dim ArgCount

Dim oArgs

Set oArgs = Wscript.Arguments

ArgCount = 0

if oArgs.Count = 0 then

wscript.echo "No arguments specified."

wscript.echo

call Help()

end if

While ArgCount < oArgs.Count

Select Case LCase(oArgs(ArgCount))

Case "-n"

ArgCount = ArgCount + 1

strComputer=LCase(oArgs(ArgCount))

wscript.echo "Server name : " & strComputer

Case "-c"

ArgCount = ArgCount + 1

strCommand=LCase(oArgs(ArgCount))

wscript.echo "Command : " & strCommand

Case Else:

wscript.echo "Invalid command."

wscript.echo

call Help()

wscript.quit

End Select

ArgCount = ArgCount + 1

Wend
End Function

sub Help()

' Display command-line syntax for the script.

wscript.echo "Script Function details"

wscript.echo "Syntax:"

wscript.echo

wscript.echo "-n Server name or IP"

wscript.echo "-c command name : drainstop or start"

wscript.echo

wscript.echo "Examples:"

wscript.echo

wscript.echo "Etc..."

wscript.quit
End Sub

AUTRE - Retirer Les Zeros
Public Function RetirerLesZeros(ByVal MaChaineDeCaracteres)

'Version du 10 avril 2007

'Retire les zéros qui sont au début d'une série de chiffres

'HD00025048g10052 devient HD25048g10052

'HD00025048g0052 devient HD25048g52

Dim Position

Dim MonCaractere

Dim DebutSerieDeZeros

Dim LongueurChaine

'Valeur de retour par défaut

RetirerLesZeros = MaChaineDeCaracteres

DebutSerieDeZeros = False

LongueurChaine = Len(MaChaineDeCaracteres)

If Len(MaChaineDeCaracteres) > 1 Then

For Position = 1 To (LongueurChaine - 1)

MonCaractere = Mid(MaChaineDeCaracteres, Position, 1)

If Len(MonCaractere) > 0 Then

'Si ce caractère est un chiffre

If IsNumeric(MonCaractere) = True Then

'Si le chiffre est un 0 et que c'est le premier de la série de chiffres

If MonCaractere = 0 Then

If Position > 1 Then

'Si le caractère avant ce zéro n'est pas un chiffre

If IsNumeric(Mid(MaChaineDeCaracteres, Position - 1, 1)) = False Then

DebutSerieDeZeros = True

Else

DebutSerieDeZeros = False

End If

Else 'Si le zéro est le premier caractère de la chaine

DebutSerieDeZeros = True

End If

Else

DebutSerieDeZeros = False

End If 'If MonCaractere = 0 Then

'Si on est au début d'une série de chiffres et tant que le premier chiffre est un zéro, alors on l'élimine

If DebutSerieDeZeros = True Then

MaChaineDeCaracteres = Left(MaChaineDeCaracteres, Position - 1) & Mid(MaChaineDeCaracteres, Position + 1)

Position = Position - 1

LongueurChaine = LongueurChaine - 1

End If

RetirerLesZeros = MaChaineDeCaracteres

End If 'If Len(MonCaractere) > 0 Then

End If

End Function

AUTRE - Tableau Dynamique - Exemple VB numero 1
Dim Tableau() 'Un tableau dynamique
Redim Tableau(3,5) 'Redimensionnement en un tableau de 2 dimensions allant de 0 à 3 et de 0 à 5
Redim Tableau(4,3,5) 'Redimensionnement en un tableau de 3 dimensions

AUTRE - Tableau Dynamique - Exemple VB numero 2
'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/script56/html/vsstmredim.asp
'

Dim Tableau() 'Un tableau dynamique
Dim CompteurTableau

Call UneProcedure("PourExemple",Tableau())

'On affiche le contenu
For CompteurTableau = LBound(Tableau) To UBound(Tableau)

Msgbox Tableau(CompteurTableau)
Next

Public Sub UneProcedure(ByVal UneVariableBidon As String, ByRef TableauResultat())

ReDim TableauResultat(1 To 1) 'On Vide et on fait un tableau de base 1

ReDim Preserve TableauResultat(1 To CompteurResultat) 'On redimensionne et on préserve les valeurs du tableau
End Sub

AUTRE - Tableau Eliminer lignes consecutives en doublon
Public Sub EliminerLignesTableauEnDoublon(ByRef MonTableau1D)

'Version du 22 octobre 2008

'Elimine les lignes consécutives en doublon

'MonTableau = Array("a","A","b","b","b","e","f","g","g")

'Call EliminerLignesTableauEnDoublon(MonTableau)

'For Each MaLigne In MonTableau

'resultat = MaLigne

'Next

Dim NumeroLigne

Dim MaValeurN

Dim MaValeurNplus1

Dim ValeursDeMonTableau

Dim MonTableauFinal

Const MonSeparateur = ";"

'Si mon tableau fait plus de 2 lignes

If UBound(MonTableau1D) > 1 Then

'Boucle allant de la premiere ligne du tableau jusqu a l avant derniere

For NumeroLigne = LBound(MonTableau1D) To (UBound(MonTableau1D)-1) Step 1

'On retient la valeur actuelle ainsi que la suivante

MaValeurN = MonTableau1D(NumeroLigne)

MaValeurNplus1 = MonTableau1D(NumeroLigne+1)

'Si les lignes consécutives ne sont identiques, retient la valeur actuelle et on l ajoute au tableau sans doublons

If Lcase(MaValeurN) <> Lcase(MaValeurNplus1) Then

ValeursDeMonTableau = ValeursDeMonTableau & MaValeurN & MonSeparateur

End If

Next 'For NumeroLigne = LBound(MonTableau1D) To ((UBound(MonTableau1D)-1)

'On termine en retenant la derniere valeur du tableau donne en entre. Cette ligne est forcement unique

MaValeurN = MonTableau1D(UBound(MonTableau1D))

ValeursDeMonTableau = ValeursDeMonTableau & MaValeurN

MonTableau1D = Split(ValeursDeMonTableau,";")

End If 'If UBound(MonTableau1D) > 1 Then

End Sub

AUTRE - Traiter un nom ou un prenom pour une recherche
Public Function TraiterNomPrenom(ByVal ZeNom)

'Version du 18 janvier 2007

'En entrée un nom ou un prenom a particule

'En sortie, le meme mais sans

'De préférence, il faut associer ce traitement avec un process de remplacement des caractères spéciaux

Dim ListPrefixASupprimer 'A separer pas des ;

Dim UnPrefix

Dim MonTableau

ListPrefixASupprimer = "de;de la;du;le;mc;di;el" 'Liste de préfixes en minuscule

MonTableau = Split(ListPrefixASupprimer, ";")

TraiterNomPrenom = ZeNom 'Par défaut on retourne la même chose qu'en entrée

ZeNom = Trim(ZeNom)

ZeNom = Replace(ZeNom, " ", " ") 'On remplace les espaces doubles par un espace simple

'Il doit y avoir une longueur minimale

If Len(ZeNom) > 4 Then

'Recherche et suppression des préfixes

For Each UnPrefix In MonTableau

'UnPrefix = UnPrefix & " " 'On ajoute un espace après le prefix pour que cela soit bien une particule

If Left(LCase(ZeNom), Len(UnPrefix)) = UnPrefix Then

ZeNom = Mid(ZeNom, Len(UnPrefix) + 1)

ZeNom = Trim(ZeNom)

Exit For

End If

If Len(ZeNom) > 4 Then

'Si le 2ème caractère est un espace, on retire le premier

If Mid(LCase(ZeNom), 2, 1) = " " Then

ZeNom = Mid(ZeNom, 3)

ZeNom = Trim(ZeNom)

End If

'Si le nom ou le prénom contient un -, on ne garde que ce qui est avant

Position = InStr(1, ZeNom, "-")

If Position > 2 Then

ZeNom = Left(ZeNom, Position - 1)

End If

'Si le nom ou le prénom contient un espace, on ne garde que ce qui est avant

Position = InStr(1, ZeNom, " ")

If Position > 4 Then

ZeNom = Left(ZeNom, Position - 1)

End If

'On retourne le résultat traité

TraiterNomPrenom = ZeNom

End Function

AUTRE - Transformation d'un tableau de 2 dimensions en un tableau a 1 dimension
Dim MonTableau2D() 'Un tableau dynamique
Redim MonTableau2D(2,2) 'Déclaré en 2 dimensions

MonTableau2D(0,0) = "OneOne"
MonTableau2D(1,1) = "TwoTwo"
MonTableau2D(1,2) = "TwoThree"
MonTableau2D(2,1) = "ThreeTwo"
MonTableau2D(0,1) = "OneTwo"
MonTableau2D(1,0) = "TwoOne"

Call TransFormerTableau(MonTableau2D,";")

'Affichage du tableau
For Each Resultat in MonTableau2D

Wscript.Echo Resultat
Next

Public Sub TransFormerTableau(ByRef MonTableau2D, ByVal SeparateurColonne)

Dim MaLigne

Dim MonTableauTempo()

Redim MonTableauTempo(Ubound(MonTableau2D,1))

'Transformation d'un tableau à 2 dimensions en un tableau à une dimension

'Les colonnes sont matérialisées par un caractère de séparateur de colonne (un peu comme un csv)

For CompteurLigne = Lbound(MonTableau2D,1) To Ubound(MonTableau2D,1)

MaLigne = ""

For CompteurColonne = Lbound(MonTableau2D,2) To Ubound(MonTableau2D,2)

MaLigne = MaLigne & MonTableau2D(CompteurLigne,CompteurColonne) & SeparateurColonne

MaLigne = Left(MaLigne,Len(MaLigne)-Len(SeparateurColonne))

MonTableauTempo(CompteurLigne) = MaLigne

'On transforme le tableau qui était en 2 dimensons en tableau à une dimension

Redim MonTableau2D(Ubound(MonTableauTempo))

'On recopie le tableau temporaire dans le tableau final

For CompteurLigne = Lbound(MonTableauTempo) To Ubound(MonTableauTempo)

MonTableau2D(CompteurLigne) = MonTableauTempo(CompteurLigne)

Next

End Sub

AUTRE - Tri a Bulle d'un tableau à 1 dimension

'Tri a bulle
'Code provenant de
'http://www.microsoft.com/technet/scriptcenter/resources/qanda/nov04/hey1122.mspx

Dim MonTableau

MonTableau = Array("t","h","i","e") 'Création d'un tableau à trier
'MonTableau = Array("i","c","o","a")

'Appel de la procédure de tri
Call TrierTableau(MonTableau)

'Affichage du tableau trié
For Each MaLigne in MonTableau

Wscript.Echo MaLigne
Next

Public Sub TrierTableau(ByRef MonTableau1D)

'Version du 22 octobre 2008

'Ex Version du 25 septembre 2008

Dim TailleMinTableau

Dim TailleMaxTableau

Dim MaVariable

For TailleMaxTableau = (UBound(MonTableau1D) - 1) to 0 Step -1

For TailleMinTableau= 0 to TailleMaxTableau

'Si la valeur n est plus grande que la valeur n+1

If UCase(MonTableau1D(TailleMinTableau)) > UCase(MonTableau1D(TailleMinTableau+1)) Then

'On permutte les 2 valeurs

MaVariable = MonTableau1D(TailleMinTableau+1)

MonTableau1D(TailleMinTableau+1) = MonTableau1D(TailleMinTableau)

MonTableau1D(TailleMinTableau) = MaVariable

End If

Next
End Sub

AUTRE - Tri a Bulle d'un tableau à 2 dimensions
Dim SeparateurColonne
SeparateurColonne = ";"

'Création d'un tableau à 2 dimensions pour l'exemple
Dim MonTableau2D (2,2)

MonTableau2D(0,0) = "OneOne"
MonTableau2D(1,1) = "TwoTwo"
MonTableau2D(1,2) = "TwoThree"
MonTableau2D(2,1) = "ThreeTwo"
MonTableau2D(0,1) = "OneTwo"
MonTableau2D(1,0) = "TwoOne"

Call TrierTableau2D(MonTableau2D, SeparateurColonne)

'On Affiche le tableau à 2 dimensions trié
Wscript.Echo ""
Wscript.Echo "Tableau trié"
For CompteurLigne = Lbound(MonTableau2D,1) To Ubound(MonTableau2D,1)

MaLigne = ""

For CompteurColonne = Lbound(MonTableau2D,2) To Ubound(MonTableau2D,2)

MaLigne = MaLigne & MonTableau2D(CompteurLigne,CompteurColonne) & ";"

MaLigne = Left(MaLigne,Len(MaLigne)-1)

Wscript.Echo MaLigne

Next

Public Sub TrierTableau2D(ByRef MonTableau2D, ByVal SeparateurColonne)

'Le tri d'un tableau en 2D fait appel à la fonction de tri d'un tableau en une dimension

Dim TableauLigne

Dim MonTableauTempo()

Redim MonTableauTempo(Ubound(MonTableau2D,1))

'Transformation d'un tableau à 2 dimensions en un tableau à une dimension

'Les colonnes sont matérialisées par un caractère de séparateur de colonne (un peu comme un csv)

For CompteurLigne = Lbound(MonTableau2D,1) To Ubound(MonTableau2D,1)

MaLigne = ""

For CompteurColonne = Lbound(MonTableau2D,2) To Ubound(MonTableau2D,2)

MaLigne = MaLigne & MonTableau2D(CompteurLigne,CompteurColonne) & SeparateurColonne

MaLigne = Left(MaLigne,Len(MaLigne)-Len(SeparateurColonne))

MonTableauTempo(CompteurLigne) = MaLigne

Call TrierTableau(MonTableauTempo,SeparateurColonne)

'On reconvertit le tableau à une dimension dans le tableau à 2 dimensions

For CompteurLigne = Lbound(MonTableauTempo) To Ubound(MonTableauTempo)

Resultat = MonTableauTempo(CompteurLigne)

TableauLigne = Split(Resultat,SeparateurColonne)

For CompteurColonne = Lbound(TableauLigne) To Ubound(TableauLigne)

MonTableau2D(CompteurLigne,CompteurColonne) = TableauLigne(CompteurColonne)

Next

End Sub

Public Sub TrierTableau(ByRef MonTableau1D, ByVal SeparateurColonne)

Dim TailleMinTableau

Dim TailleMaxTableau

Dim LigneN

Dim LigneNPlus1

Dim MaVariable

For TailleMaxTableau = (UBound(MonTableau1D) - 1) to 0 Step -1

For TailleMinTableau= 0 to TailleMaxTableau

'Si la valeur n est plus grande que la valeur n+1

LigneN = UCase(MonTableau1D(TailleMinTableau))

LigneNPlus1 = UCase(MonTableau1D(TailleMinTableau+1))

LigneN = Replace(LigneN,SeparateurColonne,"")

LigneNPlus1 = Replace(LigneNPlus1,SeparateurColonne,"")

If LigneN > LigneNPlus1 Then

'On permutte les 2 valeurs

MaVariable = MonTableau1D(TailleMinTableau+1)

MonTableau1D(TailleMinTableau+1) = MonTableau1D(TailleMinTableau)

MonTableau1D(TailleMinTableau) = MaVariable

End If

Next

End Sub

AUTRE - Verifier la presence d un nom ET d un prenom dans une variable
Public Function VerifierPresenceNomPrenom(ByVal MonNomEtPrenom)

'Version du 06/02/2007

'Retourne 1 si on a bien un nom ET un prénom

'Retourne 0 dans le cas contraire

Dim TableauPrefix

Dim UnPrefix

Dim TableauComposants

Dim UnComposant

Dim NbrGrandsComposants

Const ValeursDePrefix = "M.;Mr;Mme;Mlle;M;Me;Miss;Mc;Mac;De;El"

'Valeur par defaut

VerifierPresenceNomPrenom = 1

MonNomEtPrenom = Trim(MonNomEtPrenom)

'On remplace les espaces doubles par des espaces simples

MonNomEtPrenom = Replace(MonNomEtPrenom, " ", " ")

TableauPrefix = Split(ValeursDePrefix,";")

'On retire les prefix potentiels

For Each UnPrefix In TableauPrefix

UnPrefix = UnPrefix & " "

If Lcase(UnPrefix) = Left(Lcase(MonNomEtPrenom),Len(UnPrefix)) Then

MonNomEtPrenom = Mid(MonNomEtPrenom,Len(UnPrefix)+1)

End If

'On remplace les points par des espaces

MonNomEtPrenom = Replace(MonNomEtPrenom, ".", " ")

'Si il n y a pas au moins un espace dans la variable

If InStr(1,MonNomEtPrenom," ") = 0 Then

VerifierPresenceNomPrenom = 0

End If

'Si on n a pas au moins 2 composants d une longueur supp à 1 alors ce n est pas bon

'Si il n y a que 2 composants et qu on trouve un composant d une longueur de 1 alors ce n est pas bon

'Exemple :

'O Bun n est pas bon

'O Bun Do est bon

TableauComposants = Split(MonNomEtPrenom," ")

NbrGrandsComposants = 0

For Each UnComposant In TableauComposants

If Len(UnComposant) > 1 Then

NbrGrandsComposants = NbrGrandsComposants + 1

End If

If NbrGrandsComposants < 2 Then

VerifierPresenceNomPrenom = 0

End If

End Function

AUTRE - Verifier le domaine du user actuellement connecté
Public Function UserIsInDomain(ByVal NomDomaine)

'Version du 2 mai 2006

'Retourne 1 si le user actuellement connecté est dans le domaine demandé

'Exemple :

'avec le user Contoso\Julien actuellement connecté

'MonBoll = UserIsInDomain("Contoso")

'MonBoll retourne 1

Dim objNetwork

NomDomaine = Trim(Lcase(NomDomaine))

Set objNetwork = CreateObject("Wscript.Network")

If Lcase(objNetwork.UserDomain) = NomDomaine Then

UserIsInDomain = 1

Else

UserIsInDomain = 0

End If

Set objNetwork = Nothing

End Function

ASP - Forcer la declaration des variables
<% OPTION EXPLICIT %>

ASP - recuperer le chemin local de la page hebergeant la page ASP
Dim CheminPage
Dim Compteur

CheminPage = Server.MapPath(Request.ServerVariables("PATH_INFO"))
Compteur = Instrrev(CheminPage,"\")
CheminPage = Left(CheminPage,Compteur-1)

BBCode - Diver
Source : http://fr.wikipedia.org/wiki/Bbcode
Texte en gras : [b]Texte[/b] = Texte.
Texte en italique : [i]Texte[/i] = Texte.
Texte souligné : [u]Texte[/u] = Texte.
Texte colorié en rouge : [color=red]Texte[/color] = Texte
Lien hypertexte : [url=URL du lien]Titre du lien[/url] ou [url]URL du lien[/url] = Wikipédia ou http://fr.wikipedia.org
Lien hypertexte et image : [url=URL du lien][img]Url de l'image[/img][/url]
Il est aussi possible de rencontrer :

Texte centré [center]Texte[/center]
Texte défilant [scroll]Texte[/scroll]
Texte remontant [updown]Texte[/updown]
On peut aussi faire des melanges:

Texte defilant en diagonal: [scroll][updown]Texte[/updown][/scroll]

BBCode - Lien Hypertext
[url=URL du lien]Titre du lien[/url]

Excel - Chemin du repertoire contenant le fichier Excel
Dim CheminRepertoireFichierExcel

CheminRepertoireFichierExcel = Application.ActiveWorkbook.Path
MsgBox "Chemin du répertoire du présent fichier excel :" & vbCrLf & CheminRepertoireFichierExcel

Excel - Conversion Minutes en Heures Minutes
Public Function ConversionMinutesEnHeuresMinutes(ByVal TotalMinutes As Integer) As String

Dim TotalHeures As Integer

TotalHeures = 0

While TotalMinutes - 60 >= 0

TotalMinutes = TotalMinutes - 60
TotalHeures = TotalHeures + 1

Wend

ConversionMinutesEnHeuresMinutes = TotalHeures & "H" & TotalMinutes

End Function

Excel - Conversion Semaines en Mois-Semaine

Public Function ConversionSemainesEnMoisSemaine(ByVal NumeroSemaine As Integer, ByVal NumeroAnnee As Integer, ByRef ResultatMois, ByRef ResultatSemaine, ByRef MessageInformation As String)

Dim DateDeBase As Date

Dim DateResultat As Date

Dim SemaineTest

DateDeBase = "1/1/" & NumeroAnnee

DateDeBase = DateDeBase - 7

DateResultat = "1/1/" & NumeroAnnee

While SemaineTest < NumeroSemaine

SemaineTest = DateDiff("ww", DateDeBase, DateResultat, vbMonday)

DateResultat = DateResultat + 1

Wend

MessageInformation = "Semaine commencant le " & DateResultat - 1

ResultatMois = Month(DateResultat)

DateDeBase = "1/" & Month(DateResultat) & "/" & NumeroAnnee

DateDeBase = DateDeBase - 7

ResultatSemaine = DateDiff("ww", DateDeBase, DateResultat, vbMonday)

End Function

Excel - Copier une table excel dans une base SQL Serveur

'Cette procédure est à mettre dans un module. Ensuite elle est vue comme une macro
'Ce code nécesite la modification de certaine variables
Public Sub Ajouter()

Dim MonRecordset As New ADODB.Recordset

Dim NombreTotal

Dim MaSheet As Excel.Worksheet

Dim MaValeur As String

Dim AncienDisplayName

Dim NouveauDisplayName

Dim NombreModifAccent

Const ForReading = 1

Const ForWriting = 2

Const ForAppending = 8

'Constantes pour le recordset

Const adOpenForwardOnly = 0

Const adOpenKeyset = 1

Const adOpenDynamic = 2

Const adOpenStatic = 3

'---- LockTypeEnum Values ----

Const adLockReadOnly = 1

Const adLockPessimistic = 2

Const adLockOptimistic = 3

Const adLockBatchOptimistic = 4

'---- CursorLocationEnum Values ----

Const adUseServer = 2

Const adUseClient = 3

Const adCmdText = 1

NomServeurSQL = "Mcsrvbda10"

NomBaseSQLServeur = "WebSecure"

NomTableSQLServeur = "dbo.Annuaire"

NomFeuilleExcel = "annuaireFrance"

'Reste le nom des colonnes de la table SQL cible à rectifier plus loin dans le code

Set MaConnection = CreateObject("ADODB.Connection")

Set MonRecordset = CreateObject("ADODB.Recordset")

MaConnection.Mode = adModeReadWrite

MaConnection.ConnectionString = "PROVIDER=SQLOLEDB;" & _

"data source=" & NomServeurSQL & ";" & _

"database=" & NomBaseSQLServeur & ";" & _

"Integrated Security=SSPI;"

'"persist security info=False;"

'"User Id=utilisateur;Password=lemdp;"

MaConnection.Open

RequeteSql = "SELECT *"

RequeteSql = RequeteSql & " " & "FROM " & NomTableSQLServeur

RequeteSql = RequeteSql & " " & ";"

MonRecordset.Open RequeteSql, MaConnection, adOpenKeyset, adLockOptimistic

'For Compteur = 0 To UnRecordset.fields.Count - 1

' UnRecordset.fields(Compteur).Name

'Next

'Ligne de départ

Compteur = 2

Set MaSheet = ActiveWorkbook.Sheets(NomFeuilleExcel)

'MsgBox MaSheet.Cells(Compteur, 1).FormulaR1C1

Do While Len(MaSheet.Cells(Compteur, 1).FormulaR1C1) > 0

DoEvents

MonRecordset.AddNew

MonRecordset![MaColonne1] = MaSheet.Cells(Compteur, 1).FormulaR1C1

MonRecordset![MaColonne2] = MaSheet.Cells(Compteur, 2).FormulaR1C1

MonRecordset![MaColonne3] = MaSheet.Cells(Compteur, 4).FormulaR1C1

Compteur = Compteur + 1

Loop

MonRecordset.Update

'MaSheet.Range(Cells(1, 1), Cells(800, 5)).FormulaR1C1 = ""

MonRecordset.Close

Set MaSheet = Nothing

Set MonRecordset = Nothing

Set MaConnection = Nothing

End Sub

Excel - Créer une connexion sur une Feuille Excel

'Exemple sur
'http://support.microsoft.com/kb/278973/EN-US/

Dim MaConnection
Dim UnRecordset
Dim Compteur
Dim CheminFichierExcel 'Emplacement du fichier excel
Dim NomFeuille 'Nom de la feuille contenant les données
Dim PlageDonnees

'Constantes pour le recordset
Const adOpenForwardOnly = 0
Const adOpenKeyset = 1
Const adOpenDynamic = 2
Const adOpenStatic = 3

Set MaConnection = CreateObject("ADODB.Connection")
Set UnRecordset = CreateObject("ADODB.Recordset")

CheminFichierExcel = Application.ActiveWorkbook.Path & "\" & Application.ActiveWorkbook.Name
NomFeuille = "Feuil1"
PlageDonnees = "" 'Par exemple "A1:B10"

MaConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & CheminFichierExcel & ";" & _
"Extended Properties=""Excel 8.0;"""

'Ouverture d'un recordset à partir d'une requete SQL
UnRecordset.Open "Select * From [" & NomFeuille & "$" & PlageDonnees & "] Where b=5", MaConnection, adOpenKeyset

If UnRecordset.BOF = False Then UnRecordset.MoveFirst 'Si on est pas au début des résultats, on y va

'Pour tous les résultats contenus dans le recordset
Do While UnRecordset.EOF = False

'Affichage des valeurs de chaque champ

For Compteur = 0 To UnRecordset.fields.Count - 1

MsgBox "Valeur du champ " & UnRecordset.fields(Compteur).Name & " : " & Trim(UnRecordset.fields(Compteur).Value)

'On passe à la ligne suivante

UnRecordset.MoveNext
Loop

'Fermeture et destruction des objets
UnRecordset.Close
MaConnection.Close
Set UnRecordset = Nothing
Set MaConnection = Nothing

Excel - Ouvrir un fichier Excel
Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open("C:\Scripts\New_users.xls")

intRow = 2

Do Until objExcel.Cells(intRow,1).Value = ""
Wscript.Echo "CN: " & objExcel.Cells(intRow, 1).Value
Wscript.Echo "sAMAccountName: " & objExcel.Cells(intRow, 2).Value
Wscript.Echo "GivenName: " & objExcel.Cells(intRow, 3).Value
Wscript.Echo "LastName: " & objExcel.Cells(intRow, 4).Value
intRow = intRow + 1
Loop

Set objWorkbook = Nothing
Set objExcel = Nothing

Excel - Ouvrir un fichier Excel bis
Dim ObjetWorkBook As Workbooks

'Création de l'objet contenant les fichiers excel
Set ObjetWorkBook = Workbooks

'On ouvre le classeur en lecture seul
Call ObjetWorkBook.Open(CheminFichierExcel, 0, True)

'Je rend visible la feuille excel
Application.Visible = True

'Je passe tous les classeurs Excel en revue
For Each MonWorkBook In ObjetWorkBook

'Optionnel

'Si le nom du classeur correspond a celui recherché

'If MonWorkBook.Name = NomFichierExcel Then

'End If

MonWorkBook.Activate 'Je me positionne sur le classeur

Sheets("NomDeLaFeuille").Select 'On se positionne sur la feuille voulue

Range("C8").Select 'Je me place sur une case voule

Cells(numligne, numcolonne).Select 'Seconde solution pour se placer sur la case voule

ActiveCell.Show 'J'affiche la feuille

ActiveSheet.Unprotect ("le mot de passe") 'Je retire la protection de la feuille

Columns("D:AP").EntireColumn.Hidden = False 'Je rends visible toutes les colonnes éventuellement cachées

Application.ScreenUpdating = True 'Au cas ou, je valide la possobilite de rafraichir la feuille excel

Next

Excel - Passer en revue le contenu de la première colonne
Public Sub Start()

'Version du 25 octobre 2006
'Enumere toutes les valeurs contenues dans la première colonne
Dim CompteurLigne
Dim NomFeuille
Dim ContenuCase 'Contenu d une case

NomFeuille = "Feuil1"

Sheets(NomFeuille).Select
CompteurLigne = 1
Do

ContenuCase = Trim(Cells(CompteurLigne, 1).FormulaR1C1)
CompteurLigne = CompteurLigne + 1
DoEvents

'Mettez ici le code que vous voulez

Loop While Len(ContenuCase) > 0

End Sub

Excel - Passer en revue le contenu des cases d'une feuille
'Le code tourne en tant que Macro dans Excel
Dim NomFeuille
Dim NumLigneDepart
Dim NumColonneDepart
Dim NumLigneFin
Dim NumColonneFin
Dim CompteurLigne
Dim CompteurColonne

NomFeuille = "Feuil1" 'Indiquez le nom de la feuille a scruter dans cette variable
NumLigneDepart = 1
NumColonneDepart = 1
NumLigneFin = 10
NumColonneFin = 2

Sheets(NomFeuille).Select
For CompteurColonne = NumColonneDepart To NumColonneFin

For CompteurLigne = NumLigneDepart To NumLigneFin

'Mettez ici le code que vous voulez executer sur les cellules

'Par exemple ici on supprime les espaces en trop

Cells(CompteurLigne, CompteurColonne).FormulaR1C1 = Trim(Cells(CompteurLigne, CompteurColonne).FormulaR1C1)

Next
Next

Exchange - Convertir un chemin LDAP en chemin exploitable pour ExMerge
Public Function CheminLDAP2CheminExMerge(ByVal CheminLDAPBoiteMail)

'Version du 16 octobre 2006

Dim Position

Dim MonTableau

Dim Compteur

Dim MaVariable

Dim MaReponse

'document.write(CheminLDAPBoiteMail & "<BR>")

CheminLDAP2CheminExMerge = ""

If Len(CheminLDAPBoiteMail) > 0 Then

Position = InStr(1,CheminLDAPBoiteMail,"/cn=")

If Position > 0 Then

MaVariable = ""

MaVariable = Mid(CheminLDAPBoiteMail,Position+1)

MonTableau = Split(MaVariable,",")

'document.write LBound(MonTableau) & " " & UBound(MonTableau) & "<BR>"

'For Compteur = LBound(MonTableau) To UBound(MonTableau)

'document.write(MonTableau(Compteur) & "<BR>")

'Next

MaReponse = ""

For Compteur = LBound(MonTableau) To UBound(MonTableau)

MaReponse = "/" & MonTableau(Compteur) & MaReponse

'/o=NomSociete/ou=NomOU/cn=Recipients/cn=LeCompte

'LDAP://NomServeur/cn=LeCompte,cn=Recipients,ou=NomOU,o=NomSociete

'document.write(MaReponse & "<BR> <BR>")

CheminLDAP2CheminExMerge = MaReponse

End If 'If Position > 0 Then

End If 'If Len(CheminLDAPBoiteMail) > 0 Then

End Function

Exchange - Creer une boite mail sur un serveur Exchange 5.5
'Exemple sur
'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/ds2x/hh/ds2x/exds_ds2exchgd_0it4.asp
'On recupere le nom du serveur Exchange
NomServeurExchange = Trim(InputBox("Entrez le nom du serveur de messagerie","Serveur de messagerie","Nom du serveur 5.5"))
'On demande le login ou pseudo Exchange
UserName = Trim(InputBox("Entrez le login ou pseudo du compte mail","Pseudo de la boite","AATatayoyo"))
Set rootDSE = GetObject("LDAP://" & NomServeurExchange & "/RootDSE")

'On cré un objet qui représente le conteneur des boites mails exchange
Set objMBContainer = GetObject("LDAP://" & NomServeurExchange & "/CN=Recipients,OU=VotreNom" & "," & rootDSE.Get("defaultNamingContext"))

'Types d'objets Exchange
'"organizationalPerson" 'Boite mail
'"Remote-Address" 'Destinataire Particulier
'"groupOfNames") 'Liste de distribution

'Debut de la création de l'objet qui représente la boite mail
Set objMB = objMBContainer.Create("OrganizationalPerson", "cn=" & UserName) 'Correspond au login et au pseudo

objMB.Put "initials", Ucase("Initiales")
objMB.Put "mailPreferenceOption",0
objMB.Put "sn", "Nom de la personne"
objMB.Put "givenName", "Prenom de la personne"
objMB.Put "uid", "Pseudonyme ou Alias de la personne"

objMB.Put "cn", "nom complet"
objMB.Put "Company","Societe"
objMB.Put "Extension-Attribute-8", "Attribut etendu 8"
objMB.Put "Extension-Attribute-9", "Attribut etendu 8"
objMB.Put "l","Nom de la ville"
'objMB.Put "st","Departement"
objMB.Put "co","France" 'Pays

objMB.Put "textEncodedORAddress", "Adresse X400"
objMB.Put "mail", "Adresse SMTP"
objMB.PutEx ADS_PROPERTY_APPEND,"otherMailBox", Array("SMTP:" & "Adresse SMTP 2","SMTP:" & "Adresse SMTP 3") 'Les adresses SMTP supplementaires
'objMB.Put "Assoc-NT-Account",(arrSID)
'objMB.Put "NT-Security-Descriptor",(arrSD)
'objMB.Put "MDB-Use-Defaults",True
objMB.Put "Replication-Sensitivity",20
objMB.Put "MAPI-Recipient", True 'This allows for rich text messaging
objMB.SetInfo 'Creation effective de la boite mail

'Pour paramétrer le serveur associé
objMB.Put "Home-Server","ServeurExchangeAssocie"
objMB.SetInfo

'Destruction des objets
Set objMB = Nothing
Set objMBContainer = Nothing
Set rootDSE = Nothing

Exchange - Donner des droits à un compte sur une boite mail
'Nécessite la DLL ADSSECURITY.DLL qui est dans l'ADSI TOOL KIT

Dim mailBox
Dim oSid
Dim objADsSec
Dim objAce
Dim objSecDes
Dim objDAcl

'Pour les droits sur la boite Exchange

Const ADS_RIGHT_EXCH_MODIFY_USER_ATT = 2 '&H2
Const ADS_RIGHT_EXCH_MAIL_SEND_AS = 8 '&H8
Const ADS_RIGHT_EXCH_MAIL_RECEIVE_AS = 16 '&H10
Const ADS_ACETYPE_ACCESS_ALLOWED = 0 '&H0
Const ADS_ACETYPE_ACCESS_DENIED = 1 '&H1

CheminLDAPBoiteMail = "LDAP://NomServeurExchange/CN=NomAnnuaireDeLaBoite,CN=lenom,OU=lenom,O=lenom"

Set mailBox = GetObject(CheminLDAPBoiteMail)
Set oSid = CreateObject("ADsSid")
Set objADsSec = CreateObject("ADsSecurity")
Set objSecDes = objADsSec.GetSecurityDescriptor(mailBox.ADsPath)
Set objDAcl = objSecDes.DiscretionaryAcl
Set objAce = CreateObject("AccessControlEntry")

objAce.AccessMask = ADS_RIGHT_EXCH_MODIFY_USER_ATT Or ADS_RIGHT_EXCH_MAIL_SEND_AS Or ADS_RIGHT_EXCH_MAIL_RECEIVE_AS
objAce.Trustee = "Domaine\Login"
objAce.AceType = ADS_ACETYPE_ACCESS_ALLOWED
objDAcl.AddAce objAce
objSecDes.DiscretionaryAcl = objDAcl

On Error Resume Next
objADsSec.SetSecurityDescriptor objSecDes
NumeroErreur = Err.number
On Error Goto 0

Select Case NumeroErreur

Case 0

Case-2147024891

Wscript.echo "Vous n'avez pas les droits nécessaires"

Case Else

Wscript.echo "Erreur numero " & NumeroErreur
End Select

Set mailBox = Nothing
Set objAce = Nothing
Set oSid = Nothing
Set objADsSec = Nothing

Exchange - Creer une liste de distribution avec CDOEXM et ADSI
'Creating a Distribution List Using CDOEXM and ADSI
'http://msdn.microsoft.com/library/en-us/wss/wss/_clb_creating_a_distribution_list_using_emo_and_adsi_vb.asp

Exchange - Creer une liste de distribution pour Exchange 5.5
'http://msdn.microsoft.com/library/en-us/ds2x/hh/ds2x/exds_ds2exchgd_73p5.asp

Dim objRecipients As IADsContainer
Dim objNewDL As IADs
Dim ADOConn As ADODB.Connection
Dim ADOCommand As New ADODB.Command
Dim RS As ADODB.Recordset

Set objRecipients = GetObject(strRecipientsPath)

Set ADOconn = CreateObject("ADODB.Connection")
ADOconn.Provider = "ADSDSOObject"
ADOconn.Open "Active Directory Provider"

strADOQueryString = "<LDAP://Server>;
(&(objectClass=organizationalPerson)(l=New York));ADsPath;subtree"

Set RS = ADOconn.Execute(strADOQueryString)

'Check to see if any records were found
If Not RS.EOF Then

'Create a new DL

Set objNewDL = objRecipients.Create("groupOfNames", "cn=NewDL")

'Set the props

objNewDL.Put "cn", CStr(strDisplayname)

objNewDL.Put "uid", CStr(strAliasName)

objNewDL.Put "mail", CStr(strSMTPAddr)

objNewDL.Put "owner", "cn=user,cn=Recipients,ou=Site,o=Org"

objNewDL.SetInfo

While Not RS.EOF 'add every mailbox in the RS to the DL

objNewDL.Add RS.Fields(0).Value

RS.MoveNext

Wend

End If

RS.Close
Set ADOConn = Nothing
Set ADOCommand = Nothing
Set RS = Nothing
Set objRecipients = Nothing
Set objNewDL = Nothing

Exchange - Extraire les membres d une liste de diffusion - Version Simple
'Version du 07 dec 06
'Code à mettre dans un module Excel
'Les listes de diffusion membres de la liste à explorer seront aussi explorées
Public Sub Lancer()

Dim TableauResultat

Dim NbrResultat

Dim UnResultat

Dim CompteurLigne

Const NumeroLigneDepart = 1

CheminLDAPListDistrib = "LDAP://MonServeurExchange/CN=Recipients,OU=MonDomaine,O=COM"

TableauResultat = ExchangeExtractListeDiff(CheminLDAPListDistrib, NbrResultat)

CompteurLigne = NumeroLigneDepart

For Each UnResultat In TableauResultat

Cells(CompteurLigne, 1).FormulaR1C1 = UnResultat

CompteurLigne = CompteurLigne + 1

MsgBox "Termine"

End Sub

Public Function ExchangeExtractListeDiff(ByVal CheminLDAPListDistrib, ByRef NbrResultat)

'Using ADSI Exchange

'http://dev.coadmin.dk/Resources/ADSI%20SDK%205%20HTML/exchange.htm#dl_add

Dim ResultatFinal

ResultatFinal = ExplorerList(CheminLDAPListDistrib, NbrResultat)

ExchangeExtractListeDiff = Split(ResultatFinal, ";")

End Function

Public Function ExplorerList(ByVal CheminLDAPListDistrib, ByRef NbrResultat)

'Using ADSI Exchange

'http://dev.coadmin.dk/Resources/ADSI%20SDK%205%20HTML/exchange.htm#dl_add

Dim ObjListeDistrib

Dim NumeroErreur

Dim MembresListe

Dim SousMembresListe

Dim SousNbrResultat

MembresListe = ""

NbrResultat = 0

Set ObjListeDistrib = GetObject(CheminLDAPListDistrib)

For Each UnMembre In ObjListeDistrib.Members

'On regarde si le membre en contient lui même d'autres

On Error Resume Next

For Each Tata In UnMembre.Members

Exit For

NumeroErreur = Err.Number

On Error GoTo 0

'Si l'objet peux être exploré

If NumeroErreur = 0 Then

SousMembresListe = ExplorerList(UnMembre.ADsPath, SousNbrResultat)

NbrResultat = NbrResultat + SousNbrResultat

MembresListe = MembresListe & SousMembresListe & ";"

Else 'Si c'est juste un membre on l'additionne normalement

MembresListe = MembresListe & UnMembre.ADsPath & ";"

NbrResultat = NbrResultat + 1

End If 'If NumeroErreur = 0 Then

'ee = Toto.cn

'ee = Toto.adspath

'ee = Toto.Name

'ee = Toto.distinguishedName

If Len(MembresListe) > 0 Then

MembresListe = Left(MembresListe, Len(MembresListe) - 1)

ExplorerList = MembresListe

End If

Set ObjListeDistrib = Nothing

End Function

Exchange - Extraire une liste d'utilisateurs
Public Sub Lancer()

Dim UnResultat

Dim TableauResultat

Dim TableauUneLigne

Dim UnSousResultat

Dim NbrResultat

Dim NumeroLigne

Dim NumeroColonne

Dim CheminLDAPExtract

Const Separateur = "_#;?"

CheminLDAPExtract = "LDAP://MonServeurExchange/CN=Recipients,OU=MonDomaine,O=COM"

'For Each UnResultat In TableauResultat

'Wscript.Echo UnResultat

'Next

NumeroLigne = 1

TableauResultat = ExchangeExtract(CheminLDAPExtract, Separateur, NbrResultat)

For Each UnResultat In TableauResultat

TableauUneLigne = Split(UnResultat, Separateur)

NumeroColonne = 1

For Each UnSousResultat In TableauUneLigne

Cells(NumeroLigne, NumeroColonne).FormulaR1C1 = UnSousResultat

NumeroColonne = NumeroColonne + 1

DoEvents

NumeroLigne = NumeroLigne + 1

Next

End Sub

Public Function ExchangeExtract(ByVal CheminLDAPExtract, ByVal SeparateurDeColonnes, ByRef NbrResultat)

'Version du 05/12/2006

'Passage en parametres du nom du serveur Exchange

'Exemple d'utilisation

'Dim TableauResultat

'Call ExchangeExtract("MonServeurExchange")

'For each UnResultat in TableauResultat

'Msgbox UnResultat

'Next

Dim oConn 'As ADODB.Connection

Dim MonRecordset 'As ADODB.Recordset

Dim strQuery 'As String

Dim UnResultat

Dim LigneResultat 'Une ligne avec tous les resultats séparés par un caractère définit en constante

Dim ResultatTotal 'Contient toutes les lignes séparées par un caractère définit en constante

Const adUseServer = 2

Const adUseClient = 3

Const SeparateurDeResultats = "!;$"

TableauResultat = "" 'Par defaut

ExchangeExtract = "" 'Par defaut

If Len(SeparateurDeColonnes) = 0 Then

SeparateurDeColonnes = "_#;?"

End If

'strQuery = "<LDAP://" & strServerName & ">;(&(objectCategory=person)(Assoc-NT-Account=" & strSid & "));adspath,cn,mail;subtree"

'strQuery = "<LDAP://" & strServerName & ">;(&(objectClass=organizationalPerson));adspath,cn,mail,Assoc-NT-Account;subtree"

'strQuery = "<LDAP://" & strServerName & ">;(&(objectClass=person));adspath,cn,mail;subtree"

strQuery = "<" & CheminLDAPExtract & ">;(&(objectClass=person));adspath,cn,mail;subtree"

Set oConn = CreateObject("ADODB.Connection") 'Create an ADO Connection

oConn.Provider = "ADsDSOOBJECT" 'ADSI OLE-DB provider

'oConn.CursorLocation = adUseClient

oConn.Open "ADs Provider"

Set MonRecordset = oConn.Execute(strQuery)

NbrResultat = 0

ResultatTotal = ""

If MonRecordset.BOF = False Then

MonRecordset.MoveFirst

End If

While MonRecordset.EOF = False

LigneResultat = ""

'Extraction de la valeur de chaque colonne

For Compteur = 0 To (MonRecordset.Fields.Count - 1)

UnResultat = MonRecordset.Fields(Compteur).Value

If IsArray(UnResultat) = False Then

LigneResultat = LigneResultat & UnResultat & SeparateurDeColonnes

Else

UneLigne = ""

For Each LigneDeTableau In UnResultat

'Si la ligne du tableau n'est pas elle même une ligne de tableau

If IsArray(LigneDeTableau) = False Then

UneLigne = UneLigne & InterpreterResultat(LigneDeTableau)

Else

For Each SousLigneDeTableau In LigneDeTableau

UneLigne = UneLigne & InterpreterResultat(SousLigneDeTableau)

End If

LigneResultat = LigneResultat & UneLigne & SeparateurDeColonnes

End If

'Si on a réussit à extraire une ligne

LigneResultat = Trim(LigneResultat)

If Len(LigneResultat) > 0 Then

LigneResultat = Left(LigneResultat, Len(LigneResultat) - Len(SeparateurDeColonnes))

End If

ResultatTotal = ResultatTotal & LigneResultat & SeparateurDeResultats

'Wscript.Echo LigneResultat

NbrResultat = NbrResultat + 1

MonRecordset.MoveNext

Wend 'While MonRecordset.EOF = False

If Len(ResultatTotal) > 0 Then

ResultatTotal = Left(ResultatTotal, Len(ResultatTotal) - Len(SeparateurDeResultats))

End If

If NbrResultat > 0 Then

TableauResultat = Split(ResultatTotal, SeparateurDeResultats)

ExchangeExtract = TableauResultat

End If

MonRecordset.Close

oConn.Close

Set MonRecordset = Nothing

Set oConn = Nothing

End Function

Public Function InterpreterResultat(ByVal MonResultat)

'Si le résultat est un héxadécimal, on le traite différemment

'Sinon rien ne change

'Si on est face à un hexadecimal

If VarType(MonResultat) = 17 Then

'On force le résultat à être sous forme Hexadécimal.

'Il ne sera pas convertit automatiquement en décimal par le système

'Si l'hexadécimal est de longueur 1, on rajoute un 0 pour qu'il soit sur 2

If Len(Hex(MonResultat)) = 1 Then

MonResultat = "0" & Hex(MonResultat)

Else

MonResultat = Hex(MonResultat)

End If

'On retourne le résultat

InterpreterResultat = MonResultat

End Function

Exchange - Interroger le serveur Exchange avec une requete LDAP

Dim NbrResultat
Dim TableauResultat
Dim SousTableauResultat
Dim UnSousResultat

'FiltreLDAP = "(&(objectClass=organizationalPerson)(mail=anemail@mondomaine.com))"
'FiltreLDAP = "(&(objectClass=organizationalPerson)(givenname=*christophe*))"
FiltreLDAP = "(&(objectClass=organizationalPerson)(Assoc-NT-Account=01050000000000051500000040780F00BC068B288C533D78E10A0000))"
ChampsDemandes = "mail"

Call InterrogerLDAPEXchange("ZFRMSXIDF05", FiltreLDAP, ChampsDemandes, TableauResultat, NbrResultat)

If NbrResultat > 0 Then
For Each UnResultat In TableauResultat
SousTableauResultat = Split(UnResultat, "$")
For Each UnSousResultat In SousTableauResultat
rr = UnSousResultat
Next
Next
End If 'If NbrResultat > 0 Then

Public Sub InterrogerLDAPEXchange(ByVal strServerName, ByVal FiltreLDAP, ByVal ChampsDemandes, ByRef TableauResultat, ByRef NbrResultat)

'Version du 02/08/2006

'Fonction pour exectuer une requete LDAP sur un serveur EXCHANGE

'On passe en paramètres

'Le nom du serveur

'le filtre LDAP eventuel

'les champs demandes en retour

'une variable qui recevra un tableau avec les resultats

'une variable qui recevra le nombre de réponses

'Exemple d'utilisation

'Dim NbrResultat

'Dim TableauResultat

'Dim SousTableauResultat

'Dim UnSousResultat

'FiltreLDAP = "(&(objectClass=organizationalPerson)(Assoc-NT-Account=01050000000000051500000040780F00BC068B288C533D78E10A0000))"

'FiltreLDAP = "(&(objectClass=organizationalPerson)(mail=monemail@mondomaine.com))"

'ChampsDemandes = "adspath,cn,mail"

'Call InterrogerLDAPEXchange("ZFRMSXIDF05", FiltreLDAP, ChampsDemandes, TableauResultat, NbrResultat)

'If NbrResultat > 0 Then

For Each UnResultat In TableauResultat

SousTableauResultat = Split(UnResultat, "$")

For Each UnSousResultat In SousTableauResultat

MsgBox UnSousResultat

'End If 'If NbrResultat > 0 Then

Dim oConn 'As ADODB.Connection

Dim oRS 'As ADODB.Recordset

Dim strQuery 'As String

Dim LigneResultat 'Une ligne avec tous les resultats séparés par un ;

Dim LigneSousResultat

Dim BoolContinuer 'A 1 si on continu sinon a 0

Dim TableauChamps

Dim UnChamp

Const adUseServer = 2

Const adUseClient = 3

NbrResultat = 0

TableauResultat = "" 'Par defaut

If Len(strServerName) > 0 Then

strQuery = "<LDAP://" & strServerName & ">;" & FiltreLDAP & ";" & ChampsDemandes & ";subtree"

Set oConn = CreateObject("ADODB.Connection") 'Create an ADO Connection

oConn.Provider = "ADsDSOOBJECT" 'ADSI OLE-DB provider

oConn.Open "ADs Provider"

Set oRS = oConn.Execute(strQuery)

NbrResultat = 0

LigneResultat = ""

'Si il n'y a aucuns resultats

If oRS.BOF And oRS.EOF Then

Else

While Not oRS.EOF

NbrResultat = NbrResultat + 1

TableauChamps = Split(ChampsDemandes, ",")

LigneSousResultat = ""

For Each UnChamp In TableauChamps

LigneSousResultat = LigneSousResultat & oRS.Fields(UnChamp) & "$"

If Len(LigneSousResultat) > 0 Then

LigneSousResultat = Left(LigneSousResultat, Len(LigneSousResultat) - 1)

End If

LigneResultat = LigneResultat & LigneSousResultat & ";"

oRS.MoveNext

Wend

End If

If NbrResultat > 0 And Len(LigneResultat) > 1 Then

LigneResultat = Left(LigneResultat, Len(LigneResultat) - 1)

TableauResultat = Split(LigneResultat, ";")

End If

oRS.Close

oConn.Close

Set oRS = Nothing

Set oConn = Nothing

End If 'If Len(strServerName) > 0 Then

End Sub

Exchange - Lister les comptes en accès sur une boite mail
'Nécessite la DLL ADSSECURITY.DLL qui est dans l'ADSI TOOL KIT
Dim mailBox
Dim oSid
Dim objADsSec
Dim objAce
Dim objSecDes
Dim objDAcl
Dim CheminLDAPBoiteMail

CheminLDAPBoiteMail = "LDAP://NomServeurExchange/CN=NomAnnuaireDeLaBoite,CN=lenom,OU=lenom,O=lenom"

Set mailBox = GetObject(CheminLDAPBoiteMail)
Set oSid = CreateObject("ADsSid")
Set objADsSec = CreateObject("ADsSecurity")
Set objSecDes = objADsSec.GetSecurityDescriptor(mailBox.ADsPath)
Set objDAcl = objSecDes.DiscretionaryAcl

Set objAce = CreateObject("AccessControlEntry")
For Each objAce In objDAcl

Resultat = objAce.Trustee

Wscript.Echo Resultat
Next

Set objAce = Nothing
Set mailBox = Nothing
Set objAce = Nothing
Set oSid = Nothing
Set objADsSec = Nothing

Exchange - Lister les membres d'une liste de distribution
Public Sub Lancer()

Dim TableauResultat
Dim NbrResultat
Dim UnResultat

CheminLDAPListDistrib = "LDAP://MonServeurExchange/CN=Conteneur,CN=Recipients,OU=MonDomaine,O=COM"

TableauResultat = ExchangeExtractListeDiff(CheminLDAPListDistrib, ";", NbrResultat)

For Each UnResultat In TableauResultat
ooo = UnResultat
Next

End Sub

Public Function ExchangeExtractListeDiff(ByVal CheminLDAPListDistrib, ByVal SeparateurDeColonnes, ByRef NbrResultat)

'Using ADSI Exchange
'http://dev.coadmin.dk/Resources/ADSI%20SDK%205%20HTML/exchange.htm#dl_add

Dim ObjListeDistrib

Set ObjListeDistrib = GetObject(CheminLDAPListDistrib)

For Each Toto In ObjListeDistrib.Members
ee = Toto.cn
ee = Toto.adspath
ee = Toto.Name
ee = Toto.distinguishedName
Next

Set ObjListeDistrib = Nothing

End Function

Exchange - Microsoft Exchange Event Scripting Agent
http://msdn.microsoft.com/library/default.asp?url=/library/en-us/e2k3/e2k3/_clb_enumerating_exchange_object_properties_with_adsi_ado_vb.asp

Exchange - Modifier la valeur maximale des messages
'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/e2k3/e2k3/_clb_enumerating_exchange_object_properties_with_adsi_ado_vb.asp
Dim objMTA As IADs
Set objMTA = GetObject("LDAP://Server/cn=Microsoft MTA,cn=Server,cn=Servers,cn=Configuration,ou=Site,o=Org")

objMTA.GetInfoEx Array("Deliv-Cont-Length"), 0
Debug.Print objMTA.Get("Deliv-Cont-Length")

objMTA.Put "Deliv-Cont-Length", 5000
objMTA.SetInfo
Set bjMTA = Nothing

Exchange - Trouver l adresse mail associee a un compte
Public Sub ExchangeRecipientForNtAccount(ByVal strServerName, ByVal strDomain, ByVal strUsername, ByVal FullName, ByVal TypeResultat, ByVal TypeValeurParDefaut, ByRef TableauResultat)

'Version du 13/09/2006

'Necessite la DLL ADsSecurity.dll du ResourceKit

'Passage en parametres du nom du serveur Exchange, du domaine, du login du user, du FullName du user, Type de Resultat voulu et du type de valeur par defaut

'Le FullName est facultatif, on peut rentrer une chaine vide si le nom n est pas connu

'Pour TypeResultat :

1 correspond à l'emplacement LDAP de la boite

2 correspond à l'adresse mail

'Pour TypeValeurParDefaut

Si vide on ne retourne rien si on a pas trouve d'adresse EMail

0 on ne retourne rien si on a pas trouve d'adresse EMail

1 on retourne le FullName ou a defaut rien si on a pas d adresse Mail

2 on retourne le FullName ou le Domaine\Login si on a pas d adresse Mail

'En retour on obtient le nom Canonique, l'adresse Email et le chemin LDAP de l'objet

'Exemple d'utilisation

'Dim TableauResultat

'Call ExchangeRecipientForNtAccount("NomDuServeur","Domaine","Login","FullName ou rien",2,1,TableauResultat)

'For each UnResultat in TableauResultat

'Msgbox UnResultat

'Next

Dim oConn 'As ADODB.Connection

Dim oRS 'As ADODB.Recordset

Dim oSid 'As ADSSECURITYLib.ADsSID

Dim strSid 'As String

Dim strQuery 'As String

Dim LigneResultat 'Une ligne avec tous les resultats séparés par un ;

Dim BoolContinuer 'A 1 si on continu sinon a 0

Dim NbrResultat

Const ADS_SID_RAW = 0

Const ADS_SID_HEXSTRING = 1

Const ADS_SID_SAM = 2

Const ADS_SID_UPN = 3

Const ADS_SID_SDDL = 4

Const ADS_SID_WINNT_PATH = 5

Const ADS_SID_ACTIVE_DIRECTORY_PATH = 6

Const ADS_SID_SID_BINDING = 7

Const adUseServer = 2

Const adUseClient = 3

TableauResultat = "" 'Par defaut

If IsNumeric(TypeResultat) = True Then

If Len(strServerName) > 0 And Len(strDomain) > 0 And Len(strUsername) > 0 Then

'Determination de la valeur par defaut

If IsNumeric(TypeValeurParDefaut) = True Then

If (TypeValeurParDefaut = 1) Or (TypeValeurParDefaut = 2) Then

'Par defaut si il est présent on retourne le FullName sinon on retourne le Domaine\Login

If Len(FullName) > 0 Then

TableauResultat = FullName

Else

If TypeValeurParDefaut = 2 Then

TableauResultat = strDomain & "\" & strUsername

End If

End If 'If TypeValeurParDefaut = 1 Then

End If 'If IsNumeric(TypeValeurParDefaut) = True

Set oSid = CreateObject("ADsSid") 'Dans la DLL ADsSecurity.dll du ResourceKit

Err.Clear

On Error Resume Next

BoolContinuer = 0

oSid.SetAs ADS_SID_WINNT_PATH, "WinNT://" & strDomain & "/" & strUsername 'Get the user account SID

strSid = oSid.GetAs(ADS_SID_HEXSTRING) 'Convert to binary string

If Err.Number = 0 And Len(strSid) > 0 Then

BoolContinuer = 1

On Error Goto 0

End If

On Error Goto 0

If BoolContinuer = 1 Then

'strQuery = "<LDAP://" & strServerName & ">;(&(objectCategory=person)(Assoc-NT-Account=" & strSid & "));adspath,cn,mail;subtree"

strQuery = "<LDAP://" & strServerName & ">;(&(objectClass=organizationalPerson)(Assoc-NT-Account=" & strSid & "));adspath,cn,mail;subtree"

Set oConn = CreateObject("ADODB.Connection") 'Create an ADO Connection

oConn.Provider = "ADsDSOOBJECT" ' ADSI OLE-DB provider

'oConn.CursorLocation = adUseClient

oConn.Open "ADs Provider"

Set oRS = oConn.Execute(strQuery)

NbrResultat = 0

LigneResultat = ""

If oRS.BOF And oRS.EOF Then

'document.Write("Pas d'information sur la boite mail de " & strDomain & "\" & strUsername & " sur " & strServerName & "<BR>")

'document.Write(strQuery & "<BR>")

Else

While Not oRS.EOF

NbrResultat = NbrResultat + 1

Select Case TypeResultat

Case 1

LigneResultat = LigneResultat & oRS.Fields("adspath") & ";"

Case 2

LigneResultat = LigneResultat & oRS.Fields("mail") & ";"

Case Else 'Par défaut on retourne l'adresse mail

LigneResultat = LigneResultat & oRS.Fields("mail") & ";"

End Select

'MsgBox "Mailbox : " & oRS.Fields("cn") & vbLf & "Email : " & oRS.Fields("mail") & VbCrLf & oRS.Fields("adspath")

oRS.MoveNext

Wend

End If

If NbrResultat > 0 And Len(LigneResultat) > 1 Then

LigneResultat = Left(LigneResultat,Len(LigneResultat)-1)

TableauResultat = Split(LigneResultat,";")

End If

'Clean Up

Set oSid = Nothing

oRS.Close

oConn.Close

Set oRS = Nothing

Set oConn = Nothing

End If 'If BoolContinuer = 1 Then

End If 'If Len(strServerName) > 0 And Len(strDomain) > 0 And Len(strUsername) > 0 Then

End If 'If IsNumeric(TypeResultat) = True Then

End Sub

Exchange - Utiliser les paramètres par défaut de la banque d'informations
'Sous Exchange 5.5, dans l'onglet Limites, pour cocher la case
'Utiliser les paramètres par défaut de la banque d'informations

Dim objMB
Dim CheminLDAPBoiteMail

CheminLDAPBoiteMail = "LDAP://NomDuServeur/CN=AeffleF,CN=blabla,OU=bla,o=plop"
Set objMB = GetObject(CheminLDAPBoiteMail)
objMB.Put "DXA-Flags", 0
objMB.Put "MDB-Use-Defaults", True
objMB.SetInfo

Set objMB = GetObject(CheminLDAPBoiteMail)
Set objMB = Nothing

Exchange - Verifier que l on a les droits sur une OU Exchange
Public Function VerifierDroitsLDAP(ByVal CheminLDAP)

'Version du 18/09/2006

'Retourne 1 si on a bien les droits

'Exemple : Msgbox VerifierDroitsLDAP("LDAP://NomServeur/CN=blabla,OU=bla,o=plop")

'Par defaut on a pas les droits

VerifierDroitsLDAP = 0

On Error Resume Next

Err.Clear

Set objMBContainer = GetObject(CheminLDAP)

NumeroErreur = Err.Number

DescriptionErreur = Err.description

On Error Goto 0

Select Case NumeroErreur

Case 0 'On a les droits

VerifierDroitsLDAP = 1

Case 70 'Le user n a pas les droits

VerifierDroitsLDAP = 0

Case Else 'Autre type d erreur

VerifierDroitsLDAP = 0

End Select

Set objMBContainer = Nothing

End Function

FILES - Creer un repertoire

Public Sub CreerRepertoire(CheminRepertoire, FautIlLeCreer, PurgerRepertoire, IgnorrerErreurs)

'Version du 27 fevrier 2006

'Creation d un répertoire et des répertoires parents associés

'Exemple :

'Call CreerRepertoire("D:\01\02\03",1,0,0)

Dim CompteurCar

Dim RepertoirATester

Dim DebutRecherche 'Numero de caractère à partir duquel la recherche doit commencer

Dim objFSO

Set objFSO = CreateObject("Scripting.FileSystemObject")

If Len (CheminRepertoire) > 3 Then

If IgnorrerErreurs = 1 Then

On Error Resume Next

End If

'Si le répertoire existe, on vide le contenu

If objFSO.FolderExists(CheminRepertoire) = True Then

'Si on a demandé à purger le répertoire

If PurgerRepertoire = 1 Then

'On efface tous les ficiers

Call objFSO.DeleteFile(CheminRepertoire & "\*.*", True)

'On pointe sur le chemin à explorer

Set objFolder = objFSO.GetFolder(CheminRepertoire)

'Pour tous les sous répertoires

For Each MonFolder In objFolder.SubFolders

Wscript.Sleep 1

MonFolder.Delete 'On efface le sous répertoire

'Destruction de l objet représentant le répertoire

Set objFolder = Nothing

End If 'If PurgerRepertoire = 1 Then

Else 'Si le répertoire n'existe pas

'Si on a demandé à créer le répertoire

If FautIlLeCreer = 1 Then

'On regarde si le chemin indiqué est un chemin réseau ou non

If Left(CheminRepertoire,2) = "\\" Then

'Si c est un chemin réseau

DebutRecherche = Instr(3, CheminRepertoire, "\", 1) + 1

Else 'Si ce n est pas un chemin réseau

DebutRecherche = 4

End If

'Avant de créer le répertoire, On va vérifier que tous les répertoires 'père' existent

For CompteurCar = DebutRecherche To (Len(CheminRepertoire)-1)

If Mid(CheminRepertoire,CompteurCar,1) = "\" Then

'On retient le nom du répertoire père

RepertoirATester = Left(CheminRepertoire,CompteurCar-1)

'Si le répertoire n'existe pas, on le crée

If objFSO.FolderExists(RepertoirATester) = False Then

Call objFSO.CreateFolder(RepertoirATester)

End if

End If 'If Mid(CheminRepertoire,CompteurCar,1) = "\" Then

'Création du répertoire demandé

Call objFSO.CreateFolder(CheminRepertoire)

End If 'If FautIlLeCreer = 1 Then

End if 'If objFSO.FolderExists(CheminRepertoire) = True Then

Else 'Si le chemin de répertoire n est pas valide

Msgbox "Le chemin de répertoire" & VbCrLf & "'" & CheminRepertoire & "'" & VbCrLf & "n'est pas valide car il fait moins de 4 caractères."

End If 'If Len (CheminRepertoire) > 3 Then

Set objFSO = Nothing

End Sub

FILES - Copier le contenu d un fichier dans un autre
Public Function CopierContenuFichierDansUnAutre(ByVal CheminFichierSource, ByVal CheminFichierCible, ByVal DeleteSourceAfterMerge)

'Version du 21 fev 2007

'Copie le contenu d un fichier dans un autre

'Si DeleteSourceAfterMerge est a 1, alors le fichier source est efface apres coup

Dim objFSO

Dim objFichierSource

Dim objFichierCible

Const ForReading = 1

Const ForWritting = 2

Const ForAppending = 8

CopierContenuFichierDansUnAutre = 0 'Valeur de retour par defaut

Set objFSO = CreateObject("Scripting.FileSystemObject")

'Si le fichier source et cible existe

If (objFSO.FileExists(CheminFichierSource) = True) Then

Set objFichierSource = objFSO.OpenTextFile(CheminFichierSource, ForReading, True)

Set objFichierCible = objFSO.OpenTextFile(CheminFichierCible, ForAppending, True)

'Pour toutes les lignes du fichier

Do Until objFichierSource.AtEndOfStream

objFichierCible.WriteLine (objFichierSource.Readline)

Loop

'Fermeture des fichiers

objFichierSource.Close

objFichierCible.Close

Set objFichierSource = Nothing

Set objFichierCible = Nothing

If DeleteSourceAfterMerge = 1 Then

Call objFSO.DeleteFile(CheminFichierSource, True)

End If

'Retour positif

CopierContenuFichierDansUnAutre = 1

End If 'If (objFSO.FileExists(CheminFichierSource) = True) Then

Set objFSO = Nothing

End Function

FILES - Copier un fichier
Dim objFSO

CheminScriptActuel = Left(wscript.scriptfullname,Len(wscript.scriptfullname)-Len(wscript.scriptname)-1)
CheminFichierSource = InputBox("Entrez le chemin du fichier à copier","Fichier a copier",CheminScriptActuel & "\" & "MonfichierSource.txt")
CheminFichierCible = InputBox("Entrez le chemin du fichier destination","Fichier cible",CheminScriptActuel & "\" & "MonfichierCible.txt")

Set objFSO = CreateObject("Scripting.FileSystemObject")
Call objFSO.CopyFile (CheminFichierSource, CheminFichierCible, True)
Set objFSO = Nothing

FILES - Copier un répertoire
Dim objFSO

CheminScriptActuel = Left(wscript.scriptfullname,Len(wscript.scriptfullname)-Len(wscript.scriptname)-1)
CheminRepertoireSource = InputBox("Entrez le chemin du répertoire source","Chemin du répertoire source",CheminScriptActuel)
CheminRepertoireCible = InputBox("Entrez le chemin du répertoire cible","Chemin du répertoire cible",CheminScriptActuel)

Set objFSO = CreateObject("Scripting.FileSystemObject")
Call objFSO.CopyFolder(CheminRepertoireSource ,CheminRepertoireCible ,True)
Set objFSO = Nothing

'Exemple :
'call objFSO.CopyFolder("D:\Toto" ,"D:\Robert\Toto" ,True)

FILES - Copier un tableau dans un fichier
Public Function CopierTableauDansFichier(ByVal MonTableau, ByVal CheminFichier, ByVal TypeOuvertureFichier, ByVal NePasCopierDerniereLigne)

'Version du 21 fev 2007

'Copie le contenu d un tableau dans un fichier

'Retourne 1 si l ecriture a bien fonctionne

'Valeur possible de TypeOuvertureFichier

' 1 pour une ouverture en mode Write (efface le contenu precedent du fichier avant ecriture)

' 2 pour une ouverture en mode Append (N'efface pas l ancien contenu. Ajoute à la suite)

'Si NePasCopierDerniereLigne est a 1, on en copie pas la derniere ligne du tableau

Dim CompteurLigne

Dim objFSO

Dim objFichier

Dim Continuer

Const ForReading = 1

Const ForWritting = 2

Const ForAppending = 8

SauvegarderTableauDansFichier = 0

Set objFSO = CreateObject("Scripting.FileSystemObject")

'Si j ai bien un tableau en parametres

If IsArray(MonTableau) = True Then

Continuer = 0

Select Case TypeOuvertureFichier

Case 1

Set objFichier = objFSO.OpenTextFile(CheminFichier, ForWritting, True)

Continuer = 1

Case 2

Set objFichier = objFSO.OpenTextFile(CheminFichier, ForAppending, True)

Continuer = 1

Case Else

Continuer = 0

End Select

'Si l ouverture du fichier a bien fonctionne

If Continuer = 1 Then

For CompteurLigne = LBound(MonTableau) To Ubound(MonTableau)

'Si on ne doit pas copier la derniere ligne

If (NePasCopierDerniereLigne = 1) And (CompteurLigne = Ubound(MonTableau)) Then

Else

objFichier.WriteLine MonTableau(CompteurLigne)

End If

'On retourne un résultat positif

SauvegarderTableauDansFichier = 1

objFichier.Close

Set objFichier = Nothing

End If 'If Continuer = 1 Then

End If 'If IsArray(MonTableau) = True Then

Set objFSO = Nothing

End Function

FILES - Decouper un fichier par nombre de lignes
Public Sub DecouperFichier()

'Version du 5 aout 2008 13:35

Dim CheminScriptActuel

Dim CheminFichierSource

Dim CheminFichierCible

Dim RacineNomFichierCible

Dim NomFichierCible

Dim MaLigne

Dim NumeroLigneFichierSource

Dim NumeroLigneFichierCible

Dim NumeroFichier

Dim MaLimite

Dim MonExtension

Dim objFSO

Dim objTextFichierSource

Dim objTextFichierCible

'Déclaration des constantes

Const ForReading = 1

Const ForWritting = 2

Const ForAppending = 8

CheminScriptActuel = Left(Wscript.scriptfullname, Len(Wscript.scriptfullname) - Len(Wscript.scriptname) - 1)

'CheminScriptActuel = "D:\PourSecurite"

'CheminFichierSource = InputBox("Entrez le chemin du fichier", "Chemin du répertoire", CheminScriptActuel & "\MonFichier.txt")

CheminFichierSource = InputBox("Entrez le chemin du fichier", "Chemin du répertoire", CheminScriptActuel & "\ALIZES_20080718171048.csv")

RacineNomFichierCible = InputBox("Entrez le chemin du fichier", "Chemin du répertoire", "ALIZES_20080718171048_")

MaLimite = InputBox("Entrez le chemin du fichier", "Chemin du répertoire", 65000)

MonExtension = InputBox("Entrez le chemin du fichier", "Chemin du répertoire", ".csv")

Set objFSO = CreateObject("Scripting.FileSystemObject")

Set objTextFichierSource = objFSO.OpenTextFile(CheminFichierSource, ForReading, True)

'Pour toutes les lignes du fichier

NumeroLigneFichierSource = 0

NumeroLigneFichierCible = 0

Do Until objTextFichierSource.AtEndOfStream

NumeroLigneFichierSource = NumeroLigneFichierSource + 1

DoEvents

'Lecture d une ligne du fichier source

MaLigne = objTextFichierSource.Readline 'Lecture et affichage de la ligne

'Si on est en train de lire la première ligne, on créé le premier fichier de sortie

If NumeroLigneFichierSource = 1 Then

NumeroFichier = 1

NomFichierCible = RacineNomFichierCible & NumeroFichier

CheminFichierCible = CheminScriptActuel & "\" & NomFichierCible & MonExtension

Set objTextFichierCible = objFSO.OpenTextFile(CheminFichierCible, ForWritting, True)

End If

'Ecriture de la ligne dans le fichier Cible

objTextFichierCible.WriteLine (MaLigne)

NumeroLigneFichierCible = NumeroLigneFichierCible + 1

'Si on a atteind la limite de la taille du fichier cible, on change de fichier

If NumeroLigneFichierCible >= MaLimite Then

objTextFichierCible.Close

NumeroLigneFichierCible = 0

NumeroFichier = NumeroFichier + 1

NomFichierCible = RacineNomFichierCible & NumeroFichier

CheminFichierCible = CheminScriptActuel & "\" & NomFichierCible & MonExtension

Set objTextFichierCible = objFSO.OpenTextFile(CheminFichierCible, ForWritting, True)

End If

Loop

objTextFichierSource.Close

Set objTextFichierSource = Nothing

Set objFSO = Nothing

objTextFichierCible.Close

Set objTextFichierCible = Nothing

End Sub

FILES - Deplacement d'une liste de répertoires listés dans un fichier
'Lit un fichier contenant une liste de chemin d'accès à des répertoires et les déplacent dans un autre

'Déclaration des constantes
Const ForReading = 1
Const ForWritting = 2
Const ForAppending = 8

Dim objFSO
Dim objTextFile
Dim objFolder

CheminScriptActuel = Left(wscript.scriptfullname,Len(wscript.scriptfullname)-Len(wscript.scriptname)-1)
CheminFichier = InputBox("Entrez le chemin du fichier contenant les répertoires à déplacer","Fichier de données",CheminScriptActuel & "\MonFichier.txt")
CheminRepertoireCible = InputBox("Entrez le chemin du répertoire cible","Repertoire destination",CheminScriptActuel)

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.OpenTextFile(CheminFichier, ForReading, True)

'Pour tous les répertoires contenus dans le fichier
Do Until objTextFile.AtEndOfStream

RepertoireSource = objTextFile.Readline 'Récupération d'un répertoire

'Si le répertoire source existe

If objFSO.FolderExists(RepertoireSource) = True Then

Set objFolder = objFSO.GetFolder(RepertoireSource)

RepertoireCible = CheminRepertoireCible & "\" & objFolder.Name 'Definition de la cible

Wscript.Echo "Copie de " & RepertoireSource & " vers " & RepertoireCible

'Copie de la source vers la cible

If objFSO.FolderExists(RepertoireCible) = False Then

Call objFSO.CopyFolder(RepertoireSource, RepertoireCible, True)

Else

WScript.Echo RepertoireCible & " existe deja"

End If

Set objFolder = Nothing

'Si le répertoire a bien été copié sur la cible, on efface la source

If objFSO.FolderExists(RepertoireCible) = True Then

WScript.Echo "Effacement de " & RepertoireSource

Call objFSO.DeleteFolder (RepertoireSource, True )

End If

Else

Wscript.Echo RepertoireSource & " n'existe pas."

End If 'If objFSO.FolderExists(RepertoireSource) = True Then

Loop

objTextFile.Close 'Fermeture du fichier
'Destruction des objets
Set objTextFile = Nothing
Set objFSO = Nothing

FILES - Deplacer un répertoire

Dim objFSO

RepertoireSource = "D:\Toto\MonrepertoireNommeToto"
RepertoireCible = "E:\MonrepertoireNommeToto"

Set objFSO = CreateObject("Scripting.FileSystemObject")
If (objFSO.FolderExists(RepertoireSource) = True) And (objFSO.FolderExists(RepertoireCible) = True) Then

Call objFSO.MoveFolder RepertoireSource, RepertoireCible
End If
Set objFSO = Nothing

FILES - Ecrire dans un fichier
Dim objFSO
Dim objTextFile
Dim CheminFichier
Dim CheminScriptActuel

'Déclaration des constantes
Const ForReading = 1
Const ForWritting = 2
Const ForAppending = 8

CheminScriptActuel = Left(wscript.scriptfullname,Len(wscript.scriptfullname)-Len(wscript.scriptname)-1)
CheminFichier = CheminScriptActuel & "\ZZMonFichier.txt" 'Déclaration du chemin et du nom du fichier
CheminFichier = Trim(InputBox("Entrez le chemin complet du fichier","Chemin complet du fichier",CheminFichier))

If Len(CheminFichier) > 0 Then

Set objFSO = CreateObject("Scripting.FileSystemObject")

Set objTextFile = objFSO.OpenTextFile(CheminFichier, ForAppending, True)

objTextFile.WriteLine(Now) 'On ecrit la date et l'heure dans le fichier

objTextFile.Close 'Fermeture du fichier

Set objTextFile = Nothing

Set objFSO = Nothing
Else

Msgbox "Operation annulee"
End If 'CheminFichier

FILES - Ecrire dans un fichier de log
Public Function EcrireLog(ByVal MessageDeLogPourHistorique, ByVal CheminFichierDeLog, ByVal MettreDateHeure)

'Version du 30 septembre 2009

'Valeur de CheminFichierDeLog : Chemin complet du fichier de log. Exemple : D:\MonFichier.Txt

'Valeurs de MettreDateHeure :

' True : Mettre la date et l heure dans le log

' False : Rien

Dim objFSO

Dim objTextFile

Dim NumeroErreur

'Déclaration des constantes

Const ForReading = 1

Const ForWritting = 2

Const ForAppending = 8

If Len(CheminFichierDeLog) > 0 Then

Set objFSO = CreateObject("Scripting.FileSystemObject")

On Error Resume Next

'Si on a demande l ajout de la date et l heure

If MettreDateHeure = True Then

MessageDeLogPourHistorique = Now & " : " & MessageDeLogPourHistorique

End If

'Ecriture dans le fichier de log

Set objTextFile = objFSO.OpenTextFile(CheminFichierDeLog, ForAppending, True)

objTextFile.WriteLine(MessageDeLogPourHistorique)

objTextFile.Close 'Fermeture du fichier

NumeroErreur = Err.Number

On Error Goto 0

Select Case NumeroErreur

Case 0

'Wscript.Echo ""

Case Else

Wscript.Echo "ERREUR lors de l ecriture dans le fichier de log. Erreur numero " & NumeroErreur

End Select

Set objTextFile = Nothing

Set objFSO = Nothing

End If 'If Len(CheminFichierDeLog) > 0 Then

End Function

FILES - Ecrire le noms des fichiers d'un repertoire dans un fichier texte
'Déclaration des constantes pour la lecture et l'ecriture dans les fichiers
Const ForReading = 1
Const ForWritting = 2
Const ForAppending = 8

Dim CheminFichier 'Chemin du fichier texte

CheminScriptActuel = Left(wscript.scriptfullname,Len(wscript.scriptfullname)-Len(wscript.scriptname)-1)
CheminFichier = CheminScriptActuel & "\" & "ZZListeNomDesFichiers.txt"

'Création des objets
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.OpenTextFile(CheminFichier, ForWritting, True)

Set objFolder = objFSO.GetFolder(CheminScriptActuel)

'Pour tous les fichiers du répertoire
For Each MonFichier In objFolder.Files

objTextFile.WriteLine(MonFichier.Name) 'Ecriture du nom du fichier dans le fichier texte
Next

'Destruction des objets
Set objFolder = Nothing
objTextFile.Close
Set objTextFile = Nothing
Set objFSO = Nothing

FILES - Effacement d'un repertoire
Dim objFSO

CheminScriptActuel = Left(wscript.scriptfullname,Len(wscript.scriptfullname)-Len(wscript.scriptname)-1)
CheminRepertoire = InputBox("Entrez le chemin du répertoire à effacer","Repertoire à effacer",CheminScriptActuel & "\" & "?")

Set objFSO = CreateObject("Scripting.FileSystemObject")
Call objFSO.DeleteFolder (CheminRepertoire, True)
Set objFSO = Nothing

FILES - Exploration des répertoires
'Version du 9 février 2005

'Fonction d'exploration des répertoires

'Déclaration des constantes pour la lecture et l'ecriture dans les fichiers
Const ForReading = 1
Const ForWritting = 2
Const ForAppending = 8

Dim CheminFichierResultat 'Chemin du fichier contenant le résultat
Dim CheminRepertoireAExplorer
Dim NiveauSousArboMax

'On récupère le nom du répertoire dans une variable
CheminScriptActuel = Left(wscript.scriptfullname,Len(wscript.scriptfullname)-Len(wscript.scriptname)-1)

CheminFichierResultat = CheminScriptActuel & "\" & "ResultatRecherche.txt"
CheminFichierResultat = InputBox("Entrez le chemin du fichier contenant le resultat de la recherce","Chemin du fichier de reponse",CheminFichierResultat)
CheminRepertoireAExplorer = InputBox("Entrez le chemin du répertoire a explorer","Chemin du répertoire",CheminScriptActuel)
NiveauSousArboMax = InputBox("Entrez le niveau max d exploration" & vbCrLf & "Mettez 0 si il n y a pas de limite" & VbCrLf & "Mettez par exemple 1 pour n explorer que le premier niveau de répertoires","Niveau d exploration MAX",0)

'Pour les paramètres, la première valeur numérique doit être mise à 0 par défaut, elle correspond au niveau d'arbo de la racine
'La seconde est le niveau de sous arborescence max. Si il est à 0 il n'y a pas de limites. Si le chiffre est à 2 (par exemple) alors le script n'ira pas au dela du niveau n-2)
Call Explorer(CheminRepertoireAExplorer, CheminFichierResultat,0,0)

Public Sub Explorer(ByVal CheminRepertoireAExplorer, ByVal CheminFichierResultat, ByVal NiveauSousArborescence, NiveauSousArboMax)

Dim ExplorerSousRep 'A 1 si on doit explorer les sous répertoires

Dim objFSOExploration 'Objet FSO pour l'accès au système de fichiers

Dim objFolder 'Représente un répertoire

Dim objTextFile 'Représente le fichier texte qui contient les réponses

'Création des objets

Set objFSOExploration = CreateObject("Scripting.FileSystemObject")

'On fait un objet qui représente le répertoire à explorer

Set objFolder = objFSOExploration.GetFolder(CheminRepertoireAExplorer)

'Pour tous les fichiers du répertoire

For Each MonFichier In objFolder.Files

'Exemple d'utilisation, on ecrit le nom des fichiers

Set objTextFile = objFSOExploration.OpenTextFile(CheminFichierResultat, ForAppending, True)

objTextFile.WriteLine(NiveauSousArborescence & " ; " & "Fichier ; " & MonFichier.Name & " dans " & CheminRepertoireAExplorer) 'Ecriture du nom du fichier dans le fichier texte

objTextFile.Close

Set objTextFile = Nothing

ExplorerSousRep = 0 'Par défaut on n'explore pas les sous-répertoires

'Si on n'a pas de limitation au niveau de l'exploration des sous-répertoires

If NiveauSousArboMax = 0 Then

ExplorerSousRep = 1

End If

'Si on a une limitation au niveau de l'exploration des sous répertoire

If (NiveauSousArboMax <> 0) AND (NiveauSousArborescence < NiveauSousArboMax) Then

ExplorerSousRep = 1

End IF

'Pour tous les sous-répertoires

For Each MonFolder In objFolder.SubFolders

Wscript.Sleep 1

'Exemple d'utilisation, on ecrit uniquement le nom des répertoires portant un certain nom

Position = InStr(1, Lcase(MonFolder.Name), "NomRecherche")

If Position > 0 Then

Set objTextFile = objFSOExploration.OpenTextFile(CheminFichierResultat, ForAppending, True)

objTextFile.WriteLine(NiveauSousArborescence & " ; " & "Dossier ; " & MonFolder.Name & " dans " & CheminRepertoireAExplorer) 'Ecriture du nom du dossier dans le fichier texte

objTextFile.Close

Set objTextFile = Nothing

End If 'If Position > 0 Then

'Si on doit explorer les sous-répertoires

If ExplorerSousRep = 1 Then

'Si le nom du répertoire n'est pas à exclure de la recherche

If (Lcase(MonFolder.Name) <> "program files") AND (Lcase(MonFolder.Name) <> "system32") AND (Lcase(MonFolder.Name) <> "temporary internet files") Then

Call Explorer(MonFolder.Path, CheminFichierResultat, NiveauSousArborescence + 1, NiveauSousArboMax) 'J'explore ce sous répertoire

End If

End If 'If ExplorerSousRep = 1 Then

Next 'For Each MonFolder In objFolder.SubFolders

'Destruction des objets

Set objFolder = Nothing

Set objFSOExploration = Nothing

End Sub

FILES - Effacer les fichiers datant de plus de ...
Public function DeleteOlderFiles (ByVal FoldersToProcess, ByVal MaxDayAge, ByVal Extension, ByVal DebugMode)

'25 january 2010 version 'Add debug mode

'3 december 2009 version

'Use to delete files with a specific extension older than ...

'Parameters :

FoldersToProcess : all folders to process separated by ;

MaxDayAge : All files older than xx days will be deleted

Extension : file extension to process. All other file extension are not concerned

'Example 1 :

Call DeleteOlderFiles("D:\", 6, "txt")

'Example 1 :

Call DeleteOlderFiles("D:\;C:\Temp", 6, "log")

Dim FolderArray

Dim FolderPath

Dim objFSO

Dim ObjFolder

Dim ObjFile

Dim FileAge

Dim ErrorNumber

If DebugMode = 1 Then

Wscript.echo "DeleteOlderFiles() function"

End If

Set objFSO = CreateObject("Scripting.FileSystemObject")

FolderArray = Split(FoldersToProcess, ";")

For Each FolderPath In FolderArray

If objFSO.FolderExists(FolderPath) Then

If DebugMode = 1 Then

Wscript.echo "Process " & FolderPath & " folder"

End If

Set ObjFolder = objFSO.GetFolder(FolderPath)

For Each ObjFile In ObjFolder.Files

'Wscript.echo "File " & ObjFile.Name

If ExtensionFichier(ObjFile.Name) = Extension Then

FileAge = DateDiff("d", ObjFile.DateCreated, Now())

If DebugMode = 1 Then

Wscript.echo "File " & ObjFile.Name & " have " & FileAge & " day(s)"

End If

If FileAge > MaxDayAge Then

If DebugMode = 1 Then

Wscript.echo "Deleting " & ObjFile.Name

End If

Err.Clear

On Error Resume Next

Call objFSO.DeleteFile(objFile.Path)

ErrorNumber = Err.Number

On Error goto 0

Select Case NumeroErreur

Case 0

If DebugMode = 1 Then

Wscript.echo "Done"

End If

Case Else

Wscript.echo "Error for deleting file : " & Err.Description

End Select

End If

End If 'If ExtensionFichier(ObjFile.Name) = "bak" Then

Set ObjFolder = Nothing

Else

Wscript.echo "Folder " & FolderPath & " dont exist"

End If

Set objFSO = Nothing

End Function

Public Function ExtensionFichier(ByVal CheminFichier)

'Retourne l'extension du fichier

Dim Position

ExtensionFichier = ""

Position = InStrRev(CheminFichier,".")

If (Position > 0) And (Position < Len(CheminFichier)) Then

ExtensionFichier = Mid(CheminFichier,Position+1)

ExtensionFichier = Lcase(ExtensionFichier)

End If

End Function

FILES - Effacer les fichiers les plus anciens dans des sous-répertoires
'Version du 19 fevrier 2010 : on peut aussi traiter le répertoire racine
'Version du 22 septembre 2009
'Ex Version du 29 juillet 2009

'Fonctionnement :
'On paramètre en dur dans le script un répertoire à traiter
'Le script examine alors tous les sous répertoires présents dans le chemin indiqué
'Le script regarde ensuite si un fichier récent (créé depuis – de 24H) est présent dans le sous répertoire

'Si c’est le cas, tous les fichiers créés depuis plus de 1 mois sont effacés

'Dans le cas contraire, rien n’est fait
'Le répertoire contenant le script est exclu automatiquement.

Const DebugMode = 1

Dim objFSO
Dim objFolder
Dim FileCreationDate
Dim NomRepertoireATraiter
Dim NomRepertoireAExclure 'Contient le nom d un repertoire contenant le script. Il sera exclu du process
Dim CheminScriptActuel
Dim Position

NomRepertoireATraiter = "D:\backupfortuna"

CheminScriptActuel = Left(wscript.scriptfullname,Len(wscript.scriptfullname)-Len(wscript.scriptname)-1)
Position = InStrrev(CheminScriptActuel,"\")
NomRepertoireAExclure = Mid(CheminScriptActuel, Position + 1)
'Wscript.Echo "Le repertoire suivant sera exclu du process : " & NomRepertoireAExclure

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(NomRepertoireATraiter)

Call DeleteOldFiles(objFolder.Path,"", NomRepertoireAExclure, DebugMode)
For Each objSousFolder In objFolder.SubFolders

Call DeleteOldFiles(objSousFolder.Path,"", NomRepertoireAExclure, DebugMode)
Next

Set objFolder = Nothing
Set objFSO = Nothing

Public Function DeleteOldFiles(ByVal FolderPath, ByVal FileExtentionFilter, ByVal FolderToExclude, ByVal DebugMode)

'19 february 2010 version

'Depend of ExtensionFichier function

Dim objFSO

Dim objFolder

Dim RecentFileExist

Dim FileCreationDate

Dim FolderNameToExclude

If DebugMode > 0 Then

Wscript.Echo "Process " & FolderPath & " folder"

End If 'If DebugMode > 0 Then

Set objFSO = CreateObject("Scripting.FileSystemObject")

'Seek the name of folder to exclude

If Len(FolderToExclude) > 0 Then

If DebugMode > 0 Then

Wscript.Echo " There is no folder to exclude"

Wscript.Echo " Get the name of folder to exclude (" & FolderToExclude & ")"

End If

If objFSO.FolderExists(FolderToExclude) = False Then

If DebugMode > 0 Then

Wscript.Echo " Path to folder to exclude dont exist"

Wscript.Echo " " & FolderToExclude & " variable is just a folder name"

End If

FolderNameToExclude = FolderToExclude

Else

If DebugMode > 0 Then

Wscript.Echo " Path to folder to exclude exist"

Wscript.Echo " We just keep the folder name"

End If

Set objFolder = objFSO.GetFolder(FolderToExclude)

FolderNameToExclude = objFolder.Name

Set objFolder = Nothing

End If

Else

If DebugMode > 0 Then

Wscript.Echo "There is no folder to exclude"

End If

End If 'If Len(FolderToExclude) > 0 Then

Set objFolder = objFSO.GetFolder(FolderPath)

If Lcase(FolderNameToExclude) = Lcase(objFolder.Name) Then

Wscript.Echo "Folder " & objFolder.Name & " is exclude"

Else 'If folder is not exclude

'First pass to check if there is a new file today

If DebugMode > 0 Then

Wscript.Echo " Seek a recent file"

End If

RecentFileExist = 0

For Each objFile In objFolder.Files

If Len(FileExtentionFilter) > 0 Then

If Lcase(ExtensionFichier(objFile.Path)) = LCase(FileExtentionFilter) Then

FileCreationDate = objFile.DateCreated

If DateDiff("d", FileCreationDate, Now) <= 2 Then

If DebugMode > 0 Then

Wscript.Echo " " & objFile.Name & " is a recent file"

End If

RecentFileExist = 1

End If

Else 'If file extension is not filtered

FileCreationDate = objFile.DateCreated

If DateDiff("d", FileCreationDate, Now) <= 2 Then

If DebugMode > 0 Then

Wscript.Echo " " & objFile.Name & " is a recent file"

End If

RecentFileExist = 1

End If

End If 'If Len(FileExtentionFilter) > 0 Then

'Si un fichier recent est present dans le repertoire, on efface les anciens

If RecentFileExist = 1 Then

If DebugMode > 0 Then

Wscript.Echo " There is recent file(s) on " & objFolder.Name

Wscript.Echo " We can seek and delete older files"

Wscript.Echo " Go"

End If

'Suppression des fichiers datant de plus de 1 mois

For Each objFile In objFolder.Files

FileCreationDate = objFile.DateCreated

If DebugMode > 0 Then

Wscript.Echo " File age : " & DateDiff("d", FileCreationDate, Now)

End If

If Len(FileExtentionFilter) > 0 Then

If Lcase(ExtensionFichier(objFile.Path)) = LCase(FileExtentionFilter) Then

If DateDiff("d", FileCreationDate, Now) > 2 Then

If DebugMode > 0 Then

Wscript.Echo "Deleting " & objFile.Path & " dated " & FileCreationDate

End If

Call objFSO.DeleteFile(objFile.Path)

Else

If DebugMode > 0 Then

Wscript.Echo " We keep the file " & objFile.Path & " dated " & FileCreationDate

End If

End If 'If Lcase(ExtensionFichier(objFile.Path)) = LCase(FileExtentionFilter) Then

Else 'If there is no extension filtering

If DateDiff("d", FileCreationDate, Now) > 2 Then

If DebugMode > 0 Then

Wscript.Echo "Deleting " & objFile.Path & " dated " & FileCreationDate

End If

Call objFSO.DeleteFile(objFile.Path)

Else

If DebugMode > 0 Then

Wscript.Echo " We keep the file " & objFile.Path & " dated " & FileCreationDate

End If

End If 'If Len(FileExtentionFilter) > 0 Then

Else 'If there is no recent file

If DebugMode > 0 Then

Wscript.Echo "There is no recent file on " & FolderPath

End If

End If 'If RecentFileExist = 1 Then

End If 'If NomRepertoireAExclure = objFolder.Name Then

Set objFolder = Nothing

Set objFSO = Nothing

End Function

Public Function ExtensionFichier(ByVal CheminFichier)

'Retourne l'extension du fichier

Dim Position

ExtensionFichier = ""

Position = InStrRev(CheminFichier,".")

If (Position > 0) And (Position < Len(CheminFichier)) Then

ExtensionFichier = Mid(CheminFichier,Position+1)

End If

End Function

FILES - Isoler la racine
'Pensez à parametrer le nombre total de lignes du tableau -1. Par exemple si le tableau fait 6 lignes, mettre 5
'La première ligne commence par 0 et ainsi de suite
'Le chemin ne doit pas se terminer par \
'Toujours mettre le chemin le plus complexe apres le chemin le plus court.
'Par exemple "\\monpc\aeffacer\Espace Projets" doit être après \\monpc\aeffacer"
'

Soit :
'

ListeRacines(0) = "\\monpc\aeffacer"
'

ListeRacines(1) = "\\monpc\aeffacer\Espace Projets"
Dim ListeRacines (1)
ListeRacines(0) = "\\monpc\aeffacer"
ListeRacines(1) = "\\monpc\aeffacer\Espace Projets"

Public Sub IsolerRacine (ByVal CheminATraiter, ByVal ListeRacines, ByRef Racine, ByRef SousRepertoires)

'Used to find to divide the root part from the folders part

'Example : \\MyServer\MaShareFolder\MyRootDirectory\MyProjectSpace\MySubFolder

Function will return : \\MyServer\MaShareFolder\MyRootDirectory And MyProjectSpace\MySubFolder

'16 october version

Dim UneRacine

Racine = CheminATraiter 'Valeur par defaut

SousRepertoires = "" 'Valeur par defaut

For Each UneRacine In ListeRacines

'Si le debut du chemin a traiter correspond a une racine referencee

'Alors on peut isoler la racine des sous repertoires

If Left(Lcase(CheminATraiter), Len(UneRacine)) = Lcase(UneRacine) Then

Racine = UneRacine

Call EcrireLog("Correspondance avec la racine " & UneRacine, CheminFichierLog, True)

'Si il y a potentiellement un sous repertoire dans le chemin d acces

SousRepertoires = "" 'Par defaut

If Len(CheminATraiter) > (Len(UneRacine) + 1) Then

SousRepertoires = Mid(CheminATraiter, Len(UneRacine)+2)

End If 'If Len(CheminATraiter) > (Len(UneRacine) + 1) Then

End If 'If Left(Lcase(CheminATraiter), Len(UneRacine) = Lcase(UneRacine) Then

End Sub

FILES - Lire le contenu d'un fichier

Dim CheminScriptActuel
Dim CheminFichier
Dim MaLigne

Dim objFSO
Dim objTextFile

'Déclaration des constantes
Const ForReading = 1
Const ForWritting = 2
Const ForAppending = 8

CheminScriptActuel = Left(wscript.scriptfullname,Len(wscript.scriptfullname)-Len(wscript.scriptname)-1)
CheminFichier = InputBox("Entrez le chemin du fichier","Chemin du répertoire",CheminScriptActuel & "\MonFichier.txt")

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.OpenTextFile(CheminFichier, ForReading, True)

'Pour toutes les lignes du fichier
Do Until objTextFile.AtEndOfStream

MaLigne = objTextFile.Readline 'Lecture et affichage de la ligne

Wscript.Echo MaLigne
Loop

objTextFile.Close
Set objTextFile = Nothing
Set objFSO = Nothing

FILES - Lister les fichiers d'un répertoire
Dim objFSO 'Objet FSO pour l'accès au système de fichiers
Dim MyFile 'Représente un fichier
Dim objTextFile 'Représente le fichier texte qui contient les réponses

'Déclaration des constantes pour la lecture et l'ecriture dans les fichiers
Const ForReading = 1
Const ForWritting = 2
Const ForAppending = 8

CheminScriptActuel = Left(wscript.scriptfullname,Len(wscript.scriptfullname)-Len(wscript.scriptname)-1)
CheminFichierResultat = CheminScriptActuel & "\" & "Fichier de Sortie.txt"
CheminRepertoireAExplorer = InputBox("Entrez le chemin du répertoire","Chemin du répertoire",CheminScriptActuel)
CheminFichierResultat = InputBox("Entrez le chemin du fichier contenant le resultat","Chemin du fichier de reponse",CheminFichierResultat)

'Création des objets
Set objFSO = CreateObject("Scripting.FileSystemObject")

'On fait un objet qui représente le répertoire à explorer
Set objFolder = objFSO.GetFolder(CheminRepertoireAExplorer)
Set objTextFile = objFSO.OpenTextFile(CheminFichierResultat, ForWritting, True)

For Each MyFile In objFolder.Files

objTextFile.WriteLine(MyFile.Name)
Next

objTextFile.Close
Set objTextFile = Nothing
Set objFolder = Nothing
Set objFSO = Nothing

FILES - Lister les répertoires d'un répertoire
Dim objFSO 'Objet FSO pour l'accès au système de fichiers
Dim objFolder 'Représente un répertoire
Dim objTextFile 'Représente le fichier texte qui contient les réponses

'Déclaration des constantes pour la lecture et l'ecriture dans les fichiers
Const ForReading = 1
Const ForWritting = 2
Const ForAppending = 8

CheminScriptActuel = Left(wscript.scriptfullname,Len(wscript.scriptfullname)-Len(wscript.scriptname)-1)
CheminFichierResultat = CheminScriptActuel & "\" & "Fichier de Sortie.txt"
CheminRepertoireAExplorer = InputBox("Entrez le chemin du répertoire","Chemin du répertoire",CheminScriptActuel)
CheminFichierResultat = InputBox("Entrez le chemin du fichier contenant le resultat","Chemin du fichier de reponse",CheminFichierResultat)

'Création des objets
Set objFSO = CreateObject("Scripting.FileSystemObject")

'On fait un objet qui représente le répertoire à explorer
Set objFolder = objFSO.GetFolder(CheminRepertoireAExplorer)
Set objTextFile = objFSO.OpenTextFile(CheminFichierResultat, ForWritting, True)

For Each MonFolder In objFolder.SubFolders

objTextFile.WriteLine(MonFolder.Path & ";" & MonFolder.Name)
Next

objTextFile.Close
Set objTextFile = Nothing
Set objFolder = Nothing
Set objFSO = Nothing

FILES - Liste des fichiers ouverts et par qui
'Trouvé sur http://www.microsoft.com/technet/scriptcenter/resources/qanda/feb05/hey0216.mspx

Dim ComputerName 'Nom du poste

ComputerName = InputBox("Entrez le nom du Pc","Nom du poste","")

Set objConnection = GetObject("WinNT://" & ComputerName & "/LanmanServer")
Set colResources = objConnection.Resources

For Each objResource in colResources
Wscript.Echo "Path: " & objResource.Path
Wscript.Echo "User: " & objResource.User
Wscript.Echo
Next

FILES - Lister les sous-répertoires d'un répertoire
Dim CheminRepertoire
Dim objFSO
Dim ObjFolders
Dim ObjSubFolders
Dim ObjFolder
Dim ObjSubFolder
Dim CheminScriptActuel
Dim NomRepertoire
Dim MaLigne

'Déclaration des constantes pour la lecture et l'ecriture dans les fichiers
Const ForReading = 1
Const ForWritting = 2
Const ForAppending = 8

'On récupère le nom du répertoire dans une variable
CheminScriptActuel = Left(wscript.scriptfullname,Len(wscript.scriptfullname)-Len(wscript.scriptname)-1)
CheminRepertoire = InputBox("Entrez le chemin du répertoire","Chemin Répertoire",CheminScriptActuel)

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set ObjFolders = objFSO.GetFolder(CheminRepertoire)

CheminFichier = InputBox("Entrez le chemin du fichier de sortie","Chemin du fichier",CheminRepertoire & "\ZZ" & ObjFolders.Name & ".txt")
Set objTextFile = objFSO.OpenTextFile(CheminFichier, ForWritting, True)

For Each ObjFolder In ObjFolders.SubFolders

Set ObjSubFolders = objFSO.GetFolder(ObjFolder.Path)

For Each ObjSubFolder In ObjSubFolders.SubFolders

NomRepertoire = ObjSubFolder.Name

MaLigne = NomRepertoire & ";" & ObjSubFolder.Path

objTextFile.WriteLine(MaLigne) 'Ecriture du nom du fichier dans le fichier texte

Set ObjSubFolders = Nothing
Next

objTextFile.Close
Set objTextFile = Nothing
Set ObjFolders = Nothing
Set objFSO = Nothing

FILES - Remplacer le propriétaire d un repertoire
'https://www.microsoft.com/technet/scriptcenter/resources/qanda/jan06/hey0111.mspx
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colFolders = objWMIService.ExecQuery _
("Select * From Win32_Directory Where Name = 'C:\\Scripts'")

For Each objFolder in colFolders
objFolder.TakeOwnershipEx
Next

FILES - Retourne l extension d un fichier

Public Function ExtensionFichier(ByVal CheminFichier)

'Retourne l'extension du fichier

Dim Position

ExtensionFichier = ""

Position = InStrRev(CheminFichier,".")

If (Position > 0) And (Position < Len(CheminFichier)) Then

ExtensionFichier = Mid(CheminFichier,Position+1)

End If

End Function

FILES - Retourne une lettre de lecteur sur laquelle on a les droits d ecriture
Public Function TrouverLecteurDispo()

'Version du 2 mai 2006

Dim MonTableau()

Dim CompteurLigne

Dim Alphabet

Dim LettreLecteur

Dim objFSO

Dim NomRepertoire

Dim CheminRepertoire

'Valeur par défaut

TrouverLecteurDispo = ""

NomRepertoire = "bbbbbubfcfcbu"

NomRepertoire = Now

NomRepertoire = Replace(NomRepertoire,"/","",1)

NomRepertoire = Replace(NomRepertoire,":","",1)

NomRepertoire = "ZZAeffacer32rxtefegtrrtyh" & NomRepertoire

Set objFSO = CreateObject("Scripting.FileSystemObject")

Alphabet = "defghijklmnopqrstuvwxyzcab"

ReDim MonTableau(Len(Alphabet))

For CompteurLigne = 1 To Len(Alphabet)

LettreLecteur = Mid(Alphabet, CompteurLigne, 1) & ":\"

CheminRepertoire = LettreLecteur & NomRepertoire

'document.write(CheminRepertoire & "<BR>")

If objFSO.FolderExists(LettreLecteur) = True And objFSO.FolderExists(CheminRepertoire) = False Then

On Error Resume Next

Err.Clear

Call objFSO.CreateFolder(CheminRepertoire)

If Err.number = 0 Then

Call objFSO.DeleteFolder (CheminRepertoire, True)

TrouverLecteurDispo = LettreLecteur

Exit For

End If

On Error Goto 0

End IF 'If objFSO.FolderExists(LettreLecteur) = True And objFSO.FolderExists(LettreLecteur) = False Then

Next 'For CompteurLigne = 1 To Len(Alphabet)

Set objFSO = Nothing

End Function

FILES - Verifier l accès a un répertoire (Fonction)

'Ceci est une fonction VBS à appeler au sein d'un programme
Public Function TestAccesRepOK(ByRef ObjFolder)

'Version du 9 février 2005

'On doit passer en paramètre un objet Folder (fait partie des objets FSO)

'Retourne 1 si l'acces a un répertoire est OK

Err.Clear

On Error Resume Next

'Valeur par défaut

TestAccesRepOK = -1

'Pour tous les sous-répertoires

For Each MonFolder In objFolder.SubFolders

Exit For

'Si l'accès au répertoire est OK

If Err.number = 0 Then

TestAccesRepOK = 1

Else 'Si l'acces n'est pas OK

TestAccesRepOK = 0

End If

Err.Clear

End Function

FILES - Verifier la possibilite d ecrire dans un repertoire
Public Function WrittingTest(ByVal FolderPathToTest, ByVal ObjectType)

'24 november version

'Test to create a file in a folder.

'Return nothing if it s fine

'Return an error message if something wrong

'Parameters :

'FolderPathToTest : Folder to test

'ObjectType :

file

folder

'Example :

'Dim ErrorMessage

'ErrorMessage = WrittingTest("D:\MyFolder", "file")

'If ErrorMessage <> "" Then

'wscript.echo "Error : " & ErrorMessage

'End If

Dim objFSO

Dim AllIsOk

Dim TestFileName

Dim NumeroErreur

'Déclaration des constantes

Const ForReading = 1

Const ForWritting = 2

Const ForAppending = 8

'Default value

WrittingTest = "Error at the beginning"

AllIsOk = 0

TestFileName = "@effacer_fichierTest.txt2"

ObjectType = Lcase(ObjectType)

Select Case(ObjectType)

case "file"

AllIsOk = 1

case "folder"

AllIsOk = 1

case Else

ErrorMessage = "Wrong object type"

AllIsOk = 0

End Select

If AllIsOk = 1 Then

'If we have a folder to test

If Len(FolderPathToTest) > 0 Then

Set objFSO = CreateObject("Scripting.FileSystemObject")

If objFSO.FolderExists(FolderPathToTest) = True Then

On Error Resume Next

Set objTextFile = objFSO.OpenTextFile(FolderPathToTest & "\" & TestFileName, ForAppending, True)

objTextFile.WriteLine(Now) 'On ecrit la date et l'heure dans le fichier

NumeroErreur = Err.Number

On Error Goto 0

'Si on a reussit a ecrire, on donne un retour positif

If NumeroErreur = 0 Then

WrittingTest = ""

objTextFile.Close 'Fermeture du fichier

'On Error Resume Next

Call objFSO.DeleteFile(FolderPathToTest & "\" & TestFileName, True)

'On Error Goto 0

End If 'If NumeroErreur = 0 Then

Set objTextFile = Nothing

Else

ErrorMessage = "Folder dont exist"

End If 'If objFSO.FolderExists(FolderPathToTest) = True Then

Set objFSO = Nothing

Else

ErrorMessage = "No Folder Path"

End If 'If Len(FolderPathToTest) > 0 Then

End If 'If AllIsOk = 1 Then

End Function

FILES - Verifier la presence d un fichier
Dim objFSO
Dim objFichier

Set objFSO = CreateObject("Scripting.FileSystemObject")

If objFSO.FileExists("C:\Lefichier.txt") Then
Set objFichier = objFSO.GetFile("C:\Lefichier.txt")

Set objFichier = Nothing
Else
Wscript.Echo "Fichier non present"
End If

Set objFSO = Nothing

FILES - Verifier/Trouver une lettre de lecteur valide
Public Function FindExistingDriveLetter(ByVal ListeLecteursPreferes, ByVal OrdreRecherche)

'24 november version

'Return an existing disk letter

'Return nothing if there is not

'Exemple :

'MaLettre = FindExistingDriveLetter("","")

'MaLettre = FindExistingDriveLetter("GHI", "")

'MaLettre = FindExistingDriveLetter("", 2)

'Demande en paramètres :

' OrdreRecherche : A 1 par defaut si vide. Entier à 1 pour recherche dans l'odre alphabétique, 2 pour l ordre inverse.

' ListeLecteursPreferes : Prioritaire sur OrdreRecherche. C est une liste contenant dans l ordre les lecteurs eventuellement desires. Exemple : EFGHIJ

Dim ListeLecteursDemandes

Dim ListeLecteursExistants

Dim UnLecteurVoulu

Dim UnLecteurExistant

Dim CompteurLecteur

Dim Trouve

Dim objFSO

Const LecteursDansOrdreAller = "CDEFGHIJKLMNOPQRSTUVWXYZ"

Const LecteursDansOrdreRetour = "ZYXWVUTSRQPONMLKJIHGFEDC"

'Valeur de retour vide par défaut

FindExistingDriveLetter = ""

If (Len(OrdreRecherche) = 0) Or (IsNumeric(OrdreRecherche) = False) Then

OrdreRecherche = 1

End If

'Si on a precise une liste de lecteurs

ListeLecteursPreferes = Trim(ListeLecteursPreferes)

If Len(ListeLecteursPreferes) > 0 Then

ListeLecteursDemandes = ListeLecteursPreferes

Else

Select Case OrdreRecherche

Case 1

ListeLecteursDemandes = LecteursDansOrdreAller

Case 2

ListeLecteursDemandes = LecteursDansOrdreRetour

Case Else

ListeLecteursDemandes = LecteursDansOrdreAller

End Select

End If 'If Len(ListeLecteursPreferes) > 0 Then

'si on a bien une liste de lecteurs à tester

If Len(ListeLecteursDemandes) > 0 Then

Set objFSO = CreateObject("Scripting.FileSystemObject")

For CompteurLecteur = 1 To Len(ListeLecteursDemandes)

UnLecteurVoulu = Mid(ListeLecteursDemandes, CompteurLecteur, 1)

'If objFSO.DriveExists(UnLecteurVoulu) Then

If objFSO.FolderExists(UnLecteurVoulu & ":\") Then

FindExistingDriveLetter = UnLecteurVoulu

Exit Function

End If

Set objFSO = Nothing

End If 'If Len(ListeLecteursDemandes) > 0 Then

End Function

HTML - Afficher le contenu d'un recordset dans un tableau HTML

Document.write("<TABLE WIDTH=95% BORDER=1>" & VbCrLf) 'Ouverture du tableau

Document.write("<TR>") 'Ouverture de la ligne

For Compteur = 0 To UnRecordset.fields.Count - 1

Document.write("<TD><CENTER><B>" & Trim(UnRecordset.fields(Compteur).Name) & "</B></CENTER></TD>")
Next
Document.write("</TR>")

Do While UnRecordset.EOF = False

Document.write("<TR>") 'Ouverture de la ligne

'Affichage des valeurs de chaque champ

For Compteur = 0 To UnRecordset.fields.Count - 1

Document.write("<TD>" & Trim(UnRecordset.fields(Compteur).Value) & "</TD>")

Document.write("</TR>") 'Fermeture de la ligne

UnRecordset.MoveNext 'On passe à la ligne suivante

Loop

Document.write("</TABLE>") 'Fermeture du tableau

HTML - Apache configuration
Pour parametrer l emplacement de la page par défautn aller dans le fichier apache\conf\httpd.conf et chercher la chaine DocumentRoot

HTML - Afficher le contenu d'une variable tableau dans un tableau HTML - pour ASP
Public Function AfficherTableauASP (ByVal MonTableau, ByVal TaillePolice, ByVal PremiereLigneIsTitre, ByVal ForcerLargeurTableau)

Dim TableauIntermediaire

Dim CompteurLigneIntermediaire

Dim IsPremiereLigne

'Version du 31 janvier 2010

'Exemple d utilisation :

Call AfficherTableauASP(TableauResultat, 8, 1, 0)

If ForcerLargeurTableau = 1 Then

Response.write("<TABLE WIDTH=95% BORDER=1>" & VbCrLf) 'Ouverture du tableau

Else

Response.write("<TABLE BORDER=1>" & VbCrLf) 'Ouverture du tableau

End If

'Affichage des valeurs de chaque champ

IsPremiereLigne = 1

For Compteur = LBound(MonTableau) To UBound(MonTableau)

'TableauIntermediaire

Response.write("<TR>") 'Ouverture de la ligne

'Si la ligne est un tableau

If IsArray(MonTableau(Compteur)) = True Then

TableauIntermediaire = MonTableau(Compteur)

For CompteurLigneIntermediaire = LBound(TableauIntermediaire) To UBound(TableauIntermediaire)

Response.write("<TD>")

If (IsPremiereLigne = 1) And (PremiereLigneIsTitre = 1) Then

Response.write("<B>")

End If

If IsNumeric(TaillePolice) = True Then

Response.write("<FONT style=""FONT-SIZE: " & TaillePolice & "pt;"">")

End If

Response.write(Trim(TableauIntermediaire(CompteurLigneIntermediaire)))

If IsNumeric(TaillePolice) = True Then

Response.write("</FONT>")

End If

If (IsPremiereLigne = 1) And (PremiereLigneIsTitre = 1) Then

Response.write("</B>")

End If

Response.write("</TD>")

Else 'Si la ligne n est pas un talbeau

Response.write("<TD>")

If (IsPremiereLigne = 1) And (PremiereLigneIsTitre = 1) Then

Response.write("<B>")

End If

If IsNumeric(TaillePolice) = True Then

Response.write("<FONT style=""FONT-SIZE: " & TaillePolice & "pt;"">")

End If

Response.write(Trim(MonTableau(Compteur)))

If IsNumeric(TaillePolice) = True Then

Response.write("</FONT>")

End If

If (IsPremiereLigne = 1) And (PremiereLigneIsTitre = 1) Then

Response.write("</B>")

End If

Response.write("</TD>")

End If

Response.write("</TR>") & VbCrLf 'Fermeture de la ligne

IsPremiereLigne = 0

Response.write("</TABLE>") & VbCrLf 'Fermeture du tableau

End Function

HTML - Afficher le contenu d'une variable tableau dans un tableau HTML

Public Function AfficherTableau (ByVal MonTableau)

'Version du 29 janvier 2010

Document.write("<TABLE WIDTH=95% BORDER=1>" & VbCrLf) 'Ouverture du tableau

'Affichage des valeurs de chaque champ

For Compteur = LBound(MonTableau) To UBound(MonTableau)

Document.write("<TR>") 'Ouverture de la ligne

Document.write("<TD>" & Trim(MonTableau(Compteur)) & "</TD>")

Document.write("</TR>") 'Fermeture de la ligne

Document.write("</TABLE>") 'Fermeture du tableau

End Function

HTML - Afficher une image en fond de page
<BODY bgColor="#ffffd2" style="BACKGROUND-POSITION: right bottom; MARGIN: 20px 3px 10px 5px; BACKGROUND-REPEAT: no-repeat" background="WoufLeChien02.jpg">
</BODY>

HTML - Ajouter des elementes selectionnes d une liste dans une autre
Sub AddSelectedListItemInAnotherList(ByRef objSourceList, ByRef objFinalList)

'24 february 2010 version

'Add selected item on source list and add it to the final list

'vbscript function for HTML web page

Dim UnCompteur

Dim ValeurDeLaLigne

Dim LaLongueur

For UnCompteur = 0 To objSourceList.options.length -1

If objSourceList.options(UnCompteur).selected = True Then

ValeurDeLaLigne = ""

ValeurDeLaLigne = objSourceList.options(UnCompteur).Value

LaLongueur = objFinalList.options.length

objFinalList.options.length = LaLongueur +1

objFinalList.options(LaLongueur).Value = ValeurDeLaLigne

objFinalList.options(LaLongueur).Text = objSourceList.options(UnCompteur).Text

End If 'If objSourceList.options(UnCompteur).selected = True Then

Next

End Sub

HTML - Balises DIV et positionnement
Voir le site suivant
http://openweb.eu.org/articles/images_css/

background-position: top;
background-repeat: repeat-x;

HTML - Balises Meta
<meta name="robots" content="index,follow" />
<meta name="keywords" content="un mot clee, un mot clee etc" />
<meta name="description" content="Description du site" />
<meta name="rating" content="general" />

HTML - Bouton
<INPUT TYPE="button" NAME="ButtNom" Value = "Un bouton"></INPUT>

HTML - CheckBox
<input type="checkbox" name="CaseCocher" value="Premier item">Une case a cocher

HTML - CheckBox Exemple

<FORM NAME = "NomDeFormulaire">

Public Sub UneFonction()

'DebutDuneBoucle

Document.Write "<Input type=""checkbox"" name=""ChkCoche" & Compteur & """ value="""& LoginComplet & """>"

'FinDuneBoucle

End Sub

Sub SubProcedureFinale(ByRef MonTableau)

Dim Position

Dim UnElement

Dim Message

If IsArray(MonTableau) = True Then

For Each UnElement In MonTableau

Message = Message & VbCrLf & UnElement

End Sub

Public Sub Cocher()

Dim NomElement

Dim UneVariable

Dim MonTableau

For Each ElementsDuFormulaire In document.forms("NomDeFormulaire")

NomElement = ElementsDuFormulaire.name

If Left(ElementsDuFormulaire.name,8) = "ChkCoche" Then

If document.getElementsByName(NomElement).item.checked = True Then

UneVariable = UneVariable & document.getElementsByName(NomElement).item.Value & ";"

End If

If Len(UneVariable) > 0 Then

UneVariable = Left(UneVariable,Len(UneVariable)-1)

MonTableau = Split(UneVariable,";")

Call SubProcedureFinale(MonTableau)

End If 'If Len(UneVariable) > 0 Then

End Sub

</Script>
</FORM>

HTML - ComboBox dans un champ Texte
Function ComboBoxDansChampTexte(ByVal MaComboBox, ByVal ChampTexteCible, ByVal SeparateurLignes, ByVal SeparateurTextValue)

'Version du 22 octobre 2008

'Prend les valeurs d une combo box et les injecte sous forme d une ligne unique dans un champ texte

Dim UnCompteur

Dim MonResultatFinal

ChampTexteCible.value = ""

MonResultatFinal = ""

For UnCompteur = 0 To MaComboBox.options.length -1

MonResultatFinal = MonResultatFinal & MaComboBox.options(UnCompteur).Text & SeparateurTextValue & MaComboBox.options(UnCompteur).Value & SeparateurLignes

If Len(MonResultatFinal) > 0 Then

MonResultatFinal = Left(MonResultatFinal, Len(MonResultatFinal)-Len(SeparateurLignes))

End If

ChampTexteCible.value = MonResultatFinal

End function

HTML - Coder et decoder du texte en HTML via VbScript
'Decoder du HTML
document.write(unescape("Mon%20texte%Decode") & "<BR>")

'Coder un texte en HTML
document.write(escape("Mon%20texte%Decode") & "<BR>")

'En asp la commande aurait été
Server.HTMLEncode("Mon texte a afficher")

HTML - Couleur d'affichage du texte
<Font Color="Green"></Font>

HTML - Delete selected lines in a list box
Sub ListDeleteLine(ByRef objList)

'24 february 2010 version

'Delete all selected item in the objList

'vbscript function for HTML web page

Dim Tableau

Dim LigneDeTableau

Dim IndexLigne

Dim NewArray()

Dim LineNewArray

IndexLigne = 0

For UnCompteur = 0 To objList.options.length - 1

'Msgbox objList.options.length & objList.options(UnCompteur).text

If objList.options(UnCompteur).selected = False Then

LineNewArray = objList.options(UnCompteur).text & VbCrLf & objList.options(UnCompteur).value

Redim Preserve NewArray(IndexLigne)

NewArray(IndexLigne) = LineNewArray

IndexLigne = IndexLigne + 1

End If

If IndexLigne > 0 Then

For UnCompteur = LBound(NewArray) To Ubound(NewArray) Step 1

objList.options.length = UnCompteur + 1

objList.options(UnCompteur).text = Split(NewArray(UnCompteur), VbCrLf)(0)

objList.options(UnCompteur).value = Split(NewArray(UnCompteur), VbCrLf)(1)

Else

objList.options.length = 0

End If

End Sub

HTML - Executer du code avec un compte différent
Dim objLogon
Set objLogon = Server.CreateObject("LoginAdmin.ImpersonateUser")
objLogon.Logon Application("Login"),Application("MotDePasse"),Application("DomaineDuLogin")

objLogon.Logoff
Set objLogon=Nothing

'Il faut créer une DLL nommée LoginAdmin
'Il faut y créer un module de classe nommé ImpersonateUser et y coller le code suivant :
Private Const LOGON32_LOGON_INTERACTIVE = 2
Private Const LOGON32_PROVIDER_DEFAULT = 0

Public Sub Logon(ByVal strAdminUser As String, ByVal strAdminPassword As String, ByVal strAdminDomain As String)

Dim lngTokenHandle, lngLogonType, lngLogonProvider As Long

Dim blnResult As Boolean

lngLogonType = LOGON32_LOGON_INTERACTIVE

lngLogonProvider = LOGON32_PROVIDER_DEFAULT

blnResult = RevertToSelf()

blnResult = LogonUser(strAdminUser, strAdminDomain, strAdminPassword, lngLogonType, lngLogonProvider, lngTokenHandle)

blnResult = ImpersonateLoggedOnUser(lngTokenHandle)

CloseHandle (lngTokenHandle)

End Sub

Public Sub Logoff()

Dim blnResult As Boolean

blnResult = RevertToSelf()

End Sub

HTML - Feuille de Style
<STYLE TYPE="text/css">

</STYLE>

<DIV ID="DivPopMessage"></DIV>

est equivalent à

<DIV ID="DivPopMessage" Style="POSITION:absolute;VISIBILITY:hidden;Z-INDEX:200;"></DIV>

On a aussi des pages ayant dans la balise HEAD
<link rel="stylesheet" type="text/css" href="sstyle.css">

Le fichier sstyle.css contiendra
.texte-accueil
{
FONT-SIZE: 11px;
FONT-FAMILY: Verdana, Arial, Helvetica, sans-serif
}

Une balise aura la propriété
<td class="texte-accueil"></td>
<input name="LeNom" type="text" class="texte-accueil">

HTML - Image en fond d une balise BODY
<BODY bgColor="#ffffd2" style="BACKGROUND-POSITION: right bottom; MARGIN: 20px 3px 10px 5px; BACKGROUND-REPEAT: no-repeat" background="WoufLeChien02.jpg">
</BODY>

HTML - Image en fond d une balise DIV
<DIV ID="Div01" Style="POSITION:absolute; VISIBILITY:visible;left:50px; top:50px; Z-INDEX:0;background-image='url(MonImage.jpg)'">
Ceci est du texte et derrière j ai une image
</DIV>

HTML - Image en fond d une ligne de tableau
<TABLE align=center width=90%><TR><TD Style="background-image: url(UnRepertoire/UneImage.gif);">&nbsp</TD></TR></TABLE>
<TABLE align=center width=90%><TR><TD background="UnRepertoire/UneImage.gif">&nbsp</TD></TR></TABLE>

HTML - Include

HTML - Lien HyperText
<A href="chemin de la cible" Target="_Blank">un nom</a>

HTML - List in text
Sub ListInText(ByRef objList, ByRef objText)

'24 february 2010 version

'All item in the objList will be serialized in the objText

'vbscript function for HTML web page

Dim Tableau

Dim LigneDeTableau

For UnCompteur = 0 To objList.options.length -1

LigneDeTableau = objList.options(UnCompteur).text & VbTab & objList.options(UnCompteur).value

If UnCompteur = 0 Then

Tableau = LigneDeTableau

Else

Tableau = Tableau & VbCrLf & LigneDeTableau

End If

objText.value = Tableau

Next
End Sub

HTML - Liste deroulante dynamique en Vbscript
'Principe :

'3 champs :
'

un champ permettant de rentrer un critere de filtrage
'

un champ contenant une liste déroulante contenant les différentes valeurs
'

un champ recevant directement une saisie manuelle ou une valeur située dans la liste déroulante

'La liste des valeurs est générée à l affichage via du code ASP
'Elle est également générée coté client dans une balise vbscript au traver d une variable de type tableau
'sur un évènement de saisie dans le champs de filtrage, la liste déroulante est automatiquement regénérée en n affichant que les valeurs contenant le champs de filtrage
'sur selection d une valeur de la liste déroulante, le champ final est automatiquement remplit

<%

'Code ASP

Dim MonCompteur

Dim UneLigne

Dim MonTableau

'On genere une balise VbScript cote client contenant toutes les valeurs du tableau

MonCompteur = 0

Response.Write("<Script language=""VbScript"">" & VbCrLf)

Response.Write("Dim MonTableau(" & Ubound(MonTableau) & ")" & VbCrLf)

For Each UneLigne In MonTableau

UneLigne = Trim(UneLigne)

If Len(UneLigne) > 0 Then

Response.Write("MonTableau(" & MonCompteur & ") = """ & UneLigne & """" & VbCrLf)

MonCompteur = MonCompteur + 1

End If

Response.Write("</Script>" & VbCrLf & VbCrLf)

'Affichage du champ permettant de rentrer un critere de filtrage

Response.Write "<INPUT type=Text Size = '2' Name=TxtChampDeFiltrage Value=''></INPUT>"

'Creation de la liste deroulante avec toutes les valeurs

Response.Write("<Select Name=""TxtMaListeDeroulante"">")

Response.Write("<Option Selected></Option>")

MaVariable = ""

For Each UneLigne In MonTableau

UneLigne = Trim(UneLigne)

If Len(UneLigne) > 0 Then

Response.Write "<Option Value=" & UneLigne & ">" & UneLigne & "</Option>"

End If

Response.Write("</Select>")

'Creation du champ final, celui qui doit recevoir la valeur définitive après sélection dans la liste déroulante

Response.Write("<INPUT type=Text Name=TxtSection Value=''></INPUT>")
%>

Sub TxtMaListeDeroulante_OnChange()

'Copie de la valeurs selectionne dans la liste deroulante dans le champ texte final

MonNomDeFormulaire.TxtSection.Value = MonNomDeFormulaire.TxtMaListeDeroulante.Value
End Sub

Sub TxtChampDeFiltrage_OnKeyUp()

Dim MonFiltre

Dim UneValeurDeLaListe

Dim UnCompteur

MonFiltre = MonNomDeFormulaire.TxtChampDeFiltrage.Value

MonFiltre = Trim(MonFiltre)

If IsArray(MonTableau) = True Then

UnCompteur = 0

MonNomDeFormulaire.TxtMaListeDeroulante.options.length = 0

For Each UneValeurDeLaListe In MonTableau

'Si on a demande a filtrer

If (Len(MonFiltre) > 0) Then

If Instr(1,Lcase(UneValeurDeLaListe),Lcase(MonFiltre)) > 0 Then

UnCompteur = UnCompteur + 1

MonNomDeFormulaire.TxtMaListeDeroulante.options.length = UnCompteur

MonNomDeFormulaire.TxtMaListeDeroulante.options(UnCompteur-1).Value = UneValeurDeLaListe 'Valeur du champ

MonNomDeFormulaire.TxtMaListeDeroulante.options(UnCompteur-1).Text = UneValeurDeLaListe 'Valeur affichee

End If

Else 'On affiche tout

UnCompteur = UnCompteur + 1

MonNomDeFormulaire.TxtMaListeDeroulante.options.length = UnCompteur

MonNomDeFormulaire.TxtMaListeDeroulante.options(UnCompteur-1).Value = UneValeurDeLaListe

MonNomDeFormulaire.TxtMaListeDeroulante.options(UnCompteur-1).Text = UneValeurDeLaListe

End If 'If (Len(MonFiltre) > 0) Then

End If 'If IsArray(MonTableau) = True Then

End Sub

HTML - Mettre un Vbscript derriere un lien HyperText
'Exemple trouve sur
'http://www.asp-php.net/tutorial/scripting/1er_script.php
'Penser à ajouter les balises en A pour les liens Hypertexte
<A Href="#" onclick='vbscript:MsgBox("Salut !")'>Bonjour</A>

HTML - Police de caractere
<FONT face=Arial color=navy size=2 style="FONT-SIZE: 10pt; COLOR: navy; FONT-FAMILY: Arial"></FONT>
<Font Color="Green"></FONT>
<Font face="arial, comic sans ms" Size=2>

HTML - Radio
<input type="radio" name="Nom de la commande" value="Nom de l'option">

HTML - Rediriger vers une page Web
<html>

<head>

</head>

<body>

Patientez pendant la redirection

</body>
</html>

HTML - Rediriger vers une page Web - seconde solution

<script type="text/javascript">

</script>

HTML - Text to Line
Sub TextInList(ByVal TextField)

'24 february 2010 version

'Parse a text line for a listbox

'use it on ASP code

Dim Tableau

Dim LigneDeTableau

Dim UnCompteur

Tableau = Split(TextField, VbCrLf)

For UnCompteur = LBound(Tableau) To Ubound(Tableau) Step 1

Response.Write("<Option Value=""" & Split(Tableau(UnCompteur), VbTab)(1) & """>" & Split(Tableau(UnCompteur), VbTab)(0) & "</Option>") & VbCrLF

Next
End Sub

JavaScript - Sites utiles
On trouve un script sympa sur le site de la sacem.
Par exemple sur la page
http://www.sacem.fr/cms/home/questios-utilisation-tilisation-oeuvres
la fonction slideUpDownForFaq que l'on trouve dans
http://www.sacem.fr/templates/sacem_templates/js/sacem.js
permet d'ouvrir de façon estéthique des menus.
le fichier sacem.js est incorporé ainsi dans la page :
<script src="/templates/sacem_templates/js/sacem.js" type="text/javascript"></script>

function slideUpDownForFaq(link,divId) {

if($(divId).css("display") == "none") {

$(divId).slideDown("slow");

$(link).removeClass("faqTitleClose");

$(link).addClass("faqTitleOpen");

} else {

$(divId).slideUp("slow");

$(link).addClass("faqTitleClose");

$(link).removeClass("faqTitleOpen");

}
}

JavaScript - Afficher la longueur d une variable Texte
//http://www.devguru.com/Technologies/ecmascript/quickref/string.html
<script language="JavaScript">

$MonTexte="Salut robert";

window.alert($MonTexte.length);
</script>

JavaScript - Afficher la position de la sourie
<BODY onmousemove="window.status = 'X=' + window.event.x + ' Y=' + window.event.y">

JavaScript - Afficher un message
<Font color="red">
<Script language="JavaScript">

document.write("La largeur de l ecran est "+screen.width+"<BR>");

document.write(screen.height+"<BR>");
</Script>
</Font>

JavaScript - Afficher un message en popup
<script language="JavaScript">
window.alert("Mon Message");
</script>

JavaScript - Afficher une balise DIV
document.getElementById("MaBaliseDiv").style.display = "inline";
Ou
document.getElementById("MaBaliseDiv").style.display = "";

JavaScript - Attendre un certain temps
window.setInterval("Clock_Tick()", 500);

JavaScript - Bouton pour changer le contenu d une balise DIV
<INPUT TYPE=Button Name=ButtUnBouton Value="Un Bouton" ONCLICK="MaFonction()">

<DIV ID="DivInfo" Style="POSITION:absolute;VISIBILITY:visible;Z-INDEX:200;">

Texte comprit dans une balise DIV
</DIV>

<SCRIPT TYPE="text/javascript">

function MaFonction(){

var MonMessage="Test de message";

var MonObjetDiv;

var Ns4=document.layers;

var Ns6=document.getElementById&&!document.all;

var IE4=document.all;

if (Ns4){

MonObjetDiv=document.DivInfo

}

else {

if (Ns6){

MonObjetDiv=document.getElementById("DivInfo").style

}

else {

if (IE4){

MonObjetDiv=document.all.DivInfo.style

}

if(Ns4){MonObjetDiv.document.write(MonMessage);MonObjetDiv.document.close();MonObjetDiv.visibility="visible"}

if(Ns6){document.getElementById("DivInfo").innerHTML=MonMessage;MonObjetDiv.display=''}

if(IE4){document.all("DivInfo").innerHTML=MonMessage;MonObjetDiv.display=''}

}

</SCRIPT>

JavaScript - Cacher une balise DIV
document.getElementById("MaBaliseDiv").style.display = "none";

JavaScript - Deplacer une balise DIV
<INPUT TYPE=Button Name=ButtUnBouton Value="Un Bouton" ONCLICK="MaFonction()">
<BR>

JavaScript - Detecter du texte dans un champs et remplacer
<html>
<head>

function ChgtStatus() {

//Version du 06/09/2011

//var reg=new RegExp("^[a-z]$","gi");

var reg=new RegExp("[a-z]","gi");

var machaine=document.MonFormulaire.TxtStatusTicket.value;

if (reg.test(machaine)) {

document.MonFormulaire.TxtStatusTicket.value = 1;

}

document.MonFormulaire.TxtStatusTicket.value = document.MonFormulaire.TxtStatusTicket.value.toLowerCase();

}

</script>
</head>

<BODY>

Status : <INPUT type=Text Name=TxtStatusTicket ID="TxtStatusTicket" Value='<%=StatusTicket%>' onChange="javascript: ChgtStatus();"></INPUT><BR>

</FORM>
</BODY>
</html>

JavaScript - Connaitre la resolution de l ecran
'Trouve sur http://www.allhtml.com/articles/detail/253
<Script language="JavaScript">

echo screen.width;

echo screen.height;
</Script>

<DIV ID="Div01" Style="POSITION:absolute; VISIBILITY:visible;left:50px; top:50px; Z-INDEX:0;">

Texte comprit dans une balise DIV
</DIV>

<SCRIPT TYPE="text/javascript">

var MonObjetDiv;

var Ns4=document.layers;

var Ns6=document.getElementById&&!document.all;

var IE4=document.all;

//Creation de l objet MonObjetDiv

if (Ns4){

MonObjetDiv=document.Div01

}

else {

if (Ns6){

MonObjetDiv=document.getElementById("Div01").style

}

else {

if (IE4){

MonObjetDiv=document.all.Div01.style

}

function MaFonction(){

//alert(MonObjetDiv.posLeft);

MonObjetDiv.left = MonObjetDiv.posLeft+20;

}

</SCRIPT>

JavaScript - Ecrire du texte dans une balise DIV
document.all("MaBaliseDiv").innerHTML="Mon texte";

JavaScript - Image mise en fond d une balise DIV
<DIV ID="Div01" Style="POSITION:absolute; VISIBILITY:visible;left:50px; top:50px; Z-INDEX:0">
Ceci est du texte et derrière j ai une image
</DIV>

<SCRIPT TYPE="text/javascript">

document.all.Div01.style.backgroundImage='url(MonImage.jpg)';
</SCRIPT>

JavaScript - Passer en parametres l objet lui meme
<Input type=button id="MonBouton" value="Ok" onclick="FctTest(this)">
<script language="JavaScript">

function FctTest($ZeObj){

window.alert("L Id de l objet appeleant est "+$ZeObj.id);

}

</script>

JavaScript - Positionner une image juste à côté d une autre
<INPUT TYPE=Button Name=ButtUnBouton Value="Un Bouton" ONCLICK="MaFonction()">
<BR>

<DIV ID="Div01" Style="POSITION:absolute; VISIBILITY:visible;left:50px; top:90px; Z-INDEX:0">
<IMG ID="Img01" SRC="guerrier.jpg">
</DIV>

<DIV ID="Div02" Style="POSITION:absolute; VISIBILITY:visible;left:50px; top:50px; Z-INDEX:0">
<IMG ID="Img02" SRC="rigt.jpg">
</DIV>

<SCRIPT TYPE="text/javascript">

MaFonction();

function MaFonction(){

var PositionX;

var PositionY;

//alert(MonObjetDiv.posLeft);

//Décaler la première image de 20px sur la droite et 10 vers le bas

document.getElementById("Div01").style.left = document.getElementById("Div01").style.posLeft+20;

document.getElementById("Div01").style.top = document.getElementById("Div01").style.posTop+10;

//Donner la largeur des images aux balises Div

document.getElementById("Div01").style.width = document.getElementById("Img01").width;

document.getElementById("Div02").style.width = document.getElementById("Img02").width;

//Donner la hauteur des images aux balises Div

document.getElementById("Div01").style.height = document.getElementById("Img01").height;

document.getElementById("Div02").style.height = document.getElementById("Img02").height;

//Positionner la seconde image juste à côté de la première

PositionX = document.getElementById("Div01").style.posLeft + document.getElementById("Img01").width;

PositionY = document.getElementById("Div01").style.posTop;

document.getElementById("Div02").style.left = PositionX;

document.getElementById("Div02").style.top = PositionY;

}

</SCRIPT>

JavaScript - Rediriger vers une page Web
<script language="JavaScript">

window.location.replace("http://MonNouveauSite");
</script>

JavaScript - Rediriger vers une page Web - Solution Bis
"onclick=""javascript:self.location.href='Http://MaPageWeb.com'"" "

JavaScript/Files - Lire un fichier texte
var ForReading = 1,

ForWriting = 2, ForAppending = 8
fso = new ActiveXObject("Scripting.FileSystemObject");
ts = fso.OpenTextFile($CheminFichier,ForReading,false)
while(ts.AtEndOfStream == false){

s = ts.ReadLine()
}

NETWORK - Afficher le compte de la personne loguée localement sur un poste
NomOrdinateur = Trim(InputBox("Entrez le nom de l'ordinateur","Nom de l'ordinateur",""))

Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & NomOrdinateur & "\root\cimv2")
Set colComputer = objWMIService.ExecQuery("Select * from Win32_ComputerSystem")

For Each objComputer in colComputer
Wscript.Echo "Logged-on user: " & objComputer.UserName
Next

NETWORK - Afficher le nom de l'ordinateur
Set objNetwork = CreateObject("Wscript.Network")
Wscript.Echo = objNetwork.ComputerName
Set objNetwork = Nothing

NETWORK - Afficher le schéma d'un domaine NT4
Set objDomain = GetObject("WinNT://" & "NomDuDomaine" & ",domain")

For Each ObjetDuDomaine In objDomain

If ObjetDuDomaine.Class = "Schema" Then

Wscript.Echo ObjetDuDomaine.Name & " ; " & ObjetDuDomaine.Class

For each Attribut in ObjetDuDomaine

Wscript.Echo Attribut.Name

End if
Next 'adsDomain

NETWORK - Afficher le type d un groupe
'Types de groupe :
'2 : Global
'4 : Local

Set objGroup = GetObject("WinNT://PCFBDA4514/aeff")
Wscript.Echo TypeGroupe(objGroup)
Set objGroup = Nothing

Public Function TypeGroupe(ByVal MonGroupe)

TypeGroupe = ""

Set objClass = GetObject(MonGroupe.Schema)

TypeGroupe = objGroup.Get("groupType")

Set objClass = Nothing

End Function

NETWORK - Afficher le user connecté
Set objNetwork = CreateObject("Wscript.Network")
Wscript.Echo = objNetwork.UserDomain & "\" & objNetwork.UserName
Set objNetwork = Nothing

NETWORK - Afficher les infos d'un compte NT
NomDomaine = Trim(InputBox("Entrez le nom du domaine","Nom du domaine","NomDeMonDomaine"))
UserName = Trim(InputBox("Entrez le login du compte","Login du compte","UnLogin"))
Set objDomain = GetObject("WinNT://" & NomDomaine & ",domain")
Set ObjUser = objDomain.GetObject("user",UserName)
Set objSchemaClass = GetObject(ObjUser.Parent)
NomDomaineDuLogin = objSchemaClass.name
Set objSchemaClass = Nothing
Wscript.Echo NomDomaineDuLogin & "\" & ObjUser.Name & " - " & ObjUser.FullName
Wscript.Echo "Le login script : " & ObjUser.LoginScript
Wscript.Echo "Description : " & ObjUser.Description
Wscript.Echo "Lecteur Reseau : " & ObjUser.HomeDirDrive
Wscript.Echo "Chemin du HomeFolder : " & ObjUser.HomeDirectory
Wscript.Echo "Profil : " & ObjUser.Profile
Wscript.Echo "Groupe primaire : " & ObjUser.Get("PrimaryGroupID")
Wscript.Echo "Date d expiration : " & ObjUser.AccountExpirationDate
Wscript.Echo "Le mot de passe est expiré ? : " & ObjUser.PasswordExpired
Wscript.Echo "AutoUnlockInterval en Secondes : " & ObjUser.AutoUnlockInterval
Wscript.Echo "Historique des passwords : " & ObjUser.PasswordHistoryLength
Wscript.Echo "Age du mot de passe en secondes : " & ObjUser.PasswordAge
Wscript.Echo "Nombre de mauvaises connections : " & ObjUser.BadLoginCount
Wscript.Echo "Derniere connection : " & ObjUser.LastLogin
'Wscript.Echo "Derniere deconnection : " & ObjUser.LastLogoff
Wscript.Echo "Compte desactive ? : " & ObjUser.AccountDisabled
Wscript.Echo "Compte lock ? : " & ObjUser.IsAccountLocked
Set objDomain = Nothing

'Infos sur la fonction GetLocale
'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/script56/html/vsfctGetObject.asp
'Infos sur comment manipuler un compte
'http://www.15seconds.com/issue/020130.htm
'http://msluder.dk/Resources/ADSI%20SDK%205%20HTML/winnt.htm

NETWORK - Afficher les sessions des personnes connectees a un ordinateur
'Dim fileSvc As IADsFileService
'Dim session As IADsSession

NomOrdinateur = Trim(InputBox("Entrez le nom de l'ordinateur","Nom de l'ordinateur",""))

Set objComputer = GetObject("WinNT://" & NomOrdinateur & ",Computer")
Set fileSvc = GetObject(objComputer.ADsPath & "/" & "LanmanServer")
For Each session In fileSvc.Sessions

Wscript.Echo Session.Name '& " " & Session.ConnectTime
Next

NETWORK - Ajouter un user dans un groupe
Public Function AjoutDansGroupe(ByVal MonGroupe,ByVal DomaineUser, ByVal LoginUser)

'Version du 9 octobre 2008

'Ex Version du 9 février 2005

'Fonction d'ajout d'un compte dans un groupe

AjoutDansGroupe = -1

Dim GroupeDom

Dim GroupeNom

Dim Compteur

Dim objServeur

Dim ObjGroupe

Compteur = Instr(1,MonGroupe,"\")

If Compteur > 0 Then

GroupeDom = Left(MonGroupe,Compteur-1)

GroupeNom = Mid(MonGroupe,Compteur+1)

Err.Clear

On Error Resume Next

Set objServeur = GetObject("WinNT://" & GroupeDom) 'Création de l'objet représentant le serveur

Set ObjGroupe = ObjServeur.GetObject("Group", GroupeNom) 'Création de l'objet représentant le groupe

'Ajout du compte de la personne dans le groupe

ObjGroupe.Add("WinNT://" & DomaineUser & "/" & LoginUser)

'ObjGroupe.SetInfo

'Set objDomaineAD = GetObject("LDAP://NomServeur/CN=Compte User,OU=Utilisateurs,DC=MonDomaine,DC=COM")

'ObjGroupe.Add(objDomaineAD)

'Set objDomaineAD = Nothing

Select Case Err.number

Case 0 'Par d'erreurs

AjoutDansGroupe = 1

Case -2147023518 'Deja dans le groupe

AjoutDansGroupe = 1

Case -2147463166 'Tentative d'Ajout d'un user d'un domaine dans un groupe global d'un autre domaine

AjoutDansGroupe = 0

Case Else

AjoutDansGroupe = 0

End Select

Set ObjGroupe = Nothing

Set objServeur = Nothing

On Error Goto 0

End If 'If Compteur > 0 Then

On Error Resume Next

End Function

NETWORK - Ajouter un user dans un groupe - Gestion plus complete, prise en charge de NT et AD
Public Function GestionGroupes(ByVal ObjetSource, ByVal CheminUNCDomaineObjet, ByVal NomGroupeCible, ByVal CheminUNCDomaineDuGroupe, ByVal TypeOperation)

'Version du 19 fev 2008

'Ex Version du 18 juillet 2007

'Ajoute ou supprime un objet en tant que membre d un groupe

'Retourne 0 si cela n a pas été fait, 1 si c est Ok

'Dependant de la fonction :

' GestionGroupesSF

' ModifierCheminLDAP

'Et indirectement dépendant de

' SeekCheminObjetAD

' IsFormatLDAP

'TypeOperation peut avoir les valeurs suivantes :

' 1 pour un ajout d un objet dans le groupe

' 2 pour un suppression d un objet dans le groupe

'Exemple :

'Ajout d un objet dans un groupe

Dim Position

Dim DomaineObjSourceAGererFormatNT4

Dim LoginObjSourceAGererFormatNT4

Dim DomaineObjGroupeAGererFormatNT4

Dim LoginObjGroupeAGererFormatNT4

Dim ObjGroupeAGerer

Dim ObjAIncorporer

Dim NumeroErreur

Dim ConnectionObjetSourceOk

Dim ConnectionGroupeCibleOk

Dim ObjetSourceFormatLDAP 'Chemin de l objet en LDAP

Dim ObjetCibleFormatLDAP 'Chemin de l objet en LDAP

Dim PossibilitesObjetSource

Dim PossibilitesGroupeCible

Dim Continuer 'A 1 si on peut continuer

Const ADS_PROPERTY_APPEND = 3

Const ADS_PROPERTY_DELETE = 4

GestionGroupes = 0

ConnectionObjetSourceOk = 0

ConnectionGroupeCibleOk = 0

Continuer = 0

If IsNumeric(TypeOperation) = True Then

Continuer = 1

End If 'If IsNumeric(TypeOperation) = True Then

'_________________________________________________________
'Connexion au groupe que l on doit gerer

If Continuer = 1 Then

'Verification de la bonne connexion aux objets indiques et de leur format

Call GestionGroupesSF(ObjetSource, CheminUNCDomaineObjet, ObjetSourceFormatLDAP, ConnectionObjetSourceOk, PossibilitesObjetSource, DomaineObjSourceAGererFormatNT4, LoginObjSourceAGererFormatNT4)

Call GestionGroupesSF(NomGroupeCible, CheminUNCDomaineDuGroupe, ObjetCibleFormatLDAP, ConnectionGroupeCibleOk, PossibilitesGroupeCible, DomaineObjGroupeAGererFormatNT4, LoginObjGroupeAGererFormatNT4)

'_________________________________________________________
'La connection à l objet et au groupe à gerer fonctionne, on passe à la suite

If (ConnectionObjetSourceOk = 1) And (ConnectionGroupeCibleOk = 1) Then

'Si on doit faire un ajout ou une suppression

If (TypeOperation = 1) Or (TypeOperation = 2) Then

'Si on peut gerer les 2 objets à la sauce NT4

If ((PossibilitesObjetSource And 1) = 1) And ((PossibilitesGroupeCible And 1) = 1) Then

Set ObjGroupeAGerer = GetObject("WinNT://" & DomaineObjGroupeAGererFormatNT4 & "/" & LoginObjGroupeAGererFormatNT4)

Err.Clear

On Error Resume Next

'Pour un ajout

If TypeOperation = 1 Then

ObjGroupeAGerer.Add ("WinNT://" & DomaineObjSourceAGererFormatNT4 & "/" & LoginObjSourceAGererFormatNT4)

End If

'Pour une suppression

If TypeOperation = 2 Then

ObjGroupeAGerer.Remove ("WinNT://" & DomaineObjSourceAGererFormatNT4 & "/" & LoginObjSourceAGererFormatNT4)

End If

ObjGroupeAGerer.SetInfo

NumeroErreur = Err.Number

'toto = InputBox("", "", NumeroErreur & " - " & Err.Description)

On Error GoTo 0

'Si on a reussit

'-2147022660 si le compte est deja membre du groupe NT4

'-2147023518 si le compte est deja membre du groupe AD Domaine Local

'-2147022659 - si l utilisateur ne fait pas partie de ce groupe NT4.

If (NumeroErreur = 0) Or (NumeroErreur = -2147022660) Or (NumeroErreur = -2147023518) Or (NumeroErreur = -2147022659) Then

GestionGroupes = 1

End If 'If (NumeroErreur = 0) Then

Set ObjGroupeAGerer = Nothing

Else 'Si on ne peut gerer les 2 objets à la sauce NT4, on tente les methodes AD

If ((PossibilitesObjetSource And 2) = 2) And ((PossibilitesGroupeCible And 2) = 2) Then

Set ObjGroupeAGerer = GetObject(ObjetCibleFormatLDAP)

Err.Clear

On Error Resume Next

If TypeOperation = 1 Then

ObjGroupeAGerer.PutEx ADS_PROPERTY_APPEND, "member", Array(ModifierCheminLDAP(ObjetSourceFormatLDAP, "", 4))

End If 'If TypeOperation = 1 Then

If TypeOperation = 2 Then

ObjGroupeAGerer.PutEx ADS_PROPERTY_DELETE, "member", Array(ModifierCheminLDAP(ObjetSourceFormatLDAP, "", 4))

End If 'If TypeOperation = 2 Then

ObjGroupeAGerer.SetInfo

NumeroErreur = Err.Number

On Error GoTo 0

'Si on a reussit

If (NumeroErreur = 0) Then

GestionGroupes = 1

End If 'If (NumeroErreur = 0) Then

Set ObjGroupeAGerer = Nothing

End If

End If 'If ((PossibilitesObjetSource And 1) = 1) And ((PossibilitesGroupeCible And 1) = 1) Then

End If 'If (TypeOperation = 1) Or (TypeOperation = 2) Then

End If 'If (ConnectionObjetSourceOk = 1) And (ConnectionGroupeCibleOk = 1) Then

End If 'If Continuer = 1 Then

End Function

Public Function GestionGroupesSF(ByVal MonObjet, ByVal CheminUNCDomaineDeLobjet, ByRef CheminLDAPObjet, ByRef ConnectionOK, ByRef Possibilites, ByRef NomServeurFormatNT4, ByRef NomObjetFormatNT4)

'Version du 19 fevrier 2008

'Ex Version du 28 juin 2007

'Sous fonction de GestionGroupes

Dim Position

Dim ConteneurObjet

Dim NomObjet

Dim ObjetTest

Dim CheminObjetAD

Dim UneVariable

Dim NomLong

Dim NomDuServeurFormatNT4DepuisLDAP 'Contient le nom du serveur recupere depuis le chemin LDAP

Dim NomDelObjetFormatNT4DepuisLDAP

Dim ObjetSourceFormatNT 'A 1 si l objet est au format NT4 et que l on peut s y connecter

Dim ObjetSourceFormatLDAP 'A 1 si l objet est au format LDAP et que l on peut s y connecter

Dim NumeroErreur

'Dependant de la fonction :

' SeekCheminObjetAD

' IsFormatLDAP

'La fonction vérifie le format de l objet et sa bonne connexion

'Le resultat est retourne sous 2 variables qui sont ConnectionOK et Possibilites

'La fonction retourne egalement le nom du serveur et le nom de l objet au format NT4

'ConnectionOK retourne une valeur qui est a

' 1 si la connection est Ok

' 0 dans le cas contraire

'Possibilites est un chiffre binaire compose. Valeurs des bits

' Bit 1 a 1 si on peut se connecter à la sauce NT4

' Bit 2 a 1 si on peut se connecter en LDAP

'Algo :

'On regarde si l objet source est au format NT4 et LDAP

'Si l objet source n est pas au format LDAP, on regarde si on peut le trouver

'On valide ensuite la bonne connexion a l'objet source, aussi bien au format NT que LDAP

'On retourne les variables en fonction

'Initialisation des variables internes

ObjetSourceFormatNT = 0

ObjetSourceFormatLDAP = 0

NomDuServeurFormatNT4DepuisLDAP = ""

NomDelObjetFormatNT4DepuisLDAP = ""

'Initialisation des variables qui sont retournees en reponse

ConnectionOK = 0

CheminLDAPObjet = ""

NomServeurFormatNT4 = ""

NomObjetFormatNT4 = ""

CheminObjetAD = ""

Possibilites = 0

'_______________________________________________________

'On regarde si MonObjet est au format NT4

Position = InStr(1, MonObjet, "\")

If Position > 1 Then

NomServeurFormatNT4 = Left(MonObjet, Position - 1)

NomObjetFormatNT4 = Mid(MonObjet, Position + 1)

ObjetSourceFormatNT = 1

Else

ObjetSourceFormatNT = 0

'NomObjetFormatNT4 = MonObjet

End If 'If Position > 1 Then

'_______________________________________________________

'On regarde si MonObjet est au format LDAP

'On commence par regarder si l'objet n est pas directement au format LDAP

If IsFormatLDAP(MonObjet, NomDuServeurFormatNT4DepuisLDAP, "") = 1 Then

CheminObjetAD = MonObjet

ObjetSourceFormatLDAP = 1

Else 'Si l objet n est pas directement un chemin LDAP

ObjetSourceFormatLDAP = 0

'Si on a precise le chemin LDAP du domaine et qu il est valide

If (Len(CheminUNCDomaineDeLobjet) > 0) And (IsFormatLDAP(CheminUNCDomaineDeLobjet, "", "") = 1) Then

'Un groupe au format LDAP ne peut avoir de \ dans le chemin

'Si on en a 1 alors on ne prend que ce qui est apres le \

'Cela peut correspondre à une notation NomCourtDuDomaine\Objet. On isole donc l objet

Position = InStr(1, MonObjet, "\")

If Position > 1 Then

UneVariable = Mid(MonObjet, Position + 1)

Else

UneVariable = MonObjet

End If

CheminObjetAD = SeekCheminObjetAD(UneVariable, "", CheminUNCDomaineDeLobjet)

'Si on a trouve un chemin LDAP pour notre objet

If Len(CheminObjetAD) > 0 Then

ObjetSourceFormatLDAP = 1

End If

End If 'If (Len(CheminUNCDomaineDeLobjet) > 0) And (IsFormatLDAP(CheminUNCDomaineDeLobjet, "", "") = 1) Then

End If

'_______________________________________________________
'On Verifie la bonne connexion a l objet

'Si l objet source est au format LDAP

If ObjetSourceFormatLDAP = 1 Then

'On va valider le fait que l on puisse se connecter a l objet

Err.Clear

On Error Resume Next

Set ObjetTest = GetObject(CheminObjetAD)

NumeroErreur = Err.Number

NomLong = ObjetTest.Get("distinguishedName")

NomDelObjetFormatNT4DepuisLDAP = ObjetTest.Get("sAMAccountName") 'On note le nom de l objet au format NT4

On Error GoTo 0

'Si on a reussit à se connecter au groupe

If (NumeroErreur = 0) Then

Possibilites = Possibilites + 2 'Passage du bit 2 à 1

CheminLDAPObjet = CheminObjetAD

Set ObjetTest = Nothing

'Si on a pas encore recure le nom du serveur et de l objet au format NT4

If (Len(NomServeurFormatNT4) = 0) And (Len(NomObjetFormatNT4) = 0) Then

If (Len(NomDuServeurFormatNT4DepuisLDAP) > 0) And (Len(NomDelObjetFormatNT4DepuisLDAP) > 0) Then

NomServeurFormatNT4 = NomDuServeurFormatNT4DepuisLDAP

NomObjetFormatNT4 = NomDelObjetFormatNT4DepuisLDAP

ObjetSourceFormatNT = 1

End If

Else

ObjetSourceFormatLDAP = 0

End If

'Si l objet source est au format NT

'Ou si on l a recupere juste avant

If ObjetSourceFormatNT = 1 Then

'On va valider le fait que l on puisse se connecter a l objet

Err.Clear

On Error Resume Next

Set ObjetTest = GetObject("WinNT://" & NomServeurFormatNT4 & "/" & NomObjetFormatNT4)

NumeroErreur = Err.Number

On Error GoTo 0

'Si on a reussit à se connecter au groupe

If (NumeroErreur = 0) Then

ObjetSourceFormatNT = 1

Possibilites = Possibilites + 1 'Passage du bit 1 à 1

Set ObjetTest = Nothing

Else

ObjetSourceFormatNT = 0

NomServeurFormatNT4 = ""

NomObjetFormatNT4 = ""

End If

End If

'_______________________________________________________
'Recapitulatif

'Si on a une connexion valide a l objet

If (ObjetSourceFormatNT = 1) Or (ObjetSourceFormatLDAP = 1) Then

ConnectionOK = 1

End If

End Function

NETWORK - Ajouter un user dans un groupe Local
'Récupération des paramètres
NomServeur = Trim(InputBox("Entrez le nom du serveur","Nom du serveur","NomDuServeur"))
NomGroupe = Trim(InputBox("Entrez le nom du groupe","Nom du groupe",""))
DomaineUser = Trim(InputBox("Entrez le domaine du user","Domaine du user",""))
LoginUser = Trim(InputBox("Entrez le login du user","Login du user",""))

'Création des objets et ajout du user dans le groupe
Set objServeur = GetObject("WinNT://" & NomServeur) 'Création de l'objet représentant le serveur
Set objGroup = ObjServeur.GetObject("Group", NomGroupe) 'Création de l'objet représentant le groupe
objGroup.Add ("WinNT://" & DomaineUser & "/" & LoginUser)
objGroup.SetInfo

'Destruction des objets
Set objGroup = Nothing
Set objServeur = Nothing

NETWORK - Ajouter un user dans un groupe Local. Le user est designe par son SID
'Récupération des paramètres
NomServeur = Trim(InputBox("Entrez le nom du serveur","Nom du serveur",""))
NomGroupe = Trim(InputBox("Entrez le nom du groupe","Nom du groupe",""))
SIDUser = Trim(InputBox("Entrez le SID du user","SID du user",""S-1-5-21-xxxxxxxxx-xxxxxxxxx-xxxxxxxxxx-xxxx""))

'Création des objets et ajout du user dans le groupe
Set objServeur = GetObject("WinNT://" & NomServeur) 'Création de l'objet représentant le serveur
Set objGroup = ObjServeur.GetObject("Group", NomGroupe) 'Création de l'objet représentant le groupe

objGroup.Add ("WinNT://" & SIDUser)
objGroup.SetInfo

'Destruction des objets
Set objGroup = Nothing
Set objServeur = Nothing

NETWORK - Creer un compte NT
NomDomaine = Trim(InputBox("Entrez le nom du Domaine","Nom du domaine","NomDuDomaine"))
MonLogin = Trim(InputBox("Entrez le Login","Login",""))
MonFullName = Trim(InputBox("Entrez le Nom et prenom","Nom et prenom",""))
MaDescription = Trim(InputBox("Entrez la description","Description",""))
InitialPassword = Trim(InputBox("Entrez le mot de passe","Mot de passe",""))

Set ObjDomain = GetObject("WinNT://" & NomDomaine & ",domain")
Set ObjUser = objDomain.Create("user",MonLogin)
ObjUser.FullName = MonFullName
ObjUser.Description = MaDescription
ObjUser.SetInfo
ObjUser.SetPassword(InitialPassword)

Set ObjUser = Nothing
Set ObjDomain = Nothing

NETWORK - Creer un groupe Global NT
NomDomaine = Trim(InputBox("Entrez le nom du Domaine","Nom du domaine","NomDuDomaine"))
NomGroupe = Trim(InputBox("Entrez le nom du groupe","Nom du groupe",""))
Set objDomain = GetObject("WinNT://" & NomDomaine & ",domain")
Set objGroup = objDomain.Create("Group",NomGroupe)
objGroup.SetInfo
Set objGroup = Nothing
Set objDomain = Nothing

NETWORK - Creer un groupe Local
Public Function CreerGroupeLocal(ByVal NomServeur, ByVal NomGroupe, ByVal DescriptionGroupe)

'Version du 23 fevrier 2007

'Creation d un groupe local sur un serveur

'Retourne 0 si le groupe n'a pas ete cree

'Retourne 1 si le groupe a ete cree

Dim NumeroErreur

Dim objServeur

Dim objGroup

'Valeur par défaut

CreerGroupeLocal = 0

Err.Clear

On Error Resume Next

Set objServeur = GetObject("WinNT://" & NomServeur) 'Création de l objet représentant le serveur

NumeroErreur = Err.Number

On Error Goto 0

'Si l objet représentant le serveur a été créé

If NumeroErreur = 0 Then

Err.Clear

On Error Resume Next

Set objGroup = objServeur.Create("Group",NomGroupe)

objGroup.Description = Trim(DescriptionGroupe)

objGroup.SetInfo

Set objGroup = Nothing

NumeroErreur = Err.Number

On Error Goto 0

'Si le groupe a bien été créé

If NumeroErreur = 0 Then

CreerGroupeLocal = 1

Else

CreerGroupeLocal = 0

End If

Set objGroup = Nothing

Set objServeur = Nothing

End Function

NETWORK - Creer un lecteur reseau
Public Function CreerLecteurReseau(ByVal LettreLecteur, ByVal CheminUNC)

'Version du 25 juin 2007

'On entre en paramètre une lettre de lecteur reseau de forme X ou X: ainsi que le chemin UNC de la ressource

'Retourne 1 si ok, sinon 0

Dim objNetwork

Dim NumeroErreur

CreerLecteurReseau = 0

LettreLecteur = Trim(LettreLecteur)

'Si j ai bien en entrée une chaine de longueur 1 ou 2

If (Len(LettreLecteur) > 0) And (Len(LettreLecteur) < 3) And (Len(CheminUNC) > 0) Then

'Si LettreLecteur contient :, alors on le supprime

If (Len(LettreLecteur) = 2) Then

If Right(LettreLecteur, 1) = ":" Then

LettreLecteur = Left(LettreLecteur, 1)

End If

End If 'If (Len(LettreLecteur) = 2) Then

'Si j ai bien une chaine de longueur 1

If (Len(LettreLecteur) = 1) Then

Set objNetwork = CreateObject("Wscript.Network")

Err.Clear

On Error Resume Next

objNetwork.MapNetworkDrive LettreLecteur & ":", CheminUNC

NumeroErreur = Err.Number

On Error GoTo 0

'Si il n y a pas eu d erreur

If NumeroErreur = 0 Then

CreerLecteurReseau = 1

End If

Set objNetwork = Nothing

End If 'If (Len(LettreLecteur) = 1) Then

End If

End Function

NETWORK - Creer un partage
NomServeurPartage = Trim(InputBox("Entrez le nom du serveur qui hebergera le partage","Nom du serveur","NomDuServeurDePartage"))
NomPartage = Trim(InputBox("Entrez le nom du partage a creer","Nom du partage","NomDuPartage"))
CheminPartage = Trim(InputBox("Entrez le chemin local du partage","Chemin du partage","CheminLocalDuPartage"))
DescriptionPartage = Trim(InputBox("Entrez la description du partage","Description du partage","-"))
Set ShareSrvObj = GetObject("WinNT://" & NomServeurPartage & "/lanmanserver") 'Création de l'objet contenant les partages
Set UnShare = ShareSrvObj.Create("fileshare", NomPartage) 'Debut de création de l'objet représentant le nouveau partage
UnShare.Path = CheminPartage
UnShare.MaxUserCount = "Nombre maximum de users pouvant se connecter au partage"
UnShare.Description = DescriptionPartage
UnShare.SetInfo 'Creation effective du partage
Set UnShare = Nothing
Set ShareSrvObj = Nothing

NETWORK - Lire le SID d'un compte NT en VB-VBA
Public Declare Function GetSidSubAuthority Lib "advapi32.dll" (pSid As Any, ByVal nSubAuthority As Long) As Long
Public Declare Function GetSidSubAuthorityCount Lib "advapi32.dll" (pSid As Any) As Long
Public Declare Function GetSidIdentifierAuthority Lib "advapi32.dll" (pSid As Any) As Long
Public Declare Sub CopyByValMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, ByVal Source As Long, ByVal Length As Long)

Public Function GetUserSID(NomDomaine As String, UserName As String) As String

Dim SDDL_SID As String

Dim pSia As Long

Dim pSiaByte(5) As Byte

Dim LeSid(512) As Byte

Dim pSubAuthorityCount As Long

Dim bSubAuthorityCount As Byte

Dim pAuthority As Long

Dim lAuthority As Long

'Convertir un RAW SID en SDDL

'http://support.microsoft.com/kb/286182/EN-US/

'Convertion du SID Brut (RAW) en format SDDL ( S-?-?-???-?????? )

'Le premier chiffre dans le format S- est le numéro de révision. Si on regarde la structure d un SID dans le Header de WinNT.H C

'On remarque que ce numéro est stocké dans le 0th Byte du format brut du SID

'Le dernier byte de la structure de l'Identifying authority structure (le 6ème, soit le numéro 5 car de base 0) correspond au second chiffre du SID format SDDL form

Set objDomain = GetObject("WinNT://" & NomDomaine & ",domain")

Set ObjUser = objDomain.GetObject("user", UserName)

TableauSID = ObjUser.ObjectSID

For Compteur = LBound(ObjUser.ObjectSID) To UBound(ObjUser.ObjectSID)

LeSid(Compteur) = TableauSID(Compteur)

'Récupération d'un pointeur vers le SID de l'autorité d'identification

pSia = GetSidIdentifierAuthority(LeSid(0))

' Copie de la valeur du pointeur dans un Byte

CopyByValMemory pSiaByte(0), pSia, 6

SDDL_SID = "S-" + LTrim(Str(LeSid(0))) + "-" + LTrim(Str(pSiaByte(5))) '

'Les autres chiffres du SID au format SDDL correspondent à une liste de sous-authoritées séparées par un -

'Le nombre de ces sous-authoritées est obtenu par l'API GetSidSubAuthorityCount qui retourne un pointeur qu'il faudra convertir

pSubAuthorityCount = GetSidSubAuthorityCount(LeSid(0))

CopyByValMemory bSubAuthorityCount, pSubAuthorityCount, 1

'Utilisation de l API GetSidSubAuthority pour récupérer le numéro des sous-athoritées

For AuthCount = 0 To bSubAuthorityCount - 1

pAuthority = GetSidSubAuthority(LeSid(0), AuthCount)

CopyByValMemory lAuthority, pAuthority, LenB(lAuthority)

'puis conversion des variables Dword récupérées en Long puis en String

'Par défaut les variables de VB sont signées mais les numéros d'authorité doivent être non-signés

'd'où le code ci-dessous qui effectue la conversion

'On récupère donc le bit de poid fort (on fait un masque avec un AND &H80000000). Si il est présent

'then add it back in into the right location in the double variable (+ 2^31)

dAuthority = lAuthority

If ((lAuthority And &H80000000) <> 0) Then

dAuthority = lAuthority And &H7FFFFFFF

dAuthority = dAuthority + 2 ^ 31

End If

SDDL_SID = SDDL_SID + "-" + LTrim(Str(dAuthority))

Next AuthCount

GetUserSID = SDDL_SID 'On retourne le resultat

End Function

NETWORK - Lister les attributs d'un groupe
Set objGroup = GetObject("WinNT://MonDomaine ou ma machine/mon groupe")
Set objClass = GetObject(objGroup.Schema)

For Each property in objClass.MandatoryProperties

WScript.Echo property, objGroup.Get(property)
Next

For Each property in objClass.OptionalProperties

WScript.Echo property, objGroup.Get(property)
Next

NETWORK - Lister les fichiers ouverts et le user associe
NomMachine = "Nom de la machine"
Set objConnection = GetObject("WinNT://" & NomMachine & "/LanmanServer")
Set colResources = objConnection.Resources

For Each objResource in colResources
Wscript.Echo "Path: " & objResource.Path
Wscript.Echo "User: " & objResource.User
Wscript.Echo
Next

NETWORK - Lister les lecteurs utilises - Vbs
Dim TableauDeLecteurs
Dim UnLecteur

TableauDeLecteurs = ListerLecteursLocaux("", "")
If IsArray(TableauDeLecteurs) = True Then

For Each UnLecteur In TableauDeLecteurs

Wscript.Echo UnLecteur

Next
End If

Public Function ListerLecteursLocaux(ByVal NomMachine, ByRef NbrResultats)

'Version du 26 juin 2007

'Retourne un tableau contenant tous les lecteurs locaux et le nombre de lecteurs locaux.

' Cela comprend les lecteurs physique et les mappages reseaux

'Retourne une chaine vide si probleme

'Le tableau peut contenir par exemple A C D E etc ....

'Exemple d utilisation

'Dim TableauDeLecteurs

'Dim UnLecteur

'TableauDeLecteurs = ListerLecteursLocaux("", "")

'If IsArray(TableauDeLecteurs) = True Then

'For Each UnLecteur In TableauDeLecteurs

'Wscript.Echo UnLecteur

'Next

'End If

Dim objWMIService

Dim colDisks

Dim UnLecteur

Dim ListeLecteurs

Dim TableauLecteurs

ListerLecteursLocaux = ""

NbrResultats = 0

If Len(NomMachine) = 0 Then

NomMachine = "."

End If

If Len(NomMachine) > 0 Then

Set objWMIService = GetObject("winmgmts:\\" & NomMachine & "\root\cimv2")

Set colDisks = objWMIService.ExecQuery("Select * from Win32_LogicalDisk")

'Pour tous les lecteurs de la machine

For Each objDisk In colDisks

UnLecteur = ""

UnLecteur = objDisk.DeviceID

If (Len(UnLecteur) = 2) Then

If Right(UnLecteur, 1) = ":" Then

UnLecteur = Left(UnLecteur, 1)

End If

End If 'If (Len(LettreLecteur) = 2) Then

'Si j ai bien une chaine de longueur 1

If (Len(UnLecteur) = 1) Then

NbrResultats = NbrResultats + 1

ListeLecteurs = ListeLecteurs & UnLecteur & ";"

End If 'If (Len(UnLecteur) = 1) Then

Next 'For Each objDisk In colDisks

'Si j ai bien une liste de lecteurs

If Len(ListeLecteurs) > 1 Then

'suppression du ; tout a droite

ListeLecteurs = Left(ListeLecteurs, Len(ListeLecteurs) - 1)

'Creation du tableau avec les lettres de lecteurs

TableauLecteurs = Split(ListeLecteurs, ";")

'On retourne le tableau de lecteurs

ListerLecteursLocaux = TableauLecteurs

End If 'If Len(ListerLecteurs) > 1 Then

End If 'If Len(NomMachine) > 0 Then

End Function

NETWORK - Lister les lecteurs reseaux utilises - Vbs
'Version du 25 juin 2007

Dim WshNetwork
Dim ObjDrives
Dim Compteur

Set WshNetwork = WScript.CreateObject("WScript.Network")
Set ObjDrives = WshNetwork.EnumNetworkDrives

For Compteur = 0 To ObjDrives.Count - 1 Step 2

WScript.Echo "Lecteur " & ObjDrives.Item(Compteur) & " = " & ObjDrives.Item(Compteur + 1)
Next

Set ObjDrives = Nothing
Set WshNetwork = Nothing

NETWORK - Lister les partages d'un serveur - Vbs
'27 october 2009 version

NomServeurPartage = Trim(InputBox("Entrez le nom du serveur contenant les partages","Nom du serveur","NomDuServeurDePartage"))
Set ShareSrvObj = GetObject("WinNT://" & NomServeurPartage & "/lanmanserver") 'Création de l'objet contenant les partages

'Pour tous les partages du serveur
For each ShareObj in ShareSrvObj

'Recupération du nom du partage

NomPartage = RecupPartage(ShareObj)

'Si le nom du partage n'est pas vide (ca arrive ! Et oui !)

If Len(NomPartage) > 0 Then

Wscript.Echo "UNC Path : " & "\\" & NomServeurPartage & "\" & ShareObj.Name

Wscript.Echo "Nom : " & ShareObj.Name

Wscript.Echo "Chemin : " & ShareObj.Path

Wscript.Echo "Description : " & ShareObj.Description

Wscript.Echo "Max Users : " & ShareObj.MaxUserCount

Wscript.Echo ""

End If 'If Len(NomPartage) > 0 Then
Next
Set ShareSrvObj = Nothing

Public Function RecupPartage(Byval ShareObj)

'Reenvoie le nom du partage si OK Sinon on recupere une chaine Vide

On Error Resume Next

RecupPartage = ""

RecupPartage = ShareObj.Name
End Function

NETWORK - Lister les membres d'un groupe Local
'Pour un script VBS
'Récupération des paramètres
NomServeur = Trim(InputBox("Entrez le nom du serveur","Nom du serveur","NomDuServeur"))
NomGroupe = Trim(InputBox("Entrez le nom du groupe","Nom du groupe",""))

Set objServeur = GetObject("WinNT://" & NomServeur) 'Création de l'objet représentant le serveur
Set objGroup = ObjServeur.GetObject("Group", NomGroupe) 'Création de l'objet représentant le groupe

'Pour tous les objets contenus dans le groupe
For Each objMembre in MonGroupe.Members

'Récupération du domaine de l'objet membre

Set objSchemaClass = GetObject(objMembre.Parent)

NomDomaine = objSchemaClass.Name

Set objSchemaClass = Nothing

'Affichage des infos du membre

Wscript.Echo objMembre.Class & " : " & NomDomaine & "\" & objMembre.Name
Next

'Destruction des objets
Set objGroup = Nothing
Set objServeur = Nothing

NETWORK - Lister les personnes et postes connectées sur un ordinateur

'Trouve sur
'http://www.microsoft.com/technet/scriptcenter/resources/qanda/feb05/hey0216.mspx

Dim ComputerName 'Nom du poste

ComputerName = InputBox("Entrez le nom du Pc","Nom du poste","")

Set objConnection = GetObject("WinNT://" & ComputerName & "/LanmanServer")
Set colSessions = objConnection.Sessions

For Each objSession in colSessions

Wscript.Echo "Computer: " & objSession.Computer

Wscript.Echo "Connected Time: " & objSession.ConnectTime

Wscript.Echo "Idle Time: " & objSession.IdleTime

Wscript.Echo "Name: " & objSession.Name

Wscript.Echo "User: " & objSession.User

Wscript.Echo
Next

NETWORK - Lister les Providers disponibles
'http://www.microsoft.com/technet/scriptcenter/guide/sas_ads_llyj.mspx
Set objProvider = GetObject("ADs:")
For Each Provider In objProvider

Wscript

.Echo Provider.Name
Next

NETWORK - Lister les users d'un domaine NT
NomDomaine = Trim(InputBox("Entrez le nom du domaine","Nom du domaine","NomDuDomaine"))
Set objDomain = GetObject("WinNT://" & NomDomaine & ",domain")
objDomain.Filter = Array("User")

For Each ObjUser In objDomain

Wscript.Echo ObjUser.Name & ";" & ObjUser.FullName & ";" & ObjUser.Description

Next
Set objDomain = Nothing

NETWORK - Pinguer une machine
Function Ping(ByVal szIP)

'Ping an remote machine using \root\cimv2:Win32_PingStatus

strComputer = "."

Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")

Set colPings = objWMIService.ExecQuery( "Select * From Win32_PingStatus where Address = '"& szIP & "'")

for Each objStatus in colPings

if IsNull(objStatus.StatusCode) or objStatus.StatusCode<>0 then

Ping = false

WScript.Echo "Computer did not respond."

else

Ping = true

Wscript.Echo "Computer responded."

end If

next
End Function

NETWORK - Renommer un groupe local
Dim strComputer
Dim OldLocalGroupName
Dim NewLocalGroupName

Call LocalGroupRename(strComputer, OldLocalGroupName, NewLocalGroupName)

Public Function LocalGroupRename(ByVal strComputer, ByVal OldLocalGroupName, Byval NewLocalGroupName)

'17 november 2009 version

If (Len(strComputer) > 0) And (Len(OldLocalGroupName) > 0) And (Len(NewLocalGroupName) > 0) Then

Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")

Set colAccounts = objWMIService.ExecQuery("SELECT * FROM Win32_Account WHERE LocalAccount = True AND Name = '" & OldLocalGroupName & "'")

For Each objAccount In colAccounts

objAccount.Rename NewLocalGroupName

End If 'If (Len(strComputer) > 0) And (Len(OldLocalGroupName) > 0) And (Len(NewLocalGroupName) > 0) Then

End Function

NETWORK - Supprimer un partage
NomPartage = Trim(InputBox("Entrez le nom du partage a supprimer","Nom du partage","NomDuPartage"))

Public Function ShareDelete(ByVal CheminUNC)

'Version du 5 mars 2008

'Retourne 1 si le partage a bien ete supprime

'0 si le partage n existe pas

'-1 si le format n est pas correct

Dim Position

Dim NomServeur

Dim NomPartage

Dim ShareSrvObj

Dim ShareObj

'Valeur par défaut

ShareDelete = -1

If Len(CheminUNC) > 4 Then

Position = InStr(3,CheminUNC,"\")

'Si on a bien un chemin UNC en entrée

If (Left(CheminUNC,2) = "\\") And (Position > 0) Then

NomServeur = Mid(Left(CheminUNC,Position-1),3)

NomPartage = Mid(CheminUNC,Position+1)

On Error Resume Next

'Récupération du chemin du partage

Set ShareSrvObj = GetObject("WinNT://" & NomServeur & "/lanmanserver")

ShareSrvObj.Delete "fileshare", NomPartage

On Error Goto 0

'Si il n'y a pas d'erreurs

If Err.Number = 0 Then

ShareDelete = 1

Else

ShareDelete = 0

End If

Set ShareSrvObj = Nothing

End If 'Si on a bien un chemin UNC

End If 'If Len(CheminUNC) > 4 Then

End Function

Set ShareSrvObj = GetObject("WinNT://" & NomServeurPartage & "/lanmanserver")
ShareSrvObj.Delete "fileshare", NomPartage 'Suppression effective du partage
Set ShareSrvObj = Nothing

NETWORK - Supprimer les entres de comptes supprimes des groupes d'un serveur

Dim NombreSuppressions 'Nombre d'entrees supprimees

'Récupération des paramètres
NomServeur = Trim(InputBox("Entrez le nom du serveur","Nom du serveur",""))
Set objServeur = GetObject("WinNT://" & NomServeur) 'Création de l'objet représentant le serveur
objServeur.Filter = Array("Group") 'On ne prend que les groupes

NombreSuppressions = 0
For Each MonGroupe in objServeur 'Pour tous les groupes du serveur

Wscript.Echo "Groupe " & MonGroupe.Name

For Each objMembre in MonGroupe.Members

'Récupération du domaine du groupe

Set objSchemaClass = GetObject(objMembre.Parent)

NomDomaine = objSchemaClass.Name

Set objSchemaClass = Nothing

'Si le membre est un SID qui n'a pas été résolu

If NomDomaine = "WinNT:" Then

Wscript.Echo " Suppression de " & objMembre.Name & " du groupe " & MonGroupe.Name

Call MonGroupe.Remove("winnt://" & objMembre.Name)

NombreSuppressions = NombreSuppressions + 1

End If

Next 'For Each objMembre in MonGroupe.Members

Next 'For Each MonGroupe in objServeur

'Destruction des objets
Set objGroup = Nothing
Set objServeur = Nothing

Wscript.Echo ""
Wscript.Echo "Il y a eu " & NombreSuppressions & " suppressions"

NETWORK - Serveurs liées
Pour créer les connections
sp_addlinkedserver et sp_linkedservers.

Pour les supprimer
sp_dropserver

Exemple de requete :
Remarque Cet exemple présuppose qu'un alias de base de données Oracle a été créé sous le nom de ORCLDB.

EXEC sp_addlinkedserver 'OracleSvr',
'Oracle 7.3',
'MSDAORA',
'ORCLDB'
GO
SELECT *
FROM OPENQUERY(OracleSvr, 'SELECT name, id FROM joe.titles')
GO

Autre exemple trouve sur
http://support.microsoft.com/kb/280106/en-us

-- Adding linked server (from SQL Server Books Online):
/* sp_addlinkedserver [@server =] 'server'
[, [@srvproduct =] 'product_name']
[, [@provider =] 'provider_name']
[, [@datasrc =] 'data_source']
[, [@location =] 'location'] [, [@provstr =] 'provider_string']
[, [@catalog =] 'catalog']
*/

EXEC sp_addlinkedserver 'Ora817Link', 'Oracle', 'MSDAORA', 'oracle817'

-- Adding linked server login:
/* sp_addlinkedsrvlogin [@rmtsrvname =] 'rmtsrvname'
[,[@useself =] 'useself']
[,[@locallogin =] 'locallogin']
[,[@rmtuser =] 'rmtuser']
[,[@rmtpassword =] 'rmtpassword']
*/

EXEC sp_addlinkedsrvlogin 'Ora817Link', 'FALSE',NULL, 'scott', 'tiger'

-- Help on the linked server:
EXEC sp_linkedservers
EXEC sp_helpserver
select * from sysservers

NETWORK - Stopper les noeuds d un serveur d un cluster NLB
'31 january 2011 version
'Inspired by
'http://social.msdn.microsoft.com/Forums/en-US/csharpgeneral/thread/97c35d15-c7e1-4855-ae1b-81fd7352856b/
'http://msdn.microsoft.com/en-us/library/cc307934%28v=vs.85%29.aspx

'Script qui arrête les noeuds d un serveur NLB désigné
'Le script se connecte au serveur NLB indiqué, et lance par exemple la commande drainstop sur tous les noeuds du dit serveur, attend que le noeud soit effectivement stoppé afin que cela s arrête proprement.
'Examples de syntaxe :
'myscript.vbs -n "MyServerName" -c "drainstop"
'myscript.vbs -n "MyServerName" -c "start"

Dim strComputer
Dim strCommand

'Parse the command line.
call ParseCommand()

Wscript.Echo ""
Wscript.Echo "MicrosoftNLB_Node"
Wscript.Echo "================="
Wscript.Echo ""
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\MicrosoftNLB")
Set colItems = objWMIService.ExecQuery("Select * from MicrosoftNLB_Node",,48)

For Each objItem in colItems

Wscript.Echo "ComputerName: " & objItem.ComputerName

Wscript.Echo "DedicatedIPAddress: " & objItem.DedicatedIPAddress

Wscript.Echo "HostPriority: " & objItem.HostPriority

Wscript.Echo "Name: " & objItem.Name

Wscript.Echo "StatusCode: " & objItem.StatusCode

Wscript.Echo ""

If strCommand = "drainstop" Then

Wscript.Echo "Stopping the node"

ReturnValue = objItem.DrainStop()

bStart = true

Wscript.Echo "Waiting the node to stop..."

Wscript.Echo ""

While(bStart)

Set colItems1 = objWMIService.ExecQuery("Select StatusCode from MicrosoftNLB_Node",,48)

For Each objItem1 in colItems1

Call DisplayReturnValue(objItem1.StatusCode)

if objItem1.StatusCode = "1005" then

bStart = false

end if

WScript.Sleep 1000

Wend

Wscript.Echo ""

Wscript.Echo "Node Stopped"

Wscript.Echo ""

End If 'If strCommand = "drainstop" Then

If strCommand = "start" Then

Wscript.Echo "Start the node"

objItem.Start()

End If

Next

sub DisplayReturnValue(ReturnValue)

' Translate the return value to a string and display it to output.

select case ReturnValue

case 1000

wscript.echo " Success."

case 1001

wscript.echo " Cluster mode is already stopped/started, or traffic handling is already enabled/disabled on specified port."

case 1002

wscript.echo " Cluster mode stop or start operation interrupted connection draining process."

case 1003

wscript.echo " Cluster mode could not be started due to configuration problems on the target host."

case 1004

wscript.echo " Port number not found among port rules."

case 1005

wscript.echo " Cluster mode is stopped on the host."

case 1006

wscript.echo " Cluster is converging."

case 1007

wscript.echo " Cluster or host converged successfully."

case 1008

wscript.echo " Host is converged as default host."

case 1009

wscript.echo " Host is draining after drainstop command."

case else:

wscript.echo " Unknown return (" & ReturnValue & ")."

end select
End Sub

Function ParseCommand()

' Parses the command line and fills the script variables

' with the appropriate values.

Dim ArgCount

Dim oArgs

Set oArgs = Wscript.Arguments

ArgCount = 0

if oArgs.Count = 0 then

wscript.echo "No arguments specified."

wscript.echo

call Help()

end if

While ArgCount < oArgs.Count

Select Case LCase(oArgs(ArgCount))

Case "-n"

ArgCount = ArgCount + 1

strComputer=LCase(oArgs(ArgCount))

wscript.echo "Server name : " & strComputer

Case "-c"

ArgCount = ArgCount + 1

strCommand=LCase(oArgs(ArgCount))

wscript.echo "Command : " & strCommand

Case Else:

wscript.echo "Invalid command."

wscript.echo

call Help()

wscript.quit

End Select

ArgCount = ArgCount + 1

Wend
End Function

sub Help()

' Display command-line syntax for the script.

wscript.echo "Stop/Start Network Load Balancing (NLB) service"

wscript.echo "Syntax:"

wscript.echo

wscript.echo "-n Server name or IP"

wscript.echo "-c command name : drainstop or start"

wscript.echo

wscript.echo "Examples:"

wscript.echo

wscript.echo "myscript.vbs -n ""MyServerName"" -c ""drainstop"""

wscript.quit
End Sub

NETWORK - Supprimer un groupe local d un serveur
Dim objServer
Dim MyServerName
Dim LocalGroupName
Dim ErrorNumber

MyServerName = Trim(InputBox("Entrez le nom du serveur","Nom du serveur","ServerName"))
LocalGroupName = Trim(InputBox("Entrez le nom du groupe","Nom du groupe a supprimer",""))

Err.Clear
On Error Resume Next
Set objServer = GetObject("WinNT://" & MyServerName)
ErrorNumber = Err.number
On Error Goto 0
If (ErrorNumber = 0) Then

Call objServer.Delete("Group", LocalGroupName)
End If

Set objServer = Nothing

NETWORK - Supprimer un lecteur reseau
Public function SupprimerLecteurReseau(ByVal LettreLecteur)

'Version du 25 juin 2007

'On entre en paramètre une lettre de lecteur reseau de forme X ou X:

'Retourne 1 si ok, sinon 0

Dim objNetwork

Dim Continuer

SupprimerLecteurReseau = 0

LettreLecteur = Trim(LettreLecteur)

'Si j ai bien en entrée une chaine de longueur 1 ou 2

If (Len(LettreLecteur) > 0) And (Len(LettreLecteur) < 3) Then

'Si LettreLecteur contient :, alors on le supprime

If (Len(LettreLecteur) = 2) Then

If Right(LettreLecteur, 1) = ":" Then

LettreLecteur = Left(LettreLecteur, 1)

End If

End If 'If (Len(LettreLecteur) = 2) Then

'Si j ai bien une chaine de longueur 1

If (Len(LettreLecteur) = 1) Then

'Suppression du lecteur reseau

Set objNetwork = CreateObject("WScript.Network")

On Error Resume Next

objNetwork.RemoveNetworkDrive LettreLecteur & ":", True

On Error GoTo 0

Set objNetwork = Nothing

SupprimerLecteurReseau = 1

End If

End If 'If (Len(LettreLecteur) > 0) And (Len(LettreLecteur) < 3) Then

End function

NETWORK - Supprimer un user d'un domaine NT
'Pour info :
'LastName est le nom de la personne
'FirstName ou GivenName est le prénom de la personne
NomDomaine = Trim(InputBox("Entrez le nom du Domaine","Nom du domaine","NomDuDomaine"))
LoginUser = Trim(InputBox("Entrez le login du user","Login du user",""))

Set objDomain = GetObject("WinNT://" & NomDomaine & ",domain")
Call objDomain.Delete("User", LoginUser)
Set ObjUser = Nothing
Set objDomain = Nothing

NETWORK - Supprimer un user d'un Groupe
NomServeur = Trim(InputBox("Entrez le nom du serveur ou du domaine contenant le groupe","Nom du serveur ou domaine",""))
NomGroupe = Trim(InputBox("Entrez le nom du groupe","Nom du groupe",""))
LoginComplet = Trim(InputBox("Entrez le login de la personne a supprimer" & VbCrLf & "sous la forme Domaine\Login","Login de la personne a supprimer","Domaine\login"))

Public Function SupprimerUserGroup(ByVal NomServeur, ByVal NomGroupe, ByVal LoginComplet)

'Version du 14 fev 2008

'Retourne True si le user a bien ete supprime

Dim NumeroErreur

Dim DomaineUser

Dim LoginUser

Dim objServeur

Dim ObjGroup

Dim Position

Dim IsSID

SupprimerUserGroup = False

LoginComplet = LCase(LoginComplet)

'On récupère le domaine et le login du user

Position = InStr(1, LoginComplet, "\")

If Position > 0 Then

IsSID = False

If Left(LoginComplet, 6) = "winnt:" Then

IsSID = True

End If

If IsSID = False Then

LoginUser = Mid(LoginComplet, Position + 1)

DomaineUser = Left(LoginComplet, Position - 1)

Else

Position = "s-1-5"

LoginComplet = "WinNt://" & Mid(LoginComplet, Position)

End If

Err.Clear

On Error Resume Next

Set objServeur = GetObject("WinNT://" & NomServeur)

Set ObjGroup = objServeur.GetObject("Group", NomGroupe)

If IsSID = False Then

ObjGroup.Remove ("WinNT://" & DomaineUser & "/" & LoginUser)

Else

ObjGroup.Remove (LoginComplet)

End If

NumeroErreur = Err.Number

On Error GoTo 0

If (NumeroErreur = 0) Then

SupprimerUserGroup = True

End If

Set ObjGroup = Nothing

Set objServeur = Nothing

End If 'If Position > 0 Then

End Function

NETWORK - Trouver le chemin local d un partage
Public Function TrouverCheminLocalShare(ByVal CheminPartage, ByVal TypeResultat, ByRef ContientSousRepertoires)

'Version du 8 fevrier 2008

'Ex Version du 26 juin 2007

'Retourne le chemin local d un partage

'Le convertit eventuellement en chemin UNC mais passant par le partage administratif

'Exemple

'MonRetour = TrouverCheminLocalShare("\\UnServeur\UnPartage\UnSousRepertoire",2,NbrSousRepertoires)

'Valeurs de TypeResultat

' 1 : retourne juste le chemin local. Exemple : D:\Disks\UnRepertoire

' 2 : retourne un chemin UNC mais passant par un partage administratif. Exemple : \\MonServeur\d$\RepertoireDuPartage\SousRepertoire

'Valeurs de de retour de ContientSousRepertoires

' Contient 0 si le chemin contient des sous repertoires

' Contient le nombre de sous repertoires si il y en a

Dim Position

Dim NomServeur

Dim NomPartage

Dim ShareSrvObj

Dim CheminUNC

Dim MonTableau

Dim SousRepertoires

Dim UnSousRepertoire

Dim CompteurSousRepertoire

Dim NumeroErreur

TrouverCheminLocalShare = ""

ContientSousRepertoires = 0

'Si TypeResultat n est pas un numerique ou nul

If (IsNumeric(TypeResultat) = False) Or (Len(TypeResultat) = 0) Then

TypeResultat = 1

Else 'Si c est un numerique

If (TypeResultat < 1) Or (TypeResultat > 2) Then

TypeResultat = 1

End If

'Si le chemin commence comme un nom UNC

If (Left(CheminPartage, 2) = "\\") And (Len(CheminPartage) > 3) Then

CheminPartage = Mid(CheminPartage, 3) 'Suppression des \\ du debut

MonTableau = Split(CheminPartage, "\")

If IsArray(MonTableau) = True Then

NomServeur = MonTableau(0)

NomPartage = MonTableau(1)

'Si on a des sous repertoires, on stocke le chemin des sous repertoires du partage dans une variable

SousRepertoires = ""

If UBound(MonTableau) > 1 Then

For CompteurSousRepertoire = 2 To UBound(MonTableau)

UnSousRepertoire = MonTableau(CompteurSousRepertoire)

SousRepertoires = SousRepertoires & "\" & UnSousRepertoire

ContientSousRepertoires = ContientSousRepertoires + 1

'Suppression du caractère tout a gauche, soit le \

If Len(SousRepertoires) > 0 Then

SousRepertoires = Mid(SousRepertoires, 2)

End If

End If 'If UBound(MonTableau) > 1 Then

Err.Clear

On Error Resume Next

Set ShareSrvObj = GetObject("WinNT://" & NomServeur & "/lanmanserver") 'Création de l'objet contenant les partages

NumeroErreur = Err.Number

On Error GoTo 0

'Si on a reussit à creer l objet representant les partages du serveur

If NumeroErreur = 0 Then

'Recherche du partage nous concernant

For Each ShareObj In ShareSrvObj

'Si on a trouve le partage recherche

If Len(NomPartage) = Len(ShareObj.Name) Then

If LCase(NomPartage) = LCase(ShareObj.Name) Then

CheminUNC = ""

CheminUNC = ShareObj.Path

'Ajout du nombre de sous repertoires par rapport a la racine du lecteur

ContientSousRepertoires = ContientSousRepertoires + UBound(Split(CheminUNC, "\"))

If TypeResultat = 2 Then

CheminUNC = Replace(CheminUNC, ":", "$")

CheminUNC = "\\" & NomServeur & "\" & CheminUNC

End If 'If TypeResultat = 2 Then

'Ajout des sous repertoires

If Len(SousRepertoires) > 0 Then

CheminUNC = CheminUNC & "\" & SousRepertoires

End If

TrouverCheminLocalShare = CheminUNC

Exit For

End If 'If LCase(NomPartage) = Lcase(ShareObj.Name)

End If 'If Len(NomPartage) = Len(ShareObj.Name) Then

End If 'If NumeroErreur = 0 Then

Set ShareSrvObj = Nothing

End If 'If IsArray(MonTableau) = True Then

End If 'If (Left(CheminPartage, 2) = "\\") And (Len(CheminPartage) > 3) Then

End Function

NETWORK - Trouver le SID d un compte
Public Function GetAccountSID(ByVal DomaineLogin)

'Version du 8 fevrier 2008

'Ex Version du 20 fevrier 2007

Dim oSid 'As ADSSECURITYLib.ADsSID

Dim Position

Dim Domaine

Dim Login

Dim MonSID

Dim objSid

Dim Continuer

Dim NumeroErreur

Const ADS_SID_HEXSTRING = 1

Const ADS_SID_WINNT_PATH = 5

Continuer = 0

GetAccountSID = "" 'Valeur par défaut

Err.Clear

On Error Resume Next

Set objSid = CreateObject("ADsSid") 'from ResourceKit

NumeroErreur = Err.Number

On Error GoTo 0

If (NumeroErreur = 0) Then

Continuer = 1

Set objSid = Nothing

Else

Continuer = 0

End If

If Continuer = 1 Then

Position = InStr(DomaineLogin, "\")

If Position > 0 Then

Domaine = Left(DomaineLogin, Position - 1)

Set objSid = CreateObject("ADsSid") 'from ResourceKit

On Error Resume Next

objSid.SetAs ADS_SID_WINNT_PATH, "WinNT://" & Domaine & "/" & Login 'Get the user account SID

NumeroErreur = Err.Number

On Error GoTo 0

If (NumeroErreur = 0) Then

MonSID = objSid.GetAs(ADS_SID_HEXSTRING) 'Convert to binary string

Else

MonSID = ""

End If 'If (NumeroErreur = 0) Then

Set objSid = Nothing

'On retourne le résultat

GetAccountSID = MonSID

End If

End If 'If Continuer = 1 Then

End Function

NETWORK - Trouver une lettre de lecteur local libre
Public Function TrouverLettreLecteurLibre(ByVal NomMachine, ByVal OrdreRecherche, ByVal ListeLecteursPreferes)

'Version du 26 juin 2007

'Dépendant de la fonction ListerLecteursLocaux

'Retourne une lettre de lecteur libre

'Retourne une chaine vide si il n y en a pas de disponible

'Exemple :

'MaLettre = TrouverLettreLecteurLibre("","","")

'MaLettre = TrouverLettreLecteurLibre("NomMachine","","GHI")

'MaLettre = TrouverLettreLecteurLibre("",2,"")

'Demande en paramètres :

' NomMachine : le nom de la machine sur laquelle on recherche une lettre de lecteur. Laisser vide pour le poste local

' OrdreRecherche : A 1 par defaut si vide. Entier à 1 pour recherche dans l'odre alphabétique, 2 pour l ordre inverse.

' ListeLecteursPreferes : Prioritaire sur OrdreRecherche. C est une liste contenant dans l ordre les lecteurs eventuellement desires. Exemple : EFGHIJ

Dim ListeLecteursDemandes

Dim ListeLecteursExistants

Dim UnLecteurVoulu

Dim UnLecteurExistant

Dim CompteurLecteur

Dim Trouve

Const LecteursDansOrdreAller = "CDEFGHIJKLMNOPQRSTUVWXYZ"

Const LecteursDansOrdreRetour = "ZYXWVUTSRQPONMLKJIHGFEDC"

'Valeur de retour vide par défaut

TrouverLettreLecteurLibre = ""

'Si le nom de la machine n est pas precisé, on met un .

If Len(NomMachine) = 0 Then

NomMachine = "."

End If

If (Len(OrdreRecherche) = 0) Or (IsNumeric(OrdreRecherche) = False) Then

OrdreRecherche = 1

End If

'Si on a precise une liste de lecteurs

ListeLecteursPreferes = Trim(ListeLecteursPreferes)

If Len(ListeLecteursPreferes) > 0 Then

ListeLecteursDemandes = ListeLecteursPreferes

Else

Select Case OrdreRecherche

Case 1

ListeLecteursDemandes = LecteursDansOrdreAller

Case 2

ListeLecteursDemandes = LecteursDansOrdreRetour

Case Else

ListeLecteursDemandes = LecteursDansOrdreAller

End Select

End If 'If Len(ListeLecteursPreferes) > 0 Then

'si on a bien une liste de lecteurs à tester

If Len(ListeLecteursDemandes) > 0 Then

ListeLecteursExistants = ListerLecteursLocaux(NomMachine, "")

If IsArray(ListeLecteursExistants) = True Then

For CompteurLecteur = 1 To Len(ListeLecteursDemandes)

UnLecteurVoulu = Mid(ListeLecteursDemandes, CompteurLecteur, 1)

'Pour regarde si le lecteur voulu est dans la liste de tous les lecteurs existants

Trouve = 0

For Each UnLecteurExistant In ListeLecteursExistants

If LCase(UnLecteurVoulu) = LCase(UnLecteurExistant) Then

Trouve = 1

Exit For

End If 'If LCase(UnLecteurVoulu) = LCase(UnLecteurExistant) Then

Next 'For Each UnLecteurExistant In ListeLecteursExistants

'Si on a pas trouve le lecteur demande dans la liste des lecteurs existants, alors la lettre est libre

If Trouve = 0 Then

'On retourne la lettre de lecteur libre

TrouverLettreLecteurLibre = UnLecteurVoulu

Exit For

End If

Next 'For CompteurLecteur = 1 To Len(ListeLecteursDemandes)

End If 'If IsArray(ListeLecteursExistants) = True Then

End If 'If Len(ListeLecteursDemandes) > 0 Then

End Function

NETWORK - Utiliser un compte différent pour lancer WMI
Const WbemAuthenticationLevelPktPrivacy = 6

strComputer = "atl-ws-01"
strNamespace = “root\cimv2”
strUser = "Administrator"
strPassword = "4rTGh2#1"

Set objWbemLocator = CreateObject("WbemScripting.SWbemLocator")
Set objWMIService = objwbemLocator.ConnectServer(strComputer, strNamespace, strUser, strPassword)
objWMIService.Security_.authenticationLevel = WbemAuthenticationLevelPktPrivacy

Set colItems = objWMIService.ExecQuery("Select * From Win32_OperatingSystem")
For Each objItem in ColItems
Wscript.Echo strComputer & ": " & objItem.Caption
Next

NETWORK - Verifier la presence d'un groupe Local
NomServeur = Trim(InputBox("Entrez le nom du serveur","Nom du serveur","NomDuServeur"))
NomGroupe = Trim(InputBox("Entrez le nom du groupe","Nom du groupe",""))

If TestPresenceGroupe(NomServeur,NomGroupe) = 1 Then

Msgbox "Le groupe existe"
Else

Msgbox "Le groupe n existe pas"
End If

Public Function TestPresenceGroupe(ByVal NomServeur, ByVal NomGroupe)

'Version du 22 fevrier 2007

'Retourne 0 si le groupe n'existe pas

'Retourne 1 si le groupe existe

'Retourne -1 si il y a une erreur non prévue

Dim NumeroErreur

Dim objServeur

Dim objGroup

'Valeur par défaut

TestPresenceGroupe = -1

Err.Clear

On Error Resume Next

Set objServeur = GetObject("WinNT://" & NomServeur) 'Création de l'objet représentant le serveur

NumeroErreur = Err.Number

On Error Goto 0

'Si l'objet représentant le serveur a été créé

If NumeroErreur = 0 Then

Err.Clear

On Error Resume Next

Set objGroup = ObjServeur.GetObject("Group", NomGroupe) 'Création de l'objet représentant le groupe

NumeroErreur = Err.Number

On Error Goto 0

'Si le groupe existe

If NumeroErreur = 0 Then

TestPresenceGroupe = 1

Else 'Si le groupe n'existe pas

TestPresenceGroupe = 0

End If

Set objGroup = Nothing

Set objServeur = Nothing

End Function

NETWORK - Verifier la presence d'un Partage

CheminUNC = "\\MonServeur\MonPartage"

MsgBox PartageExiste(CheminUNC)

Public Function PartageExiste(ByVal CheminUNC)

'Version du 5 mars 2008

'Retourne 1 si le partage existe

'0 si le partage n existe pas

'-1 si le format n est pas correct

Dim Position

Dim NomServeur

Dim NomPartage

Dim ShareSrvObj

Dim ShareObj

'Valeur par défaut

PartageExiste = -1

If Len(CheminUNC) > 4 Then

Position = InStr(3,CheminUNC,"\")

'Si on a bien un chemin UNC en entrée

If (Left(CheminUNC,2) = "\\") And (Position > 0) Then

NomServeur = Mid(Left(CheminUNC,Position-1),3)

NomPartage = Mid(CheminUNC,Position+1)

On Error Resume Next

'Récupération du chemin du partage

Set ShareSrvObj = GetObject("WinNT://" & NomServeur & "/lanmanserver")

Set ShareObj = ShareSrvObj.GetObject("fileshare",NomPartage)

'Si il n'y a pas d'erreurs

If Err.Number = 0 Then

PartageExiste = 1

Else

PartageExiste = 0

End If

Set ShareObj = Nothing

Set ShareSrvObj = Nothing

End If 'Si on a bien un chemin UNC

End If 'If Len(CheminUNC) > 4 Then

End Function

NETWORK - Verifier la presence d'un user dans un groupe
NomServeur = Trim(InputBox("Entrez le nom du serveur hébergeant le groupe","Nom du serveur","NomDuServeur"))
NomGroupe = Trim(InputBox("Entrez le nom du groupe","Nom du groupe",""))
LoginUser = Trim(InputBox("Entrez le domaine et login du user (Domaine\Login)","Login du user","Domaine\Login"))

'Si le login indiqué est membre du groupe indiqué
If TestPresenceUserInGroupe(NomServeur,NomGroupe,LoginUser) = 1 Then

Msgbox "Le user est dans le groupe"
Else

Msgbox "Le user n est pas dans le groupe"
End If

Public Function TestPresenceUserInGroupe(ByVal NomServeur, ByVal NomGroupe, ByVal LoginCompletUser)

'Version du 1 février 2005

'Retourne 0 si le user n'est pas dans le groupe

'Retourne 1 si le user est dans le groupe

'Retourne -1 si il y a une erreur non prévue

Dim DomaineUser 'Contient le domaine du login indiqué

Dim LoginUser 'Contient le login

Dim Trouve 'Passe a 1 si on a trouve le compte

'Valeur par défaut

TestPresenceUserInGroupe = -1

'On récupère le domaine et le login du user

Position = InStr(1, LoginCompletUser, "\")

If Position > 0 Then

LoginUser = Mid(LoginCompletUser, Position + 1)

DomaineUser = Left(LoginCompletUser, Position - 1)

On Error Resume Next

Set objServeur = GetObject("WinNT://" & NomServeur) 'Création de l'objet représentant le serveur

'Si l'objet représentant le serveur a été créé

If Err.Number = 0 Then

Set objGroup = ObjServeur.GetObject("Group", NomGroupe) 'Création de l'objet représentant le groupe

'Si le groupe existe

If Err.Number = 0 Then

'Pour tous les objets contenus dans le groupe

If objGroup.IsMember("WinNT://" & DomaineUser & "/" & LoginUser) = True Then

TestPresenceUserInGroupe = 1 'On retourne 1 pour indiqué que le user est bien dans le groupe

Else

TestPresenceUserInGroupe = 0

End If

End If 'Si le groupe existe

End If 'Si le serveur indiqué existe

Set objGroup = Nothing

Set objServeur = Nothing

End If 'Si on a pas trouvé la position du \

End Function

NETWORK - Verifier si un login n est pas connecté a un serveur
Public Function UserNaPasSession(ByVal MonLogin, ByVal MonServeur)

'Version du 2 février 2007

'Entrez un login et un nom de serveur et la fonction retourne

' 1 si la personne n'est pas connectée

' 0 si elle possède une connection

' -1 si il y a un problème

Dim objComputer

Dim MonServeurDeFichiers

Dim UneSession

Dim Position

UserNaPasSession = -1 'Valeur par défaut

MonLogin = Trim(LCase(MonLogin))

MonServeur = Trim(LCase(MonServeur))

If Len(MonLogin) > 0 And Len(MonServeur) > 0 Then

Set objComputer = GetObject("WinNT://" & MonServeur & ",Computer")

Set MonServeurDeFichiers = GetObject(objComputer.ADsPath & "/" & "LanmanServer")

For Each Session In MonServeurDeFichiers.Sessions

UneSession = Session.Name

UneSession = Trim(LCase(UneSession))

Position = InStr(1, UneSession, "\")

If Position > 0 Then

UneSession = Left(UneSession, Position - 1)

If MonLogin = UneSession Then

UserNaPasSession = 0

End If

End If 'If Position > 0 Then

Next 'For Each Session In MonServeurDeFichiers.Sessions

If UserNaPasSession <> 0 Then

UserNaPasSession = 1

End If

End If 'If Len(MonLogin) > 0 And Len(MonServeur) > 0 Then

End Function

NTFS - Change an ACL on a folder
Public Function ChangeACL(ByVal CheminDacces, ByVal OperationType, ByVal SecurityObject, ByVal AceType, ByVal AceFlags, ByVal AccessMask)

'14/10/2009 version

'Need other functions to run : ReorderDacl, GetAccountSID, SIDBrutToSIDString

SIDBrutToSIDString function need Hexa2Decimal, PermutterPourSID

'Also need a Dll named ADSSECURITY.DLL You can find it in the ADSI TOOL KIT

'This function allow to change an ACL on a folder

'Return nothing if all is fine

'Return an error message is we got an issue

'OperationType values

' Add : to add an ACL

' Del : to retrive a specified ACL 'Not actually coded : Don t work

'Example :

'Dim ErrorMessage

'ErrorMessage = ChangeACL("\\MyPc\MyShareFolder\MyFolder", "add", "MyDomain\MyGroup", 0, 0, 1179817)

'If Len(ErrorMessage) > 0 Then

Wscript.echo "Error : " & ErrorMessage

'End If

'Folowing values are used to process Folder and sub folders : AceType = 0 And AceFlags = 3

'Folowing values are used to process only the aimed folder : AceType = 0 And AceFlags = 0

'You can directly use a SID like following :

'Dim MonSID

'MonSID = GetAccountSID("Domaine\compte")

'MonSID = SIDBrutToSIDString(MonSID)

'Call ChangeACL ("MyFolder", "add", MonSID, 0, 0, 1179817)

Const LoggerEvenements = 1 'Put 1 to get log messages

Dim objFSO

Dim objADsSec 'As ADsSecurity

Dim objSecDes 'As SecurityDescriptor

Dim objDAcl 'As AccessControlList

Dim objAce 'As AcessControlEntry

Dim objSid 'As ADsSID

Dim objSIdHex 'As Object

Dim NumeroErreur

Dim DescriptionErreur

Dim Continuer 'A 1 dans pour valider des processus de verification

Dim SecurityAlreadyInPlace 'A 1 si le droit est deja en place, sinon à 0

Dim SecurityObjectFamiliarFormat

Dim ObjShell

Dim CheminDaccesFormatCacls

Dim MaLettreDeLecteur

Dim NbrSousRepertoires

Dim SecurityObjectIsSIDString 'If SecurityObject is a SID, value is 1, else 0

Dim SecurityObjectSIDStringFormat 'Contain the SecurityObject object with a SID string format

'Déclaration des constantes

Const ADS_PATH_FILE = 1

Const ADS_PATH_FILESHARE = 2

Const ADS_PATH_REGISTRY = 3

Const ADS_SD_FORMAT_IID = 1

Const ADS_SD_FORMAT_RAW = 2

Const ADS_SD_FORMAT_HEXSTRING = 3

ChangeACL = "Error on beginning" 'Default value

If LoggerEvenements = 1 Then

Wscript.echo "Function launch for " & CheminDacces & " share with the " & SecurityObject & " account"

End If

'Check the ADsSid DLL

Continuer = 0

If LoggerEvenements = 1 Then

Wscript.echo "Check the ADsSid object call"

End If

Err.Clear

On Error Resume Next

Set oSid = CreateObject("ADsSid") 'from ResourceKit

NumeroErreur = Err.Number

On Error GoTo 0

If (NumeroErreur = 0) Then

Continuer = 1

Set oSid = Nothing

Else

ChangeACL = "We can t call the ADsSid object. Need the Dll named ADSSECURITY.DLL We can find it in the ADSI TOOL KIT."

End If

'Check for a ADsSecurity call

If Continuer = 1 Then

If LoggerEvenements = 1 Then

Wscript.echo "Check the ADsSecurity object call"

End If

Continuer = 0

Err.Clear

On Error Resume Next

Set objADsSec = CreateObject("ADsSecurity")

NumeroErreur = Err.Number

On Error GoTo 0

If (NumeroErreur = 0) Then

Continuer = 1

Set objADsSec = Nothing

End If

Else

ChangeACL = "We can t call the ADsSecurity. Need the Dll named ADSSECURITY.DLL. We can find it on the ADSI TOOL KIT."

End If 'If Continuer = 1 Then

'Check the ressource access

If Continuer = 1 Then

If LoggerEvenements = 1 Then

Wscript.echo "Check the access to " & CheminDacces

End If

Continuer = 0

CheminDacces = Trim(CheminDacces)

Set objFSO = CreateObject("Scripting.FileSystemObject")

If objFSO.FolderExists(CheminDacces) = True Then

Continuer = 1

Else

ChangeACL = "We can t reach the ressource " & CheminDacces

End If

Set objFSO = Nothing

End If

'Check OperationType values

OperationType = Lcase(Trim(OperationType))

If Continuer = 1 Then

If LoggerEvenements = 1 Then

Wscript.echo "Check the OperationType value"

End If

Continuer = 0

Select Case OperationType

Case "add", "del"

Continuer = 1

Case Else

ChangeACL = OperationType & " order is not supported"

End Select

End If 'If Continuer = 1 Then

If Continuer = 1 Then

'Check the value of SecurityObject : is it an SID ?

SecurityObjectIsSIDString = 0

If LoggerEvenements = 1 Then

Wscript.echo "Check the SecurityObject format. Is it a SID ?"

End If

If Left(SecurityObject, 5) = "s-1-5" Then

SecurityObjectIsSIDString = 1

SecurityObjectSIDStringFormat = SecurityObjectIsSIDString

SecurityObjectFamiliarFormat = ""

'No need to find the associate SID

Else 'Sinon on recherche le SID associe

SecurityObjectIsSIDString = 0

SecurityObjectFamiliarFormat = SecurityObject

SecurityObjectSIDStringFormat = GetAccountSID(SecurityObject)

If Len(SecurityObjectSIDStringFormat) > 0 Then

SecurityObjectSIDStringFormat = SIDBrutToSIDString(SecurityObjectSIDStringFormat)

Else

ChangeACL = "We can t find the associate SID to " & SecurityObject

End If

End If 'If Left(SecurityObject, 5) = "s-1-5" Then

'If we have a security object

If (Len(SecurityObject) > 0) Then

'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/adsi/adsi/iadssecurityutility_setsecuritydescriptor.asp

'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/adsi/adsi/programming_adsi_with_javacom.asp

'http://msluder.dk/Resources/ADSI%20SDK%205%20HTML/rtk.htm

If LoggerEvenements = 1 Then

Wscript.echo "Security object call"

End If

Set objADsSec = CreateObject("ADsSecurity")

Set objSecDes = objADsSec.GetSecurityDescriptor("FILE://" & CheminDacces) 'Ici on peut avoir une erreur sur certains répertoires

'Set objSecDes = objADsSec.GetSecurityDescriptor("RGY://HKEY_LOCAL_MACHINE\SOFTWARE\MICROSOFT\MyKey")

Set objDAcl = objSecDes.DiscretionaryACL

'If it s an add operation

If OperationType = "add" Then

If LoggerEvenements = 1 Then

Wscript.echo "Check if security object is not already in place"

End If

'Check if security object is not already in place

SecurityAlreadyInPlace = 0

For Each objAce In objDAcl

'Wscript.echo "verif 1 " & objAce.Trustee & " - " & SecurityObject

If (LCase(objAce.Trustee) = LCase(SecurityObject)) Or (LCase(objAce.Trustee) = LCase(SecurityObjectFamiliarFormat)) Then

'Wscript.echo "verif 2"

If (objAce.AceType = AceType) Then

'Wscript.echo "verif 3"

If (objAce.AceFlags = AceFlags) And (objAce.AccessMask = AccessMask) Then

SecurityAlreadyInPlace = 1

If LoggerEvenements = 1 Then

Wscript.echo SecurityObject & " is already in place"

End If

End If 'If (objAce.AceType = AceType) Then

End If

'Si le droit n est pas deja en place

If SecurityAlreadyInPlace = 0 Then

If LoggerEvenements = 1 Then

Wscript.echo SecurityObject & " not already in place."

End If

Set objAce = CreateObject("AccessControlEntry")

objAce.Trustee = SecurityObject

objAce.AceType = AceType

objAce.AceFlags = AceFlags

objAce.AccessMask = AccessMask

'Add AcessControlEntry to l AccessControlList

objDAcl.AddAce objAce

'Reorder AcessControlEntry in the correct order

Call ReorderDacl(objDAcl)

'AccessControlList affectation to the security descriptor

objSecDes.DiscretionaryACL = objDAcl

Err.Clear

On Error Resume Next

objADsSec.SetSecurityDescriptor objSecDes

NumeroErreur = Err.Number

On Error GoTo 0

Select Case NumeroErreur

Case 0

'Report a success !

ChangeACL = ""

If LoggerEvenements = 1 Then

Wscript.echo "Acces in place !"

End If

Case -2147023559 'Si le problème vient du fait que l on colle a distance une ressource local et que du coup le SID ne peut pas etre resolu

ChangeACL = "Problem to find the " & SecurityObject & " SID. Try to directly enter it with a SID format."

Case Else 'Erreur inconnue

ChangeACL = "AccessControlList affectation to the security descriptor error. Unknow error"

End Select

End If 'If SecurityAlreadyInPlace = 0 Then

End If 'If OperationType = "add" Then

'If it s an add operation

If OperationType = "del" Then

ChangeACL = "Del operation in not already implemented. Sorry."

End If

'Destruction des objets

Set objAce = Nothing

Set objDAcl = Nothing

Set objSecDes = Nothing

Set objADsSec = Nothing

End If 'If (Len(SecurityObject) > 0) Then

End If 'If Continuer = 1 Then

If LoggerEvenements = 1 Then

Wscript.echo "End of function"

End If

End Function

NTFS - Give an access to a folder
Public Sub AffecterGroupe(ByVal NomGroupe, ByVal CheminUncDeLaRacine, ByVal CheminUncDeLaRessource, ByVal CheminCACLS, ByVal TypeDeDroits , ByVal TraiterRepFinal, ByRef MessageErreurEnRetour)

'Version du 21 octobre 2008

: On peut choisir de traiter le répertoire final ou non. On variable retourne une eventuelle erreur

'Ex Version du 10 mars 2008

'Ex Version du 11 fevrier 2008

'Dependant de la fonction DonnerAccesSurFichiers, ReorderDacl, GetAccountSID, SIDBrutToSIDString

'TrouverCheminLocalShare, PermutterPourSID et Hexa2Decimal

Dim NomServeur

Dim NomServeurDuGroupe

Dim NomPartage

Dim MaVariable

Dim Position

Dim Continuer

Dim TableauRepertoires

Dim TableauSousRepertoires

Dim CompteurTableau

Dim PresenceSousRepertoires

Dim MonCheminDeRepertoire

'TypeDeDroits

' 1 = Lecture

' 2 = Ecriture (modification en realite)

'TraiterRepFinal

' 0 : On ne traite pas le répertoire final, celui qui est en bout de chaine

' 1 : On traite le répertoire final

Const LoggerEvenements = 0 'A 1 pour afficher les opérations pour deboggage

If LoggerEvenements = 1 Then

Wscript.echo "Lancement de la fonction AffecterGroupe pour la ressource " & CheminUncDeLaRessource & " avec le compte " & NomGroupe

End If

Continuer = 0

PresenceSousRepertoires = 0

MessageErreurEnRetour = ""

MaVariable = CheminUncDeLaRessource

'Verification de la variable TypeDeDroits

If IsNumeric(TypeDeDroits) = True Then

If (TypeDeDroits = 1) Or (TypeDeDroits = 2) Then

Continuer = 1

End If

MessageErreurEnRetour = "La variable TypeDeDroits n est pas correcte"

End If

'Verification de la variable TraiterRepFinal

If Continuer = 1 Then

Continuer = 0

If IsNumeric(TraiterRepFinal) = True Then

If (TraiterRepFinal = 0) Or (TraiterRepFinal = 1) Then

Continuer = 1

End If

MessageErreurEnRetour = "La variable TraiterRepFinal n est pas correcte"

End If 'If Continuer = 1 Then

'Si le repertoire existe

If Continuer = 1 Then

Continuer = 0

Set objFSO = CreateObject("Scripting.FileSystemObject")

If (objFSO.FolderExists(CheminUncDeLaRacine) = True) And (objFSO.FolderExists(CheminUncDeLaRessource) = True) Then

Continuer = 1

End If

Set objFSO = Nothing

MessageErreurEnRetour = "Les repertoires a traiter n existent pas"

End If

'Si on a un nom de serveur et de partage

If Continuer = 1 Then

Continuer = 0

If Left(MaVariable, 2) = "\\" Then

'On retire le \\ du debut

MaVariable = Mid(MaVariable, 3)

TableauRepertoires = Split(MaVariable, "\")

'Si on a au moins un nom de partage

If UBound(TableauRepertoires) > 0 Then

Continuer = 1

End If

MessageErreurEnRetour = "Le nom du serveur ou du partage n a pu etre trouve"

End If

'Si on a bien un chemin UNC en parametres

If Continuer = 1 Then

Continuer = 0

NomServeur = Trim(TableauRepertoires(0))

NomPartage = TableauRepertoires(1)

NomPartage = UCase(Left(NomPartage, 1)) & LCase(Mid(NomPartage, 2))

'Si on a bien un nom de serveur et un nom de partage

If (Len(NomServeur) > 0) And (Len(NomPartage) > 0) Then

Continuer = 1

End If

MessageErreurEnRetour = "Le chemin a traiter n est pas un chemin UNC"

End If

'Si le nom de groupe contient un nom de serveur

If Continuer = 1 Then

Continuer = 0

Position = Instr(1,NomGroupe,"\")

If LoggerEvenements = 1 Then

Wscript.echo "Le nom du groupe est " & NomGroupe & " et le caractere \ est a la position " & Position

End If

If Position > 0 Then

NomServeurDuGroupe = Left(NomGroupe,Position-1)

NomGroupe = Mid(NomGroupe,Position+1)

Else

NomServeurDuGroupe = NomServeur

End If

If LoggerEvenements = 1 Then

Wscript.echo "Le domaine du groupe est " & NomServeurDuGroupe & " et le nom du groupe est " & NomGroupe

End If

Continuer = 1

End If

If Continuer = 1 Then

Continuer = 0

'On regarde si on a des sous répertoire et on parametre une variable PresenceSousRepertoires en fonction

If Len(CheminUncDeLaRacine) < Len(CheminUncDeLaRessource) Then

'Si le chemin UNC de la racine correspond au debut du chemin de la ressource à traiter,

'et que la longueur de la ressource à traiter est plus long que le chemin de la racine

'c est qu il y a des sous repertoires

If LCase(CheminUncDeLaRacine) = Left(LCase(CheminUncDeLaRessource), Len(CheminUncDeLaRacine)) Then

PresenceSousRepertoires = 1

End If

'On commence par mettre les droits sur le répertoire final

If TraiterRepFinal = 1 Then

Select Case TypeDeDroits

Case 1 'Droits de lecture

'Affectation des droits de lecture

Call DonnerAccesSurFichiers(CheminUncDeLaRessource, 1, NomServeurDuGroupe & "\" & NomGroupe, 0, 3, 1179817, CheminCACLS, 1)

Case 2 'Droits de modification

'Affectation des droits de modification

Call DonnerAccesSurFichiers(CheminUncDeLaRessource, 1, NomServeurDuGroupe & "\" & NomGroupe, 0, 3, 1245631, CheminCACLS, 1)

End Select

End If 'If TraiterRepFinal = 1 Then

'Le repertoire final traité, on traite les eventuels sous repertoires

If PresenceSousRepertoires = 1 Then

'On commence par donner les droits sur la racine

Call DonnerAccesSurFichiers(CheminUncDeLaRacine, 1, NomServeurDuGroupe & "\" & NomGroupe, 0, 0, 1179817, CheminCACLS, 1)

'Puis on passe aux repertoires intermediaires

MaVariable = Mid(CheminUncDeLaRessource, Len(CheminUncDeLaRacine) + 2)

TableauSousRepertoires = Split(MaVariable, "\")

MonCheminDeRepertoire = CheminUncDeLaRacine

For CompteurTableau = 0 To (UBound(TableauSousRepertoires) - 1)

MonCheminDeRepertoire = MonCheminDeRepertoire & "\" & TableauSousRepertoires(CompteurTableau)

Call DonnerAccesSurFichiers(MonCheminDeRepertoire, 1, NomServeurDuGroupe & "\" & NomGroupe, 0, 0, 1179817, CheminCACLS, 1)

End If 'If PresenceSousRepertoires = 1 Then

End If

If LoggerEvenements = 1 Then

Wscript.echo ""

End If

End Sub

NTFS - Give an access on a folder (BIS)
Public Function DonnerAccesSurFichiers(ByVal CheminDacces, ByVal TypeOperation, ByVal CompteAAjouter, ByVal AceType, ByVal AceFlags, ByVal AccessMask, ByVal CheminCACLS, ByVal LaisserFenetreCommandeOuverte)

'Version du 10/03/2008

'Ex Version du 08/02/2008

'Ex Version du 26/06/2007

'Dépendant de la fonction ReorderDacl, GetAccountSID, SIDBrutToSIDString et TrouverCheminLocalShare

'Permet d ajouter un compte en accès sur un fichier

'Retourne 1 si l'accès a été mis en place

'Retourne 0 si l'accès n'a pas été mis en place

'Valeurs de TypeOperation

' 1 : Ajout d un acces

' 2 : Suppression d acces

'Valeurs de LaisserFenetreCommandeOuverte

' 1 : Laisse une fenetre de commande utilise par CACLS ouverte apres operation

' Autre : ne laisse pas de fenetre de commande ouverte apres execution

'Exemples :

'Ajout d un droit de modification sur un dossier uniquement, sous dossiers et fichiers

'Call DonnerAccesSurFichiers ("MonRepertoire", 1, "Domaine\compte", 0, 3, 1245631, "Chemin Cacls", 0)

'Ajout d un droit de lecture sur un dossier uniquement, sous dossiers et fichiers

'Call DonnerAccesSurFichiers ("MonRepertoire", 1, "Domaine\compte", 0, 3, 1179817, "Chemin Cacls", 0)

'Ajout d un droit de lecture sur un dossier uniquement, pas sur les fichiers et sous dossiers

'Call DonnerAccesSurFichiers ("MonRepertoire", 1, "Domaine\compte", 0, 0, 1179817, "Chemin Cacls", 0)

'On peut egalement entrer directement le SID du compte pour etre certain.

'Pour cela utilisez les fonctions suivantes :

'Dim MonSID

'MonSID = GetAccountSID("Domaine\compte")

'MonSID = SIDBrutToSIDString(MonSID)

'Call DonnerAccesSurFichiers ("MonRepertoire", 1, MonSID, 0, 0, 1179817, "Chemin Cacls", 0)

'Les opérations portant sur toute une arborescence sont faites par CACLS.

'Sinon on fait appel à une DLL

Dim objFSO

Dim objADsSec 'As ADsSecurity

Dim objSecDes 'As SecurityDescriptor

Dim objDAcl 'As AccessControlList

Dim objAce 'As AcessControlEntry

Dim objSid 'As ADsSID

Dim objSIdHex 'As Object

Dim NumeroErreur

Dim DescriptionErreur

Dim Continuer 'A 1 dans pour valider des processus de verification

Dim TraiterAvecCacls 'A 1 si on traite avec CACLS, sinon à 0

Dim DroitDejaEnPlace 'A 1 si le droit est deja en place, sinon à 0

Dim CompteAAjouterFormatStandard

Dim ObjShell

Dim CheminDaccesFormatCacls

Dim MaLettreDeLecteur

Dim NbrSousRepertoires

'Déclaration des constantes

Const ADS_PATH_FILE = 1

Const ADS_PATH_FILESHARE = 2

Const ADS_PATH_REGISTRY = 3

Const ADS_SD_FORMAT_IID = 1

Const ADS_SD_FORMAT_RAW = 2

Const ADS_SD_FORMAT_HEXSTRING = 3

Const LoggerEvenements = 0 'A 1 pour afficher les opérations pour deboggage

If LoggerEvenements = 1 Then

Wscript.echo "Lancement de la fonction DonnerAccesSurFichiers pour " & CheminDacces & " avec le compte " & CompteAAjouter

End If

'Verification de l appel correct de ADsSid du RessourceKit

Continuer = 0

Err.Clear

On Error Resume Next

Set oSid = CreateObject("ADsSid") 'from ResourceKit

NumeroErreur = Err.Number

On Error GoTo 0

If (NumeroErreur = 0) Then

Continuer = 1

Set oSid = Nothing

Else

Wscript.echo "Impossible d appeler l objet ADsSid. La Dll ADSSECURITY.DLL qui est dans l'ADSI TOOL KIT est absente."

End If

'Verification de l appel correct de ADsSecurity

If Continuer = 1 Then

Continuer = 0

Err.Clear

On Error Resume Next

Set objADsSec = CreateObject("ADsSecurity")

NumeroErreur = Err.Number

On Error GoTo 0

If (NumeroErreur = 0) Then

Continuer = 1

Set objADsSec = Nothing

End If

Else

Wscript.echo "Impossible d appeler l objet ADsSecurity. La Dll ADSSECURITY.DLL qui est dans l'ADSI TOOL KIT est absente."

End If 'If Continuer = 1 Then

'Si la ressource est bien presente

If Continuer = 1 Then

Continuer = 0

Set objFSO = CreateObject("Scripting.FileSystemObject")

If objFSO.FolderExists(CheminDacces) = True Then

Continuer = 1

End If

Set objFSO = Nothing

End If

'Valeur par défaut

DonnerAccesSurFichiers = 0

If (IsNumeric(TypeOperation) = True) And (Continuer = 1) Then

'Si on a passe en parametre un SID A ajouter

If Left(CompteAAjouter, 5) = "s-1-5" Then

CompteAAjouterFormatStandard = ""

'Pas besoin de rechercher le SID donc

Else 'Sinon on recherche le SID associe

CompteAAjouterFormatStandard = CompteAAjouter

CompteAAjouter = GetAccountSID(CompteAAjouter)

If Len(CompteAAjouter) > 0 Then

CompteAAjouter = SIDBrutToSIDString(CompteAAjouter)

End If

'Si on a un répertoire à traiter et un compte

CheminDacces = Trim(CheminDacces)

If (Len(CheminDacces) > 0) And (Len(CompteAAjouter) > 0) Then

If LoggerEvenements = 1 Then

Wscript.echo "On va bien traiter " & CheminDacces & " avec le compte " & CompteAAjouter

End If

'On decide si on traitre l opéraiton avec CACLS ou avec la DLL

TraiterAvecCacls = 0

'Si on doit traiter toutes l'arborescence

If (AceType = 0) And (AceFlags = 3) Then

'Si cacls est accessible

Set objFSO = CreateObject("Scripting.FileSystemObject")

If objFSO.FileExists(CheminCACLS) = True Then

If Len(CompteAAjouterFormatStandard) > 0 Then

'Si c est une opération d ajout ou de suppression

If (AccessMask = 1245631) Or (AccessMask = 1179817) Then

CheminDaccesFormatCacls = TrouverCheminLocalShare(CheminDacces, 2, NbrSousRepertoires)

If (Len(CheminDaccesFormatCacls) > 0) And (NbrSousRepertoires > 0) Then

TraiterAvecCacls = 1

End If

End If 'If Len(CompteAAjouterFormatStandard) > 0 Then

End If 'If objFSO.FileExists(CheminCACLS) = True Then

Set objFSO = Nothing

End If

If LoggerEvenements = 1 Then

Wscript.echo "TraiterAvecCacls est a " & TraiterAvecCacls

End If

If TraiterAvecCacls = 0 Then

'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/adsi/adsi/iadssecurityutility_setsecuritydescriptor.asp

'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/adsi/adsi/programming_adsi_with_javacom.asp

'http://msluder.dk/Resources/ADSI%20SDK%205%20HTML/rtk.htm

If LoggerEvenements = 1 Then

Wscript.echo "On ne traite pas avec CACLS"

End If

Set objADsSec = CreateObject("ADsSecurity")

Set objSecDes = objADsSec.GetSecurityDescriptor("FILE://" & CheminDacces) 'Ici on peut avoir une erreur sur certains répertoires

'Set objSecDes = objADsSec.GetSecurityDescriptor("RGY://HKEY_LOCAL_MACHINE\SOFTWARE\MICROSOFT\MyKey")

Set objDAcl = objSecDes.DiscretionaryACL

'Si c est un opération d ajout

If TypeOperation = 1 Then

'On regarde si le droit n est pas deja en place

DroitDejaEnPlace = 0

For Each objAce In objDAcl

'Wscript.echo "verif 1 " & objAce.Trustee & " - " & CompteAAjouter

If (LCase(objAce.Trustee) = LCase(CompteAAjouter)) Or (LCase(objAce.Trustee) = LCase(CompteAAjouterFormatStandard)) Then

'Wscript.echo "verif 2"

If (objAce.AceType = AceType) Then

'Wscript.echo "verif 3"

If (objAce.AceFlags = AceFlags) And (objAce.AccessMask = AccessMask) Then

DroitDejaEnPlace = 1

'Wscript.Echo "Droit deja en place"

End If

End If 'If (objAce.AceType = AceType) Then

End If

'Si le droit n est pas deja en place

If DroitDejaEnPlace = 0 Then

If LoggerEvenements = 1 Then

Wscript.echo "Le droit n etait pas deja en place. "

End If

Set objAce = CreateObject("AccessControlEntry")

objAce.Trustee = CompteAAjouter

objAce.AceType = AceType

objAce.AceFlags = AceFlags

objAce.AccessMask = AccessMask

'Ajout de l AcessControlEntry dans l AccessControlList

objDAcl.AddAce objAce

'Tri des AcessControlEntry dans le bon ordre

Call ReorderDacl(objDAcl)

'Affectation de l AccessControlList au descripteur de sécurité

objSecDes.DiscretionaryACL = objDAcl

Err.Clear

On Error Resume Next

objADsSec.SetSecurityDescriptor objSecDes

NumeroErreur = Err.Number

On Error GoTo 0

Select Case NumeroErreur

Case 0

'On reporte que cela a fonctionné

DonnerAccesSurFichiers = 1

If LoggerEvenements = 1 Then

Wscript.echo "L acces est normalement en place"

End If

Case -2147023559 'Si le problème vient du fait que l on colle a distance une ressource local et que du coup le SID ne peut pas etre resolu

MsgBox "Impossible de trouver le SID de " & CompteAAjouter & "." & vbCrLf & "Entrez directement le SID du compte à Ajouter"

Case Else 'Erreur inconnue

If LoggerEvenements = 1 Then

Wscript.echo "L acces n a pu etre donne. Erreur numero " & NumeroErreur

End If

End Select

End If 'If DroitDejaEnPlace = 0 Then

End If 'If TypeOperation = 1 Then

'Destruction des objets

Set objAce = Nothing

Set objDAcl = Nothing

Set objSecDes = Nothing

Set objADsSec = Nothing

Else 'Si on traite avec CACLS

If LoggerEvenements = 1 Then

Wscript.echo "Traitement avec CACLS"

End If

'Preparation de la commande de Base

If LaisserFenetreCommandeOuverte = 1 Then

'ZeCommande = "CMD /K """"" & CheminCACLS & """ """ & CheminDacces & """ /e /t"

'ZeCommande = "CMD /K """"" & CheminCACLS & """ """ & MaLettreDeLecteur & ":" & """ /e /t"

'Avec CACLS

ZeCommande = "CMD /K """"" & CheminCACLS & """ """ & CheminDaccesFormatCacls & """ /e /t"

'Avec Subinacl

'ZeCommande = "CMD /K """"" & CheminCACLS & """ /subdirec """ & CheminDaccesFormatCacls & """"

Else

'ZeCommande = "CMD /C """"" & CheminCACLS & """ """ & CheminDacces & """ /e /t"

'ZeCommande = "CMD /C """"" & CheminCACLS & """ """ & MaLettreDeLecteur & ":" & """ /e /t"

'Avec CACLS

ZeCommande = "CMD /C """"" & CheminCACLS & """ """ & CheminDaccesFormatCacls & """ /e /t"

'Avec Subinacl

'ZeCommande = "CMD /C """"" & CheminCACLS & """ /subdirec """ & CheminDaccesFormatCacls & """"

End If

'Suivant le cas où on demande une opération d ajout ou de suppression

Select Case TypeOperation

Case 1

ZeCommande = ZeCommande & " /g " & """" & CompteAAjouterFormatStandard & """"

'ZeCommande = ZeCommande & " /Grant=" & """" & CompteAAjouterFormatStandard & """"

Case 2

ZeCommande = ZeCommande & " /R " & """" & CompteAAjouterFormatStandard & """"

'ZeCommande = ZeCommande & " /Revoke=" & """" & CompteAAjouterFormatStandard & """"

End Select

'Pour les opérations d ajout, on precise le type de droit

If TypeOperation = 1 Then

Select Case AccessMask

Case 1179817 'Lecture

ZeCommande = ZeCommande & ":R"""

'ZeCommande = ZeCommande & "=E"""

Case 1245631 'Modification

ZeCommande = ZeCommande & ":C"""

'ZeCommande = ZeCommande & "=C"""

Case Else

ZeCommande = ""

End Select

End If

If LoggerEvenements = 1 Then

Wscript.echo "La commande CACLS est " & ZeCommande

End If

If Len(ZeCommande) > 0 Then

'ee = InputBox("", "", ZeCommande)

Set ObjShell = CreateObject("WScript.Shell")

'ObjShell.Run ZeCommande,1,True

ObjShell.Run ZeCommande, 1, False

'Destruction de l'objet Shell

Set ObjShell = Nothing

'On retourne que cela a fonctionne

DonnerAccesSurFichiers = 1

End If 'If Len(ZeCommande) > 0 Then

'Suppression du lecteur reseau

'If SupprimerLecteurReseau(MaLettreDeLecteur) = 0 Then

'Msgbox "Impossible de supprimer le lecteur " & MaLettreDeLecteur

'End If 'If SupprimerLecteurReseau(MaLettreDeLecteur) = 0 Then

End If 'If TraiterAvecCacls = 0 Then

End If 'If (Len(CheminDacces) > 0) And (Len(CompteAAjouter) > 0 )Then

End If 'If (IsNumeric(TypeOperation) = True) And (Continuer = 1) Then

If LoggerEvenements = 1 Then

Wscript.echo ""

End If

End Function

Function ReorderDacl(ByRef objDAcl)

'Version du 30/1/2007

'Remet les droits d un objDAcl (AccessControlList) dans le bon ordre

'On place les objAce (AcessControlEntry) d un objDAcl dans le bon ordre

'Ceci est une traduction de ce qui a été trouvé sur

'http://support.microsoft.com/kb/279682/en-us

Set NouveauobjDAclDansLeBonOrdre = CreateObject("AccessControlList")

Set ImpDenyDacl = CreateObject("AccessControlList")

Set InheritedDacl = CreateObject("AccessControlList")

Set ImpAllowDacl = CreateObject("AccessControlList")

Set InhAllowDacl = CreateObject("AccessControlList")

Set ImpDenyObjectDacl = CreateObject("AccessControlList")

Set ImpAllowObjectDacl = CreateObject("AccessControlList")

Dim objAce

Const ADS_ACEFLAG_INHERITED_ACE = 16 '&h10

Const ADS_ACETYPE_ACCESS_ALLOWED = 0

Const ADS_ACETYPE_ACCESS_DENIED = 1

Const ADS_ACETYPE_ACCESS_ALLOWED_OBJECT = 5 '&h5c

Const ADS_ACETYPE_ACCESS_DENIED_OBJECT = 6 '&h6

'On va séparer les objets Ace d'une Dacl en 5 type :

'Inherited Aces

'Implicit Deny Aces

'Implicit Deny Object Aces

'Implicit Allow Aces

'Implicit Allow object aces

For Each objAce In objDAcl

'Tri des objAce d'un objDAcl dans le bon ordre

If ((objAce.AceFlags And ADS_ACEFLAG_INHERITED_ACE) = ADS_ACEFLAG_INHERITED_ACE) Then

'Les ADS_ACEFLAG_INHERITED_ACE sont traités à part

'Il ne faut pas s inquieter des ADS_ACEFLAG_INHERITED_ACE

'Comme nous allons les ajouters au sommet de la liste dans le nouveau objDAcl,

'ils seront dans le même ordre qu au départ

'Just a positive side affect of adding items of a LIFO ( Last In First Out) type list.

InheritedDacl.AddAce objAce

Else 'Pour les objAce implicite

Select Case objAce.AceType

'Pour les accès authorisés

Case ADS_ACETYPE_ACCESS_ALLOWED

ImpAllowDacl.AddAce objAce

'Pour les accès refusés

Case ADS_ACETYPE_ACCESS_DENIED

ImpDenyDacl.AddAce objAce

'Pour les accès object allowed ace

Case ADS_ACETYPE_ACCESS_ALLOWED_OBJECT

impAllowObjectDacl.AddAce objAce

'Pour les accès object deny ace

Case ADS_ACETYPE_ACCESS_DENIED_OBJECT

ImpDenyObjectDacl.AddAce objAce

Case Else 'On a oublié un type ?

End Select 'Select Case objAce.AceType

End If

Next 'For Each objAce In objDAcl

'On va réaffecter les différents type d ACE dans le bon ordre, soit

'Implicit Deny

'Implicit Deny Object

'Implicit Allow

'Implicit Allow Object

'Inherited aces

'Implicit Deny

For Each objAce In ImpDenyDacl

NouveauobjDAclDansLeBonOrdre.AddAce objAce

'Implicit Deny Object

For Each objAce In ImpDenyObjectDacl

NouveauobjDAclDansLeBonOrdre.AddAce objAce

'Implicit Allow

For Each objAce In ImpAllowDacl

NouveauobjDAclDansLeBonOrdre.AddAce objAce

'Implicit Allow Object

For Each objAce In impAllowObjectDacl

NouveauobjDAclDansLeBonOrdre.AddAce objAce

'Inherited Aces

For Each objAce In InheritedDacl

NouveauobjDAclDansLeBonOrdre.AddAce objAce

Set InheritedDacl = Nothing

Set ImpAllowDacl = Nothing

Set ImpDenyObjectDacl = Nothing

Set ImpDenyDacl = Nothing

'Set the appropriate revision level for the DACL

NouveauobjDAclDansLeBonOrdre.AclRevision = objDAcl.AclRevision

'ReorderDacl = NouveauobjDAclDansLeBonOrdre

'Replace the Security Descriptor

Set objDAcl = nothing

Set objDAcl = NouveauobjDAclDansLeBonOrdre

End Function

NTFS - List users in access on a folder with VB
Public Sub Test()

Call GetSecurityDescriptor("D:\Aeffacer\Velizy")

End Sub
Public Function GetSecurityDescriptor(ByVal CheminPartage As String) As Boolean

'Version du mardi 5 avril 2005

'Code sur

'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/adsi/adsi/iadssecurityutility_setsecuritydescriptor.asp

'Un très bon site perso sur la question

'http://www.tek-tips.com/viewthread.cfm?qid=460090

'Active Directory Service Interfaces Overview

'http://www.microsoft.com/windows2000/techinfo/howitworks/activedirectory/adsilinks.asp

'HOWTO: Use ADsSecurity.dll to Remotely Add Local Account ACEs to an NTFS File

'http://support.microsoft.com/kb/q285998/

'Example Code for Adding an ACE to a File

'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/adsi/adsi/example_code_for_adding_an_ace_to_a_file.asp

'Liste et explication des AceFlag

'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/adsi/adsi/ads_aceflag_enum.asp

'Liste et explication des AceType

'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/adsi/adsi/ads_acetype_enum.asp

'CheminPartage = "D:\aeffacer"

'CompteNT = "pmr_ext\douceta"

Dim objADsSec 'As ADsSecurity

Dim objSecDes 'As SecurityDescriptor

Dim objDAcl 'As AccessControlList

Dim objAce 'As AcessControlEntry

Dim objSId 'As ADsSID

Dim objSIdHex As Object

'Pour le AceType : on dit si on authorise ou on refuse un droit

'&H0 : On Authorise

'&H1 : On refuse

'Pour le Ace Mask (les droits)

'&H1 : Liste du dossier, lecture de données

'&H2 : Creation de fichiers, Ecriture de données

'&H4 : Creation de dossiers, ajout de données

'&H8 : Lire les attributs etendus

'&H10 : Ecriture attributs etendus

'&H20 : Parcourir le dossier / executer le fichier

'&H40 : Suppression de sous dossiers et de fichiers

'&H80 : Attributs de lecture

'&H100 : Attributs d'ecriture

'&H400 : ne fait rien a priori

'&H800 : Supprimer

'&H1000 : ne fait rien a priori

'&H2000 : ne fait rien a priori, Read control y parait

'&H4000 : ne fait rien a priori

'&H8000 : Tous les droits

'&H100000 : Synchronise y parait

'&H1301BF : Modify

'&H1F01FF : Full Control

'Pour le Ace Mask (les droits), vu sur

'http://support.microsoft.com/kb/q279682/

' Define a ADS_RIGHTS_ENUM constants:

'const ADS_RIGHT_DS_CREATE_CHILD

= &h1 'bit 1

'const ADS_RIGHT_DS_DELETE_CHILD

= &h2 'bit 2 'Creation de fichiers, ecriture de données

'const ADS_RIGHT_ACTRL_DS_LIST

= &h4 'bit 3 'Creation de dossiers, ajout de données

'const ADS_RIGHT_DS_SELF

= &h8 'bit 4 'Lire les attributs etendus

'const ADS_RIGHT_DS_READ_PROP

= &h10 'bit 5 'Ecriture d'attributs etendus

'const ADS_RIGHT_DS_WRITE_PROP

= &h20 'bit 6

'const ADS_RIGHT_DS_DELETE_TREE

= &h40 'bit 7 'Suppression de sous dossiers et de fichiers

'const ADS_RIGHT_DS_LIST_OBJECT

= &h80 'bit 8 'Attributs de lecture

'const ADS_RIGHT_DS_CONTROL_ACCESS

= &h100 'bit 9 'Attributs d'ecriture

'const ADS_RIGHT_DELETE

= &h10000 'bit 17 'Supprimer

'const ADS_RIGHT_READ_CONTROL

= &h20000 'bit 18 'Authorisation de lecture

'const ADS_RIGHT_WRITE_DAC

= &h40000 'bit 19 'Modifier les authorisations

'const ADS_RIGHT_WRITE_OWNER

= &h80000 'bit 20 'Approbation

'const ADS_RIGHT_SYNCHRONIZE

= &h100000 'bit 21

'const ADS_RIGHT_ACCESS_SYSTEM_SECURITY = &h1000000 'bit 25

'const ADS_RIGHT_GENERIC_ALL

= &h10000000 'bit 29

'const ADS_RIGHT_GENERIC_EXECUTE

= &h20000000 'bit 30

'const ADS_RIGHT_GENERIC_WRITE

= &h40000000 'bit 31

'const ADS_RIGHT_GENERIC_READ

= &h80000000 'bit 32

'Pour le Ace Flags testés sur un repertoire: (détermine si le droit s'applique aux fichiers, dossiers et sous dossiers

'&H1 : Ce dossier et les fichiers

'&H2 : Ce dossier et les sous dossiers

'&H3 : Ce dossier, les sous dossiers et les fichiers

'&H4 : Ce dossier seulement

'&H8 : Rien : A priori c'est une erreur

'&H10 : 16 : (Ou le 5eme bit) En lecture il indique que nous somme en présence d'un droit hérité du parent

'Valeur par defaut

GetSecurityDescriptor = False

Err.Clear

'En cas d'erreur on continue

On Error Resume Next

Set objADsSec = CreateObject("ADsSecurity")

'Si on a réussit à créer l'objet ADsSecurity

If Err.Number = 0 Then

'Si on a reussit à recuperer l'objet de description securite du fichier ou dossier demande

Set objSecDes = objADsSec.GetSecurityDescriptor("FILE://" & Trim(CheminPartage))

If Err.Number = 0 Then

Set objDAcl = objSecDes.DiscretionaryAcl

Set objAce = CreateObject("AccessControlEntry")

'Pour tous les droits en place

For Each objAce In objDAcl

'Affichage du compte

ResultatBrut = Trim(objAce.Trustee)

Debug.Print ResultatBrut

'Affichage du AceType

Debug.Print "AceType : &H" & Hex(objAce.AceType)

Select Case objAce.AceType

Case 0

Debug.Print "Authorise"

Case 1

Debug.Print "Interdit"

Case Else

Debug.Print "Code inconnu"

End Select

'Affichage de l'AccessMask

'AccessMask correspond au droits que l'on a sur le fichier : Lecture, ecriture etc ...

Debug.Print "AccessMask : &H" & Hex(objAce.AccessMask)

'Affichage de l'AceFlag

Resultat = ConvertDecBin(objAce.AceFlags)

Debug.Print "AceFlags : " & Resultat

'Debug.Print CInt(Right(Resultat, 3))

Select Case CInt(Right(Resultat, 3)) 'objAce.AceFlags

Case 1

Debug.Print "Ce dossier et les fichiers"

Case 10

Debug.Print "Ce dossier et les sous dossiers"

Case 11

Debug.Print "Ce dossier, les sous dossiers et les fichiers"

Case 100

Debug.Print "Ce dossier seulement"

Case Else

Debug.Print "AceFlag inconnu"

End Select

If CStr(objAce.AceFlags And 16) = "16" Then

Debug.Print "Les droits sont hérités"

Else

'Debug.Print "Les droits ne sont pas hérités"

End If

Debug.Print ""

Debug.Print "--------------------------------------------------------"

Debug.Print ""

'Si on a reussit à récupérer les droits

If Err.Number = 0 Then

GetSecurityDescriptor = True

End If

Set objAce = Nothing

Else 'Si on a pas reussit à recuperer l'objet de description securite du fichier ou dossier demande

'Response.write ("Recupération de l'objet de description de securité de " & CheminPartage & " <BR>")

'Response.write ("Erreur n°" & Err.Number & " : " & Err.Description & "<BR>")

End If ''Si on a reussit à recuperer l'objet de description securite du fichier ou dossier demande

Set objSecDes = Nothing

Set objADsSec = Nothing

Else 'Si on a pas réussit à créer l'objet ADsSecurity

'Response.write ("Creation de l'objet ADsSecurity <BR>")

'Response.write ("Erreur n°" & Err.Number & " : " & Err.Description & "<BR>")

End If

End Function

Public Function ConvertDecBin(ByVal MonNombreDec As Variant) As String

'Version du mardi 5 avril 2005

Dim ResteADiviser

Dim ResultatDivision

Dim ResultatFinal As String

Dim ChiffreAVirgule As Boolean

ResteADiviser = MonNombreDec

ResultatDivision = ResteADiviser / 2

ResteADiviser = Int(ResultatDivision)

'Le reste de la division (0 ou 1) vient à gauche du résultat final

'Si le résultat de la division est un chiffre a virgule, le reste est un 1 sinon c'est un 0

If ResultatDivision <> Int(ResultatDivision) Then

ChiffreAVirgule = True

ResultatFinal = 1 & ResultatFinal

Else

ChiffreAVirgule = False

ResultatFinal = 0 & ResultatFinal

End If

Loop While ResteADiviser > 1

'Le reste à Diviser représente le bit de poid fort

ResultatFinal = ResteADiviser & ResultatFinal

'On retourne le résultat

ConvertDecBin = ResultatFinal

End Function

NTFS - List users in access on a folder with VbScript
Dim TableauObjetsEnAcces
Dim CompteurTableau
Dim TableauResultat
Dim CheminAExaminer

CheminAExaminer = "\\MonServeur\MonPartage"

If RecupObjetsEnAcces(CheminAExaminer, TableauObjetsEnAcces) = 1 Then

For CompteurTableau = Lbound(TableauObjetsEnAcces) To Ubound(TableauObjetsEnAcces)

TableauResultat = TableauObjetsEnAcces(CompteurTableau)

'Wscript.Echo CheminAExaminer & ";" & TableauResultat & ";" & Now

TableauResultat = Split(TableauResultat,";")

If IsArray(TableauResultat) = True Then

Wscript.Echo TableauResultat(0)

Else 'Si on n a pas recupere de tableau

Wscript.Echo "Erreur : Le resultat retourne n est pas un tableau"

End If

Next
Else

Wscript.Echo "Erreur lors de l examen de " & CheminAExaminer
End If 'If RecupObjetsEnAcces(CheminAExaminer, TableauObjetsEnAcces) = 1 Then

Function RecupObjetsEnAcces(ByVal CheminAExaminer, ByRef TableauListeMembres)

'Version du 25 septembre 2007

'Nécessite la DLL ADSSECURITY.DLL qui est dans l ADSI TOOL KIT

'Retourne 1 si résultat, sinon 0

'Retourne également un tableau contenant les accès du répertoire avec

'0 : Le résultat brut (SID)

'1 : Le AceType

'2 : Le AceFlags

'3 : L AccessMask

'Dim TableauObjetsEnAcces

'Dim CompteurTableau

'Dim TableauResultat

'Dim CheminAExaminer

'CheminAExaminer = "\\MonServeur\MonPartage"

'If RecupObjetsEnAcces(CheminAExaminer, TableauObjetsEnAcces) = 1 Then

'For CompteurTableau = Lbound(TableauObjetsEnAcces) To Ubound(TableauObjetsEnAcces)

'TableauResultat = TableauObjetsEnAcces(CompteurTableau)

''Wscript.Echo CheminAExaminer & ";" & TableauResultat & ";" & Now

'TableauResultat = Split(TableauResultat,";")

'If IsArray(TableauResultat) = True Then

'Wscript.Echo TableauResultat(0)

'Else 'Si on n a pas recupere de tableau

'Wscript.Echo "Erreur : Le resultat retourne n est pas un tableau"

'End If

'Next

'Else

'Wscript.Echo "Erreur lors de l examen de " & CheminAExaminer

'End If 'If RecupObjetsEnAcces(CheminAExaminer, TableauObjetsEnAcces) = 1 Then

'Déclaration des constantes pour la lecture des droits NTFS

Dim objADsSec 'As ADsSecurity

Dim objSecDes 'As SecurityDescriptor

Dim objDAcl 'As AccessControlList

Dim objAce 'As AcessControlEntry

Dim objSId 'As ADsSID

Dim objSIdHex 'As Object

Dim ResultatBrut

Dim NouvelleLigne

Dim NbrLignes

Dim NumeroErreur

Dim objFSO

'Déclaration des constantes

Const ADS_PATH_FILE = 1

Const ADS_PATH_FILESHARE= 2

Const ADS_PATH_REGISTRY = 3

Const ADS_SD_FORMAT_IID= 1

Const ADS_SD_FORMAT_RAW= 2

Const ADS_SD_FORMAT_HEXSTRING = 3

'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/adsi/adsi/iadssecurityutility_setsecuritydescriptor.asp

'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/adsi/adsi/programming_adsi_with_javacom.asp

'http://msluder.dk/Resources/ADSI%20SDK%205%20HTML/rtk.htm

Set objFSO = CreateObject("Scripting.FileSystemObject")

'Par defaut on retourne 0

RecupObjetsEnAcces = 0

'Si le répertoire à examiner existe

If objFSO.FolderExists(CheminAExaminer) = True Then

'Test de la création correcte de l'objet permettant de récupérer les infos de sécurité

On Error Resume Next

Set objADsSec = CreateObject("ADsSecurity")

NumeroErreur = Err.Number

Set objADsSec = Nothing

On Error Goto 0

If NumeroErreur = 0 Then

'Récupération des users et groupes ayant un accès au partage

'Set objADsSec = CreateObject("ADsSecurity", NomServeurCentralSecure)

Set objADsSec = CreateObject("ADsSecurity")

Set objSecDes = objADsSec.GetSecurityDescriptor("FILE://" & CheminAExaminer)

Set objDAcl = objSecDes.DiscretionaryAcl

Set objAce = CreateObject("AccessControlEntry")

Redim TableauListeMembres(0)

NbrLignes = 0

'On passe en revue tous les users ou groupes ayant un accès au partage

For Each objAce In objDAcl

NbrLignes = NbrLignes + 1

If NbrLignes > 1 Then

Redim Preserve TableauListeMembres(Ubound(TableauListeMembres) +1) 'Ajout d'une ligne au tableau

End If 'If NbrLignes > 1 Then

ResultatBrut = Trim(objAce.Trustee) 'Recuperation du resultat brut

NouvelleLigne = ResultatBrut & ";" & objAce.AceType & ";" & objAce.AceFlags & ";" & objAce.AccessMask

TableauListeMembres(Ubound(TableauListeMembres)) = NouvelleLigne

Set objDAcl = Nothing

Set objSecDes = Nothing

Set objADsSec = Nothing

'On retourne un 1 pour indiquer que tout est Ok

RecupObjetsEnAcces = 1

End If 'If NumeroErreur = 0 Then

End If 'If objFSO.FolderExists(CheminAExaminer) = True Then

Set objFSO = Nothing

End Function

NTFS - Sort AcessControlEntry members of AccessControlList
Function ReorderDacl(ByRef objDAcl)

'Version du 30/1/2007

'Remet les droits d un objDAcl (AccessControlList) dans le bon ordre

'On place les objAce (AcessControlEntry) d un objDAcl dans le bon ordre

'Ceci est une traduction de ce qui a été trouvé sur

'http://support.microsoft.com/kb/279682/en-us

Set NouveauobjDAclDansLeBonOrdre = CreateObject("AccessControlList")

Set ImpDenyDacl = CreateObject("AccessControlList")

Set InheritedDacl = CreateObject("AccessControlList")

Set ImpAllowDacl = CreateObject("AccessControlList")

Set InhAllowDacl = CreateObject("AccessControlList")

Set ImpDenyObjectDacl = CreateObject("AccessControlList")

Set ImpAllowObjectDacl = CreateObject("AccessControlList")

Dim objAce

Const ADS_ACEFLAG_INHERITED_ACE = 16 '&h10

Const ADS_ACETYPE_ACCESS_ALLOWED = 0

Const ADS_ACETYPE_ACCESS_DENIED = 1

Const ADS_ACETYPE_ACCESS_ALLOWED_OBJECT = 5 '&h5c

Const ADS_ACETYPE_ACCESS_DENIED_OBJECT = 6 '&h6

'On va séparer les objets Ace d'une Dacl en 5 type :

'Inherited Aces

'Implicit Deny Aces

'Implicit Deny Object Aces

'Implicit Allow Aces

'Implicit Allow object aces

For Each objAce In objDAcl

'Tri des objAce d'un objDAcl dans le bon ordre

If ((objAce.AceFlags And ADS_ACEFLAG_INHERITED_ACE) = ADS_ACEFLAG_INHERITED_ACE) Then

'Les ADS_ACEFLAG_INHERITED_ACE sont traités à part

'Il ne faut pas s inquieter des ADS_ACEFLAG_INHERITED_ACE

'Comme nous allons les ajouters au sommet de la liste dans le nouveau objDAcl,

'ils seront dans le même ordre qu au départ

'Just a positive side affect of adding items of a LIFO ( Last In First Out) type list.

InheritedDacl.AddAce objAce

Else 'Pour les objAce implicite

Select Case objAce.AceType

'Pour les accès authorisés

Case ADS_ACETYPE_ACCESS_ALLOWED

ImpAllowDacl.AddAce objAce

'Pour les accès refusés

Case ADS_ACETYPE_ACCESS_DENIED

ImpDenyDacl.AddAce objAce

'Pour les accès object allowed ace

Case ADS_ACETYPE_ACCESS_ALLOWED_OBJECT

impAllowObjectDacl.AddAce objAce

'Pour les accès object deny ace

Case ADS_ACETYPE_ACCESS_DENIED_OBJECT

ImpDenyObjectDacl.AddAce objAce

Case Else 'On a oublié un type ?

End Select 'Select Case objAce.AceType

End If

Next 'For Each objAce In objDAcl

'On va réaffecter les différents type d ACE dans le bon ordre, soit

'Implicit Deny

'Implicit Deny Object

'Implicit Allow

'Implicit Allow Object

'Inherited aces

'Implicit Deny

For Each objAce In ImpDenyDacl

NouveauobjDAclDansLeBonOrdre.AddAce objAce

'Implicit Deny Object

For Each objAce In ImpDenyObjectDacl

NouveauobjDAclDansLeBonOrdre.AddAce objAce

'Implicit Allow

For Each objAce In ImpAllowDacl

NouveauobjDAclDansLeBonOrdre.AddAce objAce

'Implicit Allow Object

For Each objAce In impAllowObjectDacl

NouveauobjDAclDansLeBonOrdre.AddAce objAce

'Inherited Aces

For Each objAce In InheritedDacl

NouveauobjDAclDansLeBonOrdre.AddAce objAce

Set InheritedDacl = Nothing

Set ImpAllowDacl = Nothing

Set ImpDenyObjectDacl = Nothing

Set ImpDenyDacl = Nothing

'Set the appropriate revision level for the DACL

NouveauobjDAclDansLeBonOrdre.AclRevision = objDAcl.AclRevision

'ReorderDacl = NouveauobjDAclDansLeBonOrdre

'Replace the Security Descriptor

Set objDAcl = nothing

Set objDAcl = NouveauobjDAclDansLeBonOrdre

End Function

Perl - extraire des donnees exchange d un AD
my $ldap_server = "mondomaine.com";
my $ldap_base = 'ou=UneOU,ou=-mondomaine,dc=com';
my $ldap_user = '***';
my $ldap_pwd = '***';

my $ldap = Net::LDAP->new( $ldap_server ) or die "$@";
my $mesg = $ldap->bind( $ldap_user, password => $ldap_pwd );
$mesg = $ldap->search( # perform a search

base => $ldap_base,

filter => "(&(objectClass=Person)(cn=" . $user . " *))",

# ex : cn=unlogin * => espace * à la fin du login

);
$mesg->code && die $mesg->error;
my $entry ($mesg->entriy(0));
$email = $entry->get_value("mail");
print $email . "\n";

PHP/Base - Affichage d une requete SQL avec mssql_fetch_array
$MaRequete = "Select * from dbo.MaTable";
$Resultat = mssql_query($MaRequete,$MaConnection);
echo "Passage de la requete reussit<BR>";

echo "<Table Border=1>";
While ($MaLigne=mssql_fetch_array($Resultat)){

echo "<TR>";

for($i=0;$i<mssql_num_fields($Resultat);$i++)

{

echo "<TD>";

echo $MaLigne[$i]." ";

echo "</TD>";

}

echo "</TR>";

}
echo "</Table>";

PHP/Base - Affichage d une requete SQL avec mssql_fetch_row
$MaRequete = "Select * from dbo.MaTable";
$Resultat = mssql_query($MaRequete,$MaConnection);
echo "Passage de la requete reussit<BR>";

echo "<Table Border=1>";
While ($MaLigne=mssql_fetch_row($Resultat)){

echo "<TR>";

for($i=0;$i<SizeOf($MaLigne);$i++)

{

echo "<TD>";

echo $MaLigne[$i]." ";

echo "</TD>";

}

echo "</TR>";

}
echo "</Table>";

PHP/Base - Afficher la valeur d une ligne/colonne
//http://www.laltruiste.com/document.php?rep=coursphp&page=base_exploitation&suivant.x=1&suivant.y=5
//Par exemple ici on demande la 2eme ligne et la 3eme colonne (tableau de base 0)
echo "Resultat : ".mssql_result($Resultat,1,2)."<BR>";

PHP/Base - Afficher le dernier message d erreur
echo "Dernier message : ".mssql_get_last_message()."<BR>";

PHP/Base - Afficher le nom et autre d une colonne
//http://www.laltruiste.com/document.php?rep=coursphp&page=base_propriete&suivant.x=4&suivant.y=7
echo "Nom de la 3eme colonne : ".mssql_field_name($Resultat,2)."<BR>";
echo "Type de la 3eme colonne : ".mssql_field_type($Resultat,2)."<BR>";
echo "Longueur de la 3eme colonne : ".mssql_field_length($Resultat,2)."<BR>";

PHP/Base - Afficher le nombre de lignes et de colonnes d un jeu de resultat
echo "Nombre de colonnes : ".mssql_num_fields($Resultat)."<BR>";
echo "Nombre de lignes : ".mssql_num_rows($Resultat)."<BR>";

PHP/Base - Connection a une base de données mySQL
<?php
$MaConnection = mysql_connect("MonServeur","MonLogin","MonPasse");
mysql_select_db('[NomDeLaBase]', $MaConnection);
echo "Reussite de la connection<BR>";
mysql_close($MaConnection);
?>
exemple : $MaConnection = mysql_connect("127.0.0.1","root","");

PHP/Base - Connection a une base de données SQL Serveur et requete SQL
//Necessite dans php.ini que la ligne extension=php_mssql.dll sit active
//Exemples dans http://www.laltruiste.com/document.php?url=http://www.laltruiste.com/coursphp/base_connexion.html
//Fonctions pour MSSQL sur http://www.manuelphp.com/php/ref.mssql.php
$MaConnection = mssql_connect("MonServeur","MonLogin","MonPasse");
mssql_select_db('[NomDeLaBase]', $MaConnection);
echo "Reussite de la connection<BR>";

mssql_close($MaConnection);

PHP/Base - Connection a une base de données SQL Serveur et requete SQL
<?php
$MaConnection = mssql_connect("MonServeur","MonLogin","MonPasse");
mssql_select_db('[NomDeLaBase]', $MaConnection);
echo "Reussite de la connection<BR>";

$MaRequete = "Select * from dbo.MaTable";
$Resultat = mssql_query($MaRequete,$MaConnection);
echo "Passage de la requete reussit<BR>";

echo "<Table Border=1>";
While ($MaLigne=mssql_fetch_array($Resultat)){

echo "<TR>";

for($i=0;$i<mssql_num_fields($Resultat);$i++)

{

echo "<TD>";

echo $MaLigne[$i]." ";

echo "</TD>";

}

echo "</TR>";

}
echo "</Table>";

mssql_close($MaConnection);
?>

PHP/Base - Liberation d une ressource
mssql_free_result($Resultat);

PHP/Base - Positionnement sur un enregistrement particulier
<?php
//Necessite dans php.ini que la ligne extension=php_mssql.dll sit active
//Exemples dans http://www.laltruiste.com/document.php?url=http://www.laltruiste.com/coursphp/base_connexion.html
//Fonctions pour MSSQL sur http://www.manuelphp.com/php/ref.mssql.php
$MaConnection = mssql_connect("MonServeur","MonLogin","MonPasse");
mssql_select_db('[NomDeLaBase]', $MaConnection);
echo "Reussite de la connection<BR>";

$MaRequete = "Select * from dbo.MaTable";
$Resultat = mssql_query($MaRequete,$MaConnection);
echo "Passage de la requete reussit<BR>";

//On se positionne sur la 6eme ligne (talbeau de base 0)
mssql_data_seek($Resultat,5);
$MaLigne=mssql_fetch_array($Resultat);

//Affichage
print_r($MaLigne)."<BR>";
mssql_close($MaConnection);
?>

PHP/Base - Restaurer une sauvegarde de phpBB
'Il faut que Easyphp soit installé sur le poste
Démarrer éventuellement Mysql en faisant
C:\Program Files\EasyPHP1-8\mysql\bin\mysqld.exe

Pour se connecter à MySql
cd C:\Program Files\EasyPHP1-8\mysql\bin
Mysql -u nomutilisateur (-p si mot de passe)
Exemple :
Mysql -u root
Use nomdelabase
source CheminReelDuFichier

Pour connaitre la liste des bases faites
SHOW DATABASES;

Pour creer une base :
create database LeNomDeLaBase

Utilisez éventuellement le site local suivant :
http://localhost/phpmyadmin/

PHP/Divers - Sites
http://www.ced.univ-montp2.fr/php/php4_doc/index.html
http://www.w3schools.com/default.asp

PHP/Divers - Apache
Dans le fichier de config d'apache, la racine se configure à
DocumentRoot "D:\Web"

Pour attaquer une base MsSQL au lieu de MySql, il faut aller dans le fichier php.ini et activer la ligne extension=php_mssql.dll
Exemples dans http://www.laltruiste.com/document.php?url=http://www.laltruiste.com/coursphp/base_connexion.html
Fonctions pour MSSQL sur http://www.manuelphp.com/php/ref.mssql.php

La création d'un nouveau dossier peut être réalisée par le biais de la fonction mkdir().

PHP/Divers - Do While
do{

blablabla;
}
while($Truc1!=$Truc22);

PHP/Divers - Fonctions
function NomDeFonction($UneVariable){

$UneVariable = $UneVariable + 2;

return ($UneVariable);
}

PHP/Divers - For
for($i=0;$i<$ZeObj.children.length;$i++){

Echo $ZeObj.children($i)name;
}

PHP/Divers - Foreach
foreach($tableau as $valeur){
}

PHP/Divers - If
if ($Truc1 != NULL){

$Truc1 = 1;

}
else{

$Truc1 = 2;
}

PHP/Divers - Isset
'Détermine si une variable est affectée
'http://www.ced.univ-montp2.fr/php/php4_doc/function.isset.html
<?php

$a = "test";

echo isset ($a); // TRUE

unset($a);

echo isset ($a); // FALSE
?>

PHP/Divers - Longueur du texte dans un champs/PHP
echo document.getElementById("MonChamp").value.length;

PHP/Divers - Pause d execution
//Pause de 1 seconde
sleep(1);

PHP/Divers - Passerelle VB/PHP
Instr : $MaChaine = strpos($MaChaine,$ChaineRecherchee,$PositionDepart);
Instrrev : $MaChaine = strpos($MaChaine,$ChaineRecherchee);
Lcase : $MaChaine = strtolower($MaChaine);
LEN : $MaChaine = strlen($MaChaine);
LTrim : $MaChaine = ltrim($MaChaine);
Mid : $MaChaine = substr($MaChaine,$Position,$Longueur);
RTrim : $MaChaine = chop($MaChaine);
RTrim : $MaChaine = rtrim($MaChaine);
Split : $MonTableau = explode($delimiteur,$MaChaine);
Ucase : $MaChaine = strtoupper($MaChaine);
Voir aussi implode et join

PHP/Divers - PhpBB
Droits privés : Privé Invisible

Les categories contiennent des forums (Administration du site Web contient News)
Les forums contiennent des topics (News contient des sujets)
Les topics contiennent des posts (Un sujet représente un post)
les posts contiennent des textes (un poste (ou un sujet) contient plusieurs fragments de texte)

Les tables :
phpbb_categories : Contient les grandes Divisions comme Partie Publique ou recrutement

phpbb_forums : Contient les grandes sections comme Annonce, Evénements etc

phpbb_topics : Contient les sujets des posts.

phpbb_posts : Contient les références d

phpbb_posts_text : Le contenu des posts, soit le texte

SELECT phpbb_posts_text.post_text FROM
phpbb_posts_text, phpbb_posts, phpbb_topics, phpbb_forums, phpbb_categories
where phpbb_forums.cat_id = phpbb_categories.cat_id And phpbb_forums.forum_id = phpbb_topics.forum_id And phpbb_topics.topic_id = phpbb_posts.topic_id And phpbb_posts.post_id = phpbb_posts_text.post_id And cat_title = 'Administration' and phpbb_forums.forum_name = 'News' Order By topic_time DESC, post_time Limit 0,5";

PHP/Divers - Recherche d un mot dans quelquechose
$UneVariable = eregi("toto", "La phrase avec toto", $donnee);
If ($UneVariable)
{

echo "La chaine ".$donnee[0]." a été trouvée. La variable a retourné ".$UneVariable;
}
else echo"Rien n'a été trouvé";

PHP/Divers - Remplacer des caracteres
//Ici on remplace les espaces par _
echo str_replace(" ","_","Une phrase avec des espaces");

PHP/Divers - Remplacer des caracteres V2
var MonTexte;

MonTexte = "Ceci est ma phrase";
MonTexte = MonTexte.replace("chaine a remplacer","chaine de remplacement");

PHP/Divers - Switch Select Case
switch($MaJournee){

case 'matin':

echo "C est le matin;"

case 'midi':

echo "C est le midi;"

default:

echo "par defaut c est la nuit";
}

PHP/Divers - TimeOut Definition
//Pour le mettre à 1 minute
set_time_limit (60);

PHP/Divers - unset
'Détruit une variable
unset ($foo);

PHP/Divers - while
while(){

}
endwhile;

PHP/Fichiers - Creation d un fichier
<?php
echo "<HR>";
echo "<B>Creation d un fichier : </B><BR>";
$CheminFichier = "D:\Web\ZZAeffacer.txt";
$id_fichier = fopen($CheminFichier, "w");
fclose($id_fichier);
?>

PHP/Fichiers - Ecriture dans un fichier (mode ajout)
$CheminFichier = "C:\MonFichier.txt";
$id_fichier = fopen($CheminFichier, "a+");
fputs($id_fichier, "Du texte".chr(13).chr(10));
fputs($id_fichier, "Encore du texte".chr(13).chr(10));
fclose($id_fichier);

PHP/Fichiers - Ecriture dans un fichier sur un FTP
$id_fichier = fopen("ftp://nom_utilisateur:mot_passe@ftp.site.com/nouvelle_page.html", "w");
fclose($id_fichier);

PHP/Fichiers - Fonctions pour systeme de fichier
'Vu sur
http://www.laltruiste.com/document.php?rep=coursphp&page=fonction_fichier&suivant.x=10&suivant.y=3

retourne le nom du fichier à partir de l'adresse du fichier spécifiée.
$chaine = basename($chemin_fichier);

modifie le groupe propriétaire du fichier.
true | false = chgrp($nom_fichier, $groupe_proprietaire);

modifie le mode exprimé en nombre octal, du fichier.
true | false = chmod($nom_fichier, $mode);

modifie le groupe propriétaire du fichier.
true | false = chown($nom_fichier, $proprietaire);

efface la mémoire cache remplie par les fonctions lsat et stat.
clearstatcache();

copie un fichier vers une nouvelle destination.
true | false = copy($fichier, $nouveau_fichier);

efface le fichier.
delete($fichier);

retourne le nom du dossier parent.
$chaine = dirname($chemin);

retourne l'espace disponible sur le disque sur lequel est le dossier.
$nombre = disk_free_space($dossier);

identique à disk_free_space.
$nombre = diskfreespace($dossier);

retourne la taille totale d'un dossier.
$nombre = disk_total_space($dossier);

ferme un fichier indiqué par un identificateur retourné par fopen ou fsockopen.
true | false = fclose($ID_fichier);

teste la fin du fichier.
true | false = feof($ID_fichier);

écrit les données présentes dans la mémoire tampon (buffer), dans un fichier.
true | false = fflush($ID_fichier);

retourne le caractère sélectionné par le pointeur du fichier.
$chaine = fgetc($ID_fichier);

retourne la ligne courante et cherche les champs d'un fichier CSV (fichier de valeurs séparées par des virgules).
$tableau = fgetcsv($ID_fichier, $nombre, $chaine);

retourne la ligne courante jusqu'à soit un retour charriot, soit la fin du fichier, soit la longueur spécifiée.
$chaine = fgets($ID_fichier, $longueur);

retourne la ligne courante à l'instar de fgets en supprimant les balises HTML et PHP ou juste celles spécifiées.
$chaine = fgetss($ID_fichier, $longueur [, $balises]);

lit le fichier et retourne le résultat dans un tableau.
$tableau = file($chaine, $longueur);

vérifie l'existance d'un fichier et éventuellement de son chemin si le second argument est égale à '1'.
file_exists($fichier [, $inclure_chemin]);

retourne la date du dernier accès sur le fichier.
$date | false = fileatime($fichier);

retourne l'heure du dernier accès sur le fichier.
$heure | false = filectime($fichier);

retourne le nom du groupe sous une forme numérique.
$nombre | false = filegroup($fichier);

retourne le numéro d'inode du fichier.
$nombre | false = fileinode($fichier);

retourne la date de dernière modification du fichier.
$date | false = filemtime($fichier);

retourne sous forme numérique, le nom du propriétaire du fichier.
$nombre | false = fileowner($fichier);

retourne sous forme numérique, les permissions affectées au fichier.
$nombre | false = fileperms($fichier);

retourne la taille du fichier en octets.
$nombre = filesize($fichier);

retourne le type de fichier (block, char, dir, fifo, file, link, et unknown).
$chaine = filetype($fichier);

verrouille le fichier avec un nombre égal à '1', en écriture '2' ou le déverrouille '3'.
true | false = flock($ID_fichier, $nombre);

ouvre un fichier ou une adresse URL selon un mode et éventuellement en incluant le chemin si le dernier argument est égal à '1'. Mode Description
ID_fichier | false = fopen($fichier, $mode, $inclure_chemin);
r ouvre le fichier en lecture seule.
r+ ouvre le fichier en lecture et en écriture.
w ouvre le fichier en écriture seule ou tente de le créer s'il n'existe pas.
w+ ouvre le fichier en lecture et en écriture ou tente de le créer s'il n'existe pas.
a ouvre le fichier en écriture seule ou tente de le créer s'il n'existe pas.
a+ ouvre le fichier en lecture et en écriture; place le pointeur de fichier à la fin du fichier. Si le fichier n'existe pas, on tente de le créer.
b utilisable uniquement sous Windows, ouvre un fichier en mode binaire.

lit le fichier du pointeur jusqu'à la fin et dirige le résultat vers la sortie standard.
$nombre | false = fpassthru($ID_fichier);

écrit la chaîne de caractères dans un fichier et éventuellement jusqu'à une longueur fournie.
$nombre = fputs($ID_fichier, $chaine [, $longueur]);

lit le fichier en mode binaire et éventuellement jusqu'à une certaine longueur.
$chaine = fread($ID_fichier, $longueur);

retourne les valeurs d'un fichier selon un format précis dans un tableau ou affecte ces valeurs aux variables spécifiées en renvoyant le nombre de valeurs affectées.
$valeur = fscanf($ID_fichier, $format [, &$var, ..., &$varN]);

déplace le pointeur de fichier à la position spécifiée.
true | false = fseek($ID_fichier, $position);

retourne des informations sur un fichier. Mode Description
$tableau = fstat($ID_fichier);
1 volume
2 inode
3 mode de protection du inode
4 nombre de liens
5 id de l'utilisateur propriétaire
6 id du groupe propriétaire
7 type du volume de l'inode
8 taille en octets
9 date du dernier accès
10 date de la dernière modification
11 date du dernier changement
12 taille de bloc du système pour les entrées-sorties
13 Nombre de blocs alloués

retourne la position du pointeur du fichier.
$nombre | false = ftell($ID_fichier);

tronque un fichier à la taille spécifiée.
true | false = ftruncate($ID_fichier, $taille);

écrit en mode binaire, la chaîne de caractères dans un fichier et éventuellement jusqu'à une longueur fournie.
$nombre = fwrite($ID_fichier, $chaine [, $longueur]);

détermine la taille de la mémoire tampon (buffer) utilisée en écriture dans le fichier.
0 | EOF = set_file_buffer($ID_fichier, $taille);

vérifie si le nom du fichier est un dossier.
true | false = is_dir($fichier);

vérifie si le fichier est un exécutable.
true | false = is_executable($fichier);

vérifie si le fichier en est effectivement un.
true | false = is_file($fichier);

vérifie si le fichier est un lien.
true | false = is_link($fichier);

vérifie si le fichier est autorisé en lecture.
true | false = is_readable($fichier);

vérifie si le fichier est autorisé en écriture.
true | false = is_writable($fichier);

vérifie si le fichier est autorisé en écriture.
true | false = is_writeable($fichier);

vérifie si le fichier a bien été téléchargé par la méthode HTTP POST.
true | false = is_uploaded_file($fichier);

crée un lien.
true | false = link($cible, $lien);

retourne le champ st_dev de la structure d'information UNIX, à propos d'un lien.
$nombre | false = linkinfo($chemin);

crée un dossier selon le chemin spécifié.
true | false = mkdir($chemin, $mode_octal);

déplace un fichier téléchargé vers un emplacement spécifié.
true | false = move_uploaded_file($fichier, $destination);

retourne un tableau associatif contenant les champs et les valeurs d'un fichier de configuration *.ini. Si le second argument est égal à true, un tableau multidimensionnel sera retourné avec pour clés les noms de section.
$tableau = parse_ini_file($fichier [, $bool_section]);

retourne des informations sur un chemin système sous forme d'un tableau associatif avec les clés dirname, basename et extension.
$tableau = pathinfo($chemin);

ferme un processus de pointeur de fichier.
$nombre = pclose($ID_fichier);

ouvre un processus de pointeur de fichier.
$nombre = popen($ID_fichier);

lit un fichier et l'envoie à la sortie standard. Si le dernier argument vaut '1' alors la recherche du fichier inclut le dossier.
$nb_octets = readfile($fichier [, $inclure_dossier]);

retourne le nom du fichier vers lequel pointe le lien.
$chaine | false = readlink($lien);

renomme un fichier.
true | false = rename($nom_fichier, $nouveau_nom_fichier);

replace le pointeur au début du fichier.
true | false = rewind($ID_fichier);

efface un dossier.
true | false = rmdir($chemin);

retourne les informations à propos d'un fichier dans un tableau (voir fstat).
$tableau = stat($fichier);

retourne les informations à propos d'un fichier ou d'un lien à l'instar de la fonction stat.
$tableau = lstat($fichier);

retourne le chemin absolu du chemin spécifié.
$chaine = realpath($chemin);

crée un lien.
true | false = symlink($cible, $lien);

crée un fichier temporaire unique dans le dossier spécifié.
$chaine | NULL = tempnam($chemin, $prefixe);

crée un fichier temporaire et retourne un identificateur semblable à celui de fopen.
$ID = tmpfile();

force la date de modification du fichier à la date spécifiée, par défaut à la date courante.
true | false = touch($fichier, $date);

modifie le umask courant de PHP.
$nombre = umask([$nombre_octal]);

efface un fichier.
true | false = unlink($fichier);

PHP/Fichiers - Lecture des octets d un fichier
<?php
echo "<HR>";
echo "<B>Lecture des octets d un fichier : </B><BR>";
$CheminFichier = "D:\Web\MesFonctions.inc";
$id_fichier = fopen($CheminFichier, "r");

//ftell affiche la position actuelle de lecture d'un fichier
//Affichage de la position initiale
echo "Position initiale : " . ftell($id_fichier) . "<br>";

//On se positionne à la fin du fichier
fseek($id_fichier, filesize($CheminFichier));
echo "Position de fin : " . ftell($id_fichier) . "<br>";

//
rewind($id_fichier);
echo "Position de retour : " . ftell($id_fichier) . "<br>";
fclose($id_fichier);
?>

PHP/Fichiers - Lecture d un fichier avec fgets
<?php
echo "<B>Lecture d un fichier avec fgets : </B><BR>";
$CheminFichier = "D:\MonFichier.txt";
$id_fichier = fopen($CheminFichier,"r");
while (!feof($id_fichier)) {

$contenu = fgets($id_fichier, 4096);

echo "$contenu<BR>";
}
fclose($id_fichier);
?>

PHP/Fichiers - Lecture d un fichier avec file
<?php
echo "<B>Lecture d un fichier avec file : </B><BR>";
$CheminFichier = "D:\MonFichier.txt";
$tableau = file($CheminFichier); //Le fichier est stocké dans une variable tableau
while(list($cle,$valeur) = each($tableau)) {

echo $valeur."<BR>";
}
?>

PHP/Fichiers - Lecture d un fichier de facon binaire
<?php
echo "<B>Lecture d un fichier de facon binaire : </B><BR>";
$CheminFichier = "D:\MonFichier.txt";
$id_fichier = fopen($CheminFichier, "rb");
$contenu = fread($id_fichier, filesize ($CheminFichier));
echo $contenu;
fclose($id_fichier);
?>

PHP/Fichiers - Lister les fichiers et leurs propriétées
<?php
echo "<HR>";
echo "<B>Affichage des Fichiers : </B><BR>";
$MonRepertoire = OpenDir("D:\Web");
While($MonFichier = readdir($MonRepertoire)) {
$id_fichier = $MonRepertoire.$MonFichier;

if(is_file($MonFichier)) {

echo "$MonFichier<BR>";

echo "$id_fichier<BR>";

echo filesize($MonFichier);

echo "<BR>";

echo filetype($MonFichier);

echo "<BR>";

echo date("d/m/Y H:i:s" , filectime($MonFichier));

echo "<BR>";

echo date("d/m/Y H:i:s" , filemtime($MonFichier));

echo "<BR>";

echo date("d/m/Y H:i:s" , fileatime($MonFichier));

echo "<BR>";

echo date("d/m/Y H:i:s" , fileowner($MonFichier));

echo "<BR>";

echo date("d/m/Y H:i:s" , fileperms($MonFichier));

echo "<BR>";
} //if(is_file($MonFichier)) {

} //While($MonFichier = readdir($MonRepertoire)) {
closedir($MonRepertoire);
?>

PHP/Fichiers - Lister les répertoires
<?php

echo "<HR>";
echo "<B>Affichage des dossiers : </B><BR>";
$MonRepertoire = OpenDir("D:\Web");
While($MonSousRepertoire = readdir($MonRepertoire)){

if (is_dir($MonSousRepertoire)){

if ($MonSousRepertoire != "." && $MonSousRepertoire != ".."){

echo "$MonSousRepertoire<BR>";

} //if ($MonSousRepertoire != "." && $MonSousRepertoire != ".."){

} //is_dir($MonSousRepertoire)
} //While($MonSousRepertoire = readdir($MonRepertoire)) {
closedir($MonRepertoire);
echo "<BR>";

?>

PHP/Fichiers - Suppression d un fichier
echo "<B>Suppression d un fichier</B><BR>";
//$toto à 1 si réussit
$toto = unlink("D:\MonFichier.txt");

PHP/Fichiers - Verification de l existance d un fichier
<?php
echo "<B>Verification de l existance d un fichier : </B><BR>";
$CheminFichier = "D:\Web\ZZAeffacer.txt";
echo file_exists($CheminFichier);
?>

PHP/Tableau - Afficher les valeurs d un tableau - Methode 1
for($NumeroCase=0;$NumeroCase<count($TableauData);$NumeroCase++) {

echo "Case ".$NumeroCase." : ".$TableauData[$NumeroCase]."<BR>";
}
$NumeroLigne++;

PHP/Tableau - Afficher les valeurs d un tableau - Methode 2
$MonTableau[0]="Menu";
$MonTableau[1]=array("Un Lien","http://www.l adresse.com");
$MonTableau[2]="une valeur";
$MonTableau[3]=array("Autre lien","http://www.zelien.com");

foreach($MonTableau as $UneLigne){

//Si la ligne du tableau ne contient pas un tableau

if (count($UneLigne)==1){

echo $UneLigne."<BR>";

}

else{

foreach($UneLigne as $UneSousLigne){

echo $UneSousLigne;

echo ", ";

}

echo "<BR>";

}
}//foreach($MonTableau as $UneLigne){

PHP/Tableau - Creation d un tableau a partir de valeurs
$MonTableau = array(1,'2',5);

PHP/Tableau - Fonctions pour les tableaux
//Fonctions pour les tableaux
//http://php.net/manual/fr/ref.array.php

PHP/Tableau - Taille d un tableau
$MonTableau = array(1,'2',5);
echo sizeof($MonTableau)."<BR>";

PowerShell - Afficher l aide d une commande
get-help
Exemple : get-help Export-CSV

PowerShell - Afficher les possibilites d un objet
Une commande/variable|gm

PowerShell - Afficher sous le format d une table
Clear-Host
get-process | Select-Object ProcessName, Id | Sort-Object ProcessName | format-table

PowerShell - Afficher toutes les commandes en QAD de Quest
clear-host
get-command *QAD*
get-help Set-QADGroup -examples

PowerShell - Ajouter des utilisateurs dans un groupe
clear-host
$MonCSV = Import-Csv "C:\scripts\ListeDiff.txt" -Delimiter "`t" -header ("first","second","third","fourth")
foreach ($oneline in $MonCSV) {

#Write-Host 'Affectation de $oneline.second sur $oneline.third'

$MembreListe = $oneline.first

$MonMembre = "frmain\$MembreListe"

Add-QADGroupMember "frmain\@GroupeTestCDQDeDelegation" $MonMembre
}

PowerShell - Caracteres reserve - la liste
'Vu sur http://blogs.technet.com/b/heyscriptingguy/archive/2008/01/17/how-can-i-use-windows-powershell-to-replace-characters-in-a-text-file.aspx

$
()
*
+
.
[]
?
\
/
^
{}
|

PowerShell - Ajouter Supprimer une ACL
#Version du 3 novembre 2011
Clear-Host

#Valeurs nécessaire dans tous les cas
$ObjectToProcess = "C:\d"
$Operation = "del"
$UserNameToProcess = "Tout le monde"

#Valeurs supplémentaires nécessaires pour un ajout
$FileSystemRightsValue = "Modify, Synchronize"
$InheritanceFlagsValue = "ContainerInherit, ObjectInherit"
#Valeurs par défaut que l'on peut décommenter et modifier au besoin
#$PropagationFlagValue = "None"
#$objAccessControlTypeValue = "Allow"

function ModifyACL(){

param([string]$ObjectToProcess, [string]$Operation, [string]$UserNameToProcess, [string]$FileSystemRightsValue = "Modify, Synchronize", [string]$InheritanceFlagsValue = "ContainerInherit, ObjectInherit", [string]$PropagationFlagValue = "None", [string]$objAccessControlTypeValue = "Allow")

#On recupere les droits de l objet a traiter

$objACL = Get-ACL $ObjectToProcess

switch ($Operation)

{

"add" {

#On prealable, on retirer tous les anciens accès de ce compte

foreach ($MySubACL in $objACL.Access)

{
#

Write-Host "___________________________"
#

Write-Host $MySubACL.AccessControlType
#

Write-Host $MySubACL.FileSystemRights
#

Write-Host $MySubACL.IsInherited
#

Write-Host $MySubACL.PropagationFlags
#

Write-Host $MySubACL.InheritanceFlags.value__
#

Write-Host $MySubACL.IdentityReference

if ($MySubACL.IdentityReference -eq $UserNameToProcess){
#

$objUserToDelete = New-Object System.Security.Principal.NTAccount($UserNameToProcess)
#
#

$objACEToDelete = New-Object System.Security.AccessControl.FileSystemAccessRule `
#

($objUserToDelete, $MySubACL.FileSystemRights, $MySubACL.InheritanceFlags, $MySubACL.PropagationFlags, $MySubACL.AccessControlType)
#

$objACL.RemoveAccessRule($objACEToDelete)

#Si l'objet n'est pas hérité

if ($MySubACL.IsInherited -eq $false){

$objACL.RemoveAccessRule($MySubACL)

Write-Host "Ancienne référence retirée"

}

#Maintenant on donne les accès au compte voulu

$objUser = New-Object System.Security.Principal.NTAccount($UserNameToProcess)

#$FileSystemRights = [System.Security.AccessControl.FileSystemRights]"ReadAndExecute, Synchronize"

$FileSystemRights = [System.Security.AccessControl.FileSystemRights]$FileSystemRightsValue

$InheritanceFlag = [System.Security.AccessControl.InheritanceFlags]$InheritanceFlagsValue

$PropagationFlag = [System.Security.AccessControl.PropagationFlags]::$PropagationFlagValue

$objAccessControlType =[System.Security.AccessControl.AccessControlType]::$objAccessControlTypeValue

$objACE = New-Object System.Security.AccessControl.FileSystemAccessRule `

($objUser, $FileSystemRights, $InheritanceFlag, $PropagationFlag, $objAccessControlType)

$objACL.AddAccessRule($objACE)

Write-Host "$UserNameToProcess ajouté aux accès de $ObjectToProcess"

}

"del" {

foreach ($MySubACL in $objACL.Access)

{

if ($MySubACL.IdentityReference -eq $UserNameToProcess){
#

$objUserToDelete = New-Object System.Security.Principal.NTAccount($UserNameToProcess)
#
#

$objACEToDelete = New-Object System.Security.AccessControl.FileSystemAccessRule `
#

($objUserToDelete, $MySubACL.FileSystemRights, $MySubACL.InheritanceFlags, $MySubACL.PropagationFlags, $MySubACL.AccessControlType)
#

$objACL.RemoveAccessRule($objACEToDelete)

#Si l'objet n'est pas hérité

if ($MySubACL.IsInherited -eq $false){

$objACL.RemoveAccessRule($MySubACL)

Write-Host "$MySubACL.IdentityReference retiré des accès de $ObjectToProcess"

}

default {"Operation is not recognized"}

}

#On applique les droits sur le répertoire/objet

Set-ACL $ObjectToProcess $objACL
}

#Suivant qu'on demande un ajout ou une suppression
switch ($Operation)
{
"add" {

ModifyACL -ObjectToProcess $ObjectToProcess -Operation $Operation -UserNameToProcess $UserNameToProcess -FileSystemRightsValue $FileSystemRightsValue -InheritanceFlagsValue $InheritanceFlagsValue

}

"del" {

#Pour une suppression

ModifyACL -ObjectToProcess $ObjectToProcess -Operation $Operation -UserNameToProcess $UserNameToProcess

$AllChildObjectToProcess = Get-ChildItem $ObjectToProcess -recurse #| Where-Object {$_.Attributes -eq "Directory"}

foreach ($OneObject in $AllChildObjectToProcess){

ModifyACL -ObjectToProcess $OneObject.FullName -Operation $Operation -UserNameToProcess $UserNameToProcess

}

PowerShell - Connaitre le chemin du répertoire du script actuellement lance
clear-host

$CheminScript = [string]

function Get-ScriptDirectory
{

$Invocation = (Get-Variable MyInvocation -Scope 1).Value

$ScriptFolderPath = Split-Path $Invocation.MyCommand.Path

return $ScriptFolderPath
}

$CheminScript = Get-ScriptDirectory

PowerShell - Creer un utilisateur local
Clear-Host
function create-account () {

$hostname = hostname

$MyLocalComputer = [adsi] "WinNT://$hostname"

$localaccountlogin= "alocalaccount"

$localaccountfullname= "Local account fullname"

$objlocalaccount = $MyLocalComputer.Create("User", $localaccountlogin)

$objlocalaccount.put("FullName", $localaccountfullname)

$objlocalaccount.put("Description","")

$objlocalaccount.SetPassword("Password1")

$objlocalaccount.SetInfo()
}
create-account

PowerShell - Ecrire dans un fichier
#http://blogs.technet.com/b/gbordier/archive/2009/05/05/powershell-and-writing-files-how-fast-can-you-write-to-a-file.aspx
clear-host
$file = New-Item -type file "C:\scripts\GroupsToCreate2.log" -Force
add-content $file "test"

PowerShell - Ecrire un fichier de log
#Version du 27 mars 2012
clear-host

$CheminScript = [string]
$FichierDeLog = [string]
$DateTime = Get-Date

function Get-ScriptDirectory
{

$Invocation = (Get-Variable MyInvocation -Scope 1).Value

$ScriptFolderPath = Split-Path $Invocation.MyCommand.Path

return $ScriptFolderPath
}

function WriteToLog()
{

param([string]$Message, [string]$CheminFichierDeLog, [bool]$ResetFile = $false)

if ($ResetFile -eq $true){

#http://blogs.technet.com/b/gbordier/archive/2009/05/05/powershell-and-writing-files-how-fast-can-you-write-to-a-file.aspx

$FichierDeLog = New-Item -type file $CheminFichierDeLog -Force

}

else{

$FichierDeLog = $CheminFichierDeLog

}

add-content $FichierDeLog $Message

}

$CheminScript = Get-ScriptDirectory
$FichierDeLog = "$CheminScript\ExtractGroupMembersLog.txt"

WriteToLog -Message "Debut du log : $DateTime" -CheminFichierDeLog $FichierDeLog -ResetFile $true
WriteToLog -Message "Connect to $DomainName Domain" -CheminFichierDeLog $FichierDeLog

#http://blogs.technet.com/b/gbordier/archive/2009/05/05/powershell-and-writing-files-how-fast-can-you-write-to-a-file.aspx
$FichierDeLog = New-Item -type file $FichierDeLog -Force
add-content $FichierDeLog "Debut du log : $DateTime"

PowerShell - Effacer les utilisateurs membres d un groupe local
# Le script ci-dessous puise les groupes locaux à traiter dans un fichier texte
clear-host
# List local group members on the local or a remote computer

$localgroups = Get-Content C:\GroupsToCreate.txt
$computerName = Read-Host "Enter System Name"
$LogFile = New-Item -type file "C:\LogDeleteGroupMembers.log" -Force

Foreach ($localgroupName in $localgroups){

$OneLocalGroup = [ADSI]("WinNT://$computerName/$localGroupName,group")

Foreach($UnGroupe in $OneLocalGroup.Members()){

$AdsPath = $UnGroupe.GetType().InvokeMember("Adspath", 'GetProperty', $null, $UnGroupe, $null)

#Write-host $AdsPath

$ObjectPath = $AdsPath.split('/',[StringSplitOptions]::RemoveEmptyEntries)

$name = $ObjectPath[-1]

$domain = $ObjectPath[-2]

$class = $UnGroupe.GetType().InvokeMember("Class", 'GetProperty', $null, $UnGroupe, $null)

#Write-host $class

if ($class -eq "User"){

Write-host "$localgroupName;$domain;$name"

add-content $LogFile "$localgroupName;$domain;$name"

$OneLocalGroup.remove("WinNT://$domain/$name")

}

}
}

PowerShell - Effacer un utilisateur local
Clear-Host
function delete-account () {

$hostname = hostname

$MyLocalComputer = [adsi] "WinNT://$hostname"

$MyLocalComputer | gm

$localaccountlogin= "alocalaccount"

$MyLocalComputer.Delete("user",$localaccountlogin)
}
delete-account

PowerShell - Effacer les ACL non resolus
#Version du 4 novembre 2011
Clear-Host

#Valeurs nécessaire dans tous les cas
#$ObjectToProcess = "\\brasilsat\ACHATS"
set-variable -name ObjectToProcess -value "\\brasilsat\C3I" -option constant

$file = New-Item -type file "C:\DeleteUknowACL.txt" -Force

function DelUnknowACL(){
param([string]$ObjectToProcess)

#On recupere les droits de l objet a traiter
$objACL = Get-ACL $ObjectToProcess

$AclModifiee = 0
foreach ($MySubACL in $objACL.Access)
{

if ($MySubACL.IsInherited -ieq $false){

$NomACLenAccess = [String]$MySubACL.IdentityReference

if ($NomACLenAccess.substring(0,9) -ieq "S-1-5-21-"){

$MyIdentityReference = [String]$MySubACL.IdentityReference

$MyAccessControlType = [String]$MySubACL.AccessControlType

$MyFileSystemRights = [String]$MySubACL.FileSystemRights

$MyIsInherited = [String]$MySubACL.IsInherited

$MyPropagationFlags = [String]$MySubACL.PropagationFlags

Write-Host "___________________________"

Write-Host $MySubACL.IdentityReference

Write-Host $MySubACL.AccessControlType

Write-Host $MySubACL.FileSystemRights

Write-Host $MySubACL.IsInherited

Write-Host $MySubACL.PropagationFlags

$objACL.RemoveAccessRule($MySubACL)

$AclModifiee = 1
Write-Host "$NomACLenAccess retiré des accès de $ObjectToProcess"

add-content $file "$ObjectToProcess;$NomACLenAccess;$MyIdentityReference;$MyAccessControlType;$MyFileSystemRights;$MyIsInherited;$MyPropagationFlags"

}

if ($AclModifiee -ieq 1){

#On applique les droits sur le répertoire/objet

Set-ACL $ObjectToProcess $objACL

}
}

DelUnknowACL -ObjectToProcess $ObjectToProcess

$AllChildObjectToProcess = Get-ChildItem $ObjectToProcess -recurse #| Where-Object {$_.Attributes -eq "Directory"}
foreach ($OneObject in $AllChildObjectToProcess){

DelUnknowACL -ObjectToProcess $OneObject.FullName
}

PowerShell - Eliminer les accents
Clear-Host
function EliminerCaracteres ([string] $MonMot){

#Version du 9 août 2011

$MesLettres = "à;a#â;a#ä;a#é;e#è;e#ê;e#ë;e#î;i#ï;i#ì;i#ô;o#ö;o#ò;o#û;u#ü;u#ù;u"

if ($MesLettres.Length -igt 0){

$MaListe = $MesLettres.Split("#")

for ($CompteurListe = 0; $CompteurListe -ilt $MaListe.Length; $CompteurListe++){

$UnCouple = $MaListe[$CompteurListe]

$CaractereRecherche = $UnCouple.split(";")[0]

$CaractereRemplacement = $UnCouple.split(";")[1]

$MonMot = $MonMot -replace ($CaractereRecherche, $CaractereRemplacement)

}

return $MonMot
}

$test = EliminerCaracteres ("tàtéò")

Write-Host $test

PowerShell - Emplacement du script
$EmplacementScript = Split-Path -parent $MyInvocation.MyCommand.Definition
Write-Host $EmplacementScript

PowerShell - Export dans un CSV
#30 mars 2012
#Example
add-PSSnapin quest.activeroles.admanagement
clear-host
$FilePath = "C:\ADExtract.csv"
$OuDomain = "OU=MyOUDC=MyDomain,DC=COM"
Get-QADUser -searchRoot $OuDomain -SizeLimit 5000 | select-Object name, SamAccountName, UserPrincipalName, mail | Export-Csv $FilePath -Delimiter "`t"

PowerShell - Extraire la liste des comptes de machines inactives
clear-host
$MesMachines = Get-QADComputer -name * -IncludedProperties pwdLastSet -searchscope “onelevel” -searchroot “ou=PKI,ou=Servers,ou=ADMIN,ou=-FR-,dc=main,dc=fr,dc=ds,dc=corp” -sizelimit 0

Foreach($UneMachine in $MesMachines)
{

$MaDiff = New-TimeSpan $UneMachine.pwdLastSet $(Get-Date)

$MaDiff2 = [int] $MaDiff.Days
#

Write-host $MaDiff2

if ($MaDiff2 -gt 60){

Write-host $UneMachine.Name

}
}

PowerShell - Generer une liste d'adresses email par rapport a une liste de logins
clear-host
$MonCSV = Import-Csv "C:\scripts\ListeDiff.txt" -Delimiter "`t" -header ("first","second","third","fourth")
$ListeDeDiff = ""
foreach ($oneline in $MonCSV) {

#Write-Host 'Affectation de $oneline.second sur $oneline.third'

$MembreListe = $oneline.first

$MonMembre = "mondomaine\$MembreListe"

$MonUser = Get-QADUser $MonMembre

$ListeDeDiff = $ListeDeDiff + $MonUser.email + ";"
}
Write-Host $ListeDeDiff

PowerShell - Gestion d erreur - une methode
#Reset the Error counter
$Error.Clear()
#Call the method with the possible problem
Get-PSSnapin vmware*

#If we have an error
if($Error.Count -ne 0)
{

Clear-Host

Write-Host "`n`n`t`t ERROR - blablabla," -foregroundcolor red -backgroundColor yellow

# Read-Host "`n`n`t Press <Enter> to continue."

Clear-Host

break
}

PowerShell - Lire une valeur d une clee de registre sur un poste distant
Clear-Host
$strMachineName = "NomMachine"
$NomClee = "SOFTWARE\\SYMANTEC\\SharedDefs"
$NomValeur = "DEFWATCH_10"
$objReg = [Microsoft.Win32.RegistryKey]::OpenRemoteBaseKey('LocalMachine', $strMachineName)
$objRegKey= $objReg.OpenSubKey($NomClee)
Write-Host $objRegKey.GetValue($NomValeur)

PowerShell - Lire toutes les valeurs d une clee de registre sur un poste distant
Clear-Host
$strMachineName = "NomMachine"
$NomClee = "SOFTWARE\\SYMANTEC\\SharedDefs"

$objReg = [Microsoft.Win32.RegistryKey]::OpenRemoteBaseKey('LocalMachine', $strMachineName)
$objRegKey= $objReg.OpenSubKey($NomClee)

#Foreach($sub in $objReg.GetSubKeyNames()){
Foreach($sub in $objRegKey.GetValueNames()){

Write-Host "Nom valeur : $sub"

$Valeur = $objRegKey.GetValue("$sub")

Write-Host "Valeur : $Valeur"
}

PowerShell - Lire un fichier et le stocker dans un tableau
#Version du 27 mars 2012
Clear-Host
$EmplacementFichier = "C:\MonFichier.txt"
$MonFichier = get-content $EmplacementFichier

#On stocke le fichier dans un tableau
foreach ($UneLigne in $MonFichier){
#

Write-Host $UneLigne.Trim()

$MonTableau += $UneLigne.Trim()
}

#On repasse le fichier en revue
for ($MonCompteur = 0; $MonCompteur -le $MonTableau.Length; $MonCompteur++){

$UneLigne = $MonTableau[$MonCompteur]

}
}

PowerShell - Lister les ACL d un repertoire
Clear-Host

#Valeurs nécessaire dans tous les cas
$ObjectToProcess = "d:\test"

function ListACL(){
param([string]$ObjectToProcess)

#On recupere les droits de l objet a traiter
$objACL = Get-ACL $ObjectToProcess

foreach ($MySubACL in $objACL.Access)
{

Write-Host "___________________________"

Write-Host $MySubACL.IdentityReference

Write-Host $MySubACL.AccessControlType

Write-Host $MySubACL.FileSystemRights

Write-Host $MySubACL.IsInherited

Write-Host $MySubACL.PropagationFlags

}
}
ListACL -ObjectToProcess $ObjectToProcess

PowerShell - Lister les fichiers d un répertoire
Clear-Host

$MonFolder = Get-ChildItem -Path "C:\" | Where-Object {$_.Attributes -ne "Directory"}
#Get-ChildItem -Path "C:\winapps" -recurse | Where-Object {$_.Attributes -ne "Directory"} | Format-table

foreach ($MyFile in $MonFolder)
{

Write-Host $MyFile.name
}

PowerShell - Lister les membres d un groupe de domaine
clear-host

$DomainName = 'Mydomain.com'
$GroupName = 'MyGroupName'

connect-qadservice -service $DomainName
$MyGroup = get-qadgroup $GroupName
foreach ($oneline in $MyGroup.Member) {

$OneUser = Get-QADUser -identity $oneline

Write-host $OneUser.SamAccountName
}

PowerShell - Lister les VM d une ferme ESX VMWARE
param
(
[string]$VIserver,
[switch]$verbose,
[switch]$debug
)

$VIserver = "Your Virtual Center Server"
#get-help Get-VM

function main()
{
if ($verbose) {$VerbosePreference = "Continue"}
if ($debug) {$DebugPreference = "Continue"}
CheckVIToolKit
GetVI-VMList $VIserver
}

function GetVI-VMList([string]$VIserver = "")
{
Connect-VIServer $VIserver

## Clear Screen.
Clear-Host

## List the servers

#$MesVM = Get-VM | Where-Object $_.Guest -like "*Windows Server*"

[string]$OS
foreach ($UneVM in Get-VM){

$OS = [string] $UneVM.Guest

$IsWindows = $OS.contains("Windows Server")

if ($IsWindows -ieq $true){
#

Write-Host $UneVM.Name"`t"$UneVM.VMHost"`t"$UneVM.Guest

Write-Host $UneVM.Name

}

}
}

function CheckVIToolKit()
{
## Before we do anything we must check to see if the user has the VI toolkit installed.
## If user does not then we prompt the user and exit.
$Error.Clear()
Get-PSSnapin vmware*
if($Error.Count -ne 0)
{
Clear-Host
Write-Host "`n`n`t`t ERROR - To run this script, the VI Toolkit must be installed and registered with Powershell. If the VI Tollkit is installed," -foregroundcolor red -backgroundColor yellow
Write-Host "`t`t go to the Settings menu in Powershell Plus and click on Manage Snapins." -foregroundcolor red -backgroundColor yellow
# Read-Host "`n`n`t Press <Enter> to continue."
Clear-Host
break
}
}## EOF: CheckVIToolKit()

## Run Main
main

PowerShell - Modifier la description d un groupe
clear-host
set-QADGroup 'MyDomain\AMS Managers' -description 'Amsterdam Managers'

PowerShell - Quotas - les lister
#Fonctionne en local sur le serveur a interroger
#http://www.experts-exchange.com/Programming/Languages/Scripting/Powershell/Q_26540816.html
#http://blog.dboden.be/2009/03/managing-fsrm-by-using-powershell/
#http://social.msdn.microsoft.com/Forums/en/windowsgeneraldevelopmentissues/thread/f4ce7048-81be-4853-b1b2-f28221cd135d

$fsrmremote = New-Object -com Fsrm.FsrmQuotaManager
$colItems = $fsrmremote.EnumQuotas("")
#$colItems | GM

foreach ($objItem in $colItems) {

write-host "QuotaUsed : " $objItem.QuotaUsed

write-host "QuotaLimit: " $objItem.QuotaLimit

write-host "Path: " $objItem.Path
}

#$colItems = $fsrmremote.EnumQuotas("")
#$colItems | GM
#Name MemberType Definition
#---- ---------- ----------
#AddThreshold Method void AddThreshold (int)
#ApplyTemplate Method void ApplyTemplate (string)
#Commit Method void Commit ()
#CreateThresholdAction Method IFsrmAction CreateThresholdAction (int, _FsrmActionType)
#Delete Method void Delete ()
#DeleteThreshold Method void DeleteThreshold (int)
#EnumThresholdActions Method IFsrmCollection EnumThresholdActions (int)
#ModifyThreshold Method void ModifyThreshold (int, int)
#RefreshUsageProperties Method void RefreshUsageProperties ()
#ResetPeakUsage Method void ResetPeakUsage ()
#Description Property string Description () {get} {set}
#id Property GUID id () {get}
#MatchesSourceTemplate Property bool MatchesSourceTemplate () {get}
#Path Property string Path () {get}
#QuotaFlags Property int QuotaFlags () {get} {set}
#QuotaLimit Property Variant QuotaLimit () {get} {set}
#QuotaPeakUsage Property Variant QuotaPeakUsage () {get}
#QuotaPeakUsageTime Property Date QuotaPeakUsageTime () {get}
#QuotaUsed Property Variant QuotaUsed () {get}
#SourceTemplateName Property string SourceTemplateName () {get}
#Thresholds Property SAFEARRAY(Variant) Thresholds () {get}
#UserAccount Property string UserAccount () {get}
#UserSid Property string UserSid () {get}

PowerShell - Recuperer des arguments passes en parametres dans un script - solution avancee
#Version du 30 mars 2012

clear-host
#Definition de 2 variables globales
$global:MyVar01 = ""
$global:MyVar02 = ""

Function ParseCommand($oArgs){

#Parses the command line and fills the script variables

#with the appropriate values.

#

$test = "-n,test"
#

$oArgs = $test.split(",")

$ArgCount = 0

if (!$oArgs.length -gt 0){

write-host "No arguments specified."

}

While ($ArgCount -lt $oArgs.length){

switch ($oArgs[$ArgCount].ToLower()){

"-n"{

$global:MyVar01 = $oArgs[($ArgCount+1)]

$ArgCount = ($ArgCount + 2)

write-host "-n : $MyVar01"

}

"-p"{

$global:MyVar02 = $oArgs[($ArgCount+1)]

$ArgCount = ($ArgCount + 2)

write-host "-p : $MyVar02"

}

default{

write-host "Invalid command."
#

Help

exit

}

}
}

#Parse commands
ParseCommand($args)

$VIserver = $MyVar01
$VMName = $MyVar02
#$SnapshotName

write-host "Le 1 : $VIserver"
write-host "Le 2 : $VMName"

PowerShell - SET-ACL
http://technet.microsoft.com/en-us/library/dd315261.aspx

PowerShell - SQL - Emplacement des fichiers de log d une base
#http://www.mssqltips.com/tip.asp?tip=1759
clear-host
[System.Reflection.Assembly]::LoadWithPartialName('Microsoft.SqlServer.SMO') | out-null
$MonServeur = New-Object ('Microsoft.SqlServer.Management.Smo.Server') "MonNomDeServeur"

$MesDatabases=$MonServeur.Databases
#$MesDatabases | Get-Member -MemberType Property

foreach($MesFileGroup in $MesDatabases.get_Item("MonNomDeBase").LogFiles)
{

foreach($OneFile in $MesFileGroup)

{

Write-Host $OneFile.FileName

}
}

PowerShell - SQL - Lister les bases
clear-host
[System.Reflection.Assembly]::LoadWithPartialName('Microsoft.SqlServer.SMO') | out-null
$MonServeur = New-Object ('Microsoft.SqlServer.Management.Smo.Server') "MonNomdeServeur"

$MesDatabases=$MonServeur.Databases
#$MesDatabases | Get-Member -MemberType Property

foreach($UneBase in $MesDatabases)
{

Write-Host $UneBase.Name
}

PowerShell - SQL - Stopper un Job SQL
$SqlInstance = Read-Host 'Enter name of SQL server'
$JobNameToStop = Read-Host 'Enter the Job Name to stop'

cls
[void][reflection.assembly]::LoadWithPartialName("Microsoft.SqlServer.Smo")
$NamedInstance = New-Object -typeName Microsoft.SqlServer.Management.Smo.Server -argumentList $SqlInstance

Write-Host ""
Write-Host "*********************************************************"
Write-Host "Locating jobs on $SqlInstance"
Write-Host ""

##Get all currently enabled jobs
#$jobs=$namedinstance.JobServer.Jobs | where-object{$_.isenabled}

$jobserver = $NamedInstance.JobServer
#$jobs = $jobserver.Jobs | where {$_.Name -like “*jobname*”}
$jobs = $jobserver.Jobs | where-object { $_.Name -eq $JobNameToStop}

foreach($job in $jobs)
{
$jobcnt++
# Write-Progress -activity "Looking for Actively running jobs..." -status "Progress:" -percentcomplete ($jobcnt/$totjobcnt*100)

$jobstatus=$job.CurrentRunStatus

Write-Host "Job $job.Name : $jobstatus"

if ($jobstatus.value__ -eq 1)
{
$activejobs++

$DateLancementDuJob = $job.LastRunDate

$DifferenceTemps = New-TimeSpan $DateLancementDuJob $(Get-Date)

Write-Host $DifferenceTemps.Hours

Write-Host "Job $job.Name LasRunDate : $Test"
Write-Host "Stopping job ($job.Name)..."
# $job.Stop()
}
}

Write-Host ""

PowerShell - Variables
Vu sur http://www.powershellpro.com/powershell-tutorial-introduction/variables-arrays-hashes/

[int]

32-bit signed integer
[long]

64-bit signed integer
[string]

Fixed-length string of Unicode characters
[char]

A Unicode 16-bit character
[byte]

An 8-bit unsigned character
[bool]

Boolean True/False value
[decimal]

An 128-bit decimal value
[single]

Single-precision 32-bit floating point number
[double]

Double-precision 64-bit floating point number
[xml]

Xml object
[array]

An array of values
[hashtable]

Hashtable object

#Exemples de declaration
$UneVarString = [string]
$UnCompteur = [int]
$MonTableau = @()

#Exemple de declaration de constante
set-variable -name ConstUneConstante -value 0 -option constant

PowerShell - Verification de la presence d un Snapin
function main()
{

CheckSnapin
}

function CheckSnapin()
{

## Before we do anything we must check if snapin exist

$Error.Clear()

Get-PSSnapin vmware*

if($Error.Count -ne 0)

{

Clear-Host

Write-Host "`n`n`t`t ERROR - To run this script, the VI Toolkit must be installed and registered with Powershell. If the VI Tollkit is installed," -foregroundcolor red -backgroundColor yellow

Write-Host "`t`t go to the Settings menu in Powershell Plus and click on Manage Snapins." -foregroundcolor red -backgroundColor yellow

# Read-Host "`n`n`t Press <Enter> to continue."

Clear-Host

break

}
}

## Run Main
main

Registre - Creer une Clee
'Creer une clee
'http://msdn.microsoft.com/library/en-us/wmisdk/wmi/createkey_method_in_class_stdregprov.asp

'Definition des constantes
Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Const HKEY_CURRENT_CONFIG = &H80000005
Const HKEY_DYN_DATA = &H80000006

'On pointe sur l'ordinateur local
strComputer = "."

'Je fais un objet qui represente la base de registre
Set objRegistry=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\default:StdRegProv")

'Chemin du repertoire de la clée. Ce repertoire doit exister
PathRepertoireRegistre = "SOFTWARE"
NomCleeRegistre = "Test"
ValeurCleeRegistre = 2

'Je modifie la valeur de la clee
objRegistry.SetStringValue HKEY_LOCAL_MACHINE,PathRepertoireRegistre,NomCleeRegistre,ValeurCleeRegistre

Set objRegistry = Nothing

Registre - Creer un repertoire de Clee
'Creer un répertoire de clée
'http://msdn.microsoft.com/library/en-us/wmisdk/wmi/createkey_method_in_class_stdregprov.asp

'Definition des constantes
Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Const HKEY_CURRENT_CONFIG = &H80000005
Const HKEY_DYN_DATA = &H80000006

'On pointe sur l'ordinateur local
strComputer = "."

'Je fais un objet qui represente la base de registre
Set objRegistry=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\default:StdRegProv")

'Creer un répertoire de clée
PathRepertoireRegistre = "SOFTWARE\Atotof"
objRegistry.CreateKey HKEY_LOCAL_MACHINE, PathRepertoireRegistre

Registre - Effacer les clees contenues dans une clee

'Version du 29 juillet 2008
'Effacer les clees contenues dans une clee

Dim PathRepertoireRegistre
Dim UneClee

'Definition des constantes
Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Const HKEY_CURRENT_CONFIG = &H80000005
Const HKEY_DYN_DATA = &H80000006

'On pointe sur l ordinateur local
strComputer = "."

'Chemin du sous repertoire de la clée
PathRepertoireRegistre = "Printers\Connections"

'Je fais un objet qui represente la base de registre
Set objRegistry = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\default:StdRegProv")

'Recuperation du resultat dans un tableau
objRegistry.EnumKey HKEY_CURRENT_USER, PathRepertoireRegistre, arrSubKeys

'J'affiche le contenu du tableau
For Each subkey In arrSubKeys

UneClee = subkey

Call objRegistry.DeleteKey(HKEY_CURRENT_USER, PathRepertoireRegistre & "\" & UneClee)
Next

Registre - Enumerer des Clees
'Enumeration des clees
'http://msdn.microsoft.com/library/en-us/wmisdk/wmi/enumkey_method_in_class_stdregprov.asp

Dim PathRepertoireRegistre
Dim UneClee

'Definition des constantes
Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Const HKEY_CURRENT_CONFIG = &H80000005
Const HKEY_DYN_DATA = &H80000006

'Chemin du sous repertoire de la clée
PathRepertoireRegistre = "SOFTWARE\Microsoft\Windows\CurrentVersion"

'On pointe sur l'ordinateur local
strComputer = "."

'Je fais un objet qui represente la base de registre
Set objRegistry=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\default:StdRegProv")

'Recuperation du resultat dans un tableau
objRegistry.EnumKey HKEY_LOCAL_MACHINE, PathRepertoireRegistre, arrSubKeys

'J'affiche le contenu du tableau
For Each subkey In arrSubKeys

Wscript.Echo subkey
Next

Registre - Lire une Clee
'Lire un String
'http://msdn.microsoft.com/library/en-us/wmisdk/wmi/getstringvalue_method_in_class_stdregprov.asp
'Lire un Expanded String
'http://msdn.microsoft.com/library/en-us/wmisdk/wmi/getexpandedstringvalue_method_in_class_stdregprov.asp
'Lire un DWord
'http://msdn.microsoft.com/library/en-us/wmisdk/wmi/getdwordvalue_method_in_class_stdregprov.asp
'Lire un Binary
'http://msdn.microsoft.com/library/en-us/wmisdk/wmi/getbinaryvalue_method_in_class_stdregprov.asp

'Definition des constantes
Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Const HKEY_CURRENT_CONFIG = &H80000005
Const HKEY_DYN_DATA = &H80000006

'On pointe sur l'ordinateur local
strComputer = "."

'Je fais un objet qui represente la base de registre
Set objRegistry=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\default:StdRegProv")

'Chemin de la valeur String à lire
PathRepertoireRegistre = "SOFTWARE\Microsoft\Windows\CurrentVersion"
NomCleeRegistre = "ProductId"
objRegistry.GetStringValue HKEY_LOCAL_MACHINE,PathRepertoireRegistre,NomCleeRegistre,ValeurCleeRegistre
Wscript.Echo ValeurCleeRegistre

'Chemin de la valeur ExpandedString à lire
PathRepertoireRegistre = "SOFTWARE\Microsoft\Windows\CurrentVersion"
NomCleeRegistre = "ProgramFilesPath"
objRegistry.GetExpandedStringValue HKEY_LOCAL_MACHINE,PathRepertoireRegistre,NomCleeRegistre,ValeurCleeRegistre
Wscript.Echo ValeurCleeRegistre

'Chemin de la valeur DWord à lire
PathRepertoireRegistre = "SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths"
NomCleeRegistre = "Installed"
objRegistry.GetDWORDValue HKEY_LOCAL_MACHINE,PathRepertoireRegistre,NomCleeRegistre,ValeurCleeRegistre
Wscript.Echo ValeurCleeRegistre

'Lire un Binary
'objRegistry.GetBinaryValue

Sql - Afficher la date actuelle
Select GETDATE ( )

Sql - Afficher la Liste des bases de donnees
Afficher la Liste des bases de donnees
select *
from dbo.sysdatabases
Order By Name
;

Sql - Afficher la liste des tables
Use NomDeLaBase
SELECT name
FROM sysobjects
Where xtype = 'U'
ORDER BY name

Sql - Afficher la liste des tables et de leurs colonnes en SQL Serveur
select dbo.sysobjects.name as NomTable, dbo.syscolumns.name as NomColonne
from dbo.sysobjects, dbo.syscolumns
where dbo.sysobjects.xtype = 'u' And dbo.sysobjects.id = dbo.syscolumns.id
order by NomTable, NomColonne

SQL - Afficher la Liste des Users d une base
Afficher la Liste des Users
select *
from master.dbo.sysxlogins
;

Liste des users d'une base et de leur SID
EXEC sp_change_users_login 'Report'

SQL - Afficher le nom de la journée actuelle
Select DATENAME(weekday, getdate())

SQL - Afficher les bases de données
Use Master
select *
from dbo.sysdatabases

SQL - Afficher les colonnes d une table
Use NomDeLaBase
SELECT syscolumns.*
FROM sysobjects INNER Join syscolumns On sysobjects.id = syscolumns.Id
WHERE sysobjects.name = 'NomDeLaTable'

SQL - Afficher les fichiers physiques d'une base
Afficher les fichiers physiques d'une base
Use MaBase
select *
from dbo.sysfiles

SQL - Afficher les informations sur les colonnes d une table
exec sp_MShelpcolumns N'[dbo].[NomDeLaTable]'

SQL - Afficher les membres d'un groupe
Use MaBase
sp_helpgroup @grpname = 'db_datareader'

SQL - Afficher les relations d une table :
Ic la table s'appelle UP
EXEC sp_fkeys @pktable_name = N'UP'
EXEC sp_fkeys @fktable_name = N'UP'

SQL - Afficher les triggers d une table :
sp_helptrigger N'dbo.MaTable'

SQL - Afficher l etat d'un job :
declare @job_owner sysname
declare @job_id UNIQUEIDENTIFIER
declare @job nvarchar(128)

--set @job = 'aeff.Subplan_1'
set @job = 'Backup.Subplan_1' --mettre ici le nom du job recherché
set @job_owner = SUSER_SNAME() --recuperation du user connecté

-- get job id
select @job_id=job_id
from msdb.dbo.sysjobs sj
where sj.name=@job

execute master.dbo.xp_sqlagent_enum_jobs 1, @job_owner, @job_id

SQL - Afficher l utilisateur connecté / le login de celui qui execute le code
declare @job_owner sysname
set @job_owner = SUSER_SNAME()
PRINT @job_owner

SQL - Attendre/Marquer une pause
Exemple de commande pour attendre 5 secondes :
WAITFOR DELAY '00:00:5'

SQL - Ajouter une colonne
Use MaBase
ALTER TABLE dbo.Matable
ADD [MaColonne] [varchar] (255) NULL
Go

SQL - Between
Exemple :
And ChampHeure between '28/10/2005 09:10:00' and '28/10/2005 17:25:00'

SQL - Compresser les fichiers d'une base de données
/* Compression d une base de donnée */
BACKUP LOG [Mabase] WITH TRUNCATE_ONLY
use [Mabase] DBCC SHRINKFILE ('Mabase_Log')
use [Mabase] DBCC SHRINKFILE ('Mabase_Data')

SQL - Convertir la date et l'heure
SELECT top 20 CAST(DateInfo AS smalldatetime) as Test
from dbo.MaTable;

SQL - Convertir un type de colonne
Normalment Login est de type Char 255
ici on le passe en VarChar 128

Select Distinct top 100 Cast(Login As varchar(128))
From dbo.MaTable

SQL - Créer un user/compte
exec sp_addlogin N'login', N'passe', N'basepardefaut', N'Français'
GO
EXEC sp_grantdbaccess N'login', N'base'
GO
exec sp_addrolemember N'db_owner', N'equation'

SQL - Créer un Index
CREATE [UNIQUE] INDEX Nom_de_l_index
ON Nom_de_la_table (Nom_de_champ [ASC/DESC], ...)

Ex :
CREATE INDEX index_name
ON table_name (column_name)

Et pour le supprimer :
DROP INDEX Nom_de_l_index
ON Nom_de_la_table

SQL - Créer un Trigger
CREATE TABLE table_name (column_name INT);

CREATE TRIGGER insert_trigger

NO CASCADE BEFORE INSERT ON table_name

REFERENCING NEW AS n

FOR EACH ROW

SET n.column_name = NEXTVAL FOR sequence_name;

SQL - Créer/Supprimer une colonne
ALTER TABLE dbo.MaTable
ADD [Aeffacer] [varchar] (255) NULL
Go

Update dbo.MaTable
Set Aeffacer = 'untruc'
Go

ALTER TABLE dbo.MaTable
DROP COLUMN [Aeffacer]
Go

SQL - Créer une contrainte
BEGIN TRANSACTION
ALTER TABLE dbo.NomDeLaTable ADD CONSTRAINT

PK_NomDeLaTable PRIMARY KEY CLUSTERED

(

CODEISO

) ON [PRIMARY]
GO
COMMIT

SQL - Créer une procedure
CREATE PROCEDURE UneProcedure AS
INSERT INTO UneTable(UneColonne) VALUES(getdate())

SQL - Creer une table
if exists (select * from dbo.sysobjects where id = object_id(N'[dbo].[NomDeLaTable]') and OBJECTPROPERTY(id, N'IsUserTable') = 1)
drop table [dbo].[NomDeLaTable]
GO

CREATE TABLE [dbo].[NomDeLaTable] (

[Colonne1] [varchar] (255) COLLATE French_CI_AS NULL ,

[Colonne2] [int] NULL ,

[Time] [datetime] NULL ,
) ON [PRIMARY]
GO

CREATE TABLE [dbo].[NomDeLaTable] (

[Colonne1] numeric(10, 0) NOT NULL IDENTITY (1, 1),

[Colonne2] [int] NULL ,

[Time] [datetime] NULL ,
) ON [PRIMARY]
GO

Sql - Delete
/*Effacement des 10 premiers enregistrements d une table*/
DELETE authors
FROM (SELECT TOP 10 * FROM authors) AS MonAlias
WHERE authors.MaClePrimaire = MonAlias.MaClePrimaire

/*Second Exemple*/
DELETE
FROM (SELECT TOP 10 * FROM MaTable) AS MonAlias
WHERE MaTable.MaClePrimaire = MonAlias.MaClePrimaire

/*Trosieme Exemple*/
Use LogParse
Delete
From (Select TOP 50 * From dbo.MaTable Where UnChamp = 'UneValeur') As MonAlias
Where dbo.MaTable.ExtPrimaryKey = dbo.MonAlias.ExtPrimaryKey

Sql - Déplacer le fichier temp (templog)
USE master
GO
ALTER DATABASE tempdb modify file (name = tempdev, filename = 'NewDrive:\Path\tempdb.mdf')
GO
ALTER DATABASE tempdb modify file (name = templog, filename = 'NewDrive:\Path\templog.ldf')
GO

Sql - Donner les droits a un compte a toutes les bases non-systeme
DECLARE @DBName varchar(255)
DECLARE @MyAccount varchar(255)
DECLARE @DATABASES_Fetch int
DECLARE DATABASES_CURSOR CURSOR FOR

select name
from sys.databases
Where
-- Only look at databases to which we have access
has_dbaccess(name) = 1
-- Not master, tempdb or model
and name not in ('Master','tempdb','model','msdb')
order by 1

SET @MyAccount = 'MyDomain\MyLogin'

OPEN DATABASES_CURSOR
FETCH NEXT FROM DATABASES_CURSOR INTO @DBName
WHILE @@FETCH_STATUS = 0
BEGIN

PRINT 'Process Database ' + @DBName

EXEC('USE ['+@dbname+'] exec sp_addrolemember "db_datareader","' + @MyAccount + '"')

--EXEC('USE ['+@dbname+'] exec sp_droprolemember "db_datareader","' + @MyAccount + '"')
FETCH NEXT FROM DATABASES_CURSOR INTO @DBName
END
CLOSE DATABASES_CURSOR
DEALLOCATE DATABASES_CURSOR

Sql - Insert Into
Insert Into dbo.NomDeLaTable (Champs1, Champs2, Champs3)
Values ('ValeurChamps1','ValeurChamps2','ValeurChamps3')

Sql - Instr
Instr : c'est CHARINDEX

Sql - LCASE
LCASE : c'est LOWER

Sql - Mid : c est SUBSTRING
Mid : lequivalent SQL est SUBSTRING

Sql - Modifier l association Compte login SQL / connexion SQL dans une base apres une restauration de BDD - sp_changedbowner
Utiliser la fonction sp_changedbowner
Exemple :
sp_changedbowner sa, dbo

ou encore plus simplement
sp_changedbowner sa

Article :
http://support.microsoft.com/kb/296437/en-us

En 2005 et 2008, il faut faire :
Use NomDeLaBase
Go
EXEC sp_change_users_login 'Update_One', 'NomCompte', 'NomCompte';
Go

Sql - Modifier le propriétaire d une base : sp_changedbowner
--Exemple :
Use NomDeLaBase
EXEC sp_changedbowner sa

le compte SQL qui doit devenir propriétaire ne doit pas avoir d'accès préalable sur la base visée.
le compte sera alors vu avec le compte ayant pour nom 'dbo' sur la base visée

Sql - Modifier le propriétaire d une table : sp_changeobjectowner
Modifier le propriétaire d une table :
EXEC dbo.sp_changeobjectowner @objname = 'owner.TAbleName' , @newowner = 'dbo'

--SQL Server 2005
--Transfer to 'dbo' schema
ALTER SCHEMA [dbo] TRANSFER [Test].[TestTable]

Sql - Modifier le timeout d une requete
'Jamais testé :
exec sp_configure 'remote query timeout', 600
go
reconfigure
go

Sql - Modifier les caractères d'une requête SQL par leur code ASCII
Public Function ModifierCaractSpeRequeteSQL(ByVal MaLigne)

'Version du 25 juillet 2008

'Ex Version du 3 janvier 2007

'Modifie les caractères spéciaux d'une requête SQL par leur code ASCII pour ne pas la faire planter les requêtes à cause de caractères réservés

'Caractères comme ' , ;

'Par defaut

ModifierCaractSpeRequeteSQL = MaLigne

If Len(Trim(MaLigne)) > 0 Then

'ParametresScriptForSQL = Replace(ParametresScriptForSQL,",","' + Char(44) + '")

MaLigne = Replace(MaLigne, "'", "' + Char(39) + '") 'Cette ligne doit être passée en premier

MaLigne = Replace(MaLigne, ";", "' + Char(59) + '")

'MaLigne = Replace(MaLigne, "+", "' + Char(43) + '")

MaLigne = Replace(MaLigne, Chr(9), "' + Char(9) + '")

MaLigne = Replace(MaLigne, Chr(10), "' + Char(10) + '")

MaLigne = Replace(MaLigne, Chr(13), "' + Char(13) + '")

ModifierCaractSpeRequeteSQL = MaLigne

End If 'If Len(Trim(MaLigne)) > 0 Then

End Function

Sql - Modifier les valeurs d un champs et mettre des chiffres par incrément de 1
DECLARE @counter numeric
SET @counter = 0

UPDATE dbo.MaTable
SET @counter = LeChampVisé = @counter + 1

Sql - Modifier une colonne
/* Passer le type d une colonne en varchar de 128 caractères max */
Alter Table dbo.Matable
ALTER COLUMN NomColonne varchar(128);

/* Passer le type d une colonne en varchar de 128 caractères max et qui n accepte pas les valeurs nulles*/
Alter Table dbo.Matable
ALTER COLUMN NomColonne varchar(128) NOT NULL;

Sql - Restauration d un backup - cas simple
--Cas simple : les fichiers de travail de la base à restaurer sont au même endroit que ceux de la base sauvegardée
Use "NomDeLaBaseARestaurer"
Alter Database "NomDeLaBaseARestaurer" set SINGLE_USER
Go
RESTORE DATABASE "NomDeLaBaseARestaurer" FROM DISK = 'D:\EplacementDeLaSauvegarde.bak' WITH REPLACE, RECOVERY
Go
Alter Database "NomDeLaBaseARestaurer" set MULTI_USER
Go

Sql - Restauration d un backup - modification emplacement des fichiers de travail
--les fichiers de travail de la base à restaurer n'étaient pas au même endroit lors de la sauvegarde
--1) noter le LogicalName des fichiers renvoyé par la commande suivante
RESTORE FILELISTONLY
FROM DISK = 'C:\EmplacementDeLaSauvegarde.bak'

--2) faire la restauration en utilisant le LogicalName précédemment noté
Alter Database "NomDeLaBaseARestaurer" set SINGLE_USER
Go
RESTORE DATABASE "NomDeLaBaseARestaurer" FROM DISK = 'C:\EmplacementDeLaSauvegarde.bak'
with Replace, Move 'NomLogiqueDuFichierdeData' to 'C:\EmplacementDeLaBaseDeDonnees.MDF',
move 'NomLogiqueDuFichierdeLog' to 'C:\EmplacementDuJournalDeLaBaseDeDonnees.LDF'
Go
Alter Database "NomDeLaBaseARestaurer" set MULTI_USER
Go

Sql - Sauvegarder une base en ligne de commande
--Pour faire une sauvegarde en ligne de commande, entrer :
BACKUP DATABASE "NomDeLaBase" TO DISK = 'D:\FichierDeSauvegarde.bak' WITH INIT

-- Plus d'infos sur
-- http://blogs.techrepublic.com.com/datacenter/?p=132

Sql - Supprimer un user en acces sur une base
--if exists (select * from dbo.sysusers where name = N'lenom' and uid < 16382)
EXEC sp_dropuser 'NomDuCompte'
--ou encore
EXEC sp_revokedbaccess @name_in_db = 'NomDuCompte'
go

--si le compte refuse de se supprimer
--Lister les schémas pour lequel le compte est propriétaire avec la commande
SELECT * FROM sys.schemas WHERE principal_id=user_id('LeCompte')
go

--puis mettre le compte dbo à la place avec la commande suivante
ALTER AUTHORIZATION ON SCHEMA::NomDuSchema TO dbo
go

Sql - Supprimer une Colonne
ALTER TABLE dbo.MaTable
Drop Column [Macolonne]
Go

Sql - Supprimer une contrainte
Use MaBase
ALTER TABLE dbo.MaTable DROP CONSTRAINT IX_NomDeLaTable

Exemple pour une table nommée LesInfos
ALTER TABLE dbo.LesInfos DROP CONSTRAINT IX_LesInfos

Sql - UCASE
UCASE : c'est UPPER

Sql - Transact SQL - Fonctions
'Exemples de fonctions sur
'http://sqlpro.developpez.com/cours/sqlserver/udf/
'Exemple :

/****************************************************************************/
-- remplace un datetime par une datetime avec heure à zero
/****************************************************************************/
CREATE FUNCTION FN_DATETIME_AS_DATE (@DT DATETIME)
RETURNS DATETIME AS
BEGIN
RETURN CAST(FLOOR(CAST(@DT AS FLOAT)) AS DATETIME)
END
GO

Sql - Update
/* Passer toutes les valeurs d une colonne à une valeur fixe */
Update dbo.NomDeLaTable
Set MaColonne = 'Monserveur'
Where MaColonne = 'UnTruc'

/* Copier certaines lignes d une colonne dans une autre */
Update dbo.MaPremiereTable
Set dbo.MaPremiereTable.UnChamp = dbo.MaDeuxiemeTable.UnAutreChamp, Commentaire = 'Une valeur fixe dans une colonne nommée Commentaire'
From dbo.MaPremiereTable, dbo.MaDeuxiemeTable
Where dbo.MaPremiereTable.UnChamp = dbo.MaDeuxiemeTable.UnAutreChamp

SQL scripting - Afficher le contenu d'un recordset en un tableau sur une page HTML - ASP

SQL scripting - Afficher le contenu d'un recordset en un tableau sur une page HTML - vbs

Function AffichierRecordset(ByRef UnRecordset)

Dim CompteurChamps

'Fonction du 6 octobre 2005

'Fonction VbScript

'On passe en parametre un objet recorset

'Ce dernier est affiché sous forme de tableau dans une page web

Document.Write("<TABLE WIDTH=95% BORDER=1>" & VbCrLf) 'Ouverture du tableau

Document.Write("<TR>") 'Ouverture de la ligne

'Affichage du nom des champs

For CompteurChamps = 0 To UnRecordset.fields.Count - 1

'MsgBox "Valeur du champ " & UnRecordset.fields(CompteurChamps).Name & " : " & Trim(UnRecordset.fields(CompteurChamps).Value)

Document.Write("<TD><CENTER><B>" & Trim(UnRecordset.fields(CompteurChamps).Name) & "</B></CENTER></TD>")

Document.Write("</TR>")

Do While UnRecordset.EOF = False

Document.Write("<TR>") 'Ouverture de la ligne

'Affichage des valeurs de chaque champ

For CompteurChamps = 0 To UnRecordset.fields.Count - 1

'MsgBox "Valeur du champ " & UnRecordset.fields(CompteurChamps).Name & " : " & Trim(UnRecordset.fields(CompteurChamps).Value)

Document.Write("<TD>" & Trim(UnRecordset.fields(CompteurChamps).Value) & "</TD>")

Document.Write("</TR>") 'Fermeture de la ligne

UnRecordset.MoveNext 'On passe à la ligne suivante

Loop

Document.Write("</TABLE>") 'Fermeture du tableau

End Function

SQL scripting - Executer une commande SQL sur un serveur SQL en ASP
'Version du 22 mars 2012
'Script d aide à la restauration de bases SQL avec déplacement des fichiers
'Ce script se place dans le répertoire contenant les fichiers de backups à restaurer
'Il génèrera un fichier avec des commandes de restauration indiquant une modification de l'emplacement des bases et logs SQL
'Restera a les contrôler avec exécution
'Quand il y a tout un serveur à migrer, cela peu aider.

Dim objFSO 'Objet FSO pour l'accès au système de fichiers
Dim MyFile 'Représente un fichier
Dim objTextFile 'Représente le fichier texte qui contient les réponses
Dim NomBase

'Déclaration des constantes pour la lecture et l'ecriture dans les fichiers
Const ForReading = 1
Const ForWritting = 2
Const ForAppending = 8

CheminScriptActuel = Left(wscript.scriptfullname,Len(wscript.scriptfullname)-Len(wscript.scriptname)-1)
CheminFichierResultat = CheminScriptActuel & "\" & "Fichier de Sortie.txt"
CheminRepertoireAExplorer = InputBox("Entrez le chemin du répertoire","Chemin du répertoire",CheminScriptActuel)
CheminFichierResultat = InputBox("Entrez le chemin du fichier contenant le resultat","Chemin du fichier de reponse",CheminFichierResultat)
CheminDataSQL = InputBox("Entrez le chemin du fichier du repertoire contenant les bases SQL","Bases SQL","D:\SQL DB")
CheminLogSQL = InputBox("Entrez le chemin du fichier du repertoire contenant les bases SQL","Bases SQL","L:\SQL LOG")

'Création des objets
Set objFSO = CreateObject("Scripting.FileSystemObject")

'On fait un objet qui représente le répertoire à explorer
Set objFolder = objFSO.GetFolder(CheminRepertoireAExplorer)
Set objTextFile = objFSO.OpenTextFile(CheminFichierResultat, ForWritting, True)

For Each MyFile In objFolder.Files

If ExtensionFichier(MyFile.Name) = "bak" Then

NomBase = MyFile.Name

NomBase = Left(NomBase,(Len(NomBase)-24))

Wscript.Echo NomBase

objTextFile.WriteLine("RESTORE DATABASE """ & NomBase & """ FROM DISK = '" & MyFile.Path & "' with Replace, Move '" & NomBase & "' to '" & CheminDataSQL & "\" & NomBase & ".MDF', move '" & NomBase & "_log' to '" & CheminLogSQL & "\" & NomBase & "_log.LDF'")

End If
Next

objTextFile.Close
Set objTextFile = Nothing
Set objFolder = Nothing
Set objFSO = Nothing

Public Function ExtensionFichier(ByVal CheminFichier)

'Retourne l'extension du fichier

Dim Position

ExtensionFichier = ""

Position = InStrRev(CheminFichier,".")

If (Position > 0) And (Position < Len(CheminFichier)) Then

ExtensionFichier = Mid(CheminFichier,Position+1)

End If

End Function

SQL scripting - Executer une commande SQL sur un serveur SQL en ASP
Dim MonMessagedErreur 'Message d erreur retourne eventuellement par une commande SQL
Dim NbrLigneAffectees 'nombre de lignes affectées par une commande SQL
Dim RequeteSQL
Dim ReussiteRequeteSQL

Const NomServeurSQL = "NomServeurSQL"
Const NomBaseSQL = "NomBaseSQL"
Const LoginSQL = ""
Const MdpSQL = ""

RequeteSQL = "INSERT INTO 'nom de table' ('colonne 1', 'colonne 2') VALUES ('valeur 1', 'valeur 2')"

ReussiteRequeteSQL = ExecCommandeSQL(NomServeurSQL, NomBaseSQL, RequeteSQL, LoginSQL, MdpSQL, MonMessagedErreur, NbrLigneAffectees)
If ReussiteRequeteSQL = 1 Then

'Tout est Ok
Else

'Pb lors de la requete SQL
End If

Public Function ExecCommandeSQL(ByVal NomServeurSQL, ByVal NomDeLaBase, ByVal CommandeSql, ByVal Login, ByVal MotDePasse, ByRef MessageErreur, ByRef NbrLigneAffectees)

'Version du 17 aout 2010 : meilleur gestion des erreurs et apparition du debugmode

'Version du 25 février : plus d erreurs remontées

'Version du 15 Octobre 2008 : Retourne 1 si Ok (et non plus le nbr de lignes affectées)

'La variable MessageErreur permet de retourner un eventuel message d erreur

'La variable NbrLigneAffectees permet de retourner le nombre de lignes qui ont été affectées

'Ex Version du 15 Decembre 2006

'Déclaration des constantes

Const DebugMode = 0

Const adUseServer = 2

Const adUseClient = 3

Const adCmdText = 1

Const adModeRead = 1

Const adModeReadWrite = 3

'Declaration des variables

Dim MaConnection

Dim ObjetCommande

Dim ConnectionOk

Dim LignesAffectees 'Nombre de lignes affectees par la commande SQL

Dim NumeroErreur

Dim DescriptionErreur

ExecCommandeSQL = -1 'Valeur par défaut

ConnectionOk = 0

MessageErreur = "Debut de la fonction ExecCommandeSQL" 'Valeur par défaut

Set MaConnection = CreateObject("ADODB.Connection")

MaConnection.Mode = adModeReadWrite

MaConnection.CursorLocation = adUseClient

'Pour mettre eventuellement un delai de timeout de 60s

'MaConnection.CommandTimeout = 60

MotDePasse = Trim(MotDePasse)

'Si on a un login et un mot de passe

If (Len(Login) > 0) And (Len(MotDePasse) > 0) Then

MessageErreur = "Login et mot de passe SQL précisé"

MaConnection.ConnectionString = "Provider=SQLOLEDB; Data Source=" & NomServeurSQL & "; Initial Catalog=" & NomDeLaBase & " ; User ID=" & Login & ";Password=" & MotDePasse & ";"

Else

MessageErreur = "Authentification récupérée"

MaConnection.ConnectionString = "Provider=SQLOLEDB; Data Source=" & NomServeurSQL & "; Initial Catalog=" & NomDeLaBase & " ; Integrated Security=SSPI"

End If

If DebugMode > 0 Then

Wscript.echo "MessageErreur : " & MessageErreur

End If

'Si la connexion n'est pas déjà ouverte

If MaConnection.State = 0 Then

On Error Resume Next

MaConnection.Open

Select Case Err.Number

Case 0 'Si il n'y a pas d'erreurs

'Tout va bien on ne fait rien

ConnectionOk = 1

MessageErreur = "Connection a la base Ok"

Case -2147217843 'Probleme de droits

MessageErreur = "Erreur n°" & Err.number & " (" & Err.Description & ") certainement due à un problème de droits"

NbrLigneAffectees = 0

Exit Function

Case Else 'Probleme inconnu

MessageErreur = "Erreur " & Err.number & " (" & Err.Description & ")"

NbrLigneAffectees = 0

Exit Function

End Select

On Error Goto 0

Else

MessageErreur = "Connexion deja etablie"

ConnectionOk = 1

End If

If DebugMode > 0 Then

Wscript.echo "MessageErreur : " & MessageErreur

End If

If ConnectionOk = 1 Then

'Si on a une commande a executer

If (Len(Trim(CommandeSql)) > 0) Then

Set ObjetCommande = CreateObject("ADODB.Command")

ObjetCommande.ActiveConnection = MaConnection

ObjetCommande.CommandType = adCmdText

MessageErreur = "Lancement de la commande SQL"

If DebugMode > 0 Then

Wscript.echo "MessageErreur : " & MessageErreur

End If

'Execution de commandes Sql pour mettre a jour les données

ObjetCommande.CommandText = CommandeSql

On Error Resume Next

ObjetCommande.Execute LignesAffectees

NumeroErreur = Err.number

DescriptionErreur = Err.Description

NbrLigneAffectees = LignesAffectees 'On retourne le nombre de lignes affectées

On Error Goto 0

If NumeroErreur = 0 Then

ExecCommandeSQL = 1

MessageErreur = "La commande SQL c est bien passee." & LignesAffectees & " lignes affectees."

Else

ExecCommandeSQL = 0

MessageErreur = "Erreur " & NumeroErreur & " (" & DescriptionErreur & ")"

End If

Set ObjetCommande = Nothing

Else

MessageErreur = "Commande SQL vide"

End If 'If (Len(Trim(CommandeSql)) > 0) Then

End If 'If ConnectionOk = 1 Then

If DebugMode > 0 Then

Wscript.echo "MessageErreur : " & MessageErreur

End If

Set MaConnection = Nothing

End Function

SQL scripting - Executer une commande SQL sur un serveur SQL en VBScript dans du HTML

Public Function ExecCommandeSQL(ByVal NomServeurSQL, ByVal NomDeLaBase, ByVal CommandeSql)

'Version du 11 juillet 2005

'Déclaration des constantes

Const adUseServer = 2

Const adUseClient = 3

Const adCmdText = 1

Const adModeRead = 1

Const adModeReadWrite = 3

'Declaration des variables

Dim MaConnection

Dim ObjetCommande

Dim LignesAffectees 'Nombre de lignes affectees par la commande SQL

Dim ConnectionOk

ExecCommandeSQL = -1 'Valeur par défaut

ConnectionOk = 0

Set MaConnection = CreateObject("ADODB.Connection")

MaConnection.Mode = adModeReadWrite

MaConnection.CursorLocation = adUseClient

MaConnection.ConnectionString = "Provider=SQLOLEDB; Data Source=" & NomServeurSQL & "; Initial Catalog=" & NomDeLaBase & " ; Integrated Security=SSPI"

'Si la connexion n'est pas déjà ouverte

If MaConnection.State = 0 Then

'On Error Resume Next

MaConnection.Open

Select Case Err.Number

Case 0 'Si il n'y a pas d'erreurs

ConnectionOk = 1

'Tout va bien on ne fait rien

Case -2147217843 'Probleme de droits

Msgbox "Erreur n°" & Err.number & " certainement due à un problème de droits"

Exit Function

Case Else 'Probleme inconnu

Msgbox "Erreur " & Err.number & "

Exit Function

End Select

On Error Goto 0

End If

'Si la connection est OK

If ConnectionOk = 1 Then

If (Len(Trim(CommandeSql)) > 0) Then 'Si on a une commande a executer

'Ouvrir des objets ADO Connection et Recordset

'http://support.microsoft.com/?kbid=168336

Set ObjetCommande = CreateObject("ADODB.Command")

ObjetCommande.ActiveConnection = MaConnection

ObjetCommande.CommandType = adCmdText

'Execution de commandes Sql pour mettre a jour les données

ObjetCommande.CommandText = CommandeSql

ObjetCommande.Execute LignesAffectees

Msgbox LignesAffectees & " ligne(s) affectées"

ExecCommandeSQL = LignesAffectees 'On retourne le nombre de lignes affectées

Set ObjetCommande = Nothing

Set MaConnection = Nothing

Else 'Si on a pas de commande a executer

Msgbox "Pas de commandes a executer "

End If

End If 'Si la connection est OK

ExecCommandeSQL = LignesAffectees 'On retourne le nombre de lignes affectées

End Function

SQL scripting - Executer une commande SQL sur un serveur SQL en VBScript dans du HTML - BIS
Public Sub RequeteSQLDansTableauBIS(ByVal RequeteSql, ByVal NomServeurSQL, ByVal NomBaseSQL, ByRef MonTableauDynamiquePourResultat, ByRef NbrEnregistrements, ByVal SeparateurSiPlusieursColonnes)

'Version du 01 Dececmbre 2006

'Version pour du VbScript

'Copie le contenu d'une requete SQL dans un tableau dynamique

'Se base sur un serveur SQL

'Si il n'y a pas de résultat alors le tableau est vide (ligne 0 vide)

'Si il y a un resultat, alors IsArray(MonTableauDynamiquePourResultat) retourne True

'Si il y a plusieurs colonnes dans le recordset, alors le tableau utilise un caractère de séparation

'Déclaration des constantes pour la base de données

'Constantes pour le recordset

Const adOpenForwardOnly = 0

Const adOpenKeyset = 1

Const adOpenDynamic = 2

Const adOpenStatic = 3

'---- LockTypeEnum Values ----

Const adLockReadOnly = 1

Const adLockPessimistic = 2

Const adLockOptimistic = 3

Const adLockBatchOptimistic = 4

'---- CursorLocationEnum Values ----

Const adUseServer = 2

Const adUseClient = 3

Const adCmdText = 1

Dim CompteurLignes

Dim CompteurColonnes

Dim UneLigneDeResultat

Dim ConnectionOk 'A 1 si la connection est OK

Set MaConnection = CreateObject("ADODB.Connection")

MaConnection.Mode = adModeRead 'adModeReadWrite

MaConnection.CursorLocation = adUseClient

MaConnection.ConnectionString = "Provider=SQLOLEDB; Data Source=" & NomServeurSQL & "; Initial Catalog=" & NomBaseSQL & ";Integrated Security=SSPI;"

'MaConnection.ConnectionString = "Provider=SQLOLEDB; Data Source=" & NomServeurSQL & "; Initial Catalog=" & NomBaseSQL & ";User ID=LeLgon;Password=LeMotDePasse;"

'Valeur par défaut

ConnectionOk = 0

NbrEnregistrements = 0

RequeteSql = Trim(RequeteSql)

'Si la MaConnection n'est pas déjà ouverte

If MaConnection.State = 0 Then

On Error Resume Next

MaConnection.Open

Select Case Err.Number

Case 0 'Si il n'y a pas d'erreurs

'Tout va bien on ne fait rien

ConnectionOk = 1

Case -2147217843 'Probleme de droits

'Response.Write "Erreur n°" & Err.number & " certainement due à un problème de droits<BR>"

Case Else 'Probleme inconnu

'Response.Write "Erreur " & Err.number & " (" & Err.Description & ")<BR>"

End Select

On Error Goto 0

End If

If ConnectionOk = 1 Then

If Len(RequeteSql) > 0 Then

Set UnRecordset = CreateObject("ADODB.Recordset")

UnRecordset.Open RequeteSql, MaConnection , adOpenKeyset, adLockPessimistic

'Par défaut, on efface et on redimensionne le tableau

Redim MonTableauDynamiquePourResultat(0)

'On retourne le nombre d'enregistrements

NbrEnregistrements = UnRecordset.RecordCount

'Si il y a un résultat

If UnRecordset.RecordCount > 0 Then

'Ne pas perdre de vue que les tableaux sont en base 0, c'est pour cela que l'on retire 1

TableauNbrLignes = UnRecordset.RecordCount -1 'Nombre de lignes du tableau

'TableauNbrColonnes = UnRecordset.Fields.count-1

'Redim MonTableauDynamiquePourResultat(TableauNbrLignes, TableauNbrColonnes)

Redim MonTableauDynamiquePourResultat(TableauNbrLignes)

CompteurLignes = 0

If UnRecordset.BOF = False Then UnRecordset.MoveFirst

Do While UnRecordset.EOF = False

UneLigneDeResultat = ""

'Pour toutes les colonnes de la ligne actuelle

For CompteurColonnes=0 To UnRecordset.Fields.count-1

'On stocke la valeur de la colonne dans la case correspondante du tableau

'MonTableauDynamiquePourResultat(CompteurLignes,CompteurColonnes) = UnRecordset.fields(CompteurColonnes).Value

UneLigneDeResultat = UneLigneDeResultat & UnRecordset.fields(CompteurColonnes).Value & SeparateurSiPlusieursColonnes'"#"

UneLigneDeResultat = Left(UneLigneDeResultat,Len(UneLigneDeResultat)-Len(SeparateurSiPlusieursColonnes)) 'On retire un caractère tout à droite

MonTableauDynamiquePourResultat(CompteurLignes) = UneLigneDeResultat

CompteurLignes = CompteurLignes + 1

UnRecordset.MoveNext

Loop

End If 'If UnRecordset.RecordCount > 0 Then

UnRecordset.Close

MaConnection.Close

Set UnRecordset = Nothing

End If 'If Len(RequeteSql) > 0 Then

End If 'If ConnectionOk = 1 Then

Set MaConnection = Nothing

End Sub

SQL scripting - Copier le resultat d'une requete SQL dans un tableau dynamique
Dim NbrEnregistrements
Dim RequeteSql
Dim UnResultat
Dim TableauResultat
Dim Compteur
Dim CompteurLigneIntermediaire
Dim TableauIntermediaire

Const FirstLineIsColumnName = 0
Const DebugMode = 0

RequeteSql = "Select * From MaTable;
Call RequeteSQLDansTableauQuad(RequeteSQL, "NomServeur", "NomBase", "", "", TableauResultat, NbrEnregistrements, FirstLineIsColumnName, DebugMode)

'Si on a au moins un résultat
Wscript.echo NbrEnregistrements & " enregistrements"
If NbrEnregistrements > 0 Then

If IsArray(TableauResultat) = True Then

For Compteur = LBound(TableauResultat) To UBound(TableauResultat)

'Si la ligne est un tableau

If IsArray(TableauResultat(Compteur)) = True Then

TableauIntermediaire = TableauResultat(Compteur)

For CompteurLigneIntermediaire = LBound(TableauIntermediaire) To UBound(TableauIntermediaire)

Wscript.echo (Trim(TableauIntermediaire(CompteurLigneIntermediaire)))

End If

Next 'For Compteur = LBound(TableauResultat) To UBound(TableauResultat)

Else 'Si TableauResultat n est pas un tableau

End If 'If IsArray(TableauResultat) = True Then
Else

Wscript.echo "Il n y a pas d enregistrements"
End If 'If NbrEnregistrements > 0 Then

Public Sub RequeteSQLDansTableauQuad(ByVal RequeteSql, ByVal NomServeurSQL, ByVal NomBaseSQL, ByVal OptionnelLogin, ByVal OptionnelMotDePasse , ByRef MonTableauDynamiquePourResultat, ByRef NbrEnregistrements, ByVal FirstLineIsColumnName, ByVal DebugMode)

'Version pour du ASP

'Version du 11 fevrier 2010

'Copie le contenu d'une requete SQL dans un tableau dynamique

'Le resultat du tableau peut facilement être affiché via la fonction AfficherTableauASP()

'Chaque ligne du tableau retourné est aussi

un tableau, ce qui permet de retourner facilement le resultat d une requete qui a plusieurs colonnes

'Se base sur un serveur SQL

'Si il n'y a pas de résultat alors le tableau est vide (ligne 0 vide)

'Si il y a un resultat, alors IsArray(MonTableauDynamiquePourResultat) retourne True

'Si il y a plusieurs colonnes dans le recordset, alors le tableau utilise un caractère de séparation

'FirstLineIsColumnName : a 1 pour que la première ligne contienne le nom des colonnes

'SiPlusieursColonnesUtiliserTableau : si a 1, si il y a plusieurs colonnes, on met la valeur des colonnes d une ligne dans un tableau, et on stocke ce tableau intermediaire dans le tableau final

'Déclaration des constantes pour la base de données

'Constantes pour le recordset

Const adOpenForwardOnly = 0

Const adOpenKeyset = 1

Const adOpenDynamic = 2

Const adOpenStatic = 3

'---- LockTypeEnum Values ----

Const adLockReadOnly = 1

Const adLockPessimistic = 2

Const adLockOptimistic = 3

Const adLockBatchOptimistic = 4

'---- CursorLocationEnum Values ----

Const adUseServer = 2

Const adUseClient = 3

Const adCmdText = 1

Dim CompteurLignes

Dim CompteurColonnes

Dim UneLigneDeResultat

Dim ConnectionOk 'A 1 si la connection est OK

Dim IlYaPlusieursColonnes 'A 1 si il y a plusieurs colonnes

Dim TableauResultatUneLigne

Set MaConnection = CreateObject("ADODB.Connection")

MaConnection.Mode = adModeRead 'adModeReadWrite

MaConnection.CursorLocation = adUseClient

'Pour mettre un timeout de 10mn

MaConnection.CommandTimeout = 600

'Si on a un login et un mot de passe pour se connecter à la base SQL

If (Len(OptionnelLogin) > 0) And (Len(OptionnelMotDePasse) > 0) Then

'MaConnection.ConnectionString = "Provider=SQLOLEDB; Data Source=" & NomServeurSQL & "; Initial Catalog=" & NomBaseSQL & ";User ID=CentralWebRead;Password=P@sseWebRead2;"

MaConnection.ConnectionString = "Provider=SQLOLEDB; Data Source=" & NomServeurSQL & "; Initial Catalog=" & NomBaseSQL & ";User ID=" & OptionnelLogin & ";Password=" & OptionnelMotDePasse & ";"

Else

MaConnection.ConnectionString = "Provider=SQLOLEDB; Data Source=" & NomServeurSQL & "; Initial Catalog=" & NomBaseSQL & ";Integrated Security=SSPI;"

End If

If DebugMode = 1 Then

Response.Write("RequeteSQLDansTableauQuad function<BR>")

Response.Write("ConnectionString : " & MaConnection.ConnectionString & "<BR>")

End If

'Valeur par défaut

ConnectionOk = 0

NbrEnregistrements = 0

RequeteSql = Trim(RequeteSql)

If DebugMode = 1 Then

Response.Write("RequeteSql : " & RequeteSql & "<BR>")

End If

'Si la MaConnection n'est pas déjà ouverte

If MaConnection.State = 0 Then

On Error Resume Next

MaConnection.Open

Select Case Err.Number

Case 0 'Si il n'y a pas d'erreurs

'Tout va bien on ne fait rien

ConnectionOk = 1

Case -2147217843 'Probleme de droits

'Response.Write "Erreur n°" & Err.number & " certainement due à un problème de droits<BR>"

Case Else 'Probleme inconnu

'Response.Write "Erreur " & Err.number & " (" & Err.Description & ")<BR>"

End Select

On Error Goto 0

End If

If DebugMode = 1 Then

Response.Write("ConnectionOk : " & ConnectionOk & "<BR>")

End If

If ConnectionOk = 1 Then

If Len(RequeteSql) > 0 Then

Set UnRecordset = CreateObject("ADODB.Recordset")

UnRecordset.Open RequeteSql, MaConnection , adOpenKeyset, adLockPessimistic

'Par défaut, on efface et on redimensionne le tableau

Redim MonTableauDynamiquePourResultat(0)

'On retourne le nombre d'enregistrements et de colonnes

NbrEnregistrements = UnRecordset.RecordCount

If DebugMode = 1 Then

Response.Write("NbrEnregistrements : " & NbrEnregistrements & "<BR>")

Response.Write("Nbr de colonnes : " & UnRecordset.fields.Count & "<BR>")

End If

Redim TableauResultatUneLigne(UnRecordset.fields.Count - 1)

If UnRecordset.fields.Count > 1 Then

IlYaPlusieursColonnes = 1

Else

IlYaPlusieursColonnes = 0

End If

'Si il y a un résultat

If UnRecordset.RecordCount > 0 Then

UneLigneDeResultat = ""

CompteurLignes = 0

'Definition de la taille du tableau qui va contenir le resultat

'Ne pas perdre de vue que les tableaux sont en base 0, c'est pour cela que l'on retire 1 au resultat final

TableauNbrLignes = UnRecordset.RecordCount -1 'Nombre de lignes du tableau

If DebugMode = 1 Then

Response.Write("TableauNbrLignes : " & TableauNbrLignes & " (de base 0)<BR>")

End If

If FirstLineIsColumnName = 1 Then

TableauNbrLignes = TableauNbrLignes + 1

If DebugMode = 1 Then

Response.Write("TableauNbrLignes : ajout d une ligne pour le nom des colonnes : " & TableauNbrLignes & "<BR>")

End If

Redim MonTableauDynamiquePourResultat(TableauNbrLignes)

If UnRecordset.BOF = False Then UnRecordset.MoveFirst

'Si on demande a mettre le nom des colonnes en premiere ligne

If FirstLineIsColumnName = 1 Then

If DebugMode = 1 Then

Response.Write("Traitement du nom des colonnes<BR>")

End If

For CompteurChamps = 0 To UnRecordset.fields.Count - 1

TableauResultatUneLigne(CompteurChamps) = UnRecordset.fields(CompteurChamps).Name

MonTableauDynamiquePourResultat(CompteurLignes) = TableauResultatUneLigne

CompteurLignes = CompteurLignes + 1

If DebugMode = 1 Then

Response.Write("Nom des colonnes stockée<BR>")

End If

End If 'If FirstLineIsColumnName = 1 Then

'Passage en revue de toutes les lignes du recordset

If DebugMode = 1 Then

Response.Write("Traitement des lignes de donnees du recordset<BR>")

End If

Do While UnRecordset.EOF = False

For CompteurChamps = 0 To UnRecordset.fields.Count - 1

TableauResultatUneLigne(CompteurChamps) = UnRecordset.fields(CompteurChamps).Value

MonTableauDynamiquePourResultat(CompteurLignes) = TableauResultatUneLigne

If DebugMode = 1 Then

'Response.Write("Valeur des colonnes de la ligne stockée dans un tableau<BR>")

End If

CompteurLignes = CompteurLignes + 1

UnRecordset.MoveNext

Loop

End If 'If UnRecordset.RecordCount > 0 Then

If DebugMode = 1 Then

Response.Write("Recordset traite<BR>")

End If

UnRecordset.Close

MaConnection.Close

Set UnRecordset = Nothing

End If 'If Len(RequeteSql) > 0 Then

End If 'If ConnectionOk = 1 Then

Set MaConnection = Nothing

If DebugMode = 1 Then

Response.Write("RequeteSQLDansTableauQuad function ended<BR>")

End If

End Sub

SQL scripting - Créer une connexion sur un serveur Oracle
'Version du 14 mai 2007
'Nécessite que le client Oracle soit installé sur le poste (ici la 9.2)
'Le data source dans ConnectionString est la valeur prise sous 'Bases de données' dans le Entreprise Management Console de Oracle

'Constantes pour le recordset
Const adOpenForwardOnly = 0
Const adOpenKeyset = 1
Const adOpenDynamic = 2
Const adOpenStatic = 3

'---- LockTypeEnum Values ----
Const adLockReadOnly = 1
Const adLockPessimistic = 2
Const adLockOptimistic = 3
Const adLockBatchOptimistic = 4

'---- CursorLocationEnum Values ----
Const adUseServer = 2
Const adUseClient = 3

Const adCmdText = 1
Const adModeRead = 1
Const adModeReadWrite = 3

Set objConnection = CreateObject("ADODB.Connection")
Set MonRecordset = CreateObject("ADODB.Recordset")

objConnection.Mode = adModeReadWrite
objConnection.CursorLocation = adUseClient
objConnection.ConnectionString = "Provider=MSDAORA;Data Source=NomSourEntrepriseManagementSousOracle;User ID=Login;Password=Mot De Passe"
objConnection.Open

RequeteSql = "SELECT *"
RequeteSql = RequeteSql & " " & "FROM GUIDE.PAYS"
On Error Resume Next
MonRecordset.Open RequeteSql, objConnection, adOpenKeyset, adLockOptimistic
MsgBox Err.Description

If MonRecordset.BOF = False Then MonRecordset.MoveFirst
Do While MonRecordset.EOF = False
MsgBox MonRecordset(1).Value
MonRecordset.MoveNext
Loop

MonRecordset.Close
objConnection.Close

SQL scripting - Créer une connexion sur un serveur SQL en ASP
'Déclaration des constantes
'Constantes pour le recordset
Const adOpenForwardOnly = 0
Const adOpenKeyset = 1
Const adOpenDynamic = 2
Const adOpenStatic = 3

'---- LockTypeEnum Values ----
Const adLockReadOnly = 1
Const adLockPessimistic = 2
Const adLockOptimistic = 3
Const adLockBatchOptimistic = 4

'---- CursorLocationEnum Values ----
Const adUseServer = 2
Const adUseClient = 3

Const adCmdText = 1
Const adModeRead = 1
Const adModeReadWrite = 3

NomServeurSQL = "Nom du serveur SQL"
NomDeLaBase = "Nom de la base SQL"

Set MaConnection = Server.CreateObject("ADODB.Connection")
MaConnection.Mode = adModeReadWrite
MaConnection.CursorLocation = adUseClient

MaConnection.ConnectionString = "PROVIDER=SQLOLEDB;data source=" & NomServeurSQL & ";" & _
"database=" & NomDeLaBase & ";Integrated Security=SSPI;"
'"persist security info=False;" & _

'Si la MaConnection n'est pas déjà ouverte
If MaConnection.State = 0 Then

On Error Resume Next

MaConnection.Open

Select Case Err.Number

Case 0 'Si il n'y a pas d'erreurs

'Tout va bien on ne fait rien

Case -2147217843 'Probleme de droits

Response.Write "Erreur n°" & Err.number & " certainement due à un problème de droits<BR>"

Exit Function

Case Else 'Probleme inconnu

Response.Write "Erreur " & Err.number & "<BR>"

Exit Function

End Select

On Error Goto 0
End If

Set ObjetCommande = Server.CreateObject("ADODB.Command")
CommandeSql = "Delete From Toto Where Tata = 'TITI';"
ObjetCommande.ActiveConnection = MaConnection
ObjetCommande.CommandType = adCmdText

'Execution de commandes Sql pour mettre a jour les données
ObjetCommande.CommandText = CommandeSql
ObjetCommande.Execute LignesAffectees

Set ObjetCommande = Nothing

RequeteSql = "SELECT *"
RequeteSql = RequeteSql & " " & "FROM Toto"
RequeteSql = RequeteSql & " " & ";"

Set UnRecordset = Server.CreateObject("ADODB.Recordset")
UnRecordset.Open RequeteSql, MaConnection , adOpenKeyset, adLockPessimistic

If UnRecordset.BOF = False Then UnRecordset.MoveFirst
Do While UnRecordset.EOF = False

Wscript.Echo UnRecordset(0).Value

UnRecordset.MoveNext
Loop
UnRecordset.Close

Set UnRecordset = Nothing
Set MaConnection = Nothing

SQL scripting - Créer une connexion sur un serveur SQL en VB

'Constantes pour le recordset
Const adOpenForwardOnly = 0
Const adOpenKeyset = 1
Const adOpenDynamic = 2
Const adOpenStatic = 3
'---- LockTypeEnum Values ----
Const adLockReadOnly = 1
Const adLockPessimistic = 2
Const adLockOptimistic = 3
Const adLockBatchOptimistic = 4
'---- CursorLocationEnum Values ----
Const adUseServer = 2
Const adUseClient = 3

Const adCmdText = 1
Const adModeRead = 1
Const adModeReadWrite = 3

NomServeurSQL = "Nom du serveur SQL"
NomDeLaBase = "Nom de la base"

Set MaConnection = CreateObject("ADODB.Connection")
MaConnection.Mode = adModeReadWrite
MaConnection.CursorLocation = adUseClient
MaConnection.ConnectionString = "PROVIDER=SQLOLEDB;" & _
"data source=" & NomServeurSQL & ";" & _
"database=" & NomDeLaBase & ";" & _
"Integrated Security=SSPI;"
'"persist security info=False;" & _

'Si la connexion n'est pas déjà ouverte
If MaConnection.State = 0 Then

MaConnection.Open
End If

RequeteSql = "SELECT *"
RequeteSql = RequeteSql & " " & "From dbo.MaTable"
RequeteSql = RequeteSql & ";"

Set UnRecordset = CreateObject("ADODB.Recordset")
UnRecordset.Open RequeteSql, MaConnection, adOpenKeyset, adLockPessimistic

If UnRecordset.BOF = False Then UnRecordset.MoveFirst
Do While UnRecordset.EOF = False

toto = Trim(UnRecordset(0).Value)

UnRecordset.MoveNext
Loop
UnRecordset.Close

Set UnRecordset = Nothing
Set MaConnection = Nothing

SQL scripting - Créer une connexion sur une base ACCESS en VB

'Exemple de connection en VB et C#
http://msdn.microsoft.com/library/fre/default.asp?url=/library/fre/vbcon/html/vbtskCreatingConnectionToAccessDatabase.asp

'Constantes pour le recordset
Const adOpenForwardOnly = 0
Const adOpenKeyset = 1
Const adOpenDynamic = 2
Const adOpenStatic = 3
'---- LockTypeEnum Values ----
Const adLockReadOnly = 1
Const adLockPessimistic = 2
Const adLockOptimistic = 3
Const adLockBatchOptimistic = 4
'---- CursorLocationEnum Values ----
Const adUseServer = 2
Const adUseClient = 3

Const adCmdText = 1
Const adModeRead = 1
Const adModeReadWrite = 3

Dim MaConnection As New ADODB.Connection

'On demande le chemin du fichier de la base Access
CheminBase = "Chemin du fichier Access"

'On precise le provider
'Set MaConnection = CreateObject("ADODB.Connection")
Set MaConnection = New ADODB.Connection

MaConnection.Provider = "Microsoft.Jet.OLEDB.4.0;"
MaConnection.CursorLocation = adUseClient
MaConnection.Mode = adModeReadWrite
MaConnection.ConnectionString = "Data Source=" & CheminBase & ";" & _
"Persist Security Info=False;" & _
"Jet OLEDB:Registry Path=HKEY_LOCAL_MACHINE \ SOFTWARE \ Microsoft \ Jet \4.0 \ Engines;"
'"Jet OLEDB:Database Password=MonMotDePasse" 'Au cas ou cette ligne permet de préciser le mot de passe pour ouvrir la base

'Ouverture de la connection
If MaConnection.State = 0 Then

MaConnection.Open
End If

'Fermeture de la connection a la base
MaConnection.Close

'Destruction des Objets
Set MaConnection = Nothing

Sql scripting - Parametrer le TimeOut d une connection (VBS)
Set MaConnection = Server.CreateObject("ADODB.Connection")
MaConnection.Mode = adModeReadWrite
MaConnection.CursorLocation = adUseClient
Pour mettre eventuellement un delai de timeout de 60s
MaConnection.CommandTimeout = 60

Non Classe
'Se connecter au compte d'un utilisateur
Set User = GetObject("WinNT://" & strDomain & "/" & strUser & ",user")
User.Fullname
Set User = Nothing

'http://msluder.dk/Resources/ADSI%20SDK%205%20HTML/winnt.htm
'Binding to a domain with alternate credentials
Set dso = GetObject("WinNT:")
Set dom = dso.OpenDSObject("WinNT://" & domainName, userName, password, ADS_SECURE_AUTHENTICATION)

'Binding to a computer with alternate credentials
Set dso = GetObject("WinNT:")
Set com = dso.OpenDSObject("WinNT://" & computerName & ",computer", userName, password, ADS_SECURE_AUTHENTICATION)

'Renommer un user
Renaming a user is similar to renaming an object
Set dom = GetObject("WinNT://INDEPENDENCE")
Set usr = dom.MoveHere("WinNT://INDEPENDENCE/jsmith,user", "jjohnson")
usr.FullName = "Jane Johnson"
usr.SetInfo

'Envoyer un mail quand un user est ajoute dans un groupe
http://blog.netnerds.net/2007/02/active-directory-newly-added-users-and-computers-notification-via-e-mail/