cs_Megafan
Messages postés389Date d'inscriptiondimanche 7 avril 2002StatutMembreDernière intervention23 septembre 2016
-
23 avril 2002 à 08:30
cs_jds
Messages postés8Date d'inscriptionmardi 17 décembre 2002StatutMembreDernière intervention26 novembre 2004
-
23 déc. 2002 à 01:55
Qui pourrait m'indiquer le moyen d'ouvrir une base Access (via DAO), protégée par un mot de passe.
Merci d'avance.
cs_jds
Messages postés8Date d'inscriptionmardi 17 décembre 2002StatutMembreDernière intervention26 novembre 2004 23 déc. 2002 à 01:55
Public Const LEN_PWD = &H14
Public Const LEN_PWD_CHAR = &H2
Public Const LEN_PWD_COMPILED = LEN_PWD * LEN_PWD_CHAR
Public Const LEN_DATETIME_COMPILED = &H8
Public Const OFFSET_PWD_INTERVAL = &H4
Public Const OFFSET_PWD_COMPILED = &H42
Public Const OFFSET_DATETIME_COMPILED = &H72
Public Const OFFSET_XOR_GET = OFFSET_PWD_COMPILED + LEN_PWD_COMPILED - OFFSET_PWD_INTERVAL
Public Const VAL_XOR_FIX = &H2A7DA8A8
Public Function GetAccessPwd(FileTexte As String) As String
On Error GoTo lblError
Dim NEW_XOR_VAL As Long, NEW_XOR_CHAR As Variant, i As Long, NewPassword As String, PART_CHAR As String
Dim PART_CHAR_HEX As String
For i = 1 To LEN_PWD_COMPILED / OFFSET_PWD_INTERVAL
PART_CHAR = Mid(FileTexte, OFFSET_PWD_COMPILED + (i - 1) * OFFSET_PWD_INTERVAL + 1, 4)
PART_CHAR_HEX = AddChar(Hex((GetValCompiled(PART_CHAR) Xor NEW_XOR_VAL) Xor NEW_XOR_CHAR(i - 1)), 8)
NewPassword = Chr(InvHex(Mid(PART_CHAR_HEX, 1, 4))) & Chr(InvHex(Mid(PART_CHAR_HEX, 5, 4))) & NewPassword
Next i
GetAccessPwd = InvTexte(Replace(NewPassword, Chr(0), ""))
Exit Function
lblError:
GetAccessPwd = "<Erreur dans le fichier>"
End Function
Public Function Replace(ByVal TheString As String, ByVal StringSearch As String, ByVal NewString As String) As String 'Remplace une chaine de charactère par une autre.
Dim RstString As String
Replace = TheString
If Len(StringSearch) <> 0 Or Len(TheString) <> 0 Then
While InStr(TheString, StringSearch)
If Len(RstString) > 0 Then
If Len(StringSearch) > 1 Then If InStr(TheString, StringSearch) 1 Then RstString RstString & NewString Else RstString = RstString & Left(TheString, (InStr(TheString, StringSearch)) - 1) & NewString
Else
RstString = RstString & Left(TheString, (InStr(TheString, StringSearch)) - 1) & NewString
End If
Else
RstString = Left(TheString, (InStr(TheString, StringSearch)) - 1) & NewString
End If If Len(StringSearch) > 1 Then TheString Right(TheString, Len(TheString) - (InStr(TheString, StringSearch)) - (Len(StringSearch) - 1)) Else TheString Right(TheString, Len(TheString) - (InStr(TheString, StringSearch)))
Wend
If Len(TheString) > 0 Then RstString = RstString & TheString
Replace = RstString
End If
End Function
Public Function GetValCompiled(Texte As String) As Long 'Permet de lire la valeur d'une donnée compilée.
Dim NewVal As String, NewTexte As String, i As Long
NewTexte = InvTexte(Texte)
For i = 1 To Len(NewTexte)
NewVal = NewVal & AddChar(Hex(Asc(Mid(NewTexte, i, 1))), 2)
Next i
GetValCompiled = InvHex(NewVal)
End Function
Public Function Ouvrir(FileName As String) As String 'Ouvre un fichier en mode binaire.
Dim GetFree As Long
GetFree = FreeFile
Open FileName For Binary As GetFree
Ouvrir = String(LOF(GetFree), " ")
Get #GetFree, 1, Ouvrir
Close GetFree
End Function
Public Function AddChar(Val As String, TheLen As Long, Optional Char As String = "0") As String 'Permet d'ajouter un charactère à une chaine de charactère pour obtenir une certaine longueur.
AddChar = Right(String(TheLen, Char) & Val, TheLen)
End Function
Public Function InvTexte(Texte As String) As String 'Inverse du texte.
Dim i As Long, NewTexte As String
For i = 1 To Len(Texte)
NewTexte = Mid(Texte, i, 1) & NewTexte
Next i
InvTexte = NewTexte
End Function
Public Function InvHex(ValHex As String) As Long 'Transforme une valeur Hexadécimale en valeur Décimale.
InvHex = Val("&h" & ValHex & "&")
End Function