Proteger Base de Datos de Microsoft Access

Te paso el código de un módulo...
Option Compare Database
Option Explicit
Declare Function GetVolumeInformation Lib "Kernel32" _
Alias "GetVolumeInformationA" _
(ByVal lpRootPathName As String, _
ByVal lpVolumeNameBuffer As String, _
ByVal nVolumeNameSize As Long, _
lpVolumeSerialNumber As Long, _
lpMaximumComponentLength As Long, _
lpFileSystemFlags As Long, _
ByVal lpFileSystemNameBuffer As String, _
ByVal nFileSystemNameSize As Long) As Long
Function gblInfoDisc(Optional strUnitat, Optional ValorARetornar As Byte) As String
'Código para el Procedimiento
'Definimos las variables
'ValorARetornar ---> 0 Codi del disc...
' 1 Codi Hexadecimal del disc ...
' 2 Codi Numèric (Long) del disc ...
Dim i As Integer
Dim NumeroDisco As Long, strSerialNumber As String
Dim CadenaResultante As Long
Dim NombreDisco As String
Dim FormatoDisco As String
Dim Unidad As String
Dim LongitudNombreProgramaMasLargo As Long
Dim flags As Long
Dim strAfegirCadena As String
'Inicializamos las variables
If IsMissing(strUnitat) Then
Unidad = "C:\"
Else
Unidad = strUnitat
End If
NombreDisco = String(255, Chr(0))
FormatoDisco = String(255, Chr(0))
CadenaResultante = GetVolumeInformation(Unidad, NombreDisco, Len(NombreDisco), NumeroDisco, LongitudNombreProgramaMasLargo, flags, FormatoDisco, Len(FormatoDisco))
'CadenaResultante = Devuelve cero en caso de error.
strSerialNumber = CStr(Hex(NumeroDisco))
If Len(strSerialNumber) <> 8 Then
strAfegirCadena = "00000000"
strSerialNumber = Left(strAfegirCadena, 8 - Len(strSerialNumber)) & strSerialNumber
End If
strSerialNumber = Mid(strSerialNumber, 1, 4) & ":" & Mid(strSerialNumber, 5)
'mostramos el resultado
i = InStr(NombreDisco, Chr(0))
NombreDisco = Mid(NombreDisco, 1, i - 1)
i = InStr(FormatoDisco, Chr(0))
FormatoDisco = Mid(FormatoDisco, 1, i - 1)
'Debug.Print NombreDisco
'Debug.Print FormatoDisco
'Debug.Print Hex(NumeroDisco)
'Debug.Print strSerialNumber
'Debug.Print LongitudNombreProgramaMasLargo
Select Case ValorARetornar
Case 0
gblInfoDisc = strSerialNumber
Case 1
gblInfoDisc = Hex(NumeroDisco)
Case 2
gblInfoDisc = NumeroDisco
End Select
End Function
Como puedes comprobar la función gblInfoDisc devuelve el código de serie del disco entre otra información...
Ahora únicamente debes verificar que el código devuelto sea igual que el que tu has indicado...
Function VerificarDisco()
Dim dbs as database
Dim rst as Recordset
set dbs=CurrentDb
set rst=dbs.OpenRecordset("SELECT * FROM NombreTablaControl WHERE NombreCampoControl='" & gblInfoDisc("C:",0) & "'")
if rst.RecordCount=0 then
msgbox "Esta aplicación no está debidamente instalada." & vbcrlf & _
"Contacte con su servicio técnico.",vbCritical
Docmd.Quit
Exit Function
end if
End Function
Espero haberte sido de utilidad.
Saludos.
Jordi Pérez i Madern
Mataró (Barcelona)