unit frmMain;
interface
{$WARN SYMBOL_PLATFORM OFF}
uses
Forms, Windows, Classes, Controls, StdCtrls, ExtCtrls,
dxCore, dxButton, WinInet, Gauges, SysUtils, Dialogs;
type
TfrmLiveUpdate = class(TForm)
lblVersion: TLabel;
btnNext: TdxButton;
lblToDo: TLabel;
bvlBevel1: TBevel;
lblStatus: TLabel;
gauDownload: TGauge;
btnCancel: TdxButton;
bvlBevel2: TBevel;
lblWhatsNew: TLabel;
procedure FormPaint(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure btnNextClick(Sender: TObject);
procedure btnCancelClick(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
{ Steps }
procedure CheckForUpdates;
procedure DownloadUpdate;
procedure InstallUpdate;
private
{ Private declarations }
NumStep: Byte;
IndexFileName: String;
PatchFileName: String;
TheFile: TStringList;
public
{ Public declarations }
end;
const
NewVersionLine : Byte = 0;
FileSizeLine : Byte = 1;
FileNameLine : Byte = 2;
var
frmLiveUpdate: TfrmLiveUpdate;
CurVer: String[5];
implementation
{$R *.dfm}
function RunAndWait(const TheApp: String; const Wait: Boolean): Boolean;
var
CmdLine: Array[0..255] Of char;
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
begin
Result := False;
StrPCopy(CmdLine, TheApp);
FillChar(StartupInfo, SizeOf(StartupInfo), 0);
StartupInfo.cb := SizeOf(StartupInfo);
StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
StartupInfo.wShowWindow := SW_SHOWNORMAL;
If CreateProcess(Nil, CmdLine, Nil, Nil, False, NORMAL_PRIORITY_CLASS, Nil, Nil, StartupInfo, ProcessInfo) Then Begin
Result := True;
If Wait Then
WaitForSingleObject(ProcessInfo.hThread, INFINITE);
CloseHandle(ProcessInfo.hThread);
CloseHandle(ProcessInfo.hProcess);
end;
end;
function DownloadFile(Const Source, Dest: String; Const ToLabel: TLabel = Nil; Const PrgBar: TGauge = Nil): Boolean;
var
NetHandle: HINTERNET;
UrlHandle: HINTERNET;
Buffer: Array[0..1024] Of Char;
BytesRead, Reserved: dWord;
ReadFile: String;
NumByte: Integer;
FileSize: dWord;
begin
ReadFile := '';
ToLabel.Caption := 'Connecting...';
Application.ProcessMessages;
NetHandle := InternetOpen('Delphi 5.x', INTERNET_OPEN_TYPE_PRECONFIG, Nil, Nil, 0);
If Assigned(NetHandle) Then Begin
UrlHandle := InternetOpenUrl(NetHandle, PChar(Source), Nil, 0, INTERNET_FLAG_RELOAD, 0);
If Assigned(UrlHandle) Then Begin
If (ToLabel <> Nil) Or (PrgBar <> Nil) Then Begin
Buffer := '';
FileSize := SizeOf(Buffer);
Reserved := 0;
If HttpQueryInfo(UrlHandle, HTTP_QUERY_CONTENT_LENGTH, @Buffer, FileSize, Reserved) Then
FileSize := StrToIntDef(Buffer, -1);
End;
If ToLabel <> Nil Then
ToLabel.Caption := '0 of 0 bytes';
If PrgBar <> Nil Then Begin
PrgBar.MinValue := 0;
PrgBar.MaxValue := FileSize;
PrgBar.Progress := 0;
End;
FillChar(Buffer, SizeOf(Buffer), 0);
Repeat
FillChar(Buffer, SizeOf(Buffer), 0);
InternetReadFile(UrlHandle, @Buffer, SizeOf(Buffer), BytesRead);
For NumByte := 0 To BytesRead - 1 Do
ReadFile := Concat(ReadFile, Buffer[NumByte]);
If ToLabel <> Nil Then
ToLabel.Caption := FormatFloat('0,000', Length(ReadFile)) + ' of ' + FormatFloat('0,000', FileSize) + ' bytes';
If PrgBar <> Nil Then
PrgBar.Progress := PrgBar.Progress + StrToInt(IntToStr(BytesRead));
Application.ProcessMessages;
Until BytesRead = 0;
InternetCloseHandle(UrlHandle);
End;
InternetCloseHandle(NetHandle);
End;
ToLabel.Caption := '';
Application.ProcessMessages;
If Length(ReadFile) > 0 Then
Begin
If FileExists(Dest) Then
DeleteFile(PChar(Dest));
With TFileStream.Create(Dest, fmCreate) Do
Try
Write(ReadFile[1], Length(ReadFile));
Finally
Free;
End;
Result := True;
End
Else
Result := False;
end;
procedure DeleteAllDir(Path, Mask: String; Recursive: Boolean);
var
Result: Integer;
SearchRec: TSearchRec;
begin
If Path[Length(Path)] <> '\' Then
Path := Concat(Path, '\');
Try
Result := FindFirst(Path + Mask, faAnyFile - faDirectory, SearchRec);
While Result = 0 Do Begin
If Not DeleteFile(Path + SearchRec.Name) Then Begin
FileSetAttr(Path + SearchRec.Name, 0); { reset all flags }
DeleteFile(Path + SearchRec.Name);
End;
Result := FindNext(SearchRec);
End;
FindClose(SearchRec);
If Not Recursive Then Exit;
Result := FindFirst(Path + '*.*', faDirectory, SearchRec);
While Result = 0 Do Begin
If (SearchRec.Name <> '.') And (SearchRec.Name <> '..') Then Begin
FileSetAttr(Path + SearchRec.Name, faDirectory);
DeleteAllDir(Path + SearchRec.Name + '\', Mask, True);
RmDir(Path + SearchRec.Name);
End;
Result := FindNext(SearchRec);
End;
FindClose(SearchRec);
Except
MessageDlg('The directory could not be deleted.', mtError, [mbOk], 0);
End;
end;
procedure TfrmLiveUpdate.FormPaint(Sender: TObject);
const
Red1 : Byte = 146;
Red2 : Byte = 186;
Green1 : Byte = 157;
Green2 : Byte = 197;
Blue1 : Byte = 210;
Blue2 : Byte = 250;
var
HalfHeight: Integer;
Row: Integer;
begin
HalfHeight := ClientHeight Div 2;
For Row := 0 To HalfHeight Do
With Canvas Do Begin
Brush.Color := RGB(
Red1 + Round((Red2 - Red1) / HalfHeight * Row),
Green1 + Round((Green2 - Green1) / HalfHeight * Row),
Blue1 + Round((Blue2 - Blue1) / HalfHeight * Row));
FillRect(Rect(0, Row, ClientWidth, Row + 1));
End;
For Row := HalfHeight + 1 To ClientHeight Do
With Canvas Do Begin
Brush.Color := RGB(
Red2 - Round((Red2 - Red1) / HalfHeight * (Row - HalfHeight)),
Green2 - Round((Green2 - Green1) / HalfHeight * (Row - HalfHeight)),
Blue2 - Round((Blue2 - Blue1) / HalfHeight * (Row - HalfHeight)));
FillRect(Rect(0, Row, ClientWidth, Row + 1));
End;
end;
procedure TfrmLiveUpdate.FormCreate(Sender: TObject);
begin
NumStep := 1;
end;
procedure TfrmLiveUpdate.CheckForUpdates;
var
FromFile: String;
InternetVer: String[5];
NumLine: Byte;
HistoryFile: TStringList;
label EndOfProc;
begin
lblToDo.Caption := '';
FromFile := CurVer[1] + CurVer[3] + CurVer[4];
FromFile := 'http://www.myprog.com/Updates/' + FromFile + '/Version.txt';
IndexFileName := ExtractFilePath(Application.ExeName) + '~UpdInfo.txt';
Application.ProcessMessages;
Try
lblStatus.Caption := 'Checking for updates...';
Application.ProcessMessages;
If Not DownloadFile(FromFile, IndexFileName) Then Begin
MessageDlg('Live-update couldn''t retrieve the catalog file of available updates. Please check that your connection to the Internet in functioning correctly and retry.', mtError, [mbOk], 0);
GoTo EndOfProc;
End;
TheFile := TStringList.Create;
TheFile.LoadFromFile(IndexFileName);
InternetVer := TheFile[NewVersionLine];
If Length(CurVer) < 4 Then
CurVer := CurVer + '0';
If Length(InternetVer) < 4 Then
InternetVer := InternetVer + '0';
lblStatus.Caption := '';
If InternetVer > CurVer Then
Begin
Inc(NumStep);
lblStatus.Caption := 'Downloading history...';
lblToDo.Caption := 'A new version (' + InternetVer + ') is available.' + #10 +
'The size of the patch is: ' + FormatFloat('#,##0', StrToInt(TheFile[
FileSizeLine]) / 1024) + ' KB.' + #10#10 + 'Click "Next" to download.';
bvlBevel2.Visible := True;
FromFile := ChangeFileExt(FromFile, '.his');
If DownloadFile(FromFile, ChangeFileExt(IndexFileName, '.his')) Then Begin
HistoryFile := TStringList.Create;
HistoryFile.LoadFromFile(ChangeFileExt(IndexFileNa me, '.his'));
For NumLine := 0 To HistoryFile.Count - 1 Do
lblWhatsNew.Caption := lblWhatsNew.Caption + HistoryFile[NumLine] + #10;
HistoryFile.Free;
End;
End
Else
Begin
If InternetVer = CurVer Then
MessageDlg('You have the most recent version of MyProg.', mtInformation, [mbOk], 0)
Else
MessageDlg('Your version is newer than on the Internet.', mtInformation, [mbOk], 0);
End;
EndOfProc:
lblStatus.Caption := '';
Except
MessageDlg('Sorry, I am unable to check for a new version. Make sure you are connected to the Internet.', mtError, [mbOk], 0);
lblStatus.Caption := '';
End;
end;
procedure TfrmLiveUpdate.DownloadUpdate;
label EndOfProc;
begin
Try
lblToDo.Caption := '';
lblWhatsNew.Caption := '';
lblStatus.Caption := 'Downloading...';
PatchFileName := TheFile[FileNameLine];
While Pos('/', PatchFileName) > 0 Do
Delete(PatchFileName, 1, Pos('/', PatchFileName));
Application.ProcessMessages;
gauDownload.Visible := True;
If Not DownloadFile(TheFile[FileNameLine], ExtractFilePath(Application.ExeName) + PatchFileName, Nil, gauDownload) Then
MessageDlg('Live-update couldn''t downlaod the patch. Please check that your connection to the Internet in functioning correctly and retry.', mtError, [mbOk], 0)
Else
Begin
lblToDo.Caption := 'The patch was downloaded successfully.';
InstallUpdate;
Inc(NumStep);
End;
gauDownload.Visible := False;
EndOfProc:
lblStatus.Caption := '';
Except
MessageDlg('Live-update couldn''t retrieve the catalog file of available updates. Please check that your connection to the Internet in functioning correctly and retry.', mtError, [mbOk], 0);
End;
end;
procedure TfrmLiveUpdate.InstallUpdate;
begin
If MessageDlg('The patch was downloaded successfully to "' + ExtractFileDir(Application.ExeName) + '". Would you like to run it now?', mtConfirmation, [mbYes, mbNo], 0) = mrYes Then Begin
Hide;
RunAndWait(ExtractFilePath(Application.ExeName) + PatchFileName, True);
If MessageDlg('Would you like to delete the patch (' + ExtractFilePath(Application.ExeName) + PatchFileName + ')?', mtConfirmation, [mbYes, mbNo], 0) = mrYes Then
DeleteFile(ExtractFilePath(Application.ExeName) + PatchFileName);
Show;
End;
btnNext.Visible := False;
btnCancel.Caption := 'Close';
end;
procedure TfrmLiveUpdate.btnNextClick(Sender: TObject);
begin
btnNext.Enabled := False;
btnCancel.Enabled := False;
Screen.Cursor := crHourGlass;
Case NumStep Of
1: CheckForUpdates;
2: DownloadUpdate;
End;
Screen.Cursor := crDefault;
btnCancel.Enabled := True;
If btnNext.Visible Then
Begin
btnNext.Enabled := True;
btnNext.SetFocus;
End
Else
Begin
btnCancel.Enabled := True;
btnCancel.SetFocus;
End;
end;
procedure TfrmLiveUpdate.btnCancelClick(Sender: TObject);
begin
Close;
end;
procedure TfrmLiveUpdate.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
If btnNext.Visible Then
CanClose := MessageDlg('Are you sure you want to cancel Live-Update?', mtConfirmation, [mbYes, mbNo], 0) = mrYes
Else
CanClose := True;
end;
procedure TfrmLiveUpdate.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
DeleteAllDir(ExtractFileDir(Application.ExeName), '~*.*', False);
Try TheFile.Free; Except End;
end;
end.
------
