0,0 → 1,493 |
// ****************************************************************************** |
// 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; |
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 |
//Monost vypnutí vekerý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 := 'Staeno celkem '+inttostr(round(HTTP1.DocOutput.BytesTransferred/1024))+' kB, '+inttostr(8*round(HTTP1.DocOutput.BytesTransferred/(GetTickCount-Time)))+' kbps'; |
|
ShowMessage('Poadavek 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é poloky |
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 litu |
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 lity |
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í uivatelé?', |
'', |
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 lity |
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('Dolo 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 |
// ****************************************************************************** |