Subversion Repositories svnkaklik

Rev

Blame | Last modification | View Log | Download 

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