//Сама программа (Project > View Source)
uses
Vcl.Forms,
Vcl.Dialogs,
Windows,
Registry,
System.Classes,
System.SysUtils,
Unit1 in 'Unit1.pas' {Form1},
IdMultipartFormData,
IdBaseComponent,
IdComponent,
IdTCPConnection,
IdTCPClient,
IdHTTP,
IdHashMessageDigest,
IdSSLOpenSSL,
IdSSL,
IdIOHandler,
IdIOHandlerSocket,
IdIOHandlerStack;
{$R *.res}
Var HM :THandle;
function Check: boolean;
begin
HM:=OpenMutex(MUTEX_ALL_ACCESS, false, 'Proj');
Result:=(HM<>0);
if HM=0 then HM:=CreateMutex(nil, false, 'Proj');
end;
function checkUpdate: boolean;
var
Stream: TIdMultipartFormDataStream;
HTTPClient: TidHTTP;
response: WideString;
cur_ver: string;
Reg: TRegistry;
begin
Reg:=TRegistry.Create;
Reg.RootKey := HKEY_CURRENT_USER;
Reg.OpenKey('\SOFTWARE\'+app_name_tech, true);
result:=false;
if reg.ValueExists('AppVer') then cur_ver := Reg.ReadString('AppVer');
HTTPClient := TidHTTP.Create;
try
Stream := TIdMultipartFormDataStream.Create;
Stream.AddFormField('query_type', 'update');
Stream.AddFormField('v', cur_ver);
response:= HTTPClient.Post(app_serv+'/updater.php ', Stream); // Отправим запрос
result:=StrToBool(response);
HTTPClient.Disconnect;
//FreeAndNil(response);
finally
Stream.Free;
HTTPClient.Free;
end;
end;
begin
If Check then //проверка не запущена ли уже программа
exit;
Application.Initialize;
Application.MainFormOnTaskbar := True;
if CheckUpdate() then
begin
Application.CreateForm(TForm1, Form1);
Application.Run;
end
else
begin
ShowMessage('Обновление не требуется');
end;
end.
// далее Unit1
function UnZipFile(sourceFile, destPath: String): Boolean;
var
ZipFile: TZipFile;
begin
ZipFile := TZipFile.Create;
try
if ZipFile.IsValid(sourceFile) then begin
ZipFile.ExtractZipFile(sourceFile, destPath);
ZipFile.Close;
result:= true;
end;
finally
ZipFile.Free;
end;
end;
procedure save_in_dir(dir, url: string; MyHTTP: TIdHTTP);
var
MyStream: TMemoryStream;
fname: string;
begin
MyStream := TMemoryStream.Create;
fname := url;
// Получаем имя файла из url. Имя файла - текст за последним включением "/"
while Pos('/', fname) <> 0 do
begin
Delete(fname, 1, Pos('/', fname));
end;
// Сам процесс сохранения файла
MyHTTP.Get(url, MyStream);
MyHTTP.Disconnect;
MyStream.SaveToFile(dir + '\' + fname);
MyStream.Free;
end;
procedure TForm1.FormActivate(Sender: TObject);
// тут странный момент - форма "не успевает" отобразиться (я пробовал и OnCreate и OnShow), то есть за время работы программы появляются только всплывающие окна описанные ниже.
var
Reg: TRegistry;
Stream: TMemoryStream;
begin
root_dir := ExtractFilePath(ParamStr(0));
save_in_dir(root_dir, app_serv + '/update/update.zip', IdHTTP1);
// когда скачалось
if progressbar1.position=progressbar1.max then //(как по другому определить завершение загрузки не знаю)
begin
Application.Messagebox('Загрузка обновления прошла успешно.', 'Загрузка обновления..', mb_iconinformation or mb_ok);
if FileExists(root_dir+'update.zip') then //есть ли файл
begin
try
//вырубаем основную программу
KillProcess(root_dir+'main.exe');//KillTask('main.exe'); //этот момент проверить не могу, так как не получается запустить "одновременно 2 программы". При запуске в режиме отладки тут ошибок не возникало)
except
on e:Exception do ShowMessage('Не удалось вырубить основную программу');//ShowMessage(E.ClassName+' ошибка с сообщением : '+E.Message);
end;
//распаковать архив
if UnZipFile(root_dir+'update.zip', root_dir) then
begin
//удалить архив
DeleteFile(root_dir+'update.zip');
//прописать новую версию
Reg:=TRegistry.Create;
Reg.RootKey := HKEY_CURRENT_USER;
Reg.OpenKey('\SOFTWARE\'+app_name_tech, true);
Reg.WriteString('app_ver', app_ver);
ShowMessage('Обновление установлено!');
//запустить основное приложение
try
ShellExecute(0, PChar('open'), PChar(root_dir+'main.exe'), nil, nil, SW_SHOWDEFAULT);
except
on e:Exception do ShowMessage(E.ClassName+' ошибка с сообщением : '+E.Message);
end;
//закрыть обновлятор
//Application.Destroy;
halt;
end
else
begin
ShowMessage('Не удалось обновиться! Не удалось распаковать архив');
end;
end
else//если файла нет
begin
ShowMessage('Не удалось обновиться! Архив не найден');
end;
end;
end;
procedure TForm1.IdHTTP1Work(ASender: TObject; AWorkMode: TWorkMode;
AWorkCount: Int64);
begin
ProgressBar1.Position:=AWorkCount;
end;
procedure TForm1.IdHTTP1WorkBegin(ASender: TObject; AWorkMode: TWorkMode;
AWorkCountMax: Int64);
begin
ProgressBar1.Max:=AWorkCountMax;
end;
Простой
Простой