Login | ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/musikbox/trunk/Info.pas
Revision: 2
Committed: Sat Nov 10 16:57:29 2018 UTC (22 months, 1 week ago) by daniel-marschall
Content type: text/x-pascal
File size: 3955 byte(s)
Log Message:
Released source code of version 1.5 (20 February 2007) into SVN

File Contents

# Content
1 unit Info;
2
3 interface
4
5 uses
6 Windows, SysUtils, Classes, Forms, StdCtrls, ExtCtrls, ShellApi,
7 Graphics, Controls, wininet;
8
9 type
10 TInfoForm = class(TForm)
11 lblInfo1: TLabel;
12 lblInfo2: TLabel;
13 lblInfo3: TLabel;
14 lblInfo4: TLabel;
15 imgCD: TImage;
16 imgWeb: TImage;
17 lblWeb1: TLabel;
18 lblWeb2: TLabel;
19 lblClose: TButton;
20 Button1: TButton;
21 procedure lblCloseClick(Sender: TObject);
22 procedure lblWeb1Click(Sender: TObject);
23 procedure lblWeb2Click(Sender: TObject);
24 procedure Button1Click(Sender: TObject);
25 end;
26
27 var
28 InfoForm: TInfoForm;
29
30 implementation
31
32 {$R *.dfm}
33
34 // http://www.delphipraxis.net/post43515.html
35 Function GetHTML(AUrl: string): string;
36 var
37 databuffer : array[0..4095] of char;
38 ResStr : string;
39 hSession, hfile: hInternet;
40 dwindex,dwcodelen,dwread,dwNumber: cardinal;
41 dwcode : array[1..20] of char;
42 res : pchar;
43 Str : pchar;
44 begin
45 ResStr:='';
46 if pos('http://',lowercase(AUrl))=0 then
47 AUrl:='http://'+AUrl;
48
49 // Hinzugefügt
50 application.ProcessMessages;
51
52 hSession:=InternetOpen('InetURL:/1.0',
53 INTERNET_OPEN_TYPE_PRECONFIG,
54 nil,
55 nil,
56 0);
57 if assigned(hsession) then
58 begin
59 // Hinzugefügt
60 application.ProcessMessages;
61
62 hfile:=InternetOpenUrl(
63 hsession,
64 pchar(AUrl),
65 nil,
66 0,
67 INTERNET_FLAG_RELOAD,
68 0);
69 dwIndex := 0;
70 dwCodeLen := 10;
71
72 // Hinzugefügt
73 application.ProcessMessages;
74
75 HttpQueryInfo(hfile,
76 HTTP_QUERY_STATUS_CODE,
77 @dwcode,
78 dwcodeLen,
79 dwIndex);
80 res := pchar(@dwcode);
81 dwNumber := sizeof(databuffer)-1;
82 if (res ='200') or (res ='302') then
83 begin
84 while (InternetReadfile(hfile,
85 @databuffer,
86 dwNumber,
87 DwRead)) do
88 begin
89
90 // Hinzugefügt
91 application.ProcessMessages;
92
93 if dwRead =0 then
94 break;
95 databuffer[dwread]:=#0;
96 Str := pchar(@databuffer);
97 resStr := resStr + Str;
98 end;
99 end
100 else
101 ResStr := 'Status:'+res;
102 if assigned(hfile) then
103 InternetCloseHandle(hfile);
104 end;
105
106 // Hinzugefügt
107 application.ProcessMessages;
108
109 InternetCloseHandle(hsession);
110 Result := resStr;
111 end;
112
113 procedure TInfoForm.Button1Click(Sender: TObject);
114 var
115 temp: string;
116 begin
117 temp := GetHTML('http://www.viathinksoft.de/update/?id=musikbox');
118 if copy(temp, 0, 7) = 'Status:' then
119 begin
120 Application.MessageBox('Ein Fehler ist aufgetreten. Wahrscheinlich ist keine Internetverbindung aufgebaut, oder der der ViaThinkSoft-Server temporär offline.', 'Fehler', MB_OK + MB_ICONERROR)
121 end
122 else
123 begin
124 if GetHTML('http://www.viathinksoft.de/update/?id=musikbox') <> '1.5' then
125 begin
126 if Application.MessageBox('Eine neue Programmversion ist vorhanden. Möchten Sie diese jetzt herunterladen?', 'Information', MB_YESNO + MB_ICONASTERISK) = ID_YES then
127 shellexecute(application.handle, 'open', pchar('http://www.viathinksoft.de/update/?id=@musikbox'), '', '', sw_normal);
128 end
129 else
130 begin
131 Application.MessageBox('Es ist keine neue Programmversion vorhanden.', 'Information', MB_OK + MB_ICONASTERISK);
132 end;
133 end;
134 end;
135
136 procedure TInfoForm.lblCloseClick(Sender: TObject);
137 begin
138 close;
139 end;
140
141 procedure TInfoForm.lblWeb1Click(Sender: TObject);
142 begin
143 ShellExecute(Handle, 'open', 'http://www.daniel-marschall.de/', nil, nil, SW_SHOWNORMAL);
144 end;
145
146 procedure TInfoForm.lblWeb2Click(Sender: TObject);
147 begin
148 ShellExecute(Handle, 'open', 'http://www.viathinksoft.de/', nil, nil, SW_SHOWNORMAL);
149 end;
150
151 end.