7

I built a file used by various people in one of my company service.

Each sheet is protected by a password and all users entries are handled with a VBA user form. All sheets are protected by the same password and my code protect/unprotect sheet when users modify data.

The problem is I'm storing the password in clear text in the VBA project so as to call the ActiveSheet.Protect password method. The VBA project is also protected by this password.

Is there a secure way to store that password in the VBA project ?

Anyone who knows how to search a bit would find a code to crack that VBA project password and be able to read it.

EDIT :

I have thought of computing a new password each time the file is open by adding some randomness in it. This way one could read the code without knowing the password. Adding a msgbox could reveal it but only until the file is reopenend. The problem is I cannot manually unprotect/protect sheet with that method as I won't be aware of the password.

Lich4r
  • 1,305
  • 2
  • 13
  • 27
  • I've seen a lot about cracking password not about storing it. I'm asking for a way of achieving this, that does not looks like an opinion based to me. I know they could crack it but I do not want them to find the actual password that I must keep "human readable" for my coworkers to use it... :/ – Lich4r Dec 27 '17 at 10:20
  • 4
    Storing the password within the file itself is kind of like leaving a house key under a door mat. (Might as well not have a password!) Here's some good info about obfuscation and [password storage](https://security.stackexchange.com/questions/108746/how-to-store-passwords-written-on-a-physical-notebook), – ashleedawg Dec 27 '17 at 11:18
  • Good reading although this does not help. I could store those wb passwords in a pswd manager like I do for my personal use that does not fix the problem that anyone who "crack" the VBA project will be able to read it. I'd like to protect sheets with a hash of the actual password but I do not know how to compute that hash without the password appearing in clear text in the code. – Lich4r Dec 27 '17 at 11:23
  • 1
    It looks like `ActiveSheet.Protect` takes a plain text password as its argument so the only way around saving this password in the code with the excel sheet is to try protecting them from VBA code in a _different_ Excel / VBA file. But basically, Excel is not secure. If you need this application to be secure then you need to build it on a more secure platform. – Nick.Mc Dec 27 '17 at 12:06
  • 1
    Removing the VBA password is very simple: https://stackoverflow.com/questions/1026483/is-there-a-way-to-crack-the-password-on-an-excel-vba-project So, simple answer is: No, there is no secure way to protect a VBA project. – Wernfried Domscheit Dec 27 '17 at 12:44
  • I do not want to secure the VBA project. I want that anyone who crack it is not able to know which password was used. This way I know that if sth has been modified, this means the project has been cracked and not that the password has been given. – Lich4r Dec 27 '17 at 15:56

3 Answers3

3

Summarising the useful info from comments:

  • if your code has access to the password (even directly or through obfuscation) anybody having access to the code have access to the password too
  • password protection of Excel VBA is very weak, it's a trivial job to crack it

Conclusion : there is no way securely storing password in Excel VBA

Máté Juhász
  • 2,197
  • 1
  • 19
  • 40
1

This should do the trick. The password is smp2smp2, which you will get when running GetPassword, but that actual value is not stored in the project. It is stored using the code 30555112012321187051111661144119, which will be converted to the actual password (human readable) by using CreatePasswordFromCode. By the way, I have no idea how to easily get the code that belongs to a certain password. And in this way, it is always 8 characters long, no room for changes unless you adjust the code. I have found this somewhere in an old project of somebody else, no source mentioned unfortunately.

Option Explicit

Function GetPassword() As String

    'the password is stored as codes, so the real password is not stored in this project
    GetPassword = CreatePasswordFromCode("30555112012321187051111661144119")

End Function

Function CreatePasswordFromCode(ByVal pstrPasswordCode As String) As String
Dim intChar As Integer
Dim intCode As Integer
Dim arrintShifts(0 To 7) As Integer
Dim arrlngCharCode(0 To 7) As Long
Dim strMessage As String

    intChar = 0
    intCode = 0

    For intCode = 0 To 7
        'store -8 to -1 into 0-7
        arrintShifts(intCode) = intCode - 8
    Next intCode

    'the code is stored by using the number of the letter of the password in the 4th character.
    'the real code of the character is directly behind that.
    'so the code 30555112012321187051111661144119
    'has on position 3, 055, 5, 112, 0, 123, 2, 118, 7, 051, 1, 116, 6, 114 and 4, 119
    'so sorted this is 0, 123, 1, 116, 2, 118, 3, 055, 4, 119, 5, 112, 6, 114, 7, 051
    'then there is also the part where those charcode are shifted by adding -8 to -1 to them.
    'leading to the real charactercodes:
    '0, 123-8, 1, 116-7, 2, 118-6, 3, 055-5, 4, 119-4, 5, 112-3, 6, 114-2, 7, 051-1
    '0, 115, 1, 109, 2, 112, 3, 050, 4, 115, 5, 109, 6, 112, 7, 050
    For intChar = 0 To 7
        If Mid(pstrPasswordCode, 1, 1) = intChar Then
            arrlngCharCode(intChar) = (Mid(pstrPasswordCode, 2, 3) + arrintShifts(intChar))
        ElseIf Mid(pstrPasswordCode, 5, 1) = intChar Then
            arrlngCharCode(intChar) = (Mid(pstrPasswordCode, 6, 3) + arrintShifts(intChar))
        ElseIf Mid(pstrPasswordCode, 9, 1) = intChar Then
            arrlngCharCode(intChar) = (Mid(pstrPasswordCode, 10, 3) + arrintShifts(intChar))
        ElseIf Mid(pstrPasswordCode, 13, 1) = intChar Then
            arrlngCharCode(intChar) = (Mid(pstrPasswordCode, 14, 3) + arrintShifts(intChar))
        ElseIf Mid(pstrPasswordCode, 17, 1) = intChar Then
            arrlngCharCode(intChar) = (Mid(pstrPasswordCode, 18, 3) + arrintShifts(intChar))
        ElseIf Mid(pstrPasswordCode, 21, 1) = intChar Then
            arrlngCharCode(intChar) = (Mid(pstrPasswordCode, 22, 3) + arrintShifts(intChar))
        ElseIf Mid(pstrPasswordCode, 25, 1) = intChar Then
            arrlngCharCode(intChar) = (Mid(pstrPasswordCode, 26, 3) + arrintShifts(intChar))
        ElseIf Mid(pstrPasswordCode, 29, 1) = intChar Then
            arrlngCharCode(intChar) = (Mid(pstrPasswordCode, 30, 3) + arrintShifts(intChar))
        End If
    Next intChar

    'by getting the charcodes of these values, you create the password
    CreatePasswordFromCode = Chr(arrlngCharCode(0)) & Chr(arrlngCharCode(1)) & Chr(arrlngCharCode(2)) & Chr(arrlngCharCode(3)) & Chr(arrlngCharCode(4)) & Chr(arrlngCharCode(5)) & Chr(arrlngCharCode(6)) & Chr(arrlngCharCode(7))

End Function
IKavanagh
  • 6,089
  • 11
  • 42
  • 47
Jeroen
  • 11
  • 1
1

Modified the code for use with up to 99 characters. Added Password generator.

But still: this all is just an obfuscation of the real password.

Function CreatePasswordFromCode(ByVal pstrPasswordCode As String) As String
' Original Code https://stackoverflow.com/questions/47990187/securely-store-password-in-a-vba-project?utm_medium=organic&utm_source=google_rich_qa&utm_campaign=google_rich_qa
' Modified to extend password length
' Modifications free to use
Dim codeLen As Integer

Dim intChar As Integer
Dim intCode As Integer
Dim arrintShifts() As Integer
Dim arrlngCharCode() As Long
Dim icp As Integer

    ' Initialise Arrays
    icp = IIf(Right(pstrPasswordCode, 1) Mod 2 = 0, 5, 4)
    pstrPasswordCode = Left(pstrPasswordCode, Len(pstrPasswordCode) - IIf(Right(pstrPasswordCode, 1) Mod 2 = 0, 1, 1))
    codeLen = Len(pstrPasswordCode) / icp - 1 ' Array Index starts with 0
    ReDim arrintShifts(codeLen)
    ReDim arrlngCharCode(codeLen)

    intChar = 0
    intCode = 0

    For intCode = 0 To codeLen
        'store -8 to -1 into 0-7
        arrintShifts(intCode) = intCode - (codeLen + 1)
    Next intCode

    'the code is stored by using the number of the letter of the password in the 4th character.
    'the real code of the character is directly behind that.
    'so the code 30555112012321187051111661144119
    'has on position 3, 055, 5, 112, 0, 123, 2, 118, 7, 051, 1, 116, 6, 114 and 4, 119
    'so sorted this is 0, 123, 1, 116, 2, 118, 3, 055, 4, 119, 5, 112, 6, 114, 7, 051
    'then there is also the part where those charcode are shifted by adding -8 to -1 to them.
    'leading to the real charactercodes:
    '0, 123-8, 1, 116-7, 2, 118-6, 3, 055-5, 4, 119-4, 5, 112-3, 6, 114-2, 7, 051-1
    '0, 115, 1, 109, 2, 112, 3, 050, 4, 115, 5, 109, 6, 112, 7, 050

    For intChar = 0 To codeLen
        For intCode = 0 To codeLen
            If CInt(Mid(pstrPasswordCode, intCode * icp + 1, icp - 3)) = intChar Then
                arrlngCharCode(intChar) = (Mid(pstrPasswordCode, (intCode + 1) * icp - 2, 3) + arrintShifts(intChar))
                Exit For
            End If
        Next intCode
    Next intChar

    'by getting the charcodes of these values, you create the password
    CreatePasswordFromCode = ""
    For intChar = 0 To codeLen
        CreatePasswordFromCode = CreatePasswordFromCode & Chr(arrlngCharCode(intChar))
    Next intChar

End Function

Function CreateCodeFromPassword(ByVal pstrPasswordCode As String) As String
' Generator free to use
Dim pwLen As Integer
Dim scp As String   ' String Code Position, for formatting "0" or "00"
Dim icp As Integer  ' marker if pwLen < 10 or > 10
Dim intCode As Integer
Dim arrintShifts() As Integer
Dim arrlngCharCode() As Long
Dim pw() As String

Dim Temp As Variant
Dim arnd() As Variant
Dim irnd As Variant

    Randomize

    ' Initialise Arrays
    pwLen = Len(pstrPasswordCode) - 1 ' Array Index starts with 0
    scp = IIf(pwLen < 10, "0", "00")
    ' Create odd/even marker if we have 1 (odd) or 2 (even) byte index digits (scp), values between 0 and 9
    icp = IIf(pwLen < 10, Int(Rnd() * 5 + 1) * 2 - 1, Int(Rnd() * 5 + 1) * 2)

    ReDim arrintShifts(pwLen)
    ReDim arrlngCharCode(pwLen)
    ReDim pw(pwLen)
    ReDim arnd(pwLen)

    For intCode = 0 To pwLen
        arnd(intCode) = intCode
    Next intCode

    ' randomize the indizes to bring the code into a random order
    For intCode = LBound(arnd) To UBound(arnd)
        irnd = CLng(((UBound(arnd) - intCode) * Rnd) + intCode)
        If intCode <> irnd Then
            Temp = arnd(intCode)
            arnd(intCode) = arnd(irnd)
            arnd(irnd) = Temp
        End If
    Next intCode

    'by getting the charcodes of these values, you create the password
    For intCode = 0 To pwLen
        'get characters
        pw(intCode) = Mid(pstrPasswordCode, intCode + 1, 1)
        'and store -8 to -1 into 0-7 (for additional obfuscation)
        arrintShifts(intCode) = intCode - (pwLen + 1)
    Next intCode

    ' Search for the random index and throw the shifted code at this position
    For intCode = 0 To pwLen
        arrlngCharCode(Application.Match(intCode, arnd, False) - 1) = AscB(pw(intCode)) - arrintShifts(intCode)
    Next intCode

    ' Chain All Codes, combination of arnd(intcode) and arrlngCharCode(intcode) gives the random order
    CreateCodeFromPassword = ""
    For intCode = 0 To pwLen
        CreateCodeFromPassword = CreateCodeFromPassword & Format(arnd(intCode), scp) & Format(arrlngCharCode(intCode), "000")
    Next intCode
    CreateCodeFromPassword = CreateCodeFromPassword & icp

End Function

Obfuscated version

'VBA code protection using: www.excel-pratique.com/en/vba_tricks/vba-obfuscator.php
Function CreatePasswordFromCode(ByVal z4891679d877f1da36647b21d6197fbfd As String) As String
Dim b2da54ddb60c93bf346493d7e08bc6d08 As Integer
Dim bf56f94eb6ed9a658e82e88591237324d As Integer
Dim bec732ae8e18b7b2ff2e9ccd058f3e8fc As Integer
Dim m06993036154505accc9ce092bdb57b17() As Integer
Dim b8026f9f8f7fe86372be0799d8c9c6691() As Long
Dim q24471047c7a6e466b78de3c6ae66f20f As String
Dim t5f443e88a552a3f943275f985dde03ca As Integer
t5f443e88a552a3f943275f985dde03ca = IIf(Right(z4891679d877f1da36647b21d6197fbfd, 1) Mod 2 = 0, 5, 4)
z4891679d877f1da36647b21d6197fbfd = Left(z4891679d877f1da36647b21d6197fbfd, Len(z4891679d877f1da36647b21d6197fbfd) - IIf(Right(z4891679d877f1da36647b21d6197fbfd, 1) Mod 2 = 0, 1, 1))
b2da54ddb60c93bf346493d7e08bc6d08 = Len(z4891679d877f1da36647b21d6197fbfd) / t5f443e88a552a3f943275f985dde03ca - 1
ReDim m06993036154505accc9ce092bdb57b17(b2da54ddb60c93bf346493d7e08bc6d08)
ReDim b8026f9f8f7fe86372be0799d8c9c6691(b2da54ddb60c93bf346493d7e08bc6d08)
bf56f94eb6ed9a658e82e88591237324d = 0
bec732ae8e18b7b2ff2e9ccd058f3e8fc = 0
For bec732ae8e18b7b2ff2e9ccd058f3e8fc = 0 To b2da54ddb60c93bf346493d7e08bc6d08
m06993036154505accc9ce092bdb57b17(bec732ae8e18b7b2ff2e9ccd058f3e8fc) = bec732ae8e18b7b2ff2e9ccd058f3e8fc - (b2da54ddb60c93bf346493d7e08bc6d08 + 1)
Next bec732ae8e18b7b2ff2e9ccd058f3e8fc
For bf56f94eb6ed9a658e82e88591237324d = 0 To b2da54ddb60c93bf346493d7e08bc6d08
For bec732ae8e18b7b2ff2e9ccd058f3e8fc = 0 To b2da54ddb60c93bf346493d7e08bc6d08
If CInt(Mid(z4891679d877f1da36647b21d6197fbfd, bec732ae8e18b7b2ff2e9ccd058f3e8fc * t5f443e88a552a3f943275f985dde03ca + 1, t5f443e88a552a3f943275f985dde03ca - 3)) = bf56f94eb6ed9a658e82e88591237324d Then
b8026f9f8f7fe86372be0799d8c9c6691(bf56f94eb6ed9a658e82e88591237324d) = (Mid(z4891679d877f1da36647b21d6197fbfd, (bec732ae8e18b7b2ff2e9ccd058f3e8fc + 1) * t5f443e88a552a3f943275f985dde03ca - 2, 3) + m06993036154505accc9ce092bdb57b17(bf56f94eb6ed9a658e82e88591237324d))
Exit For
End If
Next bec732ae8e18b7b2ff2e9ccd058f3e8fc
Next bf56f94eb6ed9a658e82e88591237324d
CreatePasswordFromCode = ""
For bf56f94eb6ed9a658e82e88591237324d = 0 To b2da54ddb60c93bf346493d7e08bc6d08
CreatePasswordFromCode = CreatePasswordFromCode & Chr(b8026f9f8f7fe86372be0799d8c9c6691(bf56f94eb6ed9a658e82e88591237324d))
Next bf56f94eb6ed9a658e82e88591237324d
End Function
Function CreateCodeFromPassword(ByVal z4891679d877f1da36647b21d6197fbfd As String) As String
Dim qe564274d6cab7b91a3393ef092dac78f As Integer
Dim b330c8da5472f3c36b801671ef5a54797 As String
Dim t5f443e88a552a3f943275f985dde03ca As Integer
Dim bec732ae8e18b7b2ff2e9ccd058f3e8fc As Integer
Dim m06993036154505accc9ce092bdb57b17() As Integer
Dim b8026f9f8f7fe86372be0799d8c9c6691() As Long
Dim b343223dcae485b35af2792c7dd91f92b() As String
Dim e0d4cf763c9da42470a729a29b30d7d50 As Variant
Dim b41d8f2e79c0e09113beb7629aa0d8c48() As Variant
Dim b42a57d0c121b9fe34a74143aa279157c As Variant
Randomize
qe564274d6cab7b91a3393ef092dac78f = Len(z4891679d877f1da36647b21d6197fbfd) - 1
b330c8da5472f3c36b801671ef5a54797 = IIf(qe564274d6cab7b91a3393ef092dac78f < 10, "0", "00")
t5f443e88a552a3f943275f985dde03ca = IIf(qe564274d6cab7b91a3393ef092dac78f < 10, Int(Rnd() * 5 + 1) * 2 - 1, Int(Rnd() * 5 + 1) * 2)
ReDim m06993036154505accc9ce092bdb57b17(qe564274d6cab7b91a3393ef092dac78f)
ReDim b8026f9f8f7fe86372be0799d8c9c6691(qe564274d6cab7b91a3393ef092dac78f)
ReDim b343223dcae485b35af2792c7dd91f92b(qe564274d6cab7b91a3393ef092dac78f)
ReDim b41d8f2e79c0e09113beb7629aa0d8c48(qe564274d6cab7b91a3393ef092dac78f)
For bec732ae8e18b7b2ff2e9ccd058f3e8fc = 0 To qe564274d6cab7b91a3393ef092dac78f
b41d8f2e79c0e09113beb7629aa0d8c48(bec732ae8e18b7b2ff2e9ccd058f3e8fc) = bec732ae8e18b7b2ff2e9ccd058f3e8fc
Next bec732ae8e18b7b2ff2e9ccd058f3e8fc
For bec732ae8e18b7b2ff2e9ccd058f3e8fc = LBound(b41d8f2e79c0e09113beb7629aa0d8c48) To UBound(b41d8f2e79c0e09113beb7629aa0d8c48)
b42a57d0c121b9fe34a74143aa279157c = CLng(((UBound(b41d8f2e79c0e09113beb7629aa0d8c48) - bec732ae8e18b7b2ff2e9ccd058f3e8fc) * Rnd) + bec732ae8e18b7b2ff2e9ccd058f3e8fc)
If bec732ae8e18b7b2ff2e9ccd058f3e8fc <> b42a57d0c121b9fe34a74143aa279157c Then
e0d4cf763c9da42470a729a29b30d7d50 = b41d8f2e79c0e09113beb7629aa0d8c48(bec732ae8e18b7b2ff2e9ccd058f3e8fc)
b41d8f2e79c0e09113beb7629aa0d8c48(bec732ae8e18b7b2ff2e9ccd058f3e8fc) = b41d8f2e79c0e09113beb7629aa0d8c48(b42a57d0c121b9fe34a74143aa279157c)
b41d8f2e79c0e09113beb7629aa0d8c48(b42a57d0c121b9fe34a74143aa279157c) = e0d4cf763c9da42470a729a29b30d7d50
End If
Next bec732ae8e18b7b2ff2e9ccd058f3e8fc
For bec732ae8e18b7b2ff2e9ccd058f3e8fc = 0 To qe564274d6cab7b91a3393ef092dac78f
b343223dcae485b35af2792c7dd91f92b(bec732ae8e18b7b2ff2e9ccd058f3e8fc) = Mid(z4891679d877f1da36647b21d6197fbfd, bec732ae8e18b7b2ff2e9ccd058f3e8fc + 1, 1)
m06993036154505accc9ce092bdb57b17(bec732ae8e18b7b2ff2e9ccd058f3e8fc) = bec732ae8e18b7b2ff2e9ccd058f3e8fc - (qe564274d6cab7b91a3393ef092dac78f + 1)
Next bec732ae8e18b7b2ff2e9ccd058f3e8fc
For bec732ae8e18b7b2ff2e9ccd058f3e8fc = 0 To qe564274d6cab7b91a3393ef092dac78f
b8026f9f8f7fe86372be0799d8c9c6691(Application.Match(bec732ae8e18b7b2ff2e9ccd058f3e8fc, b41d8f2e79c0e09113beb7629aa0d8c48, False) - 1) = AscB(b343223dcae485b35af2792c7dd91f92b(bec732ae8e18b7b2ff2e9ccd058f3e8fc)) - m06993036154505accc9ce092bdb57b17(bec732ae8e18b7b2ff2e9ccd058f3e8fc)
Next bec732ae8e18b7b2ff2e9ccd058f3e8fc
CreateCodeFromPassword = ""
For bec732ae8e18b7b2ff2e9ccd058f3e8fc = 0 To qe564274d6cab7b91a3393ef092dac78f
CreateCodeFromPassword = CreateCodeFromPassword & Format(b41d8f2e79c0e09113beb7629aa0d8c48(bec732ae8e18b7b2ff2e9ccd058f3e8fc), b330c8da5472f3c36b801671ef5a54797) & Format(b8026f9f8f7fe86372be0799d8c9c6691(bec732ae8e18b7b2ff2e9ccd058f3e8fc), "000")
Next bec732ae8e18b7b2ff2e9ccd058f3e8fc
CreateCodeFromPassword = CreateCodeFromPassword & t5f443e88a552a3f943275f985dde03ca
End Function
Arne G.
  • 11
  • 1