Jebol password MYOB ( Script VB)

'uji coba hanya pada MYob ver 10.5
Option Explicit

Private Sub Form_Load()
Dim pwd As String
pwd = GetMyOBPWD("E:\vbBego\myob\test.dat")'ganti dengan alamat path MYob yg
' ada passwx
If pwd <> "" Then
MsgBox "Password: " & pwd, 64, "vbBego"
Else
MsgBox "Tidak ber Password", 16, "vbBego"
End If
End Sub


Function GetMyOBPWD(hFile As String) As String
Dim Head
Dim I As Integer
Dim PosKey As String
Dim inFile As Long
Dim nLoop As Long
Dim isiDok As String * 1000
Dim Pos1 As Long
Dim posChar As String
Dim resPwd As String
Dim tmpPWD As String

Head = Split("8D 96 9D 95 8D 96 9D 95 8D 96 9D", " ")
PosKey = Chr(&H0) & Chr(&H1C) & Chr(&H0) & Chr(&H1) & _
String(9, Chr(0)) & Chr(1) & Chr(0)
inFile = FileLen(hFile)
Open hFile For Binary Access Read As #1
For nLoop = 1 To inFile Step 1024
Get #1, nLoop, isiDok
DoEvents
Pos1 = InStr(1, isiDok, PosKey, vbBinaryCompare)
If Pos1 Then
Dim H As String * 11
Get #1, nLoop + Pos1 + 68, H
For I = 1 To Len(H)
posChar = Mid(H, I, 1)
If Asc(posChar) > 0 Then
If Asc(posChar) > "&H" & Head(I - 1) Then
resPwd = resPwd & Chr(Asc(posChar) - Val( _
"&H" & Head(I - 1)))
Else
resPwd = resPwd & Chr(Asc(posChar) + (255 - Val( _
"&H" & Head(I - 1))))
End If
End If
Next I
tmpPWD = resPwd
resPwd = ""
End If
isiDok = ""
Next nLoop
Close #1
GetMyOBPWD = tmpPWD
End Function