SecurityAudit

[vinay]

let me explain my project ...
I was handed this project by the CIO of Henkel CAC Mumbai.
This project wants me to scan the computer for softwares installed in the pc as soon as a pen drive is inserted in the usb slot.Basically he wants the software to auto run.

The organization has certain policies regarding the softwares installed in their PC.They are allowed to install only certain software and the rest of the softwares apart from the ones that they have defined as authorised are to be considered as unauthorized and must not be present.

My software has to scan the computer for both authorised and unauthorised software.
1> If unauthorised software/s is found a message has to be flashed listing the name of the unauthorized software/s and the user should be able to uninstall the software from my software itself and not frm the add or remove.
2> A log file is to be maintained of the scans and the logs should contain name of the computer to differentiate the scans done by the software and the state of authorised and unauthorised software of a particular computer.

So far i am able to list the softwares installed in the computer.

Difficulties:-If an authorized software is not installed ... how am i supposed to search for it and flash a message saying that the software is not installed...Should a database be involved in handling this situation or can it be done without a database.


FORM Code:-

Option Explicit
 
 
Private Sub Command1_Click()
    Unload Me
End Sub
 
Private Sub Form_Load()
    'Label1 = GetSettingString(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall", "")
 
Dim SubKeys As Variant
Dim KeyLoop As Integer
Dim sDispName As String
SubKeys = GetAllKeys(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall")
 
If VarType(SubKeys) = vbArray + vbString Then
    For KeyLoop = 0 To UBound(SubKeys)
        sDispName = GetSettingString(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\" & SubKeys(KeyLoop), "DisplayName")
        If sDispName > "" And Left(SubKeys(KeyLoop), 1) <> "{" Then
            List1.AddItem sDispName & " / " & SubKeys(KeyLoop)
        End If
    Next
End If
End Sub
 
 
Sub CallCodeForGetAllValuesInAKey(ByVal sIn As String)
Dim Values As Variant
Dim KeyLoop As Integer
Dim RegPath As String
Dim HKCU As Long
Dim sLine As String
HKCU = HKEY_LOCAL_MACHINE 'to save typing
RegPath = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\" & sIn
 
Values = GetAllValues(HKCU, RegPath)
 
If VarType(Values) = vbArray + vbVariant Then
 
For KeyLoop = 0 To UBound(Values)
    sLine = Values(KeyLoop, 0) & " = "
    
    Select Case Values(KeyLoop, 1)
    Case REG_DWORD
        sLine = sLine & GetSettingLong(HKCU, RegPath, _
        CStr(Values(KeyLoop, 0)))
    Case REG_BINARY
        sLine = sLine & GetSettingByte(HKCU, RegPath, _
        Hex$(Values(KeyLoop, 0)))(0)
    Case REG_SZ
        sLine = sLine & GetSettingString(HKCU, RegPath, _
        CStr(Values(KeyLoop, 0)))
    End Select
    List2.AddItem sLine
Next KeyLoop
 
End If
 
End Sub
 
Private Sub List1_Click()
    If List1.ListIndex < 0 Then
        Exit Sub
    End If
    List2.Clear
    CallCodeForGetAllValuesInAKey Mid(List1.Text, InStr(List1.Text, " / ") + 3)
    
End Sub 

Module code:-

Option Explicit
 
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Public Const HKEY_CURRENT_CONFIG = &H80000005
Public Const HKEY_DYN_DATA = &H80000006
Public Const REG_SZ = 1 'Unicode nul terminated string
Public Const REG_BINARY = 3 'Free form binary
Public Const REG_DWORD = 4 '32-bit number
Public Const ERROR_SUCCESS = 0&
 
Public Declare Function RegEnumValue Lib "advapi32.dll" 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 Any, lpcbData As Long) As Long
 
Public Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" _
(ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByVal cbName As Long) 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 RegDeleteKey Lib "advapi32.dll" _
Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey _
As String) As Long
 
Public Declare Function RegDeleteValue Lib "advapi32.dll" _
Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal _
lpValueName As String) 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
 
 
Public Function GetSettingString(hKey As Long, _
strPath As String, strValue As String, Optional _
Default As String) As String
Dim hCurKey As Long
Dim lResult As Long
Dim lValueType As Long
Dim strBuffer As String
Dim lDataBufferSize As Long
Dim intZeroPos As Integer
Dim lRegResult As Long
 
'Set up default value
If Not IsEmpty(Default) Then
GetSettingString = Default
Else
GetSettingString = ""
End If
 
lRegResult = RegOpenKey(hKey, strPath, hCurKey)
lRegResult = RegQueryValueEx(hCurKey, strValue, 0&, _
lValueType, ByVal 0&, lDataBufferSize)
 
If lRegResult = ERROR_SUCCESS Then
 
If lValueType = REG_SZ Then
 
strBuffer = String(lDataBufferSize, " ")
lResult = RegQueryValueEx(hCurKey, strValue, 0&, 0&, _
ByVal strBuffer, lDataBufferSize)
 
intZeroPos = InStr(strBuffer, Chr$(0))
If intZeroPos > 0 Then
GetSettingString = Left$(strBuffer, intZeroPos - 1)
Else
GetSettingString = strBuffer
End If
 
End If
 
Else
'there is a problem
End If
 
lRegResult = RegCloseKey(hCurKey)
End Function
Public Function GetSettingLong(ByVal hKey As Long, _
ByVal strPath As String, ByVal strValue As String, _
Optional Default As Long) As Long
 
Dim lRegResult As Long
Dim lValueType As Long
Dim lBuffer As Long
Dim lDataBufferSize As Long
Dim hCurKey As Long
 
'Set up default value
If Not IsEmpty(Default) Then
GetSettingLong = Default
Else
GetSettingLong = 0
End If
 
lRegResult = RegOpenKey(hKey, strPath, hCurKey)
lDataBufferSize = 4 '4 bytes = 32 bits = long
 
lRegResult = RegQueryValueEx(hCurKey, strValue, 0&, _
lValueType, lBuffer, lDataBufferSize)
 
If lRegResult = ERROR_SUCCESS Then
 
If lValueType = REG_DWORD Then
GetSettingLong = lBuffer
End If
 
Else
'there is a problem
End If
 
lRegResult = RegCloseKey(hCurKey)
End Function
 
Public Sub SaveSettingLong(ByVal hKey As Long, ByVal _
strPath As String, ByVal strValue As String, ByVal lData As Long)
Dim hCurKey As Long
Dim lRegResult As Long
 
lRegResult = RegCreateKey(hKey, strPath, hCurKey)
 
lRegResult = RegSetValueEx(hCurKey, strValue, 0&, _
REG_DWORD, lData, 4)
 
If lRegResult <> ERROR_SUCCESS Then
'there is a problem
End If
 
lRegResult = RegCloseKey(hCurKey)
End Sub
Public Sub SaveSettingString(hKey As Long, strPath _
As String, strValue As String, strData As String)
Dim hCurKey As Long
Dim lRegResult As Long
 
lRegResult = RegCreateKey(hKey, strPath, hCurKey)
 
lRegResult = RegSetValueEx(hCurKey, strValue, 0, REG_SZ, _
ByVal strData, Len(strData))
 
If lRegResult <> ERROR_SUCCESS Then
'there is a problem
End If
 
lRegResult = RegCloseKey(hCurKey)
End Sub
 
Public Function GetSettingByte(ByVal hKey As Long, _
ByVal strPath As String, ByVal strValueName As String, _
Optional Default As Variant) As Variant
Dim lValueType As Long
Dim byBuffer() As Byte
Dim lDataBufferSize As Long
Dim lRegResult As Long
Dim hCurKey As Long
 
If Not IsEmpty(Default) Then
If VarType(Default) = vbArray + vbByte Then
GetSettingByte = Default
Else
GetSettingByte = 0
End If
 
Else
GetSettingByte = 0
End If
 
lRegResult = RegOpenKey(hKey, strPath, hCurKey)
 
lRegResult = RegQueryValueEx(hCurKey, strValueName, 0&, _
lValueType, ByVal 0&, lDataBufferSize)
 
If lRegResult = ERROR_SUCCESS Then
 
If lValueType = REG_BINARY Then
 
ReDim byBuffer(lDataBufferSize - 1) As Byte
lRegResult = RegQueryValueEx(hCurKey, strValueName, 0&, _
lValueType, byBuffer(0), lDataBufferSize)
GetSettingByte = byBuffer
 
End If
 
Else
'there is a problem
End If
 
lRegResult = RegCloseKey(hCurKey)
 
End Function
 
 
Public Function GetAllValues(hKey As Long, _
strPath As String) As Variant
'Returns: a 2D array.
'(x,0) is value name
'(x,1) is value type (see constants)
 
Dim lRegResult As Long
Dim hCurKey As Long
Dim lValueNameSize As Long
Dim strValueName As String
Dim lCounter As Long
Dim byDataBuffer(4000) As Byte
Dim lDataBufferSize As Long
Dim lValueType As Long
Dim strNames() As String
Dim lTypes() As Long
Dim intZeroPos As Integer
 
lRegResult = RegOpenKey(hKey, strPath, hCurKey)
 
Do
    'Initialise bufffers
    lValueNameSize = 255
    strValueName = String$(lValueNameSize, " ")
    lDataBufferSize = 4000
    
    lRegResult = RegEnumValue(hCurKey, lCounter, _
    strValueName, lValueNameSize, 0&, lValueType, _
    byDataBuffer(0), lDataBufferSize)
    
    If lRegResult = ERROR_SUCCESS Then
    
        'Save the type
        ReDim Preserve strNames(lCounter) As String
        ReDim Preserve lTypes(lCounter) As Long
        lTypes(UBound(lTypes)) = lValueType
        
        'Tidy up string and save it
        intZeroPos = InStr(strValueName, Chr$(0))
        If intZeroPos > 0 Then
            strNames(UBound(strNames)) = _
            Left$(strValueName, intZeroPos - 1)