Subversion Repositories svnkaklik

Rev

Go to most recent revision | Details | Last modification | View Log

Rev Author Line No. Line
6 kaklik 1
// ******************************************************************************
2
//            This source has been created by Roman Schulz, 2002.
3
//          Visit my web-site at http://gds.oceany.cz for more info
4
// ******************************************************************************
5
 
6
 
7
unit Downloader;
8
 
9
interface
10
 
11
uses
12
  Windows, ShellAPI, Messages, SysUtils, Graphics, Forms, Dialogs, Classes,
13
  StdCtrls, isp3, Menus, INIFiles, OleCtrls, Controls, FileCtrl, Registry,
14
  ComObj, ActiveX, ShlObj, ComCtrls, ExtCtrls, Gauges;
15
 
16
const
17
  WM_TRAYAPPNOTIFY = WM_USER; // vlastní identifikátor zprávy
18
 
19
type
20
  TForm1 = class(TForm)
21
    Edit1: TEdit;
22
    ListBox1: TListBox;
23
    Button1: TButton;
24
    Button2: TButton;
25
    HTTP1: THTTP;
26
    Label1: TLabel;
27
    MainMenu1: TMainMenu;
28
    File1: TMenuItem;
29
    Exit1: TMenuItem;
30
    Help1: TMenuItem;
31
    About1: TMenuItem;
32
    SearchforHelpOn1: TMenuItem;
33
    Reset1: TMenuItem;
34
    AutoSave1: TMenuItem;
35
    Zobrazen1: TMenuItem;
36
    dn1: TMenuItem;
37
    PopupMenu1: TPopupMenu;
38
    Konec1: TMenuItem;
39
    Zobrazit1: TMenuItem;
40
    Trayicon1: TMenuItem;
41
    Skrtformul1: TMenuItem;
42
    Skrtformul2: TMenuItem;
43
    Download1: TMenuItem;
44
    Hledatnainternetu1: TMenuItem;
45
    Button3: TButton;
46
    PidatdoSTARTmenu1: TMenuItem;
47
    Pidatnaplochu1: TMenuItem;
48
    StatusBar1: TStatusBar;
49
    Timer1: TTimer;
50
    Gauge1: TGauge;
51
    Vceoaplikaci1: TMenuItem;
52
    procedure Edit1KeyDown(Sender: TObject; var Key: Word;
53
      Shift: TShiftState);
54
    procedure Button2Click(Sender: TObject);
55
    procedure HTTP1StateChanged(Sender: TObject; State: Smallint);
56
    procedure Button1Click(Sender: TObject);
57
    procedure ListBox1Click(Sender: TObject);
58
    procedure AutoSave1Click(Sender: TObject);
59
    procedure Exit1Click(Sender: TObject);
60
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
61
    procedure SearchforHelpOn1Click(Sender: TObject);
62
    procedure dn1Click(Sender: TObject);
63
    procedure ZkratkyVypnuty;
64
    procedure ZkratkyZapnuty;
65
    procedure FormDestroy(Sender: TObject);
66
    procedure Trayicon1Click(Sender: TObject);
67
    procedure Zobrazit1Click(Sender: TObject);
68
    procedure Skrtformul1Click(Sender: TObject);
69
    procedure About1Click(Sender: TObject);
70
    procedure CreateLink(WorkingDirectory,FileName,Arguments: String;TargetLinkFile: WideString;
71
              Description,IconPath: String;IconIdex: Integer);
72
    procedure AddToStart(Sender: TObject);
73
    procedure AddToDesktop(Sender: TObject);
74
    procedure Timer1Timer(Sender: TObject);
75
    procedure HTTP1Error(Sender: TObject; Number: Smallint;
76
      var Description: WideString; Scode: Integer; const Source,
77
      HelpFile: WideString; HelpContext: Integer;
78
      var CancelDisplay: WordBool);
79
  private
80
    Download_file, Zobrazeni: String;
81
    Busy: boolean;
82
    Settings: TINIFile;
83
    NotifyIconData: TNotifyIconData; // data pro ikonu
84
    Time: Dword;
85
    Sekund, BytesTransferredLast: Integer;
86
    procedure WMTrayAppNotify(var M: TMessage); message WM_TRAYAPPNOTIFY;
87
  public
88
    Destination: String;
89
  protected
90
    procedure WMHotKey(var Message: TMessage); message WM_HOTKEY;
91
  end;
92
 
93
var
94
  Form1: TForm1;
95
 
96
 
97
implementation
98
 
99
uses SaveDialog;
100
 
101
{$R *.DFM}
102
 
103
 
104
 
105
 
106
// ******************************************************************************
107
//                     Rutiny download manageru
108
// ******************************************************************************
109
 
110
 
111
//Reset
112
procedure TForm1.Button1Click(Sender: TObject);
113
var i, dummy: integer;
114
//param: DWord;
115
begin
116
  //Možnost vypnutí veškerých klávesových zkratek ve Win9x
117
  //Param := 0;
118
  //SystemParametersInfo(SPI_SETFASTTASKSWITCH, UINT(not false), @Param, 0);
119
  // ALT+TAB, CTRL+ESC
120
  //SystemParametersInfo(SPI_SCREENSAVERRUNNING, UINT(not false), @Param, 0);
121
  // CTRL+ALT+DEL
122
 
123
  //Vlozi zacatek internetove adresy
124
  Edit1.text := 'http://';
125
 
126
  //Stornujeme stahování
127
  if HTTP1.Busy then HTTP1.Cancel;
128
  Busy := false;
129
  Label1.caption := 'Pøipraven na stahování';
130
 
131
  //Skrytí task baru
132
  ShowWindow(Application.Handle, SW_HIDE); //schová aplikaci z taskbaru
133
 
134
  //Nacteni hodnot z konfiguracniho souboru
135
  Settings:=TIniFile.Create((ExtractFilePath(Application.ExeName))+'settings.cfg');
136
 
137
  //Nacteni cile ukládání
138
  Destination := Settings.ReadString('Options','Destination',ExtractFilePath(Application.ExeName));
139
 
140
  //Kde se ma zobrazit ikonka
141
  Zobrazeni := Settings.ReadString('Options','Zobrazeni','TRAY_ICON');
142
  if Zobrazeni = 'TRAY_ICON' then Trayicon1Click(Sender)
143
    else if Zobrazeni = 'NONE' then dn1Click(Sender)
144
      else Trayicon1Click(Sender);
145
 
146
  //Vymazani celeho mema
147
  for i:=1 to ListBox1.Items.Count do ListBox1.Items.Delete(0);
148
end;
149
 
150
 
151
//Stahuj
152
procedure TForm1.Button2Click(Sender: TObject);
153
var i:integer;
154
  FileName:string;
155
begin
156
if (ListBox1.Items.Count <> 0) then
157
  if (Busy = false) then begin
158
    Download_file := ListBox1.Items.Strings[0];
159
 
160
    //Ziskani jmena souboru z internetove adresy
161
    for i:=0 to Length(Download_file) do
162
      if (Download_file[i]<>'/') then FileName := FileName + Download_file[i]
163
      else FileName:='';
164
 
165
    //Stavový label
166
    Label1.caption:='Stahování souboru: '+Download_file;
167
    Time := GetTickCount;
168
    HTTP1.GetDoc(Download_file, '', Destination + FileName);
169
    Busy := true;
170
  end;
171
end;
172
 
173
 
174
//Neco se stalo...
175
procedure TForm1.HTTP1StateChanged(Sender: TObject; State: Smallint);
176
begin
177
  if (State=6) then begin
178
    Label1.Caption:='Stahování souboru '+Download_file+' dokonèeno';
179
    ListBox1.Items.Delete(0);
180
    Busy := false;
181
 
182
    Gauge1.Progress := 0;
183
    StatusBar1.Panels[0].Text := 'Staženo celkem '+inttostr(round(HTTP1.DocOutput.BytesTransferred/1024))+' kB, '+inttostr(8*round(HTTP1.DocOutput.BytesTransferred/(GetTickCount-Time)))+' kbps';
184
 
185
    ShowMessage('Požadavek splnìn');
186
  end;
187
end;
188
 
189
//Prace s listboxem
190
procedure TForm1.ListBox1Click(Sender: TObject);
191
var i: integer;
192
begin
193
  for i := 0 to (ListBox1.Items.Count - 1) do begin
194
    if ListBox1.Selected[i] then
195
    begin
196
      Edit1.Text := ListBox1.Items.Strings[i];
197
      ListBox1.Items.Delete(i);
198
    end;
199
  end;
200
end;
201
 
202
//Po stisknuti enteru se data prenesou do listboxu
203
procedure TForm1.Edit1KeyDown(Sender: TObject; var Key: Word;
204
  Shift: TShiftState);
205
begin
206
if (key=13) then begin
207
  ListBox1.Items.Add(Edit1.Text);
208
  Edit1.Text:='http://';
209
  end;
210
end;
211
 
212
//Zobrazeni formulare s cestou pro ulozeni souboru
213
procedure TForm1.AutoSave1Click(Sender: TObject);
214
begin
215
  Form1.enabled:=false;
216
  Form2.visible:=true;
217
end;
218
 
219
 
220
 
221
procedure TForm1.Timer1Timer(Sender: TObject);
222
var BytesTransferred: integer;
223
begin
224
if busy then begin
225
 
226
  //Updatování pozice ukazatele
227
  BytesTransferred := HTTP1.DocOutput.BytesTransferred;
228
 
229
  Gauge1.MaxValue := HTTP1.DocOutput.BytesTotal;
230
  Gauge1.Progress := BytesTransferred;
231
 
232
  //Pøenosová rychlost B/s
233
  StatusBar1.Panels[2].text := inttostr(round(((BytesTransferred - BytesTransferredLast)/(Timer1.interval/1000))))+' B/s';
234
  BytesTransferredLast := BytesTransferred;
235
 
236
  //Pocet prenesenych bytu, procento stahování a pøenosová rychlost v kbps
237
  if (HTTP1.DocOutput.BytesTotal <> 0)then
238
      StatusBar1.Panels[0].text := inttostr(round(BytesTransferred/1024))+' kB z '
239
      +inttostr(round(HTTP1.DocOutput.BytesTotal/1024))+' kB = '
240
      +inttostr(round(100*(BytesTransferred/1024)/(HTTP1.DocOutput.BytesTotal/1024)))+' % ='
241
      +inttostr(8*round(BytesTransferred/(GetTickCount-Time)))+' kbps';
242
 
243
  //doba stahování
244
  Sekund := round((GetTickCount-Time)/1000);
245
  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';
246
end;
247
end;
248
 
249
 
250
 
251
procedure TForm1.HTTP1Error(Sender: TObject; Number: Smallint;
252
  var Description: WideString; Scode: Integer; const Source,
253
  HelpFile: WideString; HelpContext: Integer; var CancelDisplay: WordBool);
254
begin
255
  ShowMessage('Vyskytla se chyba: '+Description);
256
end;
257
 
258
 
259
 
260
 
261
 
262
// ******************************************************************************
263
//          Procedury pro zobrazení a skrytí ze system tray
264
// ******************************************************************************
265
//Zobrazení v tray icon
266
procedure TForm1.Trayicon1Click(Sender: TObject);
267
begin
268
  //Deaktivace klavesovych zkratek
269
  ZkratkyZapnuty;
270
  // nastavíme jednotlivé položky
271
  with NotifyIconData do
272
  begin
273
    cbSize := SizeOf(NotifyIconData);
274
    Wnd := Handle;
275
    uID := 0;
276
    uFlags := NIF_ICON + NIF_MESSAGE + NIF_TIP;
277
    uCallbackMessage := WM_TRAYAPPNOTIFY;
278
    hIcon := Application.Icon.Handle;
279
    szTip:='Pokusná tray aplikace';
280
  end;
281
  // pøidáme ikonu na lištu
282
  Shell_NotifyIcon(NIM_ADD, @NotifyIconData);
283
  Zobrazeni := 'TRAY_ICON';
284
end;
285
 
286
 
287
//Nezobrazovat nikde
288
procedure TForm1.dn1Click(Sender: TObject);
289
begin
290
  //Oznameni o aktivaci klavesovych zkratek
291
  ShowMessage('Program lze aktivovat klávesovou zkratkou CTRL+F7');
292
  ZkratkyZapnuty;
293
  // odebereme ikonu z lišty
294
  Shell_NotifyIcon(NIM_DELETE, @NotifyIconData);
295
  Zobrazeni := 'NONE';
296
end;
297
 
298
 
299
//Zobrazit formuláø
300
procedure TForm1.Zobrazit1Click(Sender: TObject);
301
begin
302
  Form1.visible := true;
303
end;
304
 
305
//Skrýt formuláø
306
procedure TForm1.Skrtformul1Click(Sender: TObject);
307
begin
308
  Form1.visible := false;
309
end;
310
 
311
 
312
 
313
//Události nad System Tray ikonou
314
procedure TForm1.WMTrayAppNotify(var M: TMessage);
315
var
316
  P: TPoint;
317
begin
318
  with M do
319
    case lParam of
320
      WM_LBUTTONUP:   // levé tlaèítko
321
        Application.MessageBox('Na ikonì bylo kliknuto!', 'Tray', 0);
322
      WM_RBUTTONUP:   // pravé tlaèítko
323
      begin
324
        GetCursorPos(P);             // získáme souøadnice kurzoru
325
        PopupMenu1.Popup(P.X, P.Y);  // a zobrazíme na nich menu
326
      end;
327
    end;
328
end;
329
 
330
 
331
// ******************************************************************************
332
//                     Nastavení klávesových zkratek
333
// ******************************************************************************
334
procedure TForm1.WMHotKey(var Message: TMessage);
335
begin
336
  Form1.visible := true;
337
end;
338
 
339
 
340
procedure TForm1.ZkratkyVypnuty();
341
begin
342
UnregisterHotKey(Handle,131632);
343
end;
344
 
345
 
346
procedure TForm1.ZkratkyZapnuty();
347
begin
348
RegisterHotKey(Handle,131632,MOD_CONTROL{Control,Alt,Shift,Start},VK_F7{èíslo klávesy});
349
end;
350
 
351
 
352
// ******************************************************************************
353
//                Pøidání programu do START menu a na plochu
354
// ******************************************************************************
355
procedure TForm1.CreateLink(WorkingDirectory,FileName,Arguments: String;TargetLinkFile: WideString;
356
Description,IconPath: String;IconIdex: Integer);
357
var
358
  MyObject : IUnknown;
359
  MySLink : IShellLink;
360
  MyPFile : IPersistFile;
361
begin
362
  MyObject := CreateComObject(CLSID_ShellLink);
363
  MySLink := MyObject as IShellLink;
364
  MyPFile := MyObject as IPersistFile;
365
  with MySLink do
366
  begin
367
    SetArguments (PChar(Arguments ));
368
    SetPath (PChar(FileName));
369
    SetWorkingDirectory(PChar(WorkingDirectory));
370
    SetDescription (PChar(Description));
371
    SetIconLocation (PChar(IconPath), IconIdex);
372
  end;
373
 
374
  If Not DirectoryExists(ExtractFileDir(TargetLinkFile)) then CreateDir(ExtractFileDir(TargetLinkFile));
375
  MyPFile.Save(PWChar(TargetLinkFile),False);
376
  MySLink := Nil;
377
  MyPFile := Nil;
378
  MyObject := Nil;
379
end;
380
 
381
 
382
procedure TForm1.AddToStart(Sender: TObject);
383
var MyReg: TRegIniFile;
384
  Directory: WideString;
385
begin
386
  MyReg := TRegIniFile.Create('Software\MicroSoft\Windows\CurrentVersion\Explorer');
387
 
388
  Directory := MyReg.ReadString('Shell Folders','Start Menu','')+
389
      '\Programy\Download Manager\';
390
 
391
  //Zástupce na program
392
  CreateLink(ExtractFilePath(Application.ExeName),
393
    Application.ExeName,
394
    '',
395
    Directory+'Download Manager v0.0.1.1.lnk',
396
    'Download Manager v0.0.1.1',
397
    Application.ExeName,
398
    0);
399
 
400
  //Zástupce na homepage GAME Developer Serveru
401
  CreateLink(ExtractFilePath(Application.ExeName),
402
    ExtractFilePath(Application.ExeName)+'Homepage.url',
403
    '',
404
    Directory+'GAME Developer Server.lnk',
405
    'Server o programování v DirectX a OpenGL hlavnì v Delphi a C/C++.',
406
    '',
407
    0);
408
 
409
  //Zástupce na clanek o Download Manageru
410
  CreateLink(ExtractFilePath(Application.ExeName),
411
    ExtractFilePath(Application.ExeName)+'Clanek.url',
412
    '',
413
    Directory+'Zdrojové kódy a popis Download Manageru.lnk',
414
    'Stáhnìte si zdarma zdrojové kódy a popis Download Manageru',
415
    '',
416
    0);
417
 
418
  //Zástupce na diskusi o Download Manageru
419
  CreateLink(ExtractFilePath(Application.ExeName),
420
    ExtractFilePath(Application.ExeName)+'Diskuse.url',
421
    '',
422
    Directory+'Diskuse o Download Manageru.lnk',
423
    'Zajímá vás, co si o tomto programu myslí i jiní uživatelé?',
424
    '',
425
    0);
426
 
427
  MyReg.Free;
428
end;
429
 
430
procedure TForm1.AddToDesktop(Sender: TObject);
431
var MyReg: TRegIniFile;
432
  Directory: WideString;
433
begin
434
  MyReg := TRegIniFile.Create('Software\MicroSoft\Windows\CurrentVersion\Explorer');
435
 
436
  Directory := MyReg.ReadString('Shell Folders','Desktop','');
437
 
438
  CreateLink(ExtractFilePath(Application.ExeName),
439
    Application.ExeName,
440
    '',
441
    Directory+'\Download Manager.lnk',
442
    'Download Manager',
443
    Application.ExeName,
444
    0);
445
 
446
  MyReg.Free;
447
end;
448
 
449
 
450
// ******************************************************************************
451
//                           Ukonèení programu
452
// ******************************************************************************
453
procedure TForm1.FormDestroy(Sender: TObject);
454
begin
455
  // odebereme ikonu z lišty
456
  Shell_NotifyIcon(NIM_DELETE, @NotifyIconData);
457
end;
458
 
459
procedure TForm1.Exit1Click(Sender: TObject);
460
begin
461
  Close;
462
end;
463
 
464
 
465
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
466
begin
467
  Settings.WriteString('Options','Destination',Destination);
468
  Settings.WriteString('Options','Zobrazeni',Zobrazeni);
469
  Settings.Free;
470
end;
471
 
472
 
473
 
474
 
475
//Odkaz na moje internetove stranky
476
procedure TForm1.SearchforHelpOn1Click(Sender: TObject);
477
begin
478
  if (ShellExecute(0,'open',Pchar('http://gds.oceany.cz/index.php'),nil,nil,Sw_ShowNormal)<35)
479
    then ShowMessage('Došlo k chybì k pøipojení na internetový server');
480
end;
481
 
482
procedure TForm1.About1Click(Sender: TObject);
483
begin
484
  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');
485
end;
486
 
487
 
488
 
489
 
490
end.
491
// ******************************************************************************
492
//            This source has been created by Roman Schulz, 2002.
493
//          Visit my web-site at http://gds.oceany.cz for more info
494
// ******************************************************************************