سورس کد حذف نگ اسکرین ویژوال بیسیک 6

کد:
'-----------------------------------------------'

'          **************************           '

'          * Universal Patch Engine *           '

'          **************************           '

' written by Rocky [a.k.a. Sangaletti Federico] '

'-----------------------------------------------'



Private Declare Function CharLower Lib "user32" Alias "CharLowerA" (ByVal lpsz As String) As String



'This constants need for patching

'----------------------------------------------------

Const EXEFileName = "VB6.exe" 'Name of file to patch

Const OriginalSize = 1880064  'Size of file

Const StartOffset = &H65A11   'First offset to patch

Const EndOffset = &H65A15     'Last offset to patch

'----------------------------------------------------



Dim BytesExtra As String



Private Sub Command1_Click()

   Label1.Caption = "Searching for EXE..."

   Bar 50 'Show the progress bar (only for fun ;-))

   If SearchFile = False Then

      'If file to patch doesn't exist exit

      MsgBox "Unable to find " & EXEFileName & "!", vbCritical

      Picture2.Cls

      Label1.Caption = "Ready to patch..."

      Exit Sub

   End If

   Label1.Caption = "Checking file size..."

   Bar 50 'Show the progress bar (only for fun ;-))

   If CheckSize = False Then

      'If size of file to patch is different, probably

      'it's a different version and the patch can't work

      MsgBox "Wrong file version (" & BytesExtra & ")", vbCritical

      Picture2.Cls

      Label1.Caption = "Ready to patch..."

      Exit Sub

   End If

   Label1.Caption = "Checking if already patched..."

   Bar 50 'Show the progress bar (only for fun ;-))

   If CheckAlreadyCracked = True Then

      'If file is already patched exit

      MsgBox "Already patched!", vbCritical

      Picture2.Cls

      Label1.Caption = "Ready to patch..."

      Exit Sub

   End If

   Label1.Caption = "Patching..."

   Bar 150 'Show the progress bar (only for fun ;-))

   If Crack = False Then

      'If there is an error during patching routine exit

      MsgBox "Patching error!" & vbCrLf & vbCrLf & Err.Description, vbCritical

      Picture2.Cls

      Label1.Caption = "Ready to patch..."

      Exit Sub

   End If

   Label1.Caption = "Patched complete!"

   'If patch have success show the message and show how many

   'bytes was changed

   MsgBox "Patched successfully!" & vbCrLf & vbCrLf & (EndOffset - StartOffset) + 1 & " bytes changed", vbExclamation

End Sub



Private Sub Bar(n As Long)

'Increasing progress bar



   Picture2.Cls

   i = Picture2.Width / n

   For n = 0 To n

      Picture2.Line (1, Picture2.Height)-(a, 1), 255, BF

      a = a + i

      DoEvents

      Delay

   Next n

End Sub

Private Sub Delay()

'Wait for a small time



   tm = Timer

   Do While Timer < tm + 0.01

      DoEvents

   Loop

End Sub



Private Function SearchFile() As Boolean

'This function check if file to patch exist



   If CharLower(Dir(EXEFileName)) = CharLower(EXEFileName) Then

      SearchFile = True

   Else

      SearchFile = False

   End If

End Function



Private Function CheckSize() As Boolean

'This function check the size of the original file



   If FileLen(EXEFileName) = OriginalSize Then

      CheckSize = True

   Else

      CheckSize = False

      If FileLen(EXEFileName) - OriginalSize > 0 Then

         BytesExtra = CStr(FileLen(EXEFileName) - OriginalSize) & " extra bytes"

      Else

         BytesExtra = CStr(Abs(FileLen(EXEFileName) - OriginalSize)) & " less bytes"

      End If

   End If

End Function



Private Function CheckAlreadyCracked() As Boolean

'This function chech if file is already patched



   Dim Buffer() As Byte

   Open EXEFileName For Binary As #1

      ReDim Buffer(LOF(1) - 1)

      Get #1, , Buffer

   Close #1

   If Buffer(StartOffset) = &H90 Then

      CheckAlreadyCracked = True

   Else

      CheckAlreadyCracked = False

   End If

   Erase Buffer

End Function



Private Function Crack() As Boolean

'This function put the original file in a byte array,

'modify the bytes to change and write the array over

'the original file



   On Error GoTo WARNING

   

   Dim Buffer() As Byte

   Open EXEFileName For Binary As #1

      ReDim Buffer(LOF(1) - 1)

      Get #1, , Buffer

   Close #1

   For i = StartOffset To EndOffset

      Buffer(i) = &H90

   Next i

   Open EXEFileName For Binary As #1

      Put #1, , Buffer

   Close #1

   Erase Buffer

   Crack = True

   Exit Function

   

WARNING:

   Crack = False

End Function