'***************************************************************************
' Libreria di funzioni per VbScript scritte da me o raccolte in rete.
' Cenati Giovanni - aggiornato al 18.03.2010
' Descrizione e altro materiale in http://digilander.libero.it/Cenati
' Le funzioni sono precedute dall'indicazione tipo di dato che viene restituito.
' Credits:  Bruce M. Axtens, Mayayana, microsoft.public.scripting.vbscript,
' Jeffery Hicks
'***************************************************************************

'========================================================================
' Funzioni varie
'========================================================================
' ForceScriptToRunUnderCScript(bCloseWindow)
'   Se lo script è stato lanciato da wScript, lo chiude e lo riapre con cScript.
' string ThisScriptPath()  ' Restituisce il percorso del file dello script con "\" finale.
' string GetCurDir() 'Restituisce il percorso del file dello script con "\" finale.
' Beep NumeroDiBeep, CentesimiDiSecondoDiAttesaTraIBeep
'   Attiva il cicalino del pc
' Dim oWMPlayer:playtune "C:\windows\Media\Notify.wav", false
'   Usa MediaPlayer per suonare un brano. Non parte immediatamente.
' int GetRand(iLower,iUpper) 'Genera un numero casuale compreso tra i due valori.
' string GetLogTime() 'Restituisce la data corrente nel formato aaaammgghhnnss (20040826140008)
' string ChkEngine() 'wscript.exe oppure cscript.exe?
' string GetOS()   'Nome del sistema operativo, ad esempio "Microsoft Windows XP Professional"

'========================================================================
' Funzioni e sub di input/output
'========================================================================
' Dim MyIE:ShowIEWindow 50,50,600,600,"<h1>primo","Titolo", False
'   Mostra una finestra di internet explorer nella posizione specificata
'   e con il contenuto HTML indicato. La finestra è una sola e può cambiare
'   contenuto. Se l'ultimo parametro è True si chiude la finestra
' string GetIEPassword()  'Usa IE per chiedere una password (non visualizzata)
' SetTextToClipboardUsingIE "Text to be put into the clipboard"
'   Mette negli appunti di Windows il testo specificato. Usa Internet explorer.
' string GetTextFromClipboardUsingIE()
'   Recupera dagli appunti di Windows

'========================================================================
' Funzioni per la rete locale e internet
'========================================================================
' bool ObjectExists(strADSPath) 'Esiste l'oggetto in Active Directory?
' bool UserExists(strDomain,strSAM) 'Esiste l'utente?
' string CurrentUserID() ' Restituisce l'utenza di rete dell'utente
' string GetDN(samAccount) ' Restituisce il nome completo dell'userid specificato.
' string UserFullName(UserID) ' Recupera il nome completo dell'utente.
' bool TestPing(strName)   'Esegue un Ping su internet usando WMI. XP or Windows 2003.

'========================================================================
' Costanti per l'apertura dei file usate da alcune funzioni
'========================================================================
Const ForReading  = 1 'Open a file for reading only. You can't write to this file
Const ForWriting  = 2 'Open a file for writing
Const ForAppending= 8 'Open a file and write to the end of the file

'========================================================================
' Funzioni per operare con file di testo
'========================================================================
' string File_FindInto( sFileName, str) ' Trova str nel file e ritorna l'intera riga.
' Bool File_WriteLine( sFileName, sData ) 'Scrive sData nel file
' Bool File_AppendLine( sFileName, sData ) ' Aggiunge una riga al file esistente
' string File_ReadEntireFile( sFileName ) 'Recupera il contenuto di un intero file
' Bool File_IsExist( sFileName ) ' Verifica se il file esiste
' Bool File_Create( sFileName ) 'Crea un file vuoto
' Bool File_Delete( sFileName ) 'Cancella un file esistente
' WriteLog "Scrive questa riga in un file di log con lo stesso nome dello script"
' BuildTree( sPath ) 'Crea il percorso delle directory.
'========================================================================

'========================================================================
' Funzioni per la gestione del registry
'========================================================================
' string Reg_Read ( sRegKey )
' Bool   Reg_Write( sRegKey, sValue, sType )

'========================================================================
' Funzioni per la gestione del pathname
'========================================================================
' Bool   Path_IsExist( szPath )	' Controlla se esiste un Path
' Bool   Path_Delete ( szPath )	' Rimuove un path se esistente
' Bool   Path_Add    ( szPath )	' Aggiunge un path se non esiste
' string Path_Read   ( )	' Ritorna il path attuale 
' Bool   Path_Write  ( szPath )	' Scrive un path sovrascrivendo il precedente
' Bool   Path_Compare( szPathSorg, szPathDest )	' Compara due pathname

'========================================================================
' Funzioni di controllo caratteri e stringhe di testo
'========================================================================
' Bool   Char_IsAlpha   (ByVal chAlpha ) ' True se il carattere è alfabetico
' Bool   Char_IsDigit   (ByVal chDigit) ' True se il carattere è una cifra
' Bool   Char_IsAlphaNum(ByVal chAlphaNum) ' True se il carattere è alfanumerico
' string LeftOf(sText,sItem) 'Restituisce il testo a sinistra di sItem
' string RightOf(sText,sItem) 'Restituisce il testo a destra di sItem 
' int CountFields( strText, strDelim  )
'   Conta i campi separati da strDelim nel testo specificato
' Variant NthField( sText, sDelimiter, nReqdField )
'   Nella stringa sText, in cui ci sono dei dati separati dal 
'   carattere sDelimiter, estrae il campo numero nReqdField    
' Bool BeginsWith( sText, sBeginning, bCaseInsensitive )
'   True se il testo inizia con sBeginning
' Bool EndsWith( sText, sEnding, bCaseInsensitive )
'   True se il testo finisce con sEnding
' Bool Contains( sText, sChunk, bCaseInsensitive )
'   True se il testo contiene sChunk
' String Between( sText, sBegin, sEnd ) 'Stringa compresa tra le due posizioni
' String LastLineOf( sData ) ' Ultima riga di sData (con ritorni a capo vbCrLf)
' String FirstLineOf( sData ) ' Prima riga di sData
' String NthLineOf( n, sData ) 'n-esima riga di sData

'========================================================================
' Funzioni di conversione
'========================================================================
' int    Hex2Int( ByVal chDigit )
' UndoZulu(strDate,offset)  'Convert UTC time to standard time
' ConvertToUTC(strDate,iOffset)  'Convert standard time stamp to UTC format
' ConvWMITime(wmiTime)   'Convert WMI Time stamp
'========================================================================

'------------------------------------------------------------------------
'	Private Function ThisScriptPath()
'------------------------------------------------------------------------
'------------------------------------------------------------------------
Function ThisScriptPath()
	ThisScriptPath= Left(WScript.ScriptFullName, InStrRev(WScript.ScriptFullName,"\"))
End Function

'------------------------------------------------------------------------
' string Path_Read   ( )
'------------------------------------------------------------------------
' Ritorna il path attuale del pc leggendolo da registry
'------------------------------------------------------------------------
Function Path_Read   ( )
  Dim szRegKeyPath
  Path_Read = ""
  szRegKeyPath = "HKLM\SYSTEM\CurrentControlSet\Control\Session Manager\Environment\Path"
  Path_Read = trim( Reg_Read( szRegKeyPath ))
  if Path_Read = "" then 
    Exit Function
  end if
	' Aggiungo l'eventuale ultimo ";"
	if Right( Path_Read, 1 ) <> ";" then
		Path_Read = Path_Read & ";"
	end if
End Function 

'------------------------------------------------------------------------
' Bool Path_Write ( )
'------------------------------------------------------------------------
' Scrive il path passato nella registry del pc
'------------------------------------------------------------------------
Function Path_Write  ( ByVal szPath )
  Dim szRegKeyPath

  Path_Write = False

  szRegKeyPath = "HKLM\SYSTEM\CurrentControlSet\Control\Session Manager\Environment\Path"
  Path_Write = Reg_Write( szRegKeyPath, szPath, "REG_EXPAND_SZ" )

End Function 



'------------------------------------------------------------------------
'	Bool Path_Compare(szPathSorg, szPathDest)
'------------------------------------------------------------------------
' Effettua il confronto fra 2 pathname tenendo conto delle differenze
' di eventuali punto e virgola e/o e di backslash finali
' Ritorna True se i path corrispondono
'------------------------------------------------------------------------
Function Path_Compare(ByVal szPathSorg, ByVal szPathDest)
  	dim sPathSorg
	dim sPathDest

	' Elimino gli spazi di troppo
	szPathSorg = Trim( szPathSorg )
	szPathDest = Trim( szPathDest )

	' Normalizzazione Pathname
	' Elimino i caratteri ";\" dalla fine del path

	if Right( szPathSorg, 1 ) = ";" then
		szPathSorg = left( szPathSorg, Len( szPathSorg ) - 1 )
	end if
	if Right( szPathSorg, 1 ) = "\" then
		if mid( szPathSorg, Len( szPathSorg ) - 1, 1 ) <> ":" then
			szPathSorg = left( szPathSorg, Len( szPathSorg ) - 1 )
		end if
	end if

	if Right( szPathDest, 1 ) = ";" then
		szPathDest = left( szPathDest, Len( szPathDest ) - 1 )
	end if
	if Right( szPathDest, 1 ) = "\" then
		if mid( szPathDest, Len( szPathDest ) - 1, 1 ) <> ":" then
			szPathDest = left( szPathDest, Len( szPathDest ) - 1 )
		end if
	end if

	szPathSorg = trim(ucase(szPathSorg))
	szPathDest = trim(ucase(szPathDest))
	
	if szPathSorg = szPathDest then
		Path_Compare = True
	else
		Path_Compare = False
	end if

End Function 



'------------------------------------------------------------------------
' Bool Path_Delete( szPathDest )
'------------------------------------------------------------------------
' Rimuove szPathDest dal pathname della macchina
' Torna TRUE se il percorso e' stato rimosso
'------------------------------------------------------------------------
Function Path_Delete( ByVal szPathDest )
	Dim ix, szPcPath, arPcPath

	Path_Delete = False

	szPcPath=Path_Read()

	' Elimino spazi laterali indesiderati  
	szPathDest = Trim( szPathDest )

	if szPcPath  = "" then Exit Function
	if szPathDest= "" then Exit Function

	if Path_IsExist( szPathDest ) <> True then
		Exit Function
	end if

	arPcPath = Split(szPcPath, ";", -1, 1)

	for ix = 0 to UBound( arPcPath )
		if Path_Compare( arPcPath(ix), szPathDest ) = True then
			arPcPath(ix)=""
			Path_Delete = True
		end if
	next

	if 	Path_Delete = True then
		szPcPath = Join( arPcPath, ";" )
		szPcPath = replace(szPcPath, ";;", ";", 1, -1, vbTextCompare)
		Path_Delete = Path_Write( szPcPath )
	end if

End Function 



'------------------------------------------------------------------------
' Bool Path_IsExist( szPath )
'------------------------------------------------------------------------
' Controlla se esiste il Path passato nel Path della macchina
' Torna True se trovato
'------------------------------------------------------------------------
Function Path_IsExist( ByVal szPath )
	Dim szPcPath, arPcPath, ix

	szPcPath = trim(Path_Read( ))

	' Aggiungo l'eventuale ultimo ";"
	if Right( szPcPath, 1 ) <> ";" then
		szPcPath = szPcPath & ";"
	end if

	arPcPath = Split( szPcPath, ";", -1, 1 )

	iElem = UBound( arPcPath ) 

	for ix = 0 to UBound( arPcPath ) - 1
		if Path_Compare( arPcPath(ix), szPath ) = True then 
			Path_IsExist = True
			Exit Function 
		end if
	next
	
	Path_IsExist = False

End Function 



'------------------------------------------------------------------------
' Bool Path_Add( szPathDest )
'------------------------------------------------------------------------
' Aggiunge szPathDest al pathname della macchina
' Torna TRUE se aggiunto o se gia' esistente
'------------------------------------------------------------------------
Function Path_Add( ByVal szPathDest )
Dim iRet, szPcPath

	Path_Add = False

	szPcPath = trim(Path_Read())

	' Elimino spazi laterali indesiderati  
	szPathDest = Trim( szPathDest )

	if szPcPath  = "" then Exit Function
	if szPathDest= "" then Exit Function

	if Path_IsExist( szPathDest ) = True then
		Path_Add=True
		Exit Function
	end if

	szPcPath= szPcPath & szPathDest
	Path_Add = Path_Write( szPcPath )

End Function 



'========================================================================
' Funzioni per la scrittura/lettura del registry
'========================================================================
' string Reg_Read( sRegKey )
' Bool Reg_Write( sRegKey, sValue, sType )
'========================================================================


'------------------------------------------------------------------------
' string Reg_Read( sRegKey )
'------------------------------------------------------------------------
' Legge dal registry il valore della chiave passata.
' In caso di errore torna ""
'------------------------------------------------------------------------
Function Reg_Read( sRegKey )
  Dim oSh

  On Error Resume Next
  Reg_Read = ""

  set oSh = WScript.CreateObject ( "WScript.Shell" )
  if Err <> 0 then Exit Function

  Reg_Read = oSh.RegRead ( sRegKey )
  if Err <> 0 then 
	  set oSh = nothing
		Exit Function
	end if

  set oSh = nothing
  Err.Clear
  On Error Goto 0

End Function


'------------------------------------------------------------------------
' Bool Reg_Write( sRegKey, sValue, sType )
'------------------------------------------------------------------------
' Scrive nel registry il valore sValue, nella chiave sRegKey.
' Torna True se tutto OK
'------------------------------------------------------------------------
' IL formato sType puo' valere:
'     "REG_SZ"          sValue = Stringa
'     "REG_DWORD"       sValue = Numerico
'     "REG_BINARY"      sValue = Binario/Intero
'     "REG_EXPAND_SZ"   sValue = Stringa con metacaratteri ( P.E. "%windir%\\calc.exe")
'------------------------------------------------------------------------
Function Reg_Write( sRegKey, sValue, sType )
  Dim oSh

  On Error Resume Next
  Reg_Write = False

  if sType <> "REG_SZ"        and _
     sType <> "REG_DWORD"     and _
     sType <> "REG_BINARY"    and _
     sType <> "REG_EXPAND_SZ" then
    exit function
  end if

  set oSh = WScript.CreateObject ( "WScript.Shell" )
  if Err <> 0 then Exit Function

  oSh.RegWrite sRegKey, sValue, sType
  if Err <> 0 then
	  set oSh = nothing
		Exit Function
	end if

  set oSh = nothing

  Err.Clear
  On Error Goto 0
  Reg_Write = True

End Function





'------------------------------------------------------------------------
' Bool File_Create( sFileName )
'------------------------------------------------------------------------
' Crea un file. Nel caso in cui gia' esiste, lo sovrascrive
' Torna True se tutto ok
'------------------------------------------------------------------------
Function File_Create( ByVal sFileName )
Dim opfs, fp

  On Error Resume Next
	File_Create=True

	Set opfs = CreateObject("Scripting.FileSystemObject")
  if Err <> 0 then
		File_Create=False
		Exit Function
	end if
	
	Set fp = opfs.CreateTextFile( sFileName, True )
  if Err <> 0 then
	  set opfs = nothing
		File_Create=False
		Exit Function
	end if

	fp.Close

  set opfs = nothing
  Err.Clear
  On Error Goto 0

End function


'------------------------------------------------------------------------
' Bool File_Delete( sFileName )
'------------------------------------------------------------------------
' Crea un file. Nel caso in cui gia' esiste, lo sovrascrive
' Torna True se tutto ok
'------------------------------------------------------------------------
Function File_Delete( ByVal sFileName )
Dim opfs

  On Error Resume Next
	File_Delete = False
	
	Set opfs = CreateObject("Scripting.FileSystemObject")
  if Err <> 0 then Exit Function

	opfs.DeleteFile  sFileName, True 
  if Err <> 0 then Exit Function

	File_Delete = true
  set opfs = nothing
  Err.Clear
  On Error Goto 0

End Function



'------------------------------------------------------------------------
' Bool File_IsExist( sFileName )
'------------------------------------------------------------------------
' Controlla se esiste il file passato come parametro.
' Ritorna TRUE nel caso in cui il file E' stato trovato.
'------------------------------------------------------------------------
Function File_IsExist( ByVal sFileName )
Dim opfs
	
  On Error Resume Next
	File_IsExist=False

  Set opfs = CreateObject("Scripting.FileSystemObject")
  if Err <> 0 then
		Exit Function
	end if

  ' Test per l'esistenza del file
  File_IsExist = opfs.FileExists( sFileName )

  set opfs = nothing
  Err.Clear
  On Error Goto 0

End Function



'------------------------------------------------------------------------
' string File_ReadEntireFile( sFileName )
'------------------------------------------------------------------------
' Legge l'intero contenuto del file 
' Ritorna il testo letto
'------------------------------------------------------------------------
Function File_ReadEntireFile( ByVal sFileName )
Dim opfs, fp, retstring

  On Error Resume Next
  File_ReadEntireFile = ""

  Set opfs = CreateObject("Scripting.FileSystemObject")
  if Err <> 0 then
		Exit Function
	end if

  Set fp = opfs.OpenTextFile( sFileName, ForReading, False )
  if Err <> 0 then
	  set opfs = nothing
		Exit Function
	end if


    retstring = retstring + fp.Readall

  fp.Close

  set opfs = nothing

  File_ReadEntireFile = retstring
  Err.Clear
  On Error Goto 0

End Function



'------------------------------------------------------------------------
' Bool File_AppendLine( sFileName, sData )
'------------------------------------------------------------------------
' Aggiunge al file sFileName esistente una riga
' Torna True se tutto ok
'------------------------------------------------------------------------
Function File_AppendLine( ByVal sFileName, ByVal sData )
Dim opfs, fp, retstring
  
  On Error Resume Next
	File_AppendLine=False

  Set opfs = CreateObject("Scripting.FileSystemObject")
  if Err <> 0 then
		Exit Function
	end if

  Set fp = opfs.OpenTextFile( sFileName, ForAppending, False )
  if Err <> 0 then
	  set opfs = nothing
		Exit Function
	end if

  fp.WriteLine sData
  if Err <> 0 then
	  set opfs = nothing
		Exit Function
	end if

  fp.Close

	File_AppendLine=True
  set opfs = nothing
  Err.Clear
  On Error Goto 0

End Function



'------------------------------------------------------------------------
' Bool File_WriteLine( sFileName, sData )
'------------------------------------------------------------------------
' Crea il file sFileName ed aggiunge al file una riga
' Attenzione. Se il file esiste, lo ricrea
' Torna True se tutto ok
'------------------------------------------------------------------------
Function File_WriteLine( ByVal sFileName, ByVal sData )
Dim opfs, fp

  On Error Resume Next
	File_WriteLine=False
	
	Set opfs = CreateObject("Scripting.FileSystemObject")
  if Err <> 0 then
		Exit Function
	end if

	Set fp = opfs.OpenTextFile( sFileName, ForWriting, True )
  if Err <> 0 then
	  set opfs = nothing
		Exit Function
	end if

	fp.WriteLine sData
  if Err <> 0 then
	  set opfs = nothing
		Exit Function
	end if

	fp.Close

	File_WriteLine=True
	set opfs = nothing
  Err.Clear
  On Error Goto 0

End Function



'------------------------------------------------------------------------
' string File_FindInto( sFileName, str )
'------------------------------------------------------------------------
' Cerca nel file sFileName la prima occorrenza di str e ritorna la riga
' In caso di ricerca fallita o di errore torna ""
'------------------------------------------------------------------------
Function File_FindInto( ByVal sFileName, ByVal str )
  Dim opfs, fp, retstring
  dim ForReading 'Open a file for reading only. You can't write to this file
  ForReading=1
  On Error Resume Next
  File_FindInto = ""

  Set opfs = CreateObject("Scripting.FileSystemObject")
  if Err <> 0 then
		Exit Function
	end if

  Set fp = opfs.OpenTextFile( sFileName, ForReading, False)
  if Err <> 0 then
	  set opfs = nothing
		Exit Function
	end if


  Do While fp.AtEndOfStream <> True
    strdata = fp.ReadLine
		if Err <> 0 then
			set opfs = nothing
			Exit Function
		end if

    if intr(ucase(strdata),ucase(str)) then
      File_FindInto = strdata
      fp.Close
      set opfs = nothing
      Err.Clear
			On Error Goto 0
      exit function
    End If
  Loop

  fp.Close

  set opfs = nothing
  Err.Clear
  On Error Goto 0

End Function

'========================================================================
' Funzioni di controllo caratteri
'========================================================================

'------------------------------------------------------------------------
' Bool Char_IsAlpha( ByVal chAlpha )
'------------------------------------------------------------------------
' Controlla se il carattere passato e' un valore alfabetico.
' Ritorna TRUE nel caso il carattere e' Alfanumerico.
'------------------------------------------------------------------------
Function Char_IsAlpha(ByVal chAlpha)
  Char_IsAlpha = False

  If Len(chAlpha) = 1 Then
		chAlpha = ucase(chAlpha)
    If chAlpha >= "A" And chAlpha <= "Z" Then
      Char_IsAlpha = True
    End If
  End If

End Function



'------------------------------------------------------------------------
' Bool Char_IsDigit(ByVal chDigit)
'------------------------------------------------------------------------
' Controlla se il carattere passato e' un valore numerico.
' Ritorna TRUE nel caso il carattere e' numerico.
'------------------------------------------------------------------------
Function Char_IsDigit(ByVal chDigit)
  Char_IsDigit = False
 
  If Len(chDigit) = 1 Then
    If chDigit >= "0" And chDigit <= "9" Then
      Char_IsDigit = True
    End If
  End If

End Function
 


'------------------------------------------------------------------------
' Bool Char_IsAlphaNum(ByVal chAlphaNum)
'------------------------------------------------------------------------
' Controlla se il carattere passato e' un valore alfanumerico (A-Z a-z 0-9)
' Ritorna -1 se la conversione non e' corretta.
'------------------------------------------------------------------------
Function Char_IsAlphaNum(ByVal chAlphaNum)
  Char_IsAlphaNum = False
 
	If Char_IsDigit(chAlphaNum) Then Char_IsAlphaNum = True
	If Char_IsAlpha(chAlphaNum) Then Char_IsAlphaNum = True

End Function


'========================================================================
' Funzioni di conversione
'========================================================================
' int Function Hex2Int( ByVal chDigit )
'========================================================================


'------------------------------------------------------------------------
' int Hex2Int( ByVal chDigit )
'------------------------------------------------------------------------
' Converte il digit passato da Hex a Intero.
' Ritorna -1 se la conversione non e' corretta.
'------------------------------------------------------------------------
Function Hex2Int( ByVal chDigit )
  Hex2Int = -1
	
  If Len(chDigit) = 1 Then
    If Char_IsDigit( chDigit ) = TRUE then 
      Hex2Int = CInt( chDigit )
    Else
			chDigit=ucase(chDigit)
      If chDigit >= "A" And chDigit <= "F" Then
        Hex2Int = 10 + (asc(chDigit) - 65)
      End If
    End If
  End If

End Function







' NAME: ScriptFunctionLibrary.vbs 
' v1.4
' AUTHOR: Jeffery Hicks MCSE,MCT, MCSA
' jhicks@jdhitsolutions.com
' http://www.jdhitsolutions.com
' DATE  : September 2005
'
' NOTES : These functions are used in a variety of scripts And
' are meant to be called from a WSF file or copied and pasted
' into other scripts.

'//////////////////////////////////////////////////////
'Get current path script is running in
'//////////////////////////////////////////////////////
Function GetCurDir()
On Error Resume Next
    GetCurDir=Left(WScript.ScriptFullName,Len(WScript.ScriptFullName)_
    -Len(WScript.ScriptName))
End Function

'//////////////////////////////////////////////////////
'Generate a random number between two values
'//////////////////////////////////////////////////////
Function GetRand(iLower,iUpper)
Randomize
GetRand=Int((iUpper - iLower + 1) * Rnd + iLower)
End Function

'//////////////////////////////////////////////////////
'Functions to return padded timestamp that can be used in log file names
'output will be like 20040826140008
'//////////////////////////////////////////////////////
Function GetLogTime()
    Dim strNow
    strNow = Now()
    GetLogTime = Year(strNow) _
        & Pad(Month(strNow), 2, "0", True) _
        & Pad(Day(strNow), 2, "0", True) _
        & Pad(Hour(strNow), 2, "0", True) _
        & Pad(Minute(strNow), 2, "0", True) _
        & Pad(Second(strNow), 2, "0", True)
End Function 'GetLogTime()

Function Pad(strText, nLen, strChar, bFront)
Dim nStartLen
    If strChar = "" Then
        strChar = "0"
    End If
    nStartLen = Len(strText)
    If Len(strText) >= nLen Then
        Pad = strText
    Else
        If bFront Then
            Pad = String(nLen - Len(strText), strChar) _
                & strText
        Else
            Pad = strText & String(nLen - Len(strText), _
                strChar)
        End If
    End If
End Function

'///////////////////////////////////////////
'Object Exists Function
'//////////////////////////////////////////

Function ObjectExists(strADSPath)
On Error Resume Next
Dim objZTmp

ObjectExists=FALSE
set objZTmp=GetObject(strADSPath)
If Err.Number=0 Then ObjectExists=True

Set objZTmp=Nothing
End Function

'///////////////////////////////////////////
'User Object Exists Function
'//////////////////////////////////////////

Function UserExists(strDomain,strSAM)
On Error Resume Next
Dim objZTmp

UserExists=False
set objZTmp=GetObject("WinNT://"&strDomain&"/"&strSAM& ",user")
If Err.Number=0 Then UserExists=True
Err.Clear
Set objZTmp=Nothing
End Function


'\\\\\\\\\\\\\\\\\\\\\\
'ChkEngine Function
' return whether Cscript or wscript were used to execute a script
'\\\\\\\\\\\\\\\\\\\\\\
Function ChkEngine()
'returns either cscript.exe or wscript.exe
ON ERROR RESUME NEXT

strEngine=Wscript.FullName

if Err.Number <>0 then
 wscript.echo "Error!"
  wscript.echo "Error (" & Err.Number & ") Description: " &_
   Err.Description
  wscript.quit
end if

PosX=InStrRev(strEngine,"\",-1,vbTextCompare)
ChkEngine=LCase(Mid(strEngine,PosX+1))

End Function

'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
' Get user's distinguishedname
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
Function GetDN(samAccount)
'Given NT4 account name, find the distinguished name for the user account
On Error Resume Next
Dim conn,cmd,RS
Set conn=CreateObject("ADODB.Connection")
Set cmd=CreateObject("ADODB.Command")

GetDN="NotFound"

Set RootDSE=GetObject("LDAP://RootDSE")
Set myDomain=GetObject("LDAP://"&RootDSE.get("DefaultNamingContext"))

strQuery="Select sAMAccountname,distinguishedname from '" & _
myDomain.AdsPath & "' Where objectcategory='person' AND objectclass='user'" & _
" AND sAMAccountName='" & samAccount & "'"

set cat=GetObject("GC:")
for each obj In cat
 set GC=obj
Next

conn.Provider="ADSDSOObject"
conn.Open "Active Directory Provider"
cmd.ActiveConnection=conn
cmd.Properties("Page Size") = 100
cmd.Properties("asynchronous")=True
cmd.Properties("Timeout") =30
cmd.Properties("Cache Results") = false
cmd.CommandText=strQuery

set RS=cmd.Execute 

do while not RS.EOF
 GetDN=rs.Fields("distinguishedname")
 rs.movenext
Loop
rs.Close
conn.Close  

set conn=Nothing
set cmd=Nothing
set RootDSE=Nothing
set cat=Nothing
set RS=Nothing
End Function

'///////////////////////////////////////////
'Convert UTC time to standard time
'//////////////////////////////////////////

Function UndoZulu(strDate,offset)
On Error Resume Next
yr=Left(strDate,2)
mo=Mid(strDate,3,2)
dy=Mid(strDate,5,2)
hr=Mid(strDate,7,2)
mn=Mid(strDate,9,2)
sc=Mid(strDate,11,2)

dCreated=CDate(mo&"/"&dy&"/"&yr & " " & hr & ":" &mn & ":" & sc)
'wscript.Echo strDate & " is " & dCreated & " UTC"
UndoZulu=DateAdd("h",iOffset, dCreated)

End Function

'///////////////////////////////////////////
'Convert standard time stamp to UTC format
'//////////////////////////////////////////

Function ConvertToUTC(strDate,iOffset)
On Error Resume Next
strUTC=Right(Year(strDate),2)&Pad(Month(strDate),2,"0",True) &_
 Pad(Day(strDate),2,"0",True) & Pad(Hour(strDate),2,"0",True) &_
 Pad(Minute(strDate),2,"0",True) & Pad(Second(strDate),2,"0",True)
'ConvertToUTC=DateAdd("h",strUTC,iOffSet)
ConvertToUTC=strUTC

End Function

'////////////////////////////////////
'Convert WMI Time stamp
'///////////////////////////////////
Function ConvWMITime(wmiTime)
On Error Resume Next

yr = left(wmiTime,4)
mo = mid(wmiTime,5,2)
dy = mid(wmiTime,7,2)
tm = mid(wmiTime,9,6)

ConvWMITime = mo&"/"&dy&"/"&yr & " " & FormatDateTime(left(tm,2) & _
":" & Mid(tm,3,2) & ":" & Right(tm,2),3)
End Function

'///////////////////////////////////////////
'Ping target system using WMI. Requires XP
' or Windows 2003 locally
'//////////////////////////////////////////
Function TestPing(strName)
On Error Resume Next
'this function requires Windows XP or 2003
Dim cPingResults, oPingResult
strPingQuery="SELECT * FROM Win32_PingStatus WHERE Address = '" & strName & "'"

Set cPingResults = GetObject("winmgmts://./root/cimv2").ExecQuery(strPingQuery)
For Each oPingResult In cPingResults
    If oPingResult.StatusCode = 0 Then
        TestPing = True
    Else
        TestPing = False
    End If
Next
End Function

'///////////////////////////////////////////
'returns values like:
'Microsoft Windows XP Professional
'///////////////////////////////////////////
Function GetOS()
On Error Resume Next
Dim objWMI

Set objWMI=GetObject("winmgmts://.\root\cimv2").InstancesOf("win32_operatingsystem")

For Each OS In objWMI
  GetOS=OS.Caption
Next

End Function

'///////////////////////////////////
'Use IE Password prompt
'to securely get a password
'//////////////////////////////////
Function GetIEPassword()
Dim ie
On Error Resume Next
set ie=Wscript.CreateObject("internetexplorer.application")
ie.width=400
ie.height=150
ie.statusbar=True
ie.menubar=False
ie.toolbar=False

ie.navigate ("About:blank")
ie.visible=True
ie.document.title="Password prompt"

strHTML=strHTML & "<Font color=RED><B>Enter password: <br><input id=pass type=Password></B></Font> &nbsp"
strHTML=strHTML & "<input type=checkbox id=Clicked size=1>click box when finished"

ie.document.body.innerhtml=strHTML

Do While ie.busy<>False
    wscript.sleep 100
Loop

'loop until box is checked
 Do While ie.Document.all.clicked.checked=False
    WScript.Sleep 250
Loop

GetIEPassword=ie.Document.body.all.pass.value

ie.Quit
set ie=Nothing
End Function


Sub SetTextToClipboardUsingIE(StrText)  
'http://digilander.libero.it/Cenati
StrText=Replace (StrText,"<","&lt;")
With CreateObject("InternetExplorer.Application")
  .Navigate "about:blank"
  do until .ReadyState = 4 : Wscript.Sleep 100 : Loop
  .visible = false
  With .document
    .writeln("<html><head><title></title></head><body><pre>")
    .writeln(StrText)           
    .writeln("</pre></body></html>")
    .execcommand "SelectAll"
    .execcommand "Copy"
  end with ' document
end with 'Createobject

End Sub

Sub ForceScriptToRunUnderCScript(Close)
'Forces this script to run with Cscript
'even if started with wscript.
'parameter Close=true: closes the window after completed.
'parameter Close=false: leaves window open
Dim strPath, strCommand, ObjShell,ObjArgs,I
If LCase(Right(Wscript.FullName, 11)) = "wscript.exe" Then
    strPath = Chr(34) & Wscript.ScriptFullName & Chr(34)
    Set objArgs = WScript.Arguments
    For I = 0 to objArgs.Count - 1
    	strPath = strPath & " " & chr(34) & ObjArgs(I)& Chr(34)
	Next

    If close=True Then
    	strCommand = "%comspec% /c cscript  " & strPath
    Else
    	strCommand = "%comspec% /k cscript  " & strPath 
    End If
    Set objShell = CreateObject("Wscript.Shell")
    objShell.Run(strCommand)
    Wscript.Quit
End If
End Sub

Sub ShowIEWindow(PosLeft,PosTop,WinWidth,WinHeight,HtmlContent,Title,close)
	'*** Crea una finestra che funge da output ***
	If close=True Then 
		MyIE.Quit
		MyIE="Window Closed"
		Exit Sub
	End If
	If Not IsObject(myIE) Then
		Set myIE = CreateObject("InternetExplorer.Application")
		myIE.Navigate "about:blank"
		myIE.ToolBar = False:myIE.StatusBar = False:myIE.Resizable = False
		Do
		Loop While myIE.Busy
		myIE.document.writeln("<html><title>" & Title & "</title>"&_
		"<body><div id='cont'></div></body></html>")
	End If
	myIE.Width = WinWidth:myIE.Height = WinHeight
	myIE.Left = PosLeft:myIE.Top = PosTop
	myIE.Visible = True
	myIE.Document.All("cont").INNERHTML = HtmlContent
End Sub


Sub WriteLog(sMessage)
	'***************************************
	'Scrive un file di log con lo stesso 
	'nome dello script ed estensione ".log".
	'Writes a log file with the same name
	'as the script and the extension ".log"
	'Cenati Giovanni 3/8/09
	'http://digilander.libero.it/Cenati
	'***************************************
	'Togliere il commento a EXIT SUB a debug completato
	'Uncomment EXIT SUB when debug is complete.
	'EXIT SUB
	Dim sFileName, sDateTime, ThisScriptPath
	Dim fso, fp, LenExt
	Set fso = CreateObject("Scripting.FileSystemObject")
	
	Const ForAppending= 8 'Open a file and write to the end of the file
  
  	sDateTime = Right("00" & Day(Now), 2) & _
  	Right("00" & Month(Now), 2) & _
  	Right("0000" & Year(Now), 4) & " " & _
  	Right("00" & Hour(Now), 2) & ":" & _
  	Right("00" & Minute(Now), 2) & ":" & _
  	Right("00" & Second(Now), 2)
  	
  	sFileName=WScript.ScriptFullName
	LenExt=Len(fso.GetExtensionName(WScript.ScriptFullName))
	stripExtension=Left(sFileName,Len(sFileName)-(LenExt+1))
  	ThisScriptPath= Left(sFileName, InStrRev(sFileName,"\"))	
  	sFileName = StripExtension & ".log"
              
  ' apre il file e scrive la riga. Se il file non esiste lo crea.
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set fp = fso.OpenTextFile(sFileName, ForAppending, True)
  fp.WriteLine sDateTime & " " & sMessage
  fp.Close
  Set fp = Nothing
  Set fso = Nothing

End Sub

function GetTextFromClipboardUsingIE()
	GetTextFromClipboardUsingIE = CreateObject("htmlfile").ParentWindow.ClipboardData.GetData("text")
end function

Sub Beep (n,wait)
   For i = 1 To n
      createobject("wscript.shell").Run "%comspec% /c echo "&Chr(7), 0, False
      Wscript.Sleep wait*100
   Next
End Sub

Sub playtune(tune, wait)
  '\Rems 11.jun.2008 microsoft.public.scripting.wsh
  'Set objPlayer = CreateObject("WMPlayer.OCX")
  'objPlayer.OpenPlayer(objPlayer.url)
  If (isObject(oWMPlayer) = False) _
    then Set oWMPlayer = createobject("Wmplayer.OCX.7")
  With oWMPlayer
    .url = tune
    .Controls.stop
    If wait = True then
      .Controls.Play
      Do until (.playState = 1)
      Wscript.Sleep 200 : Loop
    Else
      oWMPlayer.Controls.Play
    End If
  End With
End Sub

Function CurrentUserID()
	CurrentUserID= CreateObject("WScript.Shell").ExpandEnvironmentStrings("%USERNAME%")
End Function

Function UserFullName(UserID)
	Dim StrDomain, objDomain, objUser
	' Ottiene il nome del dominio e dell'utente
	strDomain = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%USERDOMAIN%")
	MsgBox StrDomain
	MsgBox UserID
	' Si collega al server e richiede l'utente
	Set objDomain = GetObject("WinNT://" & strDomain)
	Set objUser = objDomain.GetObject("user", UserID)
	UserFullName=objUser.Fullname
	'objUser.Name 
	'objUser.FullName 
	'objUser.Description 
	'objUser.LastLogin
End Function

'-------------------------------------------------------------------------------------------------- DATA MANIPULATION - STRING
Function LeftOf( sText, sItem )
    Dim nPos
    Dim sResult
    sResult = sText
    nPos = InStr( sText, sItem )
    If nPos >0 Then
        sResult = Left( sText, nPos -1 )
    End If
    LeftOf = sResult
End Function

Function RightOf( sText, sItem )
    Dim nPos
    Dim sResult
    sResult = sText
    nPos = InStr( sText, sItem )
    If nPos >0 Then
        sResult = Mid( sText, nPos + Len( sItem ) )
    End If
    RightOf = sResult
End Function

Function CountFields( strText, strDelim  )
    Dim nOffset, nFoundAt
    Dim nCounter

    nCounter = 1
    nOffset = 1

    Do
        nFoundAt = InStr( nOffset, strText, strDelim )
        If nFoundAt > 0 Then
                nCounter = nCounter + 1
                nOffset = nFoundAt + Len( strDelim )
        Else
            Exit Do
        End If
    Loop

    CountFields = nCounter
End Function

Function NthField( sText, sDelimiter, nReqdField )
    Dim nOffset, nFoundAt
    Dim nCounter
    Dim vResult

    nCounter = 1
    nOffset = 1
    vResult = -1
    If nReqdField >= 1 Then

        Do
            nFoundAt = InStr( nOffset, sText, sDelimiter )
            If nFoundAt > 0 Then
                If nCounter = nReqdField Then
                    vResult = Mid( sText, nOffset, nFoundAt - nOffset )
                    Exit Do
                Else
                    nCounter = nCounter + 1
                    nOffset = nFoundAt + Len( sDelimiter )
                End If
            Else
                If nCounter = nReqdField Then
                    vResult = Mid( sText, nOffset )
                End If
                Exit Do
            End If
        Loop
    End If
    NthField = vResult
End Function

Function BeginsWith( sText, sBeginning, bCaseInsensitive )
    Dim bResult

    bResult = False
    If sBeginning = vbNullString Then
        bResult = True
    Else
        If sText <> vbNullString Then
            If bCaseInsensitive = True Then
                bResult = ( Left( UCase( sText ), Len( sBeginning ) ) = UCase( sBeginning ) )
            Else
                bResult = ( Left( sText, Len( sBeginning ) ) = sBeginning )
            End If
        End If
    End If

    BeginsWith = bResult
End Function

Function EndsWith( sText, sEnding, bCaseInsensitive )
    Dim bResult

    bResult = False
    If sEnding = vbNullString Then
        bResult = True
    Else
        If sText <> vbNullString Then
            If bCaseInsensitive = True Then
                bResult = ( Right( UCase( sText ), Len( sEnding ) ) = UCase( sEnding ) )
            Else
                bResult = ( Right( sText, Len( sEnding ) ) = sEnding )
            End If
        End If
    End If

    EndsWith = bResult
End Function

Function Contains( sText, sChunk, bCaseInsensitive )
    Dim bResult

    bResult = False
    If sChunk = vbNullString Then
        bResult = True
    Else
        If sText <> vbNullString Then
            If bCaseInsensitive = True Then
                bResult = ( InStr( UCase( sText ), UCase( sChunk ) ) > 0 )
            Else
                bResult = ( InStr( sText, sChunk ) > 0 )
            End If
        End If
    End If

    Contains = bResult
End Function

Function Between( sText, sBegin, sEnd )
    Dim nBegin
    Dim nEnd

    nBegin = InStr( sText, sBegin )
    'no error checking yet
    nEnd = InStr( nBegin + Len( sBegin ), sText, sEnd )
    Between = Mid( sText, nBegin + Len( sBegin ), nEnd - nBegin - Len( sBegin ) )
End Function

Function LastLineOf( sData )
    Dim aData
    aData = Split( sData, vbCRLF )
    LastLineOf = aData( UBound( aData ) )
End Function

Function FirstLineOf( sData )
    FirstLineOf = Split( sData, vbCRLF )( 0 )
End Function

Function NthLineOf( n, sData )
    NthLineOf = Split( sData, vbCRLF )( n - 1 )
End Function

Sub BuildTree( sPath )
    Dim aPath
    Dim sStem
    Dim n
    If Not oFSO.FolderExists( oFSO.GetParentFolderName( sPath ) ) Then
        aPath = Split( sPath, "\" )
        For n = 0 To UBound( aPath ) - 1
            sStem = sStem & aPath( n ) & "\"
            IF Not oFSO.FolderExists( sStem ) Then
                oFSO.CreateFolder( LEFT( sStem, LEN( sStem ) - 1 ) )
            End If
        Next    
    End If
End Sub
'EOF