servermod.bas

优秀的木马程序,自己看吧

    frmMain.Show
End If
End Sub

Function MoveFile(oldPath As String, newPath As String, Winsock As Winsock)
    'Moves a file to new folder.
    'Sends "MOVED" to client when done, so that client may refresh file list
    On Error GoTo ErrorHandle
    Dim fSObj As FileSystemObject
    Set fSObj = CreateObject("Scripting.FileSystemObject")
    
    Call fSObj.MoveFile(oldPath, newPath) 'Move file
    
    Call Winsock.SendData("MOVED")
    
    sOutput "MOVE '" & oldPath & "' to '" & newPath & "' from IP '" & Winsock.RemoteHostIP & "'"
    Exit Function
ErrorHandle:
    Winsock.SendData "NOTMOVED"
    sOutput "Error occurred in MoveFile: " & Err.Description & " #: " & Err.Number
End Function

Function MoveFolder(oldPath As String, newPath As String, Winsock As Winsock)
    'Moves a folder and it's contents to new folder.
    'Sends "MOVED" to client when done, so that client may refresh file list
    On Error GoTo ErrorHandle
    Dim fSObj As FileSystemObject
    Set fSObj = CreateObject("Scripting.FileSystemObject")
    Dim BackSlash As Integer
    BackSlash = FindReverse(oldPath, "\")
    oldPath = Left(oldPath, BackSlash - 1)
    Call fSObj.MoveFolder(oldPath, newPath) 'Move folder
    
    Call Winsock.SendData("MOVED")
    
    sOutput "MOVE '" & oldPath & "' to '" & newPath & "' from IP '" & Winsock.RemoteHostIP & "'"
    Exit Function
ErrorHandle:
    Winsock.SendData "NOTMOVED"
    sOutput "Error occurred in MoveFolder: " & Err.Description & " #: " & Err.Number
End Function

Function FindReverse(str As String, char As String) As Integer
    'The opposite of InStr(). This function
    'will return the index of the specified character from the END
    'of the string, instead of the beginning
    ind = Len(str)
    
    Do While ind <> 1
        ch = Mid(str, ind, Len(char))
        If LCase(ch) = LCase(char) Then
            FindReverse = ind
            Exit Function
        End If
        ind = ind - 1
    Loop
    
    FindReverse = 0

End Function
Function SendDirectoryContents(Path As String, coll As Collection)
Dim objFso As New FileSystemObject
If Right(Path, 1) <> "\" Then Path = Path + "\"
    
    'This adds the files inside 'Path' (if any)
        mypath = Path
        myName = Dir(mypath)
        Do While myName <> "": DoEvents
            If myName <> "." And myName <> ".." Then
                If (GetAttr(mypath & myName) And vbDirectory) = vbDirectory Then GoTo next1
                coll.Add (mypath & myName)
                
            End If
next1:
            myName = Dir
        Loop
        
    Dim objDir1 As Folder
    Dim objDir2 As Folder
    Set objDir1 = objFso.GetFolder(Path)
    
    'This part adds all the files inside subfolders
    If objDir1.SubFolders.Count = 0 Then Exit Function
    
    For Each objDir2 In objDir1.SubFolders
        'add all the files inside the subfolder
        Call SendDirectoryContents(Path & objDir2.Name, coll)
    Next objDir2
    
    Set objDir1 = Nothing
    Set objDir2 = Nothing
    Set objFso = Nothing
     
End Function
Function ReadINI(AppName$, Keyname$, fileName$) As String
   Dim RetStr As String
   RetStr = String(255, Chr(0))
   ReadINI = Left(RetStr, GetPrivateProfileString(AppName$, ByVal Keyname$, "", RetStr, Len(RetStr), fileName$))
End Function
Function ReadEncryptedINI(xAppName As String, xSubitem As String, xPathToFile As String) As String
   'Just like ReadINI, but instead, reads an encrypted entry
   'in the INI, and decrypts it before returning the value
   'Very handy :)
   ReadEncryptedINI = Decrypt(ReadINI(xAppName, xSubitem, xPathToFile))
   
End Function

Function SendProcessesToClient(Winsock As Winsock)
    'Creates a data packet that the client can
    'translate into a list of processes running on this machine
Dim xData As String

KillApp "none", frmMain.lstProcesses

For X = 0 To frmMain.lstProcesses.ListCount - 1
    xData = xData & frmMain.lstProcesses.List(X) & "|"
Next X

xData = "PROCESSES->" & xData

Winsock.SendData (xData)

sOutput "Sent processes list to IP '" & Winsock.RemoteHostIP & "' (" & Len(xData) & " Bytes)"
End Function


Function ListBox_To_String(xList As ListBox)
    'Takes a ListBox control as an argument
    'loops through the list, and concatenates the items
    'into a string separated by semicolons
On Error Resume Next

If xList.ListCount = 0 Then
    sOutput "ListBox_To_String() Returned: No items to write. Cannot continue.": Exit Function
End If
For X = 0 To xList.ListCount - 1
    Item = xList.List(X)
If X = 0 Then xData = xData & Item: GoTo aa
    xData = xData & ";" & Item
aa:
    DoEvents
Next X
    ListBox_To_String = xData
End Function

Function StartProcess(xPath As String, Winsock As Winsock)
    'Will execute a program passed in xPath
    On Error GoTo error_handle
    If GetSetting("Andromeda", "Settings", "AllowProcessToggle", "0") = "0" Then
        Winsock.SendData ("ERROR: Process toggling not allowed.")
        Exit Function
    End If
    
    'In case of malicious intent...
    If InStr(UCase(xPath), "DELTREE") <> 0 Or InStr(UCase(xPath), "FDISK") <> 0 Or InStr(UCase(xPath), "FORMAT") <> 0 Then
        'Someone thinks it would be funny to ruin the computer...
        Winsock.SendData ("ERROR: You must be stupid to attempt to run that program.")
        Exit Function
    End If
    
    'Execute the process
    Call Shell(xPath, vbNormalFocus)
    
    Winsock.SendData ("STARTED=" & xPath)
    sOutput "Started '" & xPath & "' from IP '" & Winsock.RemoteHostIP & "'"
    Exit Function
error_handle:
    Winsock.SendData ("ERROR: An error occurred while trying to spawn the process: " & xPath)
End Function

Function TerminateRunningProcess(xPath As String, Winsock As Winsock)
    'Will execute a program passed in xPath
    If GetSetting("Andromeda", "Settings", "AllowProcessToggle") = "0" Then
        Winsock.SendData ("ERROR: Process toggling not allowed.")
        Exit Function
    End If
    On Error GoTo err_handle
    KillApp xPath, frmMain.lstProcesses
    Winsock.SendData ("TERMINATED=" & xPath)
    sOutput "Terminated'" & xPath & "' from IP '" & Winsock.RemoteHostIP & "'"
    
    Exit Function
err_handle:
    Winsock.SendData ("ERROR: Process not terminated.")
    sOutput "Error in TerminateRunningProcess: xPath = " & xPath
End Function

Function WriteINI(mizainz$, Place$, Toput$, AppName$)
    r% = WritePrivateProfileString(mizainz$, Place$, Toput$, AppName$)
End Function


Function WriteEncryptedINI(xAppName As String, xSubitem As String, xOutput As String, xPathToFile As String)
    xOutput = Encrypt(xOutput)
    r% = WritePrivateProfileString(xAppName, xSubitem, xOutput, xPathToFile)
End Function

Function AppName() As String
 AppName = "ndromeda RFS "
End Function

Sub ModifyUser(xUser As String)
    'Displays a dynamically created 'frmModifyUser'
    'and initializes it's fields to the properties for the
    'specified user
    If Exists(App.Path + "\" + xUser + ".alf") = False Then MsgBox "User '" & xUser & "' does not exist.", 16, "SERVER ERROR": Exit Sub
    Dim frmModifyUser2 As New frmModifyUser
    With frmModifyUser2
    
        .txtPassword = ReadEncryptedINI("Andromeda", "PW", App.Path + "\" + xUser + ".alf")
    
        .frameUser.Caption = "User settings for: " & xUser
        
        .Caption = "ndromeda - Settings for '" & xUser & "'"
        .txtUser = xUser
        .Show
    End With
        
End Sub
Public Function Exists(fizile As String) As Boolean
    'Checks for the existence of a file or folder.
    'Returns a Boolean value (T or F)
    On Error Resume Next
    If Dir(fizile) = "" Then
        Exists = False
    Else
        Exists = True
    End If
End Function

Sub RemoveFromRegistry()
    'Deletes the key in HKEY_LOCAL_MACHINE\_
    'Software\Microsoft\Windows\CurrentVersion\Run
    '(This allows the application to be executed when
    'windows is loaded
 Dim RetVal As Long, hKey As Long, ValueName As String, _
        SubKey As String, phkResult As Long, SA As SECURITY_ATTRIBUTES, _
        Create As Long
    hKey = HKEY_LOCAL_MACHINE
    SubKey = "SOFTWARE\Microsoft\Windows\CurrentVersion\Run\"
    RetVal = RegCreateKeyEx(hKey, SubKey, _
        0, "", REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, _
        SA, phkResult, Create)
    ValueName = "AndromedaRFS"
    RetVal = RegDeleteValue(phkResult, ValueName)
    RegCloseKey phkResult
End Sub


Sub FileTransferAdd(xFileName As String, xFileSize As Long, xIPAddress As String, xStatus As String)
    'Adds an item to the 'File Transfer' list on the
    'main window (frmMain). When files are transferred, either
    'to or from the server, it is recorded here, and if the option
    'is enabled for logging, it is written to the file transfer log
    '(App.Path + "\FTransfer.txt")
    With frmMain.lstTransfer
        Dim pinche As ListItem
        
        Set pinche = .ListItems.Add(1, , xFileName)
        pinche.SubItems(1) = xFileSize & " bytes"
        pinche.SubItems(2) = xIPAddress
        pinche.SubItems(3) = xStatus
    
    End With
End Sub

Function Encrypt(eString As String) As String
'Takes a string as an argument,
'and encrypts it. (Doubles the memory required for the string)
Dim nextChr As String
a$ = "