Source Code Untuk Membuka/Crack Password VBA Excell dan Word

Source Code Visual Basic 6.0

buka 1 project dengan 1 form, 1 module, 1 commandbutton :

yang ini source di form :

Option Explicit
‘// Header Password Untuk VBA
Const vbbego72 = “E9EB458A628A62759E8B62EFEB0B9567D2F09″ & _
“604067445E7DBDA0C1565BA2023778FEFF9″
Const vbbego74 = “C2C06E8D52AA52AAAD5653AAE9253D286E4EE” & _
“E66E86F219911B87D7162FD74EEF579FEB513″
Const vbbego76 = “ADAF0155017E1E7E1E81E27F1E1BAF57D1DB8″ & _
“E045A28FA28492BA70640C9B1EEEC57ABBBD325″
Const vbbegoxx = “5654FA3F0641585E585EA7A2595EDCE369B3D” & _
“FBAB6E0DBB94699F7682AD4B8EF5510B4E293F62A”

Private Sub Command1_Click()
Dim hFile As String
Dim inFile As Long, nLoop As Long
Dim Header As String
Dim State As Boolean
‘// Header Key VBA Password
Header = Chr(&HD) & Chr(&HA) & Chr(&H44) & Chr(&H50) & _
Chr(&H42) & Chr(&H3D) & Chr(&H22)

‘// Buka File Excel & Word
hFile = GetFile(Hwnd)
If Trim(hFile) <> “” Then
Dim isiDok As String * 1000
inFile = FileLen(hFile)
‘// Lakukan pembackupan dokumen sebelum melakukan perubahan
Dim FileAsli As String
FileAsli = Dir(hFile & “.bak”, vbNormal)
If FileAsli = “” Then
FileCopy hFile, hFile & “.bak”
End If

‘// Baca Tulis Ke File
Open hFile For Binary Access Read Write As #1
‘// Lakukan Pengulangan Menurut Ukuran File tsb
For nLoop = 1 To inFile Step 1000
‘// Ambil Data Sebanyak 1000 Karakter
Get #1, nLoop, isiDok
DoEvents
Dim Pos1 As Long, pos2 As Long, pos3 As Long

‘// Periksa Header Key Password
Pos1 = InStr(1, isiDok, Header, vbBinaryCompare)
If Pos1 Then
pos2 = nLoop + Pos1 + Len(Header) – 2
‘// Ambil data pada pointer setelah Header Key
Get #1, pos2, isiDok
‘// Periksa Isi data yg didapat, apakah terdapat End Key?
Pos1 = InStr(1, isiDok, Chr(&HD) & Chr(&HA), vbBinaryCompare)
If Pos1 Then
‘// Hitung panjang password yang terdapat pada file
pos3 = Len(Replace(Mid(isiDok, 1, Pos1 – 1), Chr(34), “”))
If pos3 Then
Select Case pos3
Case 72
‘// Rubah dengan password baru
Put #1, pos2 + 1, vbbego72
MsgBox “Password: vbbego”, 64, “www.vbbego.com”
Case 74
‘// Rubah dengan password baru
Put #1, pos2 + 1, vbbego74
MsgBox “Password: vbbego”, 64, “www.vbbego.com”
Case 76
‘// Rubah dengan password baru
Put #1, pos2 + 1, vbbego76
MsgBox “Password: vbbego”, 64, “www.vbbego.com”
Case Else
‘// Rubah dengan password baru
‘Put #1, pos2 + 1, vbbegoxx
MsgBox “Password: komunitasvbbego”, 64, “www.vbbego.com”
End Select
State = True
Exit For
End If ‘// Pos3
End If ‘// Pos1->2
End If ‘// Pos1->1
isiDok = “”
Next nLoop
Close #1
If State = False Then MsgBox “Password Tidak Ditemukan”, _
16, “www.vbbego.com”
End If
End Sub

yang ini source untuk module :

Option Explicit
Private Declare Function GetOpenFileName Lib “comdlg32.dll” Alias _
“GetOpenFileNameA” (pOpenfilename As OPENFILENAME) As Long

Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Function GetFile(Hwnd As Long) As String
Dim OFName As OPENFILENAME
OFName.lStructSize = Len(OFName)
OFName.hwndOwner = Hwnd
OFName.hInstance = App.hInstance
OFName.lpstrFilter = “Ms Ofice97/XP/2003(*.doc;*.xls)” _
+ Chr$(0) + “*.doc;*.xls” + Chr$(0) _
+ “Kabeh File (*.*)” + Chr$(0) + “*.*” + Chr$(0)
OFName.lpstrFile = Space$(254)
OFName.nMaxFile = 255
OFName.lpstrFileTitle = Space$(254)
OFName.nMaxFileTitle = 255
OFName.lpstrInitialDir = “C:\”
OFName.lpstrTitle = “Open File – vbBego Team 2000″
OFName.flags = 0
If GetOpenFileName(OFName) Then
GetFile = Left(OFName.lpstrFile, _
InStr(1, OFName.lpstrFile, Chr(0)) – 1)
Else
GetFile = “”
End If
End Function

Sumber : http://www.vbbego.net 

Posted in: Tip dan Trik