Subversion Repositories svnkaklik

// ******************************************************************************

//            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

// ******************************************************************************