Attribute VB_Name = "modIESpy"

Dim cipher As New eb_c_Cipher
'******************************************************************************************
'******************************************************************************************
'***                                                                                    ***
'***  This application is intended to track and log the URL of all open instances       ***
'***  of Internet Explorer and can be easily modified to track other web browsers       ***
'***  as well.  There are many administrative options and all stored values are         ***
'***  retained in the registry under HKLM\Software\IE Spy\Application Settings\.        ***
'***                                                                                    ***
'***  I intend on using this as a service on my LAN machines.  In this instance I       ***
'***  have each workstation logging locally, however it is easy enough to change        ***
'***  the log file to one that is on the network that everyone has Write only access    ***
'***  to, then you have a central repository for all computers.  The log file is        ***
'***  written as a Tab Delimited file so you can do what you please with it.            ***
'***                                                                                    ***
'***  This code comes with no warantees, guarantees, sureties, promises or anything     ***
'***  of the sort.  I got it to work on my machine, it may take a little work and       ***
'***  modification to get it to work on yours.  But then again, isn't that what PSC     ***
'***  is about?  I see too many people nowadays want things done for them, here is      ***
'***  a tool for you to use, you know how to use it, use it.                            ***
'***                                                                                    ***
'***  While most of the code in here is original, some has been copied exactly from     ***
'***  another author or I have modified code written by another author.  In either      ***
'***  case, credit has been given where credit is due.  I ask that if you copy any      ***
'***  code from here, you give props to the original author - whether it be me or       ***
'***  someone else.                                                                     ***
'***                                                                                    ***
'***  The original concept of this program comes from Venkat Mani and the encryption    ***
'***  routines were borrowed David Midkiff's EBCrypt program.  The use of Password      ***
'***  characters in the inputbox was copied from Arkadiy Olovyannikov.                  ***
'***                                                                                    ***
'***  To see the original works respectively, go to:                                    ***
'***  http://www.planetsourcecode.com/vb/scripts/ShowCode.asp?txtCodeId=14474&lngWId=1  ***
'***  http://www.freevbcode.com/ShowCode.Asp?ID=3779                                    ***
'***  http://www.freevbcode.com/ShowCode.Asp?ID=1214                                    ***
'***                                                                                    ***
'***  When I started this project, I knew nothing about Windows Handles.  While I am    ***
'***  by no means quite clear on the concept, I have a better understanding - thank     ***
'***  you debugger!                                                                     ***
'***                                                                                    ***
'***  I know everything on PSC revolves around votes, I don't care about votes.  If     ***
'***  you like it and feel it is worthy of voting, please do, if not, then please       ***
'***  don't.  What I find of much more value is constructive criticism.  Please post    ***
'***  your comments for the benefit of all.                                             ***
'***                                                                                    ***
'******************************************************************************************
'******************************************************************************************
'***                                                                                    ***
'***  NOTE:  PLEASE SEE THE COMMENTS IN PUBLIC FUNCTION ENCRYPTSTRING BEFORE            ***
'***  ATTEMPTING TO RUN THIS APPLICATION!!                                              ***
'***                                                                                    ***
'******************************************************************************************
'******************************************************************************************

Option Explicit

Public Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Public Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Public Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Public Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Public Declare Function GetDesktopWindow Lib "user32" () As Long
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Public Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public Declare Function RegQueryValueEx Lib "advapi32.dll" 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
Public Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Private Declare Function EnumChildWindows Lib "user32" (ByVal hWndParent As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Boolean

' Code to put Password Chars in InputBox
' Code provided by Arkadiy Olovyannikov at Far-Eastern State Marine University
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Public Declare Function SetTimer& Lib "user32" (ByVal hwnd&, ByVal nIDEvent&, ByVal uElapse&, ByVal lpTimerFunc&)
Private Declare Function KillTimer& Lib "user32" (ByVal hwnd&, ByVal nIDEvent&)
    
Const EM_SETPASSWORDCHAR = &HCC
Public Const NV_INPUTBOX As Long = &H5000&
' End Password Chars code

Public Const SW_HIDE = 0
Public Const SW_NORMAL = 1
Public Const VK_F10 = &H79
Public Const VK_F9 = &H78
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const ERROR_SUCCESS = 0&
Public Const WM_GETTEXT = &HD
Public Const WM_GETTEXTLENGTH = &HE
Public Const VK_LBUTTON = &H1
Public Const VK_RETURN = &HD
Public Const REG_SZ = 1                         ' Unicode nul terminated string

' Local pointer to the main form list box
Private mListBox As Control

Global strLogFile As String
Global intRefreshRate As Integer
Global varRefreshRateValue As Variant
Global intRefreshRateSeconds As Integer
Global intLogInterval As Integer
Global strLogIntervalRate As String
Global strAdminPassword As String
Global strEncryptedPassword As String
Global bolNoClick As Boolean
Global bolAllowUserExit As Boolean
Global bolAllowUserEdit As Boolean
Global tmeNextWriteTime As Date



Public Sub ListChildWindows(ctlListBox As Control, hwnd As Long)

  Dim bolngResult As Boolean

  ' Grab the pointer to the main form list box
  Set mListBox = ctlListBox

  ' Clear the referenced list box
  mListBox.Clear

  ' Make the call to start the callback series
  bolngResult = EnumChildWindows(hwnd, AddressOf ChildCallback, 0&)

End Sub

Public Function ChildCallback(ByVal hWndChild As Long, lRaram As Long) As Boolean

  Dim strTempSting  As String
  Dim strListText As String
  Dim lngResult As Long

  ' Get the window text for the child window
  strTempSting = String(255, " ")
  lngResult = GetWindowText(hWndChild, ByVal strTempSting, 254&)

  ' Build a string containing the window text
  If InStr(1, strTempSting, vbNullChar) > 0 Then
    strTempSting = Left$(strTempSting, Len(strTempSting) - 1)
  End If

  ' Concatenate the window handle and text
  strListText = hWndChild & " - " & strTempSting

  ' Add the item to the list box
  mListBox.AddItem strListText

  ' Set the return value to keep the callback going
  ChildCallback = True

End Function


Public Sub ImOuttaHere()
  ' Procedure to close all open windown and exit safely
  Dim intLoop As Integer
  On Error Resume Next  'We're trying to exit here, so bail if there 's an Error
  For intLoop = Forms.Count - 1 To 0 Step -1
      Unload Forms(intLoop)
      Set Forms(intLoop) = Nothing
  Next intLoop
  'We now exit the app
  End
End Sub

Public Function GetRegistryString(hKey As Long, strPath As String, strValue)

  ' Standard GetRegistryString function, no explanation should be necessary
  Dim lngKeyHand As Long
  Dim lngDataType As Long
  Dim lngResult As Long
  Dim strBuf As String
  Dim lngDataBufSize As Long
  Dim intZeroPos As Integer
  Dim lngR As Long
  Dim lngvaluetype As Long
  
  lngR = RegOpenKey(hKey, strPath, lngKeyHand)
  lngResult = RegQueryValueEx(lngKeyHand, strValue, 0&, lngvaluetype, ByVal 0&, lngDataBufSize)
  
  If lngvaluetype = REG_SZ Then
      strBuf = String(lngDataBufSize, " ")
      lngResult = RegQueryValueEx(lngKeyHand, strValue, 0&, 0&, ByVal strBuf, lngDataBufSize)
      If lngResult = ERROR_SUCCESS Then
          intZeroPos = InStr(strBuf, Chr$(0))
          If intZeroPos > 0 Then
              GetRegistryString = Left$(strBuf, intZeroPos - 1)
          Else
              GetRegistryString = strBuf
          End If
      End If
  End If
End Function

Public Sub SaveRegistryString(hKey As Long, strPath As String, strValue As String, strdata As String)
  ' Standard SaveRegistryString function, no explanation should be necessary
  Dim lngKeyHand As Long
  Dim lngR As Long
  
  lngR = RegCreateKey(hKey, strPath, lngKeyHand)
  lngR = RegSetValueEx(lngKeyHand, strValue, 0, REG_SZ, ByVal strdata, Len(strdata))
  lngR = RegCloseKey(lngKeyHand)
End Sub


Public Sub GetRegistrySettings()
  ' Retrieve the settings from the Registry, located at "HKLM\Software\IESpy\Application Settings\"
  strLogFile = GetRegistryString(HKEY_LOCAL_MACHINE, "Software\IESpy\Application Settings", "Log File")
  intLogInterval = GetRegistryString(HKEY_LOCAL_MACHINE, "Software\IESpy\Application Settings", "Logging Interval")
  strLogIntervalRate = GetRegistryString(HKEY_LOCAL_MACHINE, "Software\IESpy\Application Settings", "Logging Rate")
  strEncryptedPassword = GetRegistryString(HKEY_LOCAL_MACHINE, "Software\IESpy\Application Settings", "Admin Password")
  intRefreshRateSeconds = GetRegistryString(HKEY_LOCAL_MACHINE, "Software\IESpy\Application Settings", "Refresh Rate in Seconds")
  intRefreshRate = GetRegistryString(HKEY_LOCAL_MACHINE, "Software\IESpy\Application Settings", "Refresh Rate")
  bolAllowUserEdit = GetRegistryString(HKEY_LOCAL_MACHINE, "Software\IESpy\Application Settings", "Allow User Edit")
  bolAllowUserExit = GetRegistryString(HKEY_LOCAL_MACHINE, "Software\IESpy\Application Settings", "Allow User Exit")
  
  ' The first thing we check for is the existance of an Admin Password.  If one exists then
  '   we decrypt it and return the value in the strAdminPassword variable
  If strEncryptedPassword <> "" Then strAdminPassword = DecryptString(strEncryptedPassword, "Astr0nOm1caL", "񰀯e^")
  
  ' If the logfile is populated then we load that value in the strLogFile variable, otherwise
  '   we set a default Log File of App.Path & "\IESpy.log"
  If strLogFile = "" Then strLogFile = App.path & "\IESpy.log"
  WriteRegistryEntry "Log File", strLogFile

  ' Next check to see how often we write out to the log file.  The value -if there is one -  is
  '   loaded into intLogInterval.  If there is no value, the default is 5.....
  If intLogInterval = 0 Then intLogInterval = "5"
  WriteRegistryEntry "Logging Interval", Str(intLogInterval)
  
  ' minutes, which is then loaded into strLogIntervalRate
  If strLogIntervalRate = "" Then strLogIntervalRate = "n"
  WriteRegistryEntry "Logging Rate", strLogIntervalRate
  
  ' If there is no default value set for the Refresh Rate (rate in which the computer is scanned
  '   for instances of Internet Explorer) then we set the default value to 12 which corresponds
  '   the the frmAdmin.lstRefreshRate.ListIndex of 300 miliseconds.  The value is loaded into
  '   intRefreshRate
  If intRefreshRate = 0 Then intRefreshRate = "12"
  WriteRegistryEntry "Refresh Rate", Str(intRefreshRate)
  
End Sub

Public Sub WriteRegistryEntry(RegString As String, Value As String)
  Call SaveRegistryString(HKEY_LOCAL_MACHINE, "Software\IESpy\Application Settings", _
    RegString, Trim(Value))
End Sub

'*************************************************************************************
'   Encryption Routine
'
'   This encryption routine was derived from David Midkiff's EBCrypt:
'     http://www.freevbcode.com/ShowCode.Asp?ID=3779
'
'   In order to run this Triple-DES encryption algorithm, you will need
'     to place the file EBCrypt.dll in the %SystemRoot%\System[32] directory
'     and register the DLL.
'*************************************************************************************

Public Function EncryptString(Text As String, Key As String, Salt As String) As String
    On Error GoTo errorhandler
    Dim cipher As ebCryptLib.eb_c_Cipher
    Set cipher = New ebCryptLib.eb_c_Cipher
    EncryptString = StrConv(cipher.EncryptString(EB_CRYPT_CIPHER_ALGORITHM_DES3_OFB, Key, Salt, Text), vbUnicode)
    Exit Function

errorhandler:
MsgBox Err.Description & vbCr & "Error: " & Err.Source & vbCr & "Source: " & Err.Source
End Function


Public Function DecryptString(CipherText As String, Key As String, Salt As String) As String
    On Error GoTo errorhandler
    Dim cipher As ebCryptLib.eb_c_Cipher, BArray() As Byte
    Set cipher = New ebCryptLib.eb_c_Cipher
    BArray() = StrConv(CipherText, vbFromUnicode)
    DecryptString = cipher.DecryptString(EB_CRYPT_CIPHER_ALGORITHM_DES3_OFB, Key, Salt, BArray())
    Exit Function
    
errorhandler:
MsgBox Err.Description
End Function

'*************************************************************************************
'   Code to put Password Chars in InputBox
'
'   This routine was copied from a snippet by Arkadiy Olovyannikov:
'     http://www.freevbcode.com/ShowCode.Asp?ID=1214
'
'*************************************************************************************

Public Sub TimerProc(ByVal hwnd&, ByVal uMsg&, ByVal idEvent&, ByVal dwTime&)

    Dim EditHwnd As Long

' CHANGE APP.TITLE TO YOUR INPUT BOX TITLE.

    EditHwnd = FindWindowEx(FindWindow("#32770", App.Title), 0, "Edit", "")

    Call SendMessage(EditHwnd, EM_SETPASSWORDCHAR, 42, 0)
    KillTimer hwnd, idEvent
End Sub
