Poner password a 1600 excel del tiron!

18/04/2006 - 12:53 por Mario J. Pedras | Informe spam

Hola a tod@s,

A ver si me podeis hechar una mano, en mi empresa estan pensando en poner la
misma contraseña a unos 1600 archivos excel, quieren hacerlo a mano, y
pregunto yo;
Existe alguna herramienta que ponga la contraseña a los archivos
automaticamente?

Muchisimas gracias a todos!

Slds

Siga el debate

2 respuestas

Tengo una respuesta

Preguntas similare

Mostrar todos los temas similares

Leer las respuestas

#1 KL

18/04/2006 - 16:09 | Informe spam

Hola Mario,

Prueba poner los 1600 archivos en una carpeta (p.ej. el codigo usa el directorio "C:\Temp") y ejecutar el codigo que te pongo a continuacion desde cualquier otro libro abierto.

Saludos,
KL

'-Inicio Codigo--
Sub ProtegerArchivos()
Dim sBusc As String, sArchivo As String
Dim sRuta As String, sFiltro As String, sClave As String

sRuta = "C:\Temp" 'ruta hacia la carpeta
sFiltro = "*.xls"
sClave = "abracadabra"

If Right(sRuta, 1) <> "\" Then sRuta = sRuta & "\"
sBusc = Dir(sRuta & sFiltro)

'Sacamos la lista de los ficheros
If sBusc = "" Then Exit Sub

With Application
.StatusBar = "Protegiendo archivos. Espere por favor..."
.ScreenUpdating = False
.DisplayAlerts = False
Do While sBusc <> ""
sArchivo = sRuta & sBusc
Select Case sArchivo
Case ThisWorkbook.FullName
Case Else
With Workbooks.Open(sArchivo)
.SaveAs sArchivo, , sClave
.Close
End With
End Select
sBusc = Dir()
Loop
.DisplayAlerts = True
.ScreenUpdating = True
.StatusBar = False
End With
MsgBox "La operacion ha finalizado."
End Sub
'-Fin Codigo--

Responder a este mensaje

#2 Mario J. Pedras

18/04/2006 - 18:43 | Informe spam

Kl muchisimas gracias por tu ayuda!!!!

"KL" wrote:

Hola Mario,

Prueba poner los 1600 archivos en una carpeta (p.ej. el codigo usa el directorio "C:\Temp") y ejecutar el codigo que te pongo a continuacion desde cualquier otro libro abierto.

Saludos,
KL

'-Inicio Codigo--
Sub ProtegerArchivos()
Dim sBusc As String, sArchivo As String
Dim sRuta As String, sFiltro As String, sClave As String

sRuta = "C:\Temp" 'ruta hacia la carpeta
sFiltro = "*.xls"
sClave = "abracadabra"

If Right(sRuta, 1) <> "\" Then sRuta = sRuta & "\"
sBusc = Dir(sRuta & sFiltro)

'Sacamos la lista de los ficheros
If sBusc = "" Then Exit Sub

With Application
.StatusBar = "Protegiendo archivos. Espere por favor..."
.ScreenUpdating = False
.DisplayAlerts = False
Do While sBusc <> ""
sArchivo = sRuta & sBusc
Select Case sArchivo
Case ThisWorkbook.FullName
Case Else
With Workbooks.Open(sArchivo)
.SaveAs sArchivo, , sClave
.Close
End With
End Select
sBusc = Dir()
Loop
.DisplayAlerts = True
.ScreenUpdating = True
.StatusBar = False
End With
MsgBox "La operacion ha finalizado."
End Sub
'-Fin Codigo--

Siga el debate Respuesta

Responder a este mensaje

Ads by Google

Hacer una pregunta

Tengo una respuesta

Busqueda sugerida