CopiarHaciaPerfiles.vbs

'Script Para Copiar Ficheros y/o Carpetas en los Perfiles de un Equipo

'Programador: Fco. J. Perez
'Mail: [email protected]
'Fecha: 23/02/09



On Error Resume Next


'Constantes Generales del progama
Const HKEY_LOCAL_MACHINE = &H80000002
Const ForReading = 1
Const FOR_WRITING = 2
Const ForAppending = 8

Const OverWriteFiles = TRUE


'*************************** Parametros del programa *******************************

'Parametros de Filtrado
Const SinceElement = 3 'Listado de perfiles desde el elemento indicado
Const ExcludeText = "admin" ' 

'Parametros de Copia de Carpetas
Const BoolCopyFolder = False
Const CarpetaOrigen = "C:\Test Prueba" 

'Parametros de Ficheros
Const BoolCopyFiles = True
Const FicherosOrigen = "C:\Test\*.*"



'Parametros de Log
Const BoolLog = True
strPath = ""
strLogFile = strPath & WScript.ScriptName & ".log"
Set WshNetwork = WScript.CreateObject("WScript.Network")
strBeginnerLog = CStr(Now) & " " & WshNetwork.ComputerName & ": "



'************************** Ejecicion del Programa *********************************
strComputer = "."



Call Principal()
WScript.Quit



'*************************** Funciones Principal **********************************

Sub Principal()
	Dim ArrPerfiles
	Dim ArrFilterPerfiles
	

	'Obtencion del Array de Perfiles
	ArrPerfiles = ArrProfiles()
	ListProfiles ArrPerfiles
	
	'Obtencion del Array de Perfiles Filtrado
	ArrFilterPerfiles = FilterProfiles(ArrPerfiles)
	Mensaje "Filtrado desde Elemento: " & SinceElement 
	Mensaje "Texto Excluido: " & ExcludeText
	ListProfiles ArrFilterPerfiles
	
	'Copia de Carpeta Origen
	If BoolCopyFolder Then CopyFolderToProfile ArrFilterPerfiles,CarpetaOrigen,"\"
	
	'Copia de Ficheros
	If BoolCopyFiles Then CopyFilesToProfile ArrFilterPerfiles,FicherosOrigen,"\"
	
End Sub

'*************************** Funciones y Procedimientos ****************************

'Funcion para la obtencion de los perfiles en un equipo (incluyendo su ubicacion)
Function ArrProfiles()
	Dim i
	Dim ArrPerfiles()
	Set objRegistry=GetObject("winmgmts:\\" & _ 
	    strComputer & "\root\default:StdRegProv")
	 
	strKeyPath = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\ProfileList"
	objRegistry.EnumKey HKEY_LOCAL_MACHINE, strKeyPath, arrSubkeys
	i = 0
	ReDim Preserve ArrPerfiles(i) '"Recremos" la matriz
	For Each objSubkey In arrSubkeys
	    strValueName = "ProfileImagePath"
	    strSubPath = strKeyPath & "\" & objSubkey
	    objRegistry.GetExpandedStringValue HKEY_LOCAL_MACHINE,strSubPath,strValueName,strValue
	    ArrPerfiles(i) = strValue
	    i = i + 1
	    ReDim Preserve ArrPerfiles(i) 'Aumento la matriz en un elemento
	Next
	ReDim Preserve ArrPerfiles(UBound(ArrPerfiles,1)-1)
	ArrProfiles = ArrPerfiles
End Function


' Procedimiento para listar los perfiles en en un equipo
' Recibe la matriz de Perfiles, comprueba la constate lista y muestra la lista de perfiles
Sub ListProfiles(ArrPerfiles)
	Dim i
	Dim StrM
	For i= 0 To UBound(ArrPerfiles,1)
		If Not ArrPerfiles(i) = "" Then
			StrM =  i & "--" & ArrPerfiles(i)
			Mensaje StrM
		End If
	Next

End Sub

Function FilterProfiles(ArrPerfiles)
	Dim i,j,u
	Dim strList
	Dim arrFilterProfile()

'Comprobamos si el ultimo elmento de la lista es menor que el numero de perfiles
	If SinceElement > UBound(ArrPerfiles,1) Or SinceElement < 0 Then
		ReDim Preserve arrFilterProfile(0)
		Mensaje("Error!!!: Criterios de Filtrado erroneo")
		FilterProfiles = arrFilterProfile
		Exit Function
	End If
	j=0
	For i = SinceElement To UBound(ArrPerfiles,1)
		If FindElementsInStr(ArrPerfiles(i)) = 0 And Not ArrPerfiles(i)= "" Then
			ReDim Preserve arrFilterProfile(i-SinceElement)
			arrFilterProfile(i-SinceElement-j) = ArrPerfiles(i)
		Else
			j = j + 1
		End If
	Next
	'Eliminamos los elmentos vacios del final de la matriz
	For i=0 To UBound(arrFilterProfile,1)
		If IsEmpty(arrFilterProfile(i)) Then
			u = u + 1
		End If
	Next
	ReDim Preserve arrFilterProfile(UBound(arrFilterProfile,1)-u)
	FilterProfiles = arrFilterProfile
End Function

'Funcion para buscar en una Cadena la lista de Exclusion
Function FindElementsInStr(str)
	Dim arrExcludeList
	Dim k
	arrExcludeList = Split(ExcludeText,",")
	For k=0 To UBound(arrExcludeList,1)
		If InStr(1,str,arrExcludeList(k)) > 0 Then
			FindElementsInStr = InStr(1,str,arrExcludeList(k))
			Exit Function
		End If
	Next
	FindElementsInStr = 0
End Function

'Funcion para la emision de mensajes
Function Mensaje(strMess)
	WScript.Echo strMess
	If BoolLog Then WriteScritpLog strMess
End Function

'Procedimeinto de Log
Sub WriteScritpLog(LineToWrite)
	Set objFSOLog = CreateObject("Scripting.FileSystemObject")
	Set objTextFile = objFSOLog.OpenTextFile(strLogFile, ForAppending, True)
	objTextFile.WriteLine(strBeginnerLog & LineToWrite)
	objTextFile.Close
End Sub

'Funcion para generar la fecha en formato YYYYMMDDHHNNSS
Function strDate()

	strDateTemp = year(now) 
	If month(now) < 10 Then  
		strDateTemp = strDateTemp & "0" & month(now)
	Else
		strDateTemp = strDateTemp & month(now)
	End If
	If day(now) < 10 Then
		strDateTemp = strDateTemp & "0" & day(now)
	Else
		strDateTemp = strDateTemp & day(now)
	End If
	If hour(now)<10 Then
		strDateTemp = strDateTemp & "0" & hour(now)
	Else
		strDateTemp = strDateTemp & hour(now)
	End If 
	If minute(now)<10 Then
		strDateTemp = strDateTemp & "0" & minute(now)
	Else
		strDateTemp = strDateTemp & minute(now)
	End If
	If second(now)<10 Then
		strDateTemp = strDateTemp & "0" & second(now)
	Else
		strDateTemp = strDateTemp & second(now)
	End If
	strDate = strDateTemp
End Function

'Funcion para la copia de carpetas
'Los parametros son:
'1.- Matriz de Perfiles
'2.- Carpeta Origen 
'3.- La carpeta destino dentro del perfil
'Nota: La raiz del Perfil = "\"
Sub CopyFolderToProfile(ArrProfiles,strCarpetaOrigen,strSubCarpetaDestino)
	Dim i
	Dim strDestino
	

	For i = 0 To UBound(ArrProfiles)
		strDestino = ArrProfiles(i)& strSubCarpetaDestino
		Set objFSO = CreateObject("Scripting.FileSystemObject")
		Mensaje "Copiando de: " & strCarpetaOrigen &  " A: " & strDestino
		objFSO.CopyFolder CarpetaOrigen , strDestino , OverWriteFiles
	Next
End Sub

'Funcion para la copia de ficheros
'Los parametros son:
'1.- Matriz de Perfiles
'2.- Ficheros Origen 
'3.- La Ficheros destino dentro del perfil
'Nota: La raiz del Perfil = "\"
Sub CopyFilesToProfile(ArrProfiles,strFilesOrigen,strCarpetaDestino)
	Dim i
	Dim strDestino
	

	For i = 0 To UBound(ArrProfiles)
		strDestino = ArrProfiles(i)& strCarpetaDestino
		Set objFSO = CreateObject("Scripting.FileSystemObject")
		Mensaje "Copiando de: " & strFilesOrigen &  " A: " & strDestino
		objFSO.CopyFile strFilesOrigen , strDestino , OverWriteFiles
	Next
End Sub