Subversion Repositories svnkaklik

Compare Revisions

Ignore whitespace Rev 5 → Rev 6

/programy/delphi/download/Download Manager 0.0.1.2/Downloader.~pas
0,0 → 1,494
// ******************************************************************************
// This source has been created by Roman Schulz, 2002.
// Visit my web-site at http://gds.oceany.cz for more info
// ******************************************************************************
 
 
unit Downloader;
 
interface
 
uses
Windows, ShellAPI, Messages, SysUtils, Graphics, Forms, Dialogs, Classes,
StdCtrls, isp3, Menus, INIFiles, OleCtrls, Controls, FileCtrl, Registry,
ComObj, ActiveX, ShlObj, ComCtrls, ExtCtrls, Gauges;
 
const
WM_TRAYAPPNOTIFY = WM_USER; // vlastní identifikátor zprávy
 
type
TForm1 = class(TForm)
Edit1: TEdit;
ListBox1: TListBox;
Button1: TButton;
Button2: TButton;
HTTP1: THTTP;
Label1: TLabel;
MainMenu1: TMainMenu;
File1: TMenuItem;
Exit1: TMenuItem;
Help1: TMenuItem;
About1: TMenuItem;
SearchforHelpOn1: TMenuItem;
Reset1: TMenuItem;
AutoSave1: TMenuItem;
Zobrazen1: TMenuItem;
dn1: TMenuItem;
PopupMenu1: TPopupMenu;
Konec1: TMenuItem;
Zobrazit1: TMenuItem;
Trayicon1: TMenuItem;
Skrtformul1: TMenuItem;
Skrtformul2: TMenuItem;
Download1: TMenuItem;
Hledatnainternetu1: TMenuItem;
Button3: TButton;
PidatdoSTARTmenu1: TMenuItem;
Pidatnaplochu1: TMenuItem;
StatusBar1: TStatusBar;
Timer1: TTimer;
Gauge1: TGauge;
Vceoaplikaci1: TMenuItem;
procedure Edit1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure Button2Click(Sender: TObject);
procedure HTTP1StateChanged(Sender: TObject; State: Smallint);
procedure Button1Click(Sender: TObject);
procedure ListBox1Click(Sender: TObject);
procedure AutoSave1Click(Sender: TObject);
procedure Exit1Click(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure SearchforHelpOn1Click(Sender: TObject);
procedure dn1Click(Sender: TObject);
procedure ZkratkyVypnuty;
procedure ZkratkyZapnuty;
procedure FormDestroy(Sender: TObject);
procedure Trayicon1Click(Sender: TObject);
procedure Zobrazit1Click(Sender: TObject);
procedure Skrtformul1Click(Sender: TObject);
procedure About1Click(Sender: TObject);
procedure CreateLink(WorkingDirectory,FileName,Arguments: String;TargetLinkFile: WideString;
Description,IconPath: String;IconIdex: Integer);
procedure AddToStart(Sender: TObject);
procedure AddToDesktop(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure HTTP1Error(Sender: TObject; Number: Smallint;
var Description: WideString; Scode: Integer; const Source,
HelpFile: WideString; HelpContext: Integer;
var CancelDisplay: WordBool);
private
Download_file, Zobrazeni: String;
Busy: boolean;
Settings: TINIFile;
NotifyIconData: TNotifyIconData; // data pro ikonu
Time: Dword;
Sekund, BytesTransferredLast: Integer;
procedure WMTrayAppNotify(var M: TMessage); message WM_TRAYAPPNOTIFY;
public
Destination: String;
protected
procedure WMHotKey(var Message: TMessage); message WM_HOTKEY;
end;
 
var
Form1: TForm1;
 
 
implementation
 
uses SaveDialog;
 
{$R *.DFM}
 
 
 
 
// ******************************************************************************
// Rutiny download manageru
// ******************************************************************************
 
 
//Reset
procedure TForm1.Button1Click(Sender: TObject);
var i, dummy: integer;
//param: DWord;
begin
//Možnost vypnutí veškerých klávesových zkratek ve Win9x
//Param := 0;
//SystemParametersInfo(SPI_SETFASTTASKSWITCH, UINT(not false), @Param, 0);
// ALT+TAB, CTRL+ESC
//SystemParametersInfo(SPI_SCREENSAVERRUNNING, UINT(not false), @Param, 0);
// CTRL+ALT+DEL
 
//Vlozi zacatek internetove adresy
Edit1.text := 'http://';
 
//Stornujeme stahování
if HTTP1.Busy then HTTP1.Cancel;
Busy := false;
Label1.caption := 'Pøipraven na stahování';
 
//Skrytí task baru
ShowWindow(Application.Handle, SW_HIDE); //schová aplikaci z taskbaru
 
//Nacteni hodnot z konfiguracniho souboru
Settings:=TIniFile.Create((ExtractFilePath(Application.ExeName))+'settings.cfg');
 
//Nacteni cile ukládání
Destination := Settings.ReadString('Options','Destination',ExtractFilePath(Application.ExeName));
 
//Kde se ma zobrazit ikonka
Zobrazeni := Settings.ReadString('Options','Zobrazeni','TRAY_ICON');
if Zobrazeni = 'TRAY_ICON' then Trayicon1Click(Sender)
else if Zobrazeni = 'NONE' then dn1Click(Sender)
else Trayicon1Click(Sender);
 
//Vymazani celeho mema
for i:=1 to ListBox1.Items.Count do ListBox1.Items.Delete(0);
end;
 
 
//Stahuj
procedure TForm1.Button2Click(Sender: TObject);
var i:integer;
FileName:string;
begin
if (ListBox1.Items.Count <> 0) then
if (Busy = false) then begin
Download_file := ListBox1.Items.Strings[0];
 
//Ziskani jmena souboru z internetove adresy
for i:=0 to Length(Download_file) do
if (Download_file[i]<>'/') then FileName := FileName + Download_file[i]
else FileName:='';
 
//Stavový label
Label1.caption:='Stahování souboru: '+Download_file;
Time := GetTickCount;
HTTP1.GetDoc(Download_file, '', Destination + FileName);
Busy := true;
end;
end;
 
 
//Neco se stalo...
procedure TForm1.HTTP1StateChanged(Sender: TObject; State: Smallint);
begin
if (State=6) then begin
Label1.Caption:='Stahování souboru '+Download_file+' dokonèeno';
ListBox1.Items.Delete(0);
Busy := false;
 
Gauge1.Progress := 0;
StatusBar1.Panels[0].Text := 'Staženo celkem '+inttostr(round(HTTP1.DocOutput.BytesTransferred/1024))+' kB, '+inttostr(8*round(HTTP1.DocOutput.BytesTransferred/(GetTickCount-Time)))+' kbps';
 
ShowMessage('Požadavek splnìn');
end;
end;
 
//Prace s listboxem
procedure TForm1.ListBox1Click(Sender: TObject);
var i: integer;
begin
for i := 0 to (ListBox1.Items.Count - 1) do begin
if ListBox1.Selected[i] then
begin
Edit1.Text := ListBox1.Items.Strings[i];
ListBox1.Items.Delete(i);
end;
end;
end;
 
//Po stisknuti enteru se data prenesou do listboxu
procedure TForm1.Edit1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if (key=13) then begin
ListBox1.Items.Add(Edit1.Text);
Edit1.Text:='http://';
end;
end;
 
//Zobrazeni formulare s cestou pro ulozeni souboru
procedure TForm1.AutoSave1Click(Sender: TObject);
begin
Form1.enabled:=false;
Form2.visible:=true;
end;
 
 
 
procedure TForm1.Timer1Timer(Sender: TObject);
var BytesTransferred: integer;
begin
if busy then begin
 
//Updatování pozice ukazatele
BytesTransferred := HTTP1.DocOutput.BytesTransferred;
 
Gauge1.MaxValue := HTTP1.DocOutput.BytesTotal;
Gauge1.Progress := BytesTransferred;
 
//Pøenosová rychlost B/s
StatusBar1.Panels[2].text := inttostr(round(((BytesTransferred - BytesTransferredLast)/(Timer1.interval/1000))))+' B/s';
BytesTransferredLast := BytesTransferred;
 
//Pocet prenesenych bytu, procento stahování a pøenosová rychlost v kbps
if (HTTP1.DocOutput.BytesTotal <> 0)then
StatusBar1.Panels[0].text := inttostr(round(BytesTransferred/1024))+' kB z '
+inttostr(round(HTTP1.DocOutput.BytesTotal/1024))+' kB = '
+inttostr(round(100*(BytesTransferred/1024)/(HTTP1.DocOutput.BytesTotal/1024)))+' % ='
+inttostr(8*round(BytesTransferred/(GetTickCount-Time)))+' kbps';
 
//doba stahování
Sekund := round((GetTickCount-Time)/1000);
StatusBar1.Panels[1].text := inttostr(trunc(sekund/3600))+'hodin, '+inttostr(trunc(sekund/60-60*trunc(sekund/3600)))+'minut, '+inttostr(trunc(sekund)-60*(trunc(sekund/60-60*trunc(sekund/3600))))+'sekund';
end;
end;
 
 
 
procedure TForm1.HTTP1Error(Sender: TObject; Number: Smallint;
var Description: WideString; Scode: Integer; const Source,
HelpFile: WideString; HelpContext: Integer; var CancelDisplay: WordBool);
begin
ShowMessage('Vyskytla se chyba: '+Description);
end;
 
 
 
 
 
// ******************************************************************************
// Procedury pro zobrazení a skrytí ze system tray
// ******************************************************************************
//Zobrazení v tray icon
procedure TForm1.Trayicon1Click(Sender: TObject);
begin
//Deaktivace klavesovych zkratek
ZkratkyZapnuty;
// nastavíme jednotlivé položky
with NotifyIconData do
begin
cbSize := SizeOf(NotifyIconData);
Wnd := Handle;
uID := 0;
uFlags := NIF_ICON + NIF_MESSAGE + NIF_TIP;
uCallbackMessage := WM_TRAYAPPNOTIFY;
hIcon := Application.Icon.Handle;
szTip:='Pokusná tray aplikace';
end;
// pøidáme ikonu na lištu
Shell_NotifyIcon(NIM_ADD, @NotifyIconData);
Zobrazeni := 'TRAY_ICON';
end;
 
 
//Nezobrazovat nikde
procedure TForm1.dn1Click(Sender: TObject);
begin
//Oznameni o aktivaci klavesovych zkratek
ShowMessage('Program lze aktivovat klávesovou zkratkou CTRL+F7');
ZkratkyZapnuty;
// odebereme ikonu z lišty
Shell_NotifyIcon(NIM_DELETE, @NotifyIconData);
Zobrazeni := 'NONE';
end;
 
 
//Zobrazit formuláø
procedure TForm1.Zobrazit1Click(Sender: TObject);
begin
Form1.visible := true;
end;
 
//Skrýt formuláø
procedure TForm1.Skrtformul1Click(Sender: TObject);
begin
Form1.visible := false;
end;
 
 
 
//Události nad System Tray ikonou
procedure TForm1.WMTrayAppNotify(var M: TMessage);
var
P: TPoint;
begin
with M do
case lParam of
WM_LBUTTONUP: // levé tlaèítko
Application.MessageBox('Na ikonì bylo kliknuto!', 'Tray', 0);
WM_RBUTTONUP: // pravé tlaèítko
begin
GetCursorPos(P); // získáme souøadnice kurzoru
PopupMenu1.Popup(P.X, P.Y); // a zobrazíme na nich menu
end;
end;
end;
 
 
// ******************************************************************************
// Nastavení klávesových zkratek
// ******************************************************************************
procedure TForm1.WMHotKey(var Message: TMessage);
begin
Form1.visible := true;
end;
 
 
procedure TForm1.ZkratkyVypnuty();
begin
UnregisterHotKey(Handle,131632);
end;
 
 
procedure TForm1.ZkratkyZapnuty();
begin
RegisterHotKey(Handle,131632,MOD_CONTROL{Control,Alt,Shift,Start},VK_F7{èíslo klávesy});
end;
 
 
// ******************************************************************************
// Pøidání programu do START menu a na plochu
// ******************************************************************************
procedure TForm1.CreateLink(WorkingDirectory,FileName,Arguments: String;TargetLinkFile: WideString;
Description,IconPath: String;IconIdex: Integer);
var
MyObject : IUnknown;
MySLink : IShellLink;
MyPFile : IPersistFile;
begin
MyObject := CreateComObject(CLSID_ShellLink);
MySLink := MyObject as IShellLink;
MyPFile := MyObject as IPersistFile;
with MySLink do
begin
SetArguments (PChar(Arguments ));
SetPath (PChar(FileName));
SetWorkingDirectory(PChar(WorkingDirectory));
SetDescription (PChar(Description));
SetIconLocation (PChar(IconPath), IconIdex);
end;
 
If Not DirectoryExists(ExtractFileDir(TargetLinkFile)) then CreateDir(ExtractFileDir(TargetLinkFile));
MyPFile.Save(PWChar(TargetLinkFile),False);
MySLink := Nil;
MyPFile := Nil;
MyObject := Nil;
end;
 
 
procedure TForm1.AddToStart(Sender: TObject);
var MyReg: TRegIniFile;
Directory: WideString;
begin
MyReg := TRegIniFile.Create('Software\MicroSoft\Windows\CurrentVersion\Explorer');
 
Directory := MyReg.ReadString('Shell Folders','Start Menu','')+
'\Programy\Download Manager\';
 
//Zástupce na program
CreateLink(ExtractFilePath(Application.ExeName),
Application.ExeName,
'',
Directory+'Download Manager v0.0.1.1.lnk',
'Download Manager v0.0.1.1',
Application.ExeName,
0);
 
//Zástupce na homepage GAME Developer Serveru
CreateLink(ExtractFilePath(Application.ExeName),
ExtractFilePath(Application.ExeName)+'Homepage.url',
'',
Directory+'GAME Developer Server.lnk',
'Server o programování v DirectX a OpenGL hlavnì v Delphi a C/C++.',
'',
0);
 
//Zástupce na clanek o Download Manageru
CreateLink(ExtractFilePath(Application.ExeName),
ExtractFilePath(Application.ExeName)+'Clanek.url',
'',
Directory+'Zdrojové kódy a popis Download Manageru.lnk',
'Stáhnìte si zdarma zdrojové kódy a popis Download Manageru',
'',
0);
 
//Zástupce na diskusi o Download Manageru
CreateLink(ExtractFilePath(Application.ExeName),
ExtractFilePath(Application.ExeName)+'Diskuse.url',
'',
Directory+'Diskuse o Download Manageru.lnk',
'Zajímá vás, co si o tomto programu myslí i jiní uživatelé?',
'',
0);
 
MyReg.Free;
end;
 
procedure TForm1.AddToDesktop(Sender: TObject);
var MyReg: TRegIniFile;
Directory: WideString;
begin
MyReg := TRegIniFile.Create('Software\MicroSoft\Windows\CurrentVersion\Explorer');
 
Directory := MyReg.ReadString('Shell Folders','Desktop','');
 
CreateLink(ExtractFilePath(Application.ExeName),
Application.ExeName,
'',
Directory+'\Download Manager.lnk',
'Download Manager',
Application.ExeName,
0);
 
MyReg.Free;
end;
 
 
// ******************************************************************************
// Ukonèení programu
// ******************************************************************************
procedure TForm1.FormDestroy(Sender: TObject);
begin
// odebereme ikonu z lišty
Shell_NotifyIcon(NIM_DELETE, @NotifyIconData);
end;
 
procedure TForm1.Exit1Click(Sender: TObject);
begin
Close;
end;
 
 
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Settings.WriteString('Options','Destination',Destination);
Settings.WriteString('Options','Zobrazeni',Zobrazeni);
Settings.Free;
end;
 
 
 
 
//Odkaz na moje internetove stranky
procedure TForm1.SearchforHelpOn1Click(Sender: TObject);
begin
if (ShellExecute(0,'open',Pchar('http://gds.oceany.cz/index.php'),nil,nil,Sw_ShowNormal)<35)
then ShowMessage('Došlo k chybì k pøipojení na internetový server');
end;
 
procedure TForm1.About1Click(Sender: TObject);
begin
ShowMessage('Download Manager v. 0.0.1.1'+chr(13)+'Copyright: Roman Schulz'+chr(13)+'Tento program je freeware'+chr(13)+chr(13)+'Popis a zdrojáky: GAME Developer Server'+chr(13)+'http://gds.oceany.cz');
end;
 
 
 
 
end.
// ******************************************************************************
// This source has been created by Roman Schulz, 2002.
// Visit my web-site at http://gds.oceany.cz for more info
// ******************************************************************************