HELLO, Visitor

mengembalikan password yang tersimpan dalam Internet explorer v.8

Go down

mengembalikan password yang tersimpan dalam Internet explorer v.8

Post by Admin on Sat Oct 15, 2011 11:51 am



Form
sub:

[-]sebuah textbox
[-]sebuah command button
Source
Option Explicit

Private Sub Command1_Click()
    Text1.Text = mIEPass.GetIE & vbCrLf & "Done..."
End Sub

Module
Beri nama module menjadi mIEPass
source
mIEPASS:

Option Explicit

Private Declare Sub CopyBytes Lib "msvbvm60" Alias "__vbaCopyBytes" (ByVal Size As Long, Dest As Any, Source As Any)
Private Declare Function CryptUnprotectData Lib "crypt32" (ByRef pDataIn As DATA_BLOB, ByVal ppszDataDescr As Long, ByVal pOptionalEntropy As Long, ByVal pvReserved As Long, ByVal pPromptStruct As Long, ByVal dwFlags As Long, ByRef pDataOut As DATA_BLOB) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegEnumValue Lib "advapi32" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, lpData As Byte, lpcbData As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function CryptAcquireContext Lib "advapi32" Alias "CryptAcquireContextA" (ByRef phProv As Long, ByVal pszContainer As Long, ByVal pszProvider As String, ByVal dwProvType As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptCreateHash Lib "advapi32" (ByVal hProv As Long, ByVal Algid As Long, ByVal hKey As Long, ByVal dwFlags As Long, ByRef phHash As Long) As Long
Private Declare Function CryptHashData Lib "advapi32" (ByVal hHash As Long, ByVal pbData As Long, ByVal dwDataLen As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptGetHashParam Lib "advapi32" (ByVal hHash As Long, ByVal dwParam As Long, ByVal pByte As Long, ByRef pdwDataLen As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptSignHash Lib "advapi32" Alias "CryptSignHashA" (ByVal hHash As Long, ByVal dwKeySpec As Long, ByVal sDescription As Long, ByVal dwFlags As Long, ByVal pbSignature As Long, ByRef pdwSigLen As Long) As Long
Private Declare Function CryptDestroyHash Lib "advapi32" (ByVal hHash As Long) As Long
Private Declare Function CryptReleaseContext Lib "advapi32" (ByVal hProv As Long, ByVal dwFlags As Long) As Long
Private Declare Function CredEnumerate Lib "advapi32" Alias "CredEnumerateW" (ByVal lpszFilter As Long, ByVal lFlags As Long, ByRef pCount As Long, ByRef lppCredentials As Long) As Long
Private Declare Function FindFirstUrlCacheEntry Lib "wininet" Alias "FindFirstUrlCacheEntryA" (ByVal lpszUrlSearchPattern As String, lpFirstCacheEntryInfo As Any, lpdwFirstCacheEntryInfobufDataerSize As Long) As Long
Private Declare Function FindNextUrlCacheEntry Lib "wininet" Alias "FindNextUrlCacheEntryA" (ByVal hEnumHandle As Long, lpNextCacheEntryInfo As Any, lpdwNextCacheEntryInfobufDataerSize As Long) As Long
Private Declare Function lstrlenA Lib "kernel32" (ByVal ptr As Any) As Long
Private Declare Function lstrcpyA Lib "kernel32" (ByVal RetVal As String, ByVal ptr As Long) As Long
Private Declare Function SysAllocString Lib "oleaut32" (ByVal pOlechar As Long) As String

Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
Private Type StringIndexHeader
    dwWICK As Long
    dwStructSize As Long
    dwEntriesCount As Long
    dwUnkId As Long
    dwType As Long
    dwUnk As Long
End Type
Private Type StringIndexEntry
    dwDataOffset As Long
    ftInsertDateTime As FILETIME
    dwDataSize As Long
End Type
Private Type DATA_BLOB
    cbData As Long
    pbData As Long
End Type
Private Type CREDENTIAL
    dwFlags As Long
    dwType As Long
    lpstrTargetName As Long
    lpstrComment As Long
    ftLastWritten As FILETIME
    dwCredentialBlobSize As Long
    lpbCredentialBlob As Long
    dwPersist As Long
    dwAttributeCount As Long
    lpAttributes As Long
    lpstrTargetAlias As Long
    lpUserName As Long
End Type
Private Type INTERNET_CACHE_ENTRY_INFO
   dwStructSize As Long
   lpszSourceUrlName As Long
   lpszLocalFileName As Long
   CacheEntryType  As Long
   dwUseCount As Long
   dwHitRate As Long
   dwSizeLow As Long
   dwSizeHigh As Long
   LastModifiedTime As FILETIME
   ExpireTime As FILETIME
   LastAccessTime As FILETIME
   LastSyncTime As FILETIME
   lpHeaderInfo As Long
   dwHeaderInfoSize As Long
   lpszFileExtension As Long
   dwExemptDelta  As Long
End Type

Private Const NORMAL_CACHE_ENTRY            As Long = &H1
Private Const URLHISTORY_CACHE_ENTRY        As Long = &H200000
Private Const HKEY_CURRENT_USER                As Long = &H80000001
Private Const IE_KEY                        As String = "Software\Microsoft\Internet Explorer\IntelliForms\Storage2"
Private Const READ_CONTROL                  As Long = &H20000
Private Const SYNCHRONIZE                   As Long = &H100000
Private Const KEY_ENUMERATE_SUB_KEYS        As Long = &H8
Private Const KEY_QUERY_VALUE               As Long = &H1
Private Const KEY_NOTIFY                    As Long = &H10
Private Const KEY_READ                      As Long = ((READ_CONTROL Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))
Private Const ERROR_SUCCESS                 As Long = 0&
Private Const PROV_RSA_FULL                 As Long = 1&
Private Const ALG_CLASS_HASH                As Long = (4 * 2 ^ 13)
Private Const ALG_TYPE_ANY                  As Long = 0
Private Const ALG_SID_SHA                   As Long = 4
Private Const CALG_SHA                      As Long = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_SHA)
Private Const HP_HASHVAL                    As Long = &H2
Private hKey As Long
Private m_Data As String
Private m_Storage() As String
Private i As Integer
Public Function GetIE() As String
    On Local Error Resume Next
   
    Dim x As Integer
    Dim strOut() As String, strSplit() As String, strHash() As String
   
    m_Data = vbNullString: Erase m_Storage: hKey = 0
   
    Call GetStorage2
    Call GetCredentials
   
    If Len(m_Data) = 0 Then Exit Function
    strOut = Split(m_Data, vbFormFeed)
   
    ReDim Preserve m_Storage(0 To UBound(strOut) - 1)
    For i = 0 To UBound(strOut) - 1
        strSplit = Split(strOut(i), vbVerticalTab)
       
        For x = 0 To UBound(m_Storage)
            If m_Storage(x) = strSplit(3) And m_Storage(x) <> "n/a" Then GoTo skipMsg
        Next x

        GetIE = GetIE & "URL: " & strSplit(0) & vbCrLf & "Username: " & strSplit(1) & vbCrLf & "Password: " & strSplit(2) & vbCrLf & "Hash: " & strSplit(3) & vbCrLf & vbCrLf
skipMsg:
        m_Storage(i) = strSplit(3)
    Next i
End Function
Private Sub GetCredentials()
    Dim tmp As String, sRes As String, sURL As String, tAuth() As String
    Dim ptrData As Long, dwNumCreds As Long, lpCredentials As Long
    Dim bufData(36) As Integer, x As Integer
    Dim m_Cred As CREDENTIAL, dataIn As DATA_BLOB, dataOut As DATA_BLOB, dataEntry As DATA_BLOB

    Call CredEnumerate(StrPtr("Microsoft_WinInet_*"), 0, dwNumCreds, lpCredentials)
    If dwNumCreds Then
        For i = 0 To dwNumCreds - 1
            CopyBytes 4&, ByVal VarPtr(ptrData), ByVal lpCredentials + (i) * 4: CopyBytes LenB(m_Cred), ByVal VarPtr(m_Cred), ByVal ptrData
            sRes = CopyString(m_Cred.lpstrTargetName): dataEntry.cbData = 74
            For x = 0 To 36: bufData(x) = CInt(Asc(Mid("abe2869f-9b47-4cd9-a358-c22904dba7f7" & vbNullChar, x + 1, 1)) * 4): Next
           
            dataEntry.pbData = VarPtr(bufData(0)): dataIn.pbData = m_Cred.lpbCredentialBlob: dataIn.cbData = m_Cred.dwCredentialBlobSize: dataOut.cbData = 0: dataOut.pbData = 0
            Call CryptUnprotectData(dataIn, ByVal 0&, ByVal VarPtr(dataEntry), ByVal 0&, ByVal 0&, 0, dataOut)
           
            tmp = Space(dataOut.cbData \ 2 - 1)
            CopyBytes dataOut.cbData, ByVal StrPtr(tmp), ByVal dataOut.pbData
            tAuth = Split(tmp, ":"): x = InStr(Mid$(sRes, 19), "/")
           
            If x > 0 Then
                sURL = Mid$(sRes, 19, x - 1)
            Else
                sURL = Mid$(sRes, 19)
            End If
           
            m_Data = m_Data & sURL & vbVerticalTab & tAuth(0) & vbVerticalTab & tAuth(1) & vbVerticalTab & "n/a" & vbFormFeed
        Next
    End If
End Sub
Private Sub GetStorage2()
    Dim tmp As String, sRet As String, sHash As String
    Dim m_Cache As Long, dwSize As Long, cbData As Long
    Dim x As Integer, z As Integer
    Dim bufData() As Byte
   
    Dim m_URL As INTERNET_CACHE_ENTRY_INFO
    If RegOpenKeyEx(HKEY_CURRENT_USER, IE_KEY, 0&, KEY_READ, hKey) <> ERROR_SUCCESS Then Exit Sub
       
    Do
        sRet = Space(4096)
        If RegEnumValue(hKey, z, sRet, 4096, 0, ByVal 0&, ByVal 0&, ByVal 0&) <> 0 Then Exit Do
        sRet = StripTerminator(sRet)
       
        m_Cache = FindFirstUrlCacheEntry(vbNullString, ByVal 0&, dwSize)
        If dwSize Then
            ReDim bufData(dwSize - 1): CopyBytes 4&, bufData(0), dwSize
            m_Cache = FindFirstUrlCacheEntry(vbNullString, bufData(0), dwSize)
        Else
            Exit Sub
        End If
       
            Do
                CopyBytes LenB(m_URL), m_URL, bufData(0)
                If (m_URL.CacheEntryType And (NORMAL_CACHE_ENTRY Or URLHISTORY_CACHE_ENTRY)) = (NORMAL_CACHE_ENTRY Or URLHISTORY_CACHE_ENTRY) Then
                    tmp = Trim(GetStrFromPtrA(m_URL.lpszSourceUrlName))
                                       
                    x = InStr(tmp, "file://")
                    If x Then GoTo Nxt
                    x = InStr(tmp, "@")
                    If x Then tmp = Mid(tmp, x + 1)
                    x = InStr(tmp, "?")
                    If x Then tmp = Left(tmp, x - 1)
                    tmp = LCase(tmp)
                   
                    sHash = GetSHA1Hash(StrPtr(tmp), (Len(tmp) + 1) * 2)
                    If sHash = sRet Then
                        RegQueryValueEx hKey, sHash, 0&, 3, ByVal 0&, cbData
                        If cbData Then Call DecryptData(tmp, sHash, cbData)
                     Else
                        tmp = tmp & "/"
                        sHash = GetSHA1Hash(StrPtr(tmp), (Len(tmp) + 1) * 2)
                        If sHash = sRet Then
                            RegQueryValueEx hKey, sHash, 0&, 3, ByVal 0&, cbData
                            If cbData Then Call DecryptData(tmp, sHash, cbData)
                        End If
                    End If
                End If
               
Nxt:
                dwSize = 0: Call FindNextUrlCacheEntry(m_Cache, ByVal 0&, dwSize)
                If dwSize Then
                    ReDim bufData(dwSize - 1)
                    CopyBytes 4&, bufData(0), dwSize
                End If
               
            Loop While FindNextUrlCacheEntry(m_Cache, bufData(0), dwSize)
               
        z = z + 1
    Loop
End Sub
Private Sub DecryptData(sURL As String, sHash As String, ByVal cbData As Long)
    Dim sUsername As String, sPassword As String
    Dim ptrData As Long, ptrEntry As Long

    Dim hIndex As StringIndexHeader, eIndex As StringIndexEntry
    Dim dataIn As DATA_BLOB, dataOut As DATA_BLOB, dataEntry As DATA_BLOB

    Dim bufData() As Byte

    ReDim bufData(cbData - 1)
    Call RegQueryValueEx(hKey, sHash, 0&, 3, bufData(0), cbData)
    dataIn.cbData = cbData: dataIn.pbData = VarPtr(bufData(0))
    dataEntry.cbData = (Len(sURL) + 1) * 2: dataEntry.pbData = StrPtr(sURL)
    Call CryptUnprotectData(dataIn, 0&, ByVal VarPtr(dataEntry), 0&, 0&, 0&, dataOut)
   
    ReDim bufData(dataOut.cbData - 1)
    CopyBytes dataOut.cbData, bufData(0), ByVal dataOut.pbData
   
    CopyBytes Len(hIndex), hIndex, bufData(bufData(0))
   
    If hIndex.dwType = 1 Then
        If hIndex.dwEntriesCount >= 2 Then
            ptrEntry = VarPtr(bufData(bufData(0))) + hIndex.dwStructSize
           
            ptrData = ptrEntry + hIndex.dwEntriesCount * Len(eIndex)
            If ptrData = 0 Or ptrEntry = 0 Then Exit Sub
           
            For i = 1 To hIndex.dwEntriesCount / 2
                If i <> 1 Then ptrEntry = ptrEntry + Len(eIndex)
               
                CopyBytes Len(eIndex), eIndex, ByVal ptrEntry
                sUsername = Space(eIndex.dwDataSize)
                If lstrlenA(ptrData + eIndex.dwDataOffset) <> eIndex.dwDataSize Then
                    CopyBytes eIndex.dwDataSize * 2, ByVal StrPtr(sUsername), ByVal ptrData + eIndex.dwDataOffset
                Else
                    CopyBytes eIndex.dwDataSize, ByVal sUsername, ByVal ptrData + eIndex.dwDataOffset
                End If
                ptrEntry = ptrEntry + Len(eIndex)
                CopyBytes Len(eIndex), eIndex, ByVal ptrEntry
                sPassword = Space(eIndex.dwDataSize)
                If lstrlenA(ptrData + eIndex.dwDataOffset) <> eIndex.dwDataSize Then
                    Call CopyBytes(eIndex.dwDataSize * 2, ByVal StrPtr(sPassword), ByVal ptrData + eIndex.dwDataOffset)
                Else
                    Call CopyBytes(eIndex.dwDataSize, ByVal sPassword, ByVal ptrData + eIndex.dwDataOffset)
                End If
           
                m_Data = m_Data & sURL & vbVerticalTab & sUsername & vbVerticalTab & sPassword & vbVerticalTab & sHash & "/" & i & vbFormFeed
            Next i
           
        End If
    End If
End Sub
Private Function GetSHA1Hash(ByVal pbData As Long, ByVal dwDataLen As Long) As String
    Dim hProv As Long, hHash As Long
    Dim bufData(20) As Byte
   
    Call CryptAcquireContext(hProv, 0&, vbNullString, PROV_RSA_FULL, 0&)
    Call CryptCreateHash(hProv, CALG_SHA, 0&, 0&, hHash)
    Call CryptHashData(hHash, pbData, dwDataLen, 0&)
    Call CryptGetHashParam(hHash, HP_HASHVAL, ByVal VarPtr(bufData(0)), 20, 0)
    Call CryptDestroyHash(hHash)
    Call CryptReleaseContext(hProv, 0&)
       
    For i = 0 To 19: GetSHA1Hash = GetSHA1Hash & Right("00" & Hex$(bufData(i)), 2): Next
   
    GetSHA1Hash = GetSHA1Hash & Right("00" & Hex$(CheckSum(GetSHA1Hash)), 2)
End Function
Private Function CheckSum(s As String) As Byte
    Dim sum As Long
   
    For i = 1 To Len(s) Step 2: sum = sum + Val("&H" & Mid(s, i, 2)): Next
    CheckSum = CByte(sum Mod 256)
End Function
Private Function StripTerminator(s As String) As String
    Dim z As Integer
   
    z = InStr(1, s, vbNullChar)
    If z > 0 Then
        StripTerminator = Left$(s, z - 1)
    Else
        StripTerminator = s
    End If
End Function
Private Function CopyString(ByVal ptr As Long) As String
    If ptr Then
        CopyString = StrConv(SysAllocString(ptr), vbFromUnicode)
    Else
        CopyString = vbNullString
    End If
End Function
Private Function GetStrFromPtrA(ByVal lpszA As Long) As String
   GetStrFromPtrA = String$(lstrlenA(ByVal lpszA), 0)
   Call lstrcpyA(ByVal GetStrFromPtrA, ByVal lpszA)
End Function

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
[You must be registered and logged in to see this image.]
~Forumnya Anak Indonesia~
avatar
Admin
Admin
Admin

Leo

Jumlah posting : 69
Points : 2777
Reputation : 2
Join date : 10.10.11
Age : 33
Lokasi : Kolaka,sultra Indonesia

http://cyber.forum-canada.com

Kembali Ke Atas Go down

Kembali Ke Atas

- Similar topics

 
Permissions in this forum:
Anda tidak dapat menjawab topik