DELPHI - Все о Дельфи

ICQ Client 1.21

ADMIN — Fri, 20 Apr 2007 19:20:36 GMT

исходник программы, предназначенной для обмена мгновенными сообщениями (полный аналог ICQ). Это небольшая компонента, которая позволяет вам общаться с ICQ пользователями прямо из вашей программы. Исходники довольно хорошо описаны (правда на английском), так что можно без проблем расширять возможности компоненты

Скачать

Компонент вставляет ссылку в Вашу программу

ADMIN — Fri, 20 Apr 2007 19:18:29 GMT

Компонент сделан на базе стандартного компонента Label. Компонент вставляет ссылку в вашу программу.

Скачать

Простая программа, записывает когда включается и выключается компьютер

ADMIN — Fri, 20 Apr 2007 19:17:26 GMT

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;

type
TForm1 = class(TForm)
Memo1: TMemo;
procedure FormActivate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormActivate(Sender: TObject);
begin
Application.Minimize;
ShowWindow(Application.Handle, SW_HIDE);
Memo1.Lines.LoadFromFile('show.txt');
Memo1.Lines.Add('Êîìïüþòåð áûë âêëþ÷åí ' + DateToStr(Now) + ' ' + TimeToStr(Now));
Memo1.Lines.SaveToFile('show.txt');
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Memo1.Lines.Add('Êîìïüþòåð áûë âûêëþ÷åí ' + DateToStr(Now)+ ' ' + TimeToStr(Now));
Memo1.Lines.SaveToFile('show.txt');
end;

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
Memo1.Lines.Add('Êîìïüþòåð áûë âûêëþ÷åí ' + DateToStr(Now)+ ' ' + TimeToStr(Now));
Memo1.Lines.SaveToFile('show.txt');
end;

end.

Открываем и закрываем CD-ROM

ADMIN — Fri, 20 Apr 2007 19:16:06 GMT

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ComCtrls, MMSystem;

type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
ComboBox1: TComboBox;
Button3: TButton;
procedure Button1Click(Sender: TObject);
function CloseCD(Drive : string) : Boolean;
function OpenCD(Drive : string) : Boolean;
procedure FormCreate(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
private
public
end;

var
Form1: TForm1;
Driv: array [1..25] of string;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
OpenCD(ComboBox1.Text);
end;

function TForm1.OpenCD(Drive: string): Boolean;
var
Res : MciError;
OpenParm: TMCI_Open_Parms;
Flags : DWord;
S : string;
DeviceID : Word;
begin
Result:=false;
S:=Drive;
Flags:=mci_Open_Type or mci_Open_Element;
with OpenParm do
begin
dwCallback := 0;
lpstrDeviceType := 'CDAudio';
lpstrElementName := PChar(S);
end;
Res := mciSendCommand(0, mci_Open, Flags, Longint(@OpenParm));
if Res<>0 then
exit;
DeviceID:=OpenParm.wDeviceID;
try
Res:=mciSendCommand(DeviceID, MCI_SET, MCI_SET_DOOR_OPEN, 0);
if Res=0 then
exit;
Result:=True;
finally
mciSendCommand(DeviceID, mci_Close, Flags, Longint(@OpenParm));
end;
end;

function TForm1.CloseCD(Drive: string): Boolean;
var
Res : MciError;
OpenParm: TMCI_Open_Parms;
Flags : DWord;
S : string;
DeviceID : Word;
begin
Result:=false;
S:=Drive;
Flags:=mci_Open_Type or mci_Open_Element;
with OpenParm do
begin
dwCallback := 0;
lpstrDeviceType := 'CDAudio';
lpstrElementName := PChar(S);
end;
Res := mciSendCommand(0, mci_Open, Flags, Longint(@OpenParm));
if Res<>0 then
exit;
DeviceID:=OpenParm.wDeviceID;
try
Res:=mciSendCommand(DeviceID, MCI_SET, MCI_SET_DOOR_CLOSED, 0);
if Res=0 then
exit;
Result:=True;
finally
mciSendCommand(DeviceID, mci_Close, Flags, Longint(@OpenParm));
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
w:dword;
Root:string;
I, K:integer;
begin
k:=0;
w:=GetLogicalDrives;
Root := '#:';
for i := 0 to 25 do
begin
Root[1] := Char(Ord('A')+i);
if (W and (1 shl i))>0 then
if GetDriveType(Pchar(Root)) = DRIVE_CDROM then
begin
k:=k+1;
Driv[k] := Root;
ComboBox1.Items.Add(Driv[k]);
ComboBox1.Text := Driv[1];
end;
end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
CloseCD(ComboBox1.Text);
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
Close;
end;

end.

Постоянно свежие рабочие прокси :)

ADMIN — Fri, 20 Apr 2007 19:14:40 GMT

моя очередная разработка

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, IdBaseComponent, IdComponent, IdTCPConnection,
IdTCPClient, IdHTTP, ExtCtrls, IdAntiFreezeBase, IdAntiFreeze, GruString;

type
TForm1 = class(TForm)
Timer1: TTimer;
Memo1: TMemo;
IdHTTP1: TIdHTTP;
Label1: TLabel;
IdAntiFreeze1: TIdAntiFreeze;
Memo2: TMemo;
procedure Timer1Timer(Sender: TObject);
procedure FormActivate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Timer1Timer(Sender: TObject);
begin
Label1.Caption := IntToStr(StrToInt(Label1.Caption) - 1);
if Label1.Caption='0' then
begin
Application.ProcessMessages;
Memo2.Lines.LoadFromFile('HTTPProxies.txt');
try
Memo1.Text := IdHTTP1.Get('http://proxy-list.org/downloadproxylist.php?sp=-1&pp=any&pt=any&pc=any&ps=any');
except
end;
Memo2.Text := Memo2.Text + Memo1.Text;
DeleteCopy(Memo2.Lines);
Memo2.Lines.SaveToFile('HTTPProxies.txt');
Label1.Caption := '600';
end;
end;

procedure TForm1.FormActivate(Sender: TObject);
begin
Application.ProcessMessages;
IdAntiFreeze1.Process;
Memo2.Lines.LoadFromFile('HTTPProxies.txt');
try
Memo1.Text := IdHTTP1.Get('http://proxy-list.org/downloadproxylist.php?sp=-1&pp=any&pt=any&pc=any&ps=any');
except
end;
Memo2.Text := Memo2.Text + Memo1.Text;
DeleteCopy(Memo2.Lines);
Memo2.Lines.SaveToFile('HTTPProxies.txt');
Label1.Caption := '600';
end;

end.

Скриншот экрана

ADMIN — Fri, 20 Apr 2007 19:12:57 GMT

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
Var
DesktopCanvas:TCanvas ;
BitMap:TBitMap;
begin
DesktopCanvas:=TCanvas.Create;
DesktopCanvas.Handle:=GetDC(Hwnd_Desktop);
BitMap := TBitMap.Create;
BitMap.Width := Screen.Width;
BitMap.Height:=Screen.Height;
Bitmap.Canvas.CopyRect(Bitmap.Canvas.ClipRect,
DesktopCanvas, DesktopCanvas.ClipRect);
Bitmap.Canvas.TextOut(0,0,DateToStr(Now)+ ' ' + TimeToStr(Now));
Bitmap.SaveToFile('pic.bmp');
end;

end.

Shurl Regger

ADMIN — Fri, 20 Apr 2007 19:11:18 GMT

Программа регестрирует короткие ссылки на сайте http://shurl.org/

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Menus, StdCtrls, ShellApi, GruString, StrUtils, IdBaseComponent,
IdComponent, IdTCPConnection, IdTCPClient, IdHTTP, IdAntiFreezeBase,
IdAntiFreeze, Gauges;

type
TForm1 = class(TForm)
MainMenu1: TMainMenu;
N1: TMenuItem;
N2: TMenuItem;
N3: TMenuItem;
N4: TMenuItem;
N5: TMenuItem;
N6: TMenuItem;
N7: TMenuItem;
N8: TMenuItem;
N9: TMenuItem;
GroupBox1: TGroupBox;
Edit1: TEdit;
Button1: TButton;
GroupBox2: TGroupBox;
Button2: TButton;
Button3: TButton;
Button4: TButton;
Button5: TButton;
Label2: TLabel;
GroupBox3: TGroupBox;
Memo1: TMemo;
GroupBox4: TGroupBox;
Label3: TLabel;
Edit2: TEdit;
CheckBox1: TCheckBox;
Label4: TLabel;
Label5: TLabel;
Memo2: TMemo;
Button6: TButton;
Button7: TButton;
OpenDialog1: TOpenDialog;
SaveDialog1: TSaveDialog;
PopupMenu1: TPopupMenu;
N10: TMenuItem;
N11: TMenuItem;
N12: TMenuItem;
IdHTTP1: TIdHTTP;
Memo3: TMemo;
IdAntiFreeze1: TIdAntiFreeze;
ListBox1: TListBox;
Gauge1: TGauge;
procedure N2Click(Sender: TObject);
procedure N3Click(Sender: TObject);
procedure N4Click(Sender: TObject);
procedure N5Click(Sender: TObject);
procedure N7Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
procedure Button5Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure ListBox1DblClick(Sender: TObject);
procedure N10Click(Sender: TObject);
procedure N11Click(Sender: TObject);
procedure N12Click(Sender: TObject);
procedure Button7Click(Sender: TObject);
procedure Button6Click(Sender: TObject);
procedure N9Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

uses Unit2;

{$R *.dfm}

procedure TForm1.N2Click(Sender: TObject);
begin
OpenDialog1.Execute;
if OpenDialog1.FileName<>'' then
begin
ListBox1.Items.LoadFromFile(OpenDialog1.FileName);
end;
end;

procedure TForm1.N3Click(Sender: TObject);
begin
SaveDialog1.Execute;
if ListBox1.Items.Text<>'' then
begin
ListBox1.Items.SaveToFile(SaveDialog1.FileName + '.txt');
end
else
Application.MessageBox('Ôàéë íå ñîõðàíåí, òàê êàê ïîëå ñ ñóáäîìåíîì ïóñòîå','Îøèáêà',mb_OK);
end;

procedure TForm1.N4Click(Sender: TObject);
begin
Application.ProcessMessages;
DeleteCopy(ListBox1.Items);
end;

procedure TForm1.N5Click(Sender: TObject);
begin
Close;
end;

procedure TForm1.N7Click(Sender: TObject);
begin
ListBox1.Clear;
Memo1.Clear;
Memo2.Clear;
Edit1.Clear;
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
Application.ProcessMessages;
DelEmpStrings(ListBox1.Items);
end;

procedure TForm1.Button5Click(Sender: TObject);
var
chto,na:string;
begin
chto := InputBox('Çàìåíà','×òî Âû õîòèòå çàìåíèòü?','');
if chto<>'' then
begin
na := InputBox('Çàìåíà','Íà ÷òî Âû õîòèòå çàìåíèòü ' + chto + '?','');
ListBox1.Items.Text := AnsireplaceStr(ListBox1.Items.Text,chto,na);
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if Edit1.Text<>'' then
begin
ListBox1.Items.Add(Edit1.Text);
Edit1.Clear;
end;
end;

procedure TForm1.ListBox1DblClick(Sender: TObject);
begin
ListBox1.DeleteSelected;
end;

procedure TForm1.N10Click(Sender: TObject);
begin
ListBox1.DeleteSelected;
end;

procedure TForm1.N11Click(Sender: TObject);
begin
ListBox1.Clear;
end;

procedure TForm1.N12Click(Sender: TObject);
begin
Application.MessageBox(PChar(IntToStr(ListBox1.Items.Count)),'Êîëè÷åñòâî ñóáäîìåíîâ',mb_OK);
end;

procedure TForm1.Button7Click(Sender: TObject);
begin
ListBox1.Clear;
end;

procedure TForm1.Button6Click(Sender: TObject);
var
i,pos1,trust:integer;
Post: TStrings;
query,sub,long,responce:string;
begin
IdAntiFreeze1.Process;
Gauge1.MaxValue := ListBox1.Items.Count;
try
for i:=0 to ListBox1.Items.Count do
begin
Gauge1.Progress := i;
Memo3.Clear;
query := ListBox1.Items[i];
query := AnsireplaceStr(query,' ','+');
query := AnsireplaceStr(query,'_','+');
query := AnsireplaceStr(query,'.','+');
sub := ListBox1.Items[i];
sub := AnsireplaceStr(sub,' ','-');
sub := AnsireplaceStr(sub,'_','-');
sub := AnsireplaceStr(sub,'.','-');
long := Edit2.Text;
long := AnsireplaceStr(long,'[QUERY]',query);
Post := TStringList.Create;
Post.Clear;
Post.Add('url='+long);
Post.Add('name='+sub);
if CheckBox1.Checked=true then
begin
Post.Add('urlmasking=true');
end;
Memo3.Text := IdHTTP1.Post('http://shurl.org/advanced', Post);
responce := Memo3.Text;
pos1 := pos('occupied',responce);
if pos1=0 then
begin
Memo1.Lines.Add('http://shurl.org/' + sub);
end
else
Memo2.Lines.Add('http://shurl.org/' + sub);
end;
except
end;
end;

procedure TForm1.N9Click(Sender: TObject);
begin
AboutBox.Show;
end;

end.

AutoRun

ADMIN — Fri, 20 Apr 2007 19:07:25 GMT

Компонент добавит вашу программу в автозапуск Windows через ключи реестра, возможность выбора ключа

Скачать

GruString очень полезная вещь для работы с текстом, строками

ADMIN — Fri, 20 Apr 2007 18:43:20 GMT

GruString

Модуль для работы со строками.
Неполный перечень функций:
Удаление из строки пробелов: DeleteBlank
пример: DeleteBlank('Мое любимое молоко'); {функция возвращает 'Моелюбимоемолоко'}
Удаление из строки двойных пробелов: DelDoubBlank
пример: DelDoubBlank('Мое любимое молоко'); {функция возвращает 'Мое любимое молоко'}
Удаления из списка строк всех пробелов в строках: DelBlankStrings
Удаления из списка строк всех пустых строк: DelEmpStrings
Удаления из списка строк всех повторяюших строк: DeleteCopy
Возвратит строку с указанной большой буквой: LargeLtterStr
пример: LargeLtterStr('Мое любимое молоко', 3); {функция возвращает 'МоЕ любимое молоко'}
Возвращает строку где все слова начинаются с большой буквы: LargeStr
пример: LargeStr('Мое любимое молоко'); {функция возвращает 'Мое Любимое Молоко'}
Возвращает аббревиатуру слов: AbbrevStr
пример: AbbrevStr('Мое любимое молоко'); {функция возвращает 'МЛМ'}
Возвращает слово наоборот: SrtTotrS
пример: SrtTotrS('Мое любимое молоко'); {функция возвращает 'околом еомибюл еоМ'}
Возвращает с английской раскладкой в русскою: EngToRus
пример: EngToRus('Vjt k.,bvjt vjkjrj'); {функция возвращает 'Мое любимое молоко'}
Возвращает с русской раскладкой в английскою: RusToEng
пример: RusToEng('Ьн афмщгкшеу ьшдл'); {функция возвращает 'My favourite milk'}
Сравнивает две строки и возвращает процент сходства: SimStrPro
пример: SimStrPro('доска','москва'); {функция возвращает 60 -60% сходства}
Удаления из строки всех <Тегов>: DeleteTag
пример: DeleteTag('

Я обманывать себя не стану
'); {функция возвращает 'Я обманывать себя не стану'}
Выделения из строки всех <Тегов>: CopyTag
пример: CopyTag('Я обманывать себя не стану
'); {функция возвращает '
'}
Выделения из HTML строки всех E-Mail : GetHtmlMail
пример: GetHtmlMail(' mail ');{функция возвращает 'test@mail.ru'}
ExtractPath Получение пути к папке
ConcatLink Сложение ссылок для анализа ссылок
ChangeHSym и ChangeTSym Замена спец. HTML символов и обратно
CopyServer Возвращает из grundic.hut.ru/index.htm grundic.hut.ru
CompareLink Возвращает локальность ссылки относительно маски
DelCopyMask Удаления из списка, строки повторяющие в маске
ToLetInteger Проверка строки на символы типа Integer
ZoneToState (Возвращает с домена название страны по русский
GetZone Выделения ccTLD домена
DeleteSpam Удаление из строки спама #10, #13 и т.д

Скачать