2 Cara Gampang Reset Password Vba Office Excel

Aplikasi berbasis MS. Excel banyak dikembangkan oleh para creator-creator handal dengan skil berbasis MS. Excel. Sebut saja dalam dunia pendidikan banyak dikembangkan aplikasi tersebut.

Bagi kita yang penasaran akan rumus dan script yang digunakan dalam MS Excel itu sendiri, tentunya membuat kita "GATAL" untuk megotak-atik aplikasi tersebut. Namun, hal yang paling menjengkelkan ketika menerima aplikasi yang anggun harus menghadapi LOCK atau aplikasi tersebut di PASSWORD. Dalam EXCEL sangat memungkingkan dipasswor, baik SHEET maupun MACRO yang digunakan.

Berikut akan dijelaskan cara membuka password dalam macro.

Cara 1.
Cara 1 ini kalian mampu menggunakan aplikasi rvba.exe. atau aplikasi remove vba exce.
1. Download aplikasi rvba.exe di sini versi lawas atau versi baru.
2. Instal aplikasi rvba.exe tersebut mirip biasanya
3. Masukkan file excel yang akan di reset password vba nya.
4. Klik gambar gembok terbuka pada aplikasi.
5. Taraaa,, file excel sudah terbebas dari password vba nya.
6. Kurang jelas? Perhatikan video berikut


Cara 2
Cara 2 ini kalian mampu menggunakan macro. Lho, kok dengan macro? kan aplikasinya terkunci dibagian macro....
Tenang, cara ini menggunakan file excel baru, jadi kita membuat file excel untuk memasang macro, kemudian kita buka/open file excel yang terkunci macronya dengan file excel yang gres ini.

Lebih jelasnya, perhattikan video berikut ini...

Script untuk cara ke 2, atau download file text script nya di sini

Option Base 1
Function ProtectedVBProject(ByRef wb As Workbook) As Boolean
' returns TRUE if the VB project in the active document is protected
Dim VBC As Integer
VBC = -1
On Error Resume Next
  VBC = wb.VBProject.VBComponents.Count
On Error GoTo 0
If VBC = -1 Then
  ProtectedVBProject = True
Else
  ProtectedVBProject = False
End If
End Function

Sub GeneralSub()
Dim CopyFname As Variant
Dim FileNameFolder As Variant

ChDir (Environ("USERPROFILE") & "\Desktop")
 'Select the file
Fname = Application.GetOpenFilename(filefilter:="Excel files (*.xlsm), *.xlsm", MultiSelect:=False)
 'Check if file selected
If Fname = False Then
    Exit Sub
End If
''Check if workBook has password for opening
On Error Resume Next
Dim tmpWB As Workbook
Set tmpWB = Workbooks.Open(Fname, ReadOnly:=True, Password:="")
If Err.Number > 0 Then
  MsgBox "Selected Workbook is encrypted (Password for Openning)!" & vbCrLf & "This acara doesn't works with such files.", vbCritical, "VBA Unlocker"
  Exit Sub
End If
On Error GoTo 0
''Check if WorkBook is in Shared mode
If tmpWB.MultiUserEditing = True Then
  ''Close WorkBook
  tmpWB.Close saveChanges:=False
  MsgBox "Selected Workbook is in Shared Mode!" & vbCrLf & "Please change mode to Exclusive (non Shared) and try again", vbExclamation, "VBA Unlocker"
  Exit Sub
End If
''Check if VBProjec protected
ProjectProtected = ProtectedVBProject(tmpWB)
''Close WorkBook
tmpWB.Close saveChanges:=False
Set tmpWB = Nothing
'' Check if converting to ZIP is required
If ProjectProtected Then
       ''Create Scripting Object
        Dim FSO As Object
        Set FSO = CreateObject("scripting.filesystemobject")
     
        'Copy the file with .zip extension
        CopyFname = Left(Fname, Len(Fname) - 4) & "zip"
        LastSeparatorPos = Len(CopyFname) - InStr(1, StrReverse(CopyFname), CStr(Application.PathSeparator), vbTextCompare) + 1
        CopyFname = Left(CopyFname, LastSeparatorPos) & "Unlocked_" & Right(CopyFname, Len(CopyFname) - LastSeparatorPos)
     
        FSO.CopyFile Fname, CopyFname, True
     
        ''Path to tmp folder
        FileNameFolder = Environ("tmp") & "\UnlockFolderTMP"
     
        ''Delete if previous files exists
        If FSO.FolderExists(FileNameFolder & "\") Then
           FSO.deletefolder FileNameFolder
        End If
     
        'Make the tmp folder in User tmp
        FSO.CreateFolder FileNameFolder
End If

Dim OutMSG As String
OutMSG = ""

 'Check whether WorkBook has VBA Project protection
If ProjectProtected = True Then
   OutMSG = ChangePasswordForVBA(CopyFname, FileNameFolder)
Else
   OutMSG = "Selected WorkBook has no VBA Project protection."
End If


''Check if returning to previous state is required
If ProjectProtected Then
        ''Delete tmp files--------------------------
        If FSO.FolderExists(FileNameFolder & "\") Then
           FSO.deletefolder FileNameFolder
        End If
     
        ''Change extension to .xlsm
        CopyFname_unlocked = Left(CopyFname, Len(CopyFname) - 3) & "xlsm"
       
        ''Delete file with the same name if exists
        If FSO.FileExists(CopyFname_unlocked) Then
          FSO.DeleteFile CopyFname_unlocked, True
        End If
     
        ''Rename back to .xlsm file
        FSO.MoveFile CopyFname, CopyFname_unlocked
        Set FSO = Nothing
End If


MsgBox OutMSG, vbInformation, "VBA Unlocker"
End Sub

Function ChangePasswordForVBA(CopyFname As Variant, FileNameFolder As Variant) As String
'Object for work with ZIP file
Set oApp = CreateObject("Shell.Application")
''Set to false
ProjectFileFound = False
''Cycle trought Zip archive
For Each fileNameInZip In oApp.Namespace(CopyFname).items
       'find 'xl' folder
    If fileNameInZip = "xl" Then
       'find vbaProject.bin
       For Each subFile In fileNameInZip.Getfolder.items
            'extract 'vbaProject.bin' file
            If subFile = "vbaProject.bin" Then
                   ''Move bin file to tmp folder
                  oApp.Namespace(FileNameFolder).movehere subFile
                  ProjectFileFound = True
                  Exit For
            End If
       Next
    End If
Next
''HASH for Password = 'macro'
Dim PasswordString As String
PasswordString = "282A84CBA1CBA1345FCCB154E20721DE77F7D2378D0EAC90427A22021A46E9CE6F17188A"
 ''if VbaProject exists
If ProjectFileFound = True Then
    tmpMSG = ""
    tmpMSG = ChangeDPBValue(FileNameFolder & "\vbaProject.bin", PasswordString) ''DPB change
         
    ''Overwirte existing vbaProject.bin file
    oApp.Namespace(CopyFname).items.Item("xl").Getfolder.CopyHere FileNameFolder & "\vbaProject.bin"
         
    'Keep script waiting until Compressing is done
    On Error Resume Next
    Do Until oApp.Namespace(CopyFname).items.Item("xl").Getfolder.items.Item("vbaProject.bin").Name = "vbaProject.bin"
        Application.Wait (Now + TimeValue("0:00:01"))
    Loop
    On Error GoTo 0
 
    If tmpMSG = "" Then
        ChangePasswordForVBA = "Password for VbaProject: 'macro'"
    Else
        ChangePasswordForVBA = tmpMSG
    End If
 
Else
    ChangePasswordForVBA = "File don't have VbaProject!"
End If
Set oApp = Nothing
End Function
Function ChangeDPBValue(PathToBinFile As String, HASHPassword As String) As String
''Dim adoStream As ADODB.Stream
''Dim adoBin As ADODB.Stream
Dim PasswordArrayByte() As Byte
Set adoStream = CreateObject("ADODB.Stream")
Set adoBin = CreateObject("ADODB.Stream")
ReDim PasswordArrayByte(Len(HASHPassword))
''Convert String to byte
For i = 1 To Len(HASHPassword)
  PasswordArrayByte(i) = Asc(Mid(HASHPassword, i, 1))
Next i
''Read TXT data fine 'DPB' value
With adoStream
    .Mode = 3 'adModeReadWrite
    .Type = 2 'adTypeText  ' adTypeBinary
    .Charset = "us-ascii"
    .Open
    .LoadFromFile (PathToBinFile)
    bytes = .ReadText
 
    ''Find Start of Value pos
    StartPosVal = InStr(1, bytes, "DPB=", vbTextCompare) + 5
 
    ''IF there is no DPB value
    If StartPosVal = 5 Then
        .Close
        Set adoStream = Nothing
        Set adoBin = Nothing
        ChangeDPBValue = "VBA Protection Not found"
        Exit Function
    End If
 
     ''Find End of Value pos
    EndPosVal = InStr(StartPosVal, bytes, """", vbTextCompare) - 1
     'Define lenght
    ValLength = EndPosVal - StartPosVal + 1
 
    If Len(HASHPassword) < ValLength Then
        'add additional '0' if coded password is longer
       ReDim Preserve PasswordArrayByte(Len(HASHPassword) + ValLength - Len(HASHPassword))
     
       For i = Len(HASHPassword) + 1 To UBound(PasswordArrayByte)
          PasswordArrayByte(i) = Asc(0)
       Next i
    End If
     
    .Close
End With
''Read binary data
With adoStream
    .Mode = 3 'adModeReadWrite
    .Type = 1 'adTypeBinary
    .Open
    .LoadFromFile (PathToBinFile)
 
      ''Create empty stream object
    With adoBin
        .Mode = 3 'adModeReadWrite
        .Type = 1 'adTypeBinary
        .Open
    End With
   
    'copy first part of bytes (till start of 'DPB' value)
    .Position = 0
    .CopyTo adoBin, StartPosVal - 1
 
    'copy new DPB value
     adoBin.Write (PasswordArrayByte)
    'copy remaining part of bytes (after 'DPB' value)
    .Position = EndPosVal  ''Set position to remaining part
    .CopyTo adoBin
    'save to file
    adoBin.SaveToFile PathToBinFile, 2 'adSaveCreateOverWrite
    adoBin.Close
 
    .Close
End With
Set adoStream = Nothing
Set adoBin = Nothing
ChangeDPBValue = ""
End Function

Bagikan Artikel ini