Proteger archivo para que no sea copiado

Esta macro aplica la protección para impedir la copia a unidades externas, solo puede grabar en una carpeta predefinida

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
ActiveWorkbook.SaveAs Filename:="C:\archivos excell\PROTECCION.xlsm", _
        FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    Cancel = True
    MsgBox ("no esta autorizada la grabacion en USB")
End Sub
Private Sub Workbook_Open()
PROTEGER_HOJA
End Sub

esta es la macro protege_hoja, en la hoja2 te pondra tres condiciones de seguridad para proteger el libro si ninguna se cumple no te dejara abrirlo, la macro graba por primera vez la informacion en la hoja2 y si alguien copia este archivo entran 4 protecciones, la 1era verifica desde donde se esta intentando abrir el archivo si detecta que es una unidad externa manda un mensaje y cierra el archivo, la 2a proteccion si copia la informacion al disco duro de otra maquina, la macro busca el numero de serie del disco duro sino coincide con el que esta registrado cierra el archivo, la 3a proteccion actua en conjunto con la segunda busca una modificacion en el regedit de la maquina e igual sino la encuentra cierra el archivo, la modificacion la puedes ver abriendo el regedit hkey_current_user,software,vb and vba program settings,macrosexcel y hay veras inicio,fecha,clave que son los parametros que busca la macro para validar el archivo, la 4a proteccion compara las fechas si el archivo tiene una diferencia de fechas mayor a 2 años tampoco permite abrir el archivo, esa macro no es mia la tome de un libro que compre de programacion no la he usado asi que no puedo decirte que tal funciona, como proteccion adicional te recomiendo que protegas la macro poniendole password y que obligues a los usuarios a activar la macro con otra macro que una vez que cierres el archivo oculte y les ponga password a las hojas y que solo puedan ser desbloqueadas con la macro, al final de esta macro esta otra para restaurar el regedit cuando ya no quieras la proteccion.

Sub PROTEGER_HOJA()
RUTA = CurDir
LETRA = Left(RUTA, 1)
Set FS = CreateObject("SCRIPTING.FILESYSTEMOBJECT")
Set DC = FS.DRIVES
For Each D In DC
If D.DRIVELETTER = LETRA Then GoTo MIRAR
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
Next
MIRAR:
NUMSERIE = D.SERIALNUMBER
ESPACIO = D.FREESPACE / 1024 / 1024 / 1024
If D.DRIVETYPE <> 2 Then
    RESPUESTA = MsgBox("ESTA ARCHIVO NO SE PUEDE ABRIR" _
    & "DESDE UN DISPOSITIVO QUE NO SEA EL DISCO DURO", vbOKOnly, "AVISO")
    AUXSALIDA = 1
    ActiveWorkbook.Close SAVECHANGES:=False
    GoTo SALIDA
End If
If D.DRIVETYPE < 1 Then
    RESPUESTA = MsgBox("ESPACIO INSUFICIENTE EN HD" _
    , vbOKOnly, "AVISO")
    AUXSALIDA = 1
    ActiveWorkbook.Close SAVECHANGES:=False
    GoTo SALIDA
End If
COMPROBAR_REGISTRO:
REGISTRO_HOJA = Range("HOJA2!B1")
Range("A1").Select
UNO = GetSetting("MACROSEXCEL", "INICIO", "LACLAVE", NUMDISC)
If UNO = "" And IsEmpty(REGISTRO_HOJA) = True Then GoTo SALTO
DOS = GetSetting("MACROSEXCEL", "INICIO", "LAFECHA", LAFECHA)
If DOS = "" Then DOS = Date - 720
DOSFECHA = DateValue(DOS)
DIAS = Date - DOSFECHA + 1
If UNO = "" Then UNO = 0
If CDbl(UNO) <> CDbl(REGISTRO_HOJA) Or DIAS > 360 Then
    RESPUESTA = MsgBox("ESTE ARCHIVO YA NO ES VALIDO" _
    , vbOKOnly, "AVISO")
    AUXSALIDA = 1
    ActiveWorkbook.Close SAVECHANGES:=False
    GoTo SALIDA
End If
GoTo SALIDA
SALTO:
Range("HOJA2!B1") = NUMSERIE
NUMDISC = NUMSERIE
Range("HOJA2!B2") = NUMDISC
LAFECHA = Date
Range("HOJA2!B3") = LAFECHA
Range("HOJA2!B1:B3").Font.ColorIndex = 1
PERMITIR = 1
ActiveWorkbook.Save
PERMITIR = 0
SaveSetting APPNAME:="MACROSEXCEL", SECTION:="INICIO", _
Key:="LACLAVE", SETTING:=NUMDISC
SaveSetting APPNAME:="MACROSEXCEL", SECTION:="INICIO", _
Key:="LAFECHA", SETTING:=LAFECHA
SALIDA:
Application.ScreenUpdating = True
End Sub
Sub RETIRAR_PROTECCION()
On Error Resume Next
Range("HOJA2!B1:B3").ClearContents
DeleteSetting APPNAME:="MACROSEXCEL", SECTION:="INICIO", Key:="LACLAVE"
DeleteSetting APPNAME:="MACROSEXCEL", SECTION:="INICIO", Key:="LAFECHA"
End Sub