WebSVN – musikbox – Blame – /trunk/Info.pas

Rev	Author	Line No.	Line
2	daniel-mar	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
6	daniel-mar	34	const
		35	ProgrammVersion = '1.5';
		36
		37	// https://www.delphipraxis.net/post43515.html , fixed , works for Delphi 12 Athens
		38	function GetHTML(AUrl: string): RawByteString;
2	daniel-mar	39	var
6	daniel-mar	40	databuffer : array[0..4095] of ansichar; // SIC! ansichar!
		41	ResStr : ansistring; // SIC! ansistring
2	daniel-mar	42	hSession, hfile: hInternet;
		43	dwindex,dwcodelen,dwread,dwNumber: cardinal;
		44	dwcode : array[1..20] of char;
		45	res : pchar;
6	daniel-mar	46	Str : pansichar; // SIC! pansichar
2	daniel-mar	47	begin
		48	ResStr:='';
6	daniel-mar	49	if (system.pos('http://',lowercase(AUrl))=0) and
		50	(system.pos('https://',lowercase(AUrl))=0) then
2	daniel-mar	51	AUrl:='http://'+AUrl;
		52
		53	// Hinzugef�gt
6	daniel-mar	54	if Assigned(Application) then Application.ProcessMessages;
2	daniel-mar	55
		56	hSession:=InternetOpen('InetURL:/1.0',
		57	INTERNET_OPEN_TYPE_PRECONFIG,
		58	nil,
		59	nil,
		60	0);
		61	if assigned(hsession) then
		62	begin
		63	// Hinzugef�gt
6	daniel-mar	64	if Assigned(Application) then application.ProcessMessages;
2	daniel-mar	65
		66	hfile:=InternetOpenUrl(
		67	hsession,
		68	pchar(AUrl),
		69	nil,
		70	0,
		71	INTERNET_FLAG_RELOAD,
		72	0);
		73	dwIndex := 0;
		74	dwCodeLen := 10;
		75
		76	// Hinzugef�gt
6	daniel-mar	77	if Assigned(Application) then application.ProcessMessages;
2	daniel-mar	78
		79	HttpQueryInfo(hfile,
		80	HTTP_QUERY_STATUS_CODE,
		81	@dwcode,
		82	dwcodeLen,
		83	dwIndex);
		84	res := pchar(@dwcode);
		85	dwNumber := sizeof(databuffer)-1;
6	daniel-mar	86	if (res ='200') or (res = '302') then
2	daniel-mar	87	begin
		88	while (InternetReadfile(hfile,
		89	@databuffer,
		90	dwNumber,
		91	DwRead)) do
		92	begin
		93
		94	// Hinzugef�gt
6	daniel-mar	95	if Assigned(Application) then application.ProcessMessages;
2	daniel-mar	96
		97	if dwRead =0 then
		98	break;
		99	databuffer[dwread]:=#0;
6	daniel-mar	100	Str := pansichar(@databuffer);
2	daniel-mar	101	resStr := resStr + Str;
		102	end;
		103	end
		104	else
6	daniel-mar	105	ResStr := 'Status:'+AnsiString(res);
2	daniel-mar	106	if assigned(hfile) then
		107	InternetCloseHandle(hfile);
		108	end;
		109
		110	// Hinzugef�gt
6	daniel-mar	111	if Assigned(Application) then application.ProcessMessages;
2	daniel-mar	112
		113	InternetCloseHandle(hsession);
6	daniel-mar	114	Result := resStr;
2	daniel-mar	115	end;
		116
		117	procedure TInfoForm.Button1Click(Sender: TObject);
		118	var
6	daniel-mar	119	temp: RawByteString;
2	daniel-mar	120	begin
7	daniel-mar	121	temp := GetHTML('https://www.viathinksoft.de/update/?id=musikbox');
2	daniel-mar	122	if copy(temp, 0, 7) = 'Status:' then
		123	begin
		124	Application.MessageBox('Ein Fehler ist aufgetreten. Wahrscheinlich ist keine Internetverbindung aufgebaut, oder der der ViaThinkSoft-Server tempor�r offline.', 'Fehler', MB_OK + MB_ICONERROR)
		125	end
		126	else
		127	begin
7	daniel-mar	128	if GetHTML('https://www.viathinksoft.de/update/?id=musikbox') <> ProgrammVersion then
2	daniel-mar	129	begin
		130	if Application.MessageBox('Eine neue Programmversion ist vorhanden. M�chten Sie diese jetzt herunterladen?', 'Information', MB_YESNO + MB_ICONASTERISK) = ID_YES then
7	daniel-mar	131	shellexecute(application.handle, 'open', pchar('https://www.viathinksoft.de/update/?id=@musikbox'), '', '', sw_normal);
2	daniel-mar	132	end
		133	else
		134	begin
		135	Application.MessageBox('Es ist keine neue Programmversion vorhanden.', 'Information', MB_OK + MB_ICONASTERISK);
		136	end;
		137	end;
		138	end;
		139
		140	procedure TInfoForm.lblCloseClick(Sender: TObject);
		141	begin
		142	close;
		143	end;
		144
		145	procedure TInfoForm.lblWeb1Click(Sender: TObject);
		146	begin
7	daniel-mar	147	ShellExecute(Handle, 'open', 'https://www.daniel-marschall.de/', nil, nil, SW_SHOWNORMAL);
2	daniel-mar	148	end;
		149
		150	procedure TInfoForm.lblWeb2Click(Sender: TObject);
		151	begin
7	daniel-mar	152	ShellExecute(Handle, 'open', 'https://www.viathinksoft.de/', nil, nil, SW_SHOWNORMAL);
2	daniel-mar	153	end;
		154
		155	end.

Subversion Repositories musikbox

musikbox/trunk/Info.pas – Rev 7