none
How to make a cell encrypted using vba RRS feed

  • Question

  • Hi,

     I want to encrypt a specific cell (B4) in my worksheet(Sheet1). Actually I’m using that cell as a password field. So I want when a user type anything in that cell it will appear as asterisk (*). I have tried with format cell like the following way:

    Format Cell->Custom-> ;;;**

    But if I double click on that cell, actual password is getting visible. Is it possible to make a specific cell encrypted using vba.

    Thanks.

    Friday, June 19, 2015 9:02 AM

Answers

  • Hi Zoyas,

    You can try the following to get your password protected.

    Step 1: Set your Cell or Cell Range as Hidden but NOT Locked

    i) Select all your cells or range which has to be made editable (including the Password cell as well)

    ii) Right Click and go to Format Cells -> Protection Tab 

    iii) Now Select your Password cell which you want to make it as masked.

    iv) Right click and again go to Format Cells –> Protection Tab (as shown in above picture)

    v) Now Check the Hidden check-box for your Password Cell as shown in the below picture:

    Make-Cell-Hidden

    Step 2: Custom Masking (Custom Formatting) of Password Cell

    Now you need to Custom Format your password cell so that after typing your password it shows ******** a masked password. To do so follow below steps:

    i) select the password cell

    ii) Right Click –> Format Cells –> Number Tab

    iii) Select category as Custom

    iv Enter type as ;;;** and Click OK as shown in below picture:

    If you do not not want to use this method, Probably you can completely define your own Encrypt/Decrypt code to do this:

    Sub decrypt()
    
    Dim aPwd(20), aPlus(20), aKey(100)
    sPwd = InputBox("Enter Password", "En-Pwd", "", 1, 1)
    sPwd1 = sPwd
    sKey = InputBox("Enter Key", "En-Key", "", 1, 1)
    sKey = sKey & sKey & sKey & sKey & sKey
    sKeyTmp = sKey
    iLoop = 0
    
    iLenK = Len(sKey)
    For i = 0 To iLenK - 1
        aKey(i) = Left(sKeyTmp, 1)
        sKeyTmp = Right(sKeyTmp, Len(sKeyTmp) - 1)
    Next
    
    Do While sPwd1 <> ""
        
        iLft = Int(Left(sPwd1, 4))
        iRgt = Int(Right(iLft, 1))
        iAsc = Int(Left(sPwd1, 3)) + iRgt
        iKeyAsc = Asc(aKey(iLoop))
        iActAsc = iAsc - iKeyAsc
        sPwd1 = Right(sPwd1, Len(sPwd1) - 4)
        sOrigPwd = sOrigPwd & Chr(iActAsc)
        iLoop = iLoop + 1
    Loop
    
    InputBox "Original Password", "Org-Pwd", sOrigPwd, 1, 1
    
    End Sub
    
    
    Sub encrypt()
    
    Dim aPwd(20), aKey(50)
    
    sPwd = InputBox("Enter Password", "En-Pwd", "", 1, 1)
    sPwdTmp = sPwd
    sKey = InputBox("Enter Key", "En-Key", "", 1, 1)
    sKey = sKey & sKey & sKey & sKey & sKey
    sKeyTmp = sKey
    
    iLenP = Len(sPwd)
    For i = 0 To iLenP - 1
        aPwd(i) = Left(sPwdTmp, 1)
        sPwdTmp = Right(sPwdTmp, Len(sPwdTmp) - 1)
        'msgbox sPwdTmp
    Next
    
    iLenK = Len(sKey)
    For i = 0 To iLenK - 1
        aKey(i) = Left(sKeyTmp, 1)
        sKeyTmp = Right(sKeyTmp, Len(sKeyTmp) - 1)
    Next
    
    sNewPwd = ""
    For i = 0 To iLenP - 1
        iSub = 0
        iTmp = Int(Asc(aPwd(i)) + Asc(aKey(i)))
        iTmp1 = iTmp
        Do While iTmp1 > 0
            a = iTmp1 Mod 10
            b = Int(iTmp1 / 10)
            iSub = iSub + a
            iTmp1 = b
        Loop
        iSpl = Int(Left(iSub, 1))
        sNewPwd = sNewPwd & (iTmp - iSpl) & iSpl
        'msgbox Asc(aPwd(i)) & "  " & Asc(aKey(i)) & "  " & iTmp & "  " & iSub & "  " & iSpl
        
    Next
    InputBox "Encripted Password", "Enc-Pwd", sNewPwd, 1, 1


    Vish Mishra

    • Marked as answer by Zoyas Monday, June 22, 2015 5:08 PM
    Sunday, June 21, 2015 6:50 PM

All replies

  • What you try to accomplish is senseless.

    When you save the password anywhere as clear text I can read it from anywhere with a simple formula =B4

    And even if you save the password encrypted, there must be anywhere a code in your file that decrypts the password. And it doesn't matter if you use a 1024-bit key high security algorithm or just one for kids.

    Whatever you do, there is a point anywhere where you use the password as clear text. And everyone who knows the VBA has a debugger can find that point and get the password using the watch window.

    So all your efforts will be for naught. Forget it.

    Andreas.

    Friday, June 19, 2015 12:04 PM
  • Hi Andreas,

    Thanks for your reply. But before you call something as senseless you must have some basis idea about this. I have come up with a system in which all the sheets will be protected and Formula Bar, Sheet Tab is also not visible to any user. System won’t allow the user to make any unnecessary changes to the workbook.

    My question was to make a tab protected in such a way so that when a user types something in B4 cells that should appear as ******(Asterisk).

    If you know the answer of the solution then I would request you to share the same with me but please do not comment anything ‘Senseless’ without knowing that asset.

    Thanks.

    Friday, June 19, 2015 1:08 PM
  • Hi

    Have a look at the link below. It's a sample file with a password. It's not exactly what you want but maybe that could work for you.

    http://dropcanvas.com/5e5la


    Cimjet

    Friday, June 19, 2015 1:37 PM
  • My question was to make a tab protected in such a way so that when a user types something in B4 cells that should appear as ******(Asterisk).

    There is no way to accomplish that, it is not possible to modify the behavior of the input method in Excel.

    As Cimjet has shown, you can create a Userform with a TextBox control that has assigned a char to the PasswordChar property. You can write the value into B4.

    Another way is to patch the VBA.InputBox with some API-code and send the EM_SETPASSWORDCHAR message to the Edit field of the InputBox window. After that any typed char is shown as an asterisk.

    You can use the SelectionChange event and show a Userform or an InputBox when the User selects B4 and get the input.

    Andreas.

    Friday, June 19, 2015 3:06 PM
  • Hi Cimjet & Andreas,

    Thank you all for your support. Finally I got some tricks to encrypt a specific cell. :)

    Friday, June 19, 2015 6:52 PM
  • Finally I got some tricks to encrypt a specific cell. :)

    I you like upload your file (maybe with anonymous data) on an online file hoster like www.dropbox.com and post the download link here.

    I bet I can break your protection or easily bypass. .-)

    Andreas.

    Saturday, June 20, 2015 4:45 AM
  • Hi Andreas,

    Why are you always talking about bypassing/breaking protection. Are you a hacker? :P I know bypassing vba password is simple but you should not mention it in a forum.

    Just kidding.. Don't mind!!

    You can find the sample file in the below link. Only 'Password' filed has been made protected.

    http://dropcanvas.com/etyrz

    Please let me know without breaking the password if you can bypass the protection.

    Thanks. 


    • Edited by Zoyas Saturday, June 20, 2015 9:37 AM
    Saturday, June 20, 2015 9:35 AM
  • Please let me know without breaking the password if you can bypass the protection.

    At first, your code in Module1 is not compatible with 64bit Office, so it doesn't work when use a 64bit version. Anyway, we can use a 32bit version:

    - Open Excel
    - Click File\Open and select your file
    - Press the SHIFT key
    - Click Open

    As you see the code in Workbook_Open is not executed, especially "ToggleCutCopyAndPaste".

    - Click File\Options\Section Advanced\Display options for this workbook:
    - Check all "Show" options

    As you see, your sheets are all visible.

    And I don't need to break into the file to read this line (and all other):

     If Worksheets("Sheet1").Cells(5, 5).Value = "Kunal1!" Then

    Do you believe me now?

    Andreas.

    Saturday, June 20, 2015 11:53 AM
  • Hi Andreas,

    >>Do you believe me now?<<

    It's impossible.. you have broken the password and in my system the workbook is opening in full screen mode.. so user does not have any chance to close the workbook with system defined X button and also all the sheets are invisible to the user. That's why I have embedded a close function in the workbook. I have tested it in 4 different system and it's working as expected.

    Anyways, if you can use the workbook without any intention of breaking its protection, you will get the desired result for which I have opened this thread.

    Thanks.


    • Edited by Zoyas Saturday, June 20, 2015 12:08 PM
    Saturday, June 20, 2015 12:07 PM
  • Hi Zoyas,

    You can try the following to get your password protected.

    Step 1: Set your Cell or Cell Range as Hidden but NOT Locked

    i) Select all your cells or range which has to be made editable (including the Password cell as well)

    ii) Right Click and go to Format Cells -> Protection Tab 

    iii) Now Select your Password cell which you want to make it as masked.

    iv) Right click and again go to Format Cells –> Protection Tab (as shown in above picture)

    v) Now Check the Hidden check-box for your Password Cell as shown in the below picture:

    Make-Cell-Hidden

    Step 2: Custom Masking (Custom Formatting) of Password Cell

    Now you need to Custom Format your password cell so that after typing your password it shows ******** a masked password. To do so follow below steps:

    i) select the password cell

    ii) Right Click –> Format Cells –> Number Tab

    iii) Select category as Custom

    iv Enter type as ;;;** and Click OK as shown in below picture:

    If you do not not want to use this method, Probably you can completely define your own Encrypt/Decrypt code to do this:

    Sub decrypt()
    
    Dim aPwd(20), aPlus(20), aKey(100)
    sPwd = InputBox("Enter Password", "En-Pwd", "", 1, 1)
    sPwd1 = sPwd
    sKey = InputBox("Enter Key", "En-Key", "", 1, 1)
    sKey = sKey & sKey & sKey & sKey & sKey
    sKeyTmp = sKey
    iLoop = 0
    
    iLenK = Len(sKey)
    For i = 0 To iLenK - 1
        aKey(i) = Left(sKeyTmp, 1)
        sKeyTmp = Right(sKeyTmp, Len(sKeyTmp) - 1)
    Next
    
    Do While sPwd1 <> ""
        
        iLft = Int(Left(sPwd1, 4))
        iRgt = Int(Right(iLft, 1))
        iAsc = Int(Left(sPwd1, 3)) + iRgt
        iKeyAsc = Asc(aKey(iLoop))
        iActAsc = iAsc - iKeyAsc
        sPwd1 = Right(sPwd1, Len(sPwd1) - 4)
        sOrigPwd = sOrigPwd & Chr(iActAsc)
        iLoop = iLoop + 1
    Loop
    
    InputBox "Original Password", "Org-Pwd", sOrigPwd, 1, 1
    
    End Sub
    
    
    Sub encrypt()
    
    Dim aPwd(20), aKey(50)
    
    sPwd = InputBox("Enter Password", "En-Pwd", "", 1, 1)
    sPwdTmp = sPwd
    sKey = InputBox("Enter Key", "En-Key", "", 1, 1)
    sKey = sKey & sKey & sKey & sKey & sKey
    sKeyTmp = sKey
    
    iLenP = Len(sPwd)
    For i = 0 To iLenP - 1
        aPwd(i) = Left(sPwdTmp, 1)
        sPwdTmp = Right(sPwdTmp, Len(sPwdTmp) - 1)
        'msgbox sPwdTmp
    Next
    
    iLenK = Len(sKey)
    For i = 0 To iLenK - 1
        aKey(i) = Left(sKeyTmp, 1)
        sKeyTmp = Right(sKeyTmp, Len(sKeyTmp) - 1)
    Next
    
    sNewPwd = ""
    For i = 0 To iLenP - 1
        iSub = 0
        iTmp = Int(Asc(aPwd(i)) + Asc(aKey(i)))
        iTmp1 = iTmp
        Do While iTmp1 > 0
            a = iTmp1 Mod 10
            b = Int(iTmp1 / 10)
            iSub = iSub + a
            iTmp1 = b
        Loop
        iSpl = Int(Left(iSub, 1))
        sNewPwd = sNewPwd & (iTmp - iSpl) & iSpl
        'msgbox Asc(aPwd(i)) & "  " & Asc(aKey(i)) & "  " & iTmp & "  " & iSub & "  " & iSpl
        
    Next
    InputBox "Encripted Password", "Enc-Pwd", sNewPwd, 1, 1


    Vish Mishra

    • Marked as answer by Zoyas Monday, June 22, 2015 5:08 PM
    Sunday, June 21, 2015 6:50 PM