Como permitir acceder al libro solamente en dos PC
Con la idea de impedir sacar la información del lugar de trabajo, he pensado que la solución podría ser limitar la apertura del libro a los PCs del trabajo. Es decir, que solamente se pueda abrir el libro en los dos Pcs del trabajo. ¿Sería posible?
2 Respuestas
Es posible, por ejemplo, sabiendo el nº de serie de los discos duros y que al abrir el archivo lo compruebe, si no es alguno de los discos permitidos, cierra Excel. De todas formas, con conocimientos avanzados se podría desproteger el código, y borrar esta macro que te pongo a continuación. Te aviso para que veas que no es infalible.
Lo primero es saber el número de serie de los pc´s en los que se permite trabajar con el libro, haz lo siguiente en cada PC:
1º Busca la aplicación cmd.exe, (Símbolo del sistema)
2º Escribe Vol letra unidad: Cambia letra unidad por la letra del disco del que quieras saber el nº de serie. No te olvides de los dos puntos :
3º Guarda el nº de serie (sin el guión) que te muestre.
En ThisWorkbook pon lo siguiente:
Private Sub Workbook_Open()
'Por Marcial Castro'
nserie1 = "5C1B117B" 'Pon aquí el número de serie del 1 PC'
nserie2 = "5C1B117B" 'Pon aquí el número de serie del 2 PC'
n = NumeroSerieUnidad("C")
If nserie1 = n Or nserie2 = n Then
MsgBox n
Else
Application.DisplayAlerts = False
Application.Quit
End If
End SubSi el disco es correcto, muestra un mensaje con el número de serie, bórralo cuando pruebes la macro, es sólo para ver que te funciona.
Y esta es la función, que la puedes colocar en el mismo a continuación de lo anterior, o en un módulo.
Function NumeroDeSerie(ByVal unidad As String) As String
'Por Marcial Castro'
Dim fso As Object, disco As Object
Dim SerieUnidadDec As Long
Set fso = CreateObject("Scripting.FileSystemObject")
Set disco = fso.GetDrive(unidad)
With disco
If .IsReady Then
nDec = Abs(.SerialNumber) 'En decimal'
Else
nDec = -1
End If
End With
nHex = Application.WorksheetFunction.Dec2Hex(nDec) 'En Hexadecimal'
NumeroDeSerie = nHex
Set disco = Nothing
Set fso = NothingLo que hace esta función es guardar el numero de serie en decimal (de la unidad que le indiquemos) y convertirlo a hexadecimal, que es cómo los tenemos en Sub Workbook_Open().
Si te ha valido la respuesta.
¡Gracias!
Discúlpame, pero se me había pasado comentarte que en la línea NumeroSerieUnidad me dice: error de compilación. No se ha definido Sub o Funtion. A qué se puede deber?
gracias
Disculpa, es que le cambié el nombre a la Sub, la línea:
n = NumeroSerieUnidad("C")tiene que ser
n = NumeroDeSerie("C")
¡Gracias!
Pero sigue dando el mismo error
Puedes poner aquí el código, ¿tal cómo lo tienes?
Private Sub Workbook_Open()
'Por Marcial Castro'
nserie1 = "437BF29C" 'Pon aquí el número de serie del 1 PC'
nserie2 = "5C1B117B" 'Pon aquí el número de serie del 2 PC'
n = NumeroDeSerie("C")
If nserie1 = n Or nserie2 = n Then
MsgBox n
Else
Application.DisplayAlerts = False
Application.Quit
End If
End Sub
Y la función, ¿dónde la has colocado?. Prueba a ponerla en un módulo.
La he puesto en ThisWorkbook y también he probado en un módulo
Pues no lo entiendo, funciona correctamente, me imagino que algo habrás cambiado. Bájate el archivo de aquí y verá que es el mismo y funciona.
https://www.dropbox.com/s/ji8kgep87mmz7bz/numero%20de%20serie%20del%20disco%20duro.xlsm?dl=0
Dime si te funcionó.
Me lo descargué, pero me da el mismo mensaje en: usuarioRed
He probando quitando las líneas siguientes y funciona. Es correcto así?
'comp = usuarioRed()
'dis = NroSerieDisco()
Funciona correctamente. Otra pregunta más (y perdona la lata que te estoy dando). Este procedimiento limita la apertura del libro, pero pulsando MAY mientras se abre, se puede acceder al libro, hay alguna forma de inhabilitar la tecla MAY?
Gracias por tu paciencia
Ya me parecía raro. Esas líneas no estaban en el código que te puse aquí, para que te funcione con esas líneas, debes añadir las funciones que te ha puesto Gustavo.
Prueba con el siguiente evento en el objeto ThisWorkbook
Private Sub Workbook_Open() Dim pcRed As String, d As String Dim W As Worksheet On Error Resume Next pcRed = usuarioRed() d = NroSerieDisco() MsgBox "Nombre de la PC: " & pcRed & ", N° serie del disco: " & d, vbOKOnly, "Información" For Each W In ThisWorkbook.Worksheets If W.Name <> Hoja1.Name Then W.Visible = xlSheetVisible End If Next W Hoja1.Visible = xlSheetVeryHidden Set W = Nothing End Sub
y para que sirva necesitarás las dos funciones auxiliares que está llamando, que debes poner en un módulo
Function usuarioRed() As String
Dim ObjetoRed As Object
Set ObjetoRed = CreateObject("WScript.Network")
usuarioRed = ObjetoRed.ComputerName
Set ObjetoRed = Nothing
End Function
Function NroSerieDisco() As String
Dim fs, d, s, t, drvpath
drvpath = "C"
Set fs = CreateObject("Scripting.FileSystemObject")
Set d = fs.GetDrive(fs.GetDriveName(fs.GetAbsolutePathName(drvpath)))
Select Case d.DriveType
Case 0: t = "Desconocido"
Case 1: t = "Separable"
Case 2: t = "Fijo"
Case 3: t = "Red"
Case 4: t = "CD-ROM"
Case 5: t = "Disco RAM "
End Select
NroSerieDisco = d.SerialNumber
End FunctionBásicamente lo que hace esto es decirte el nombre de la pc y el número de serie del disco, pero estimo que vas a poder adaptarlo a lo que necesites. En todos casos acomoda un poco esto en función a tu requerimiento y luego repregunta un poco más específico.