Последняя версия DataExpress 3 beta от 9 августа 2020 года.
Изображение Скачать | Изображение Что нового?
См. также: Энциклопедия DX | Форум на develop-soft | Расширения
ИзображениеИзображениеИзображение

Лаунчер для DataExpress с функционалом обновления программы.

Полезное от пользователей DataExpress
wowsab
Новичок
Сообщения: 38
Зарегистрирован: 13 апр 2017, 07:57

Re: Лаунчер для DataExpress с функционалом обновления программы.

Сообщение wowsab » 07 ноя 2017, 13:23

Ну или можно костыльно, но действенно- fread+fwrite

Аватара пользователя
YurAnt
Эксперт
Сообщения: 3352
Зарегистрирован: 13 апр 2017, 08:57
Поблагодарили: 6 раз
Контактная информация:

Re: Лаунчер для DataExpress с функционалом обновления программы.

Сообщение YurAnt » 07 ноя 2017, 16:50

В принципе довольно сносная обновлялка получилась. Код вставляется в Main, там и живет. При каждом запуске DX тихо "спрашивает" версию с сайта и в случае нахождения свежей, предлагает ее скачать:
Изображение

"Нет" - успокаивается до следующего запуска, "Да":
Изображение

В общем, да, пока на URLDownloadToFileA. В принципе у кого быстрый интернет - глазом не успеют моргнуть, ну а у кого слабенький - придется чутка подождать, пока окончание загрузки выведет программу из нирваны...
Ну и после закачки установка как обычно - "Далее"->"Далее".., соглашаемся с Борисычем, и кстати - даже не обязательно было мутить закрывачку. Стандартная установка об этом заботится:
Изображение

Жмакаем "Далее" и DX самоубивается. По окончанию установки уже стоит волшебная галка:
Изображение

Ну и до появления новой версии на сайте, тихо-мирно и беззвучно при каждом запуске проверяется ее наличие...

Код: Выделить всё

function URLDownloadToFile(pCaller: cardinal; URL: PChar;
FileName: PChar;Reserved: cardinal; lpfnCB : cardinal): cardinal;
external 'URLDownloadToFileA@urlmon.dll stdcall';

function DeleteUrlCacheEntry(lpszUrlName:PChar):cardinal;
external 'DeleteUrlCacheEntry@wininet.dll stdcall';

procedure CheckAndInstallUpdate;
var Current,New:TDateTime;
objWinHttp:variant;
begin
Current:=StrToDate(FormatDateTime('dd.mm.yyyy',FileDateToDateTime(FileAge(Application.Exename))));
try
    objWinHttp := CreateOleObject('MSXML2.XMLHTTP');
    objWinHttp.Open('GET', 'http://mydataexpress.ru/latest_version.php', false);
    objWinHttp.Send;
  if StrToDate(objWinHttp.ResponseText)<>Current then
 // MsgBox('Проверка обновлений','У вас установлена последняя версия DataExpress.')
 // else
  if MessageDlg(
  'Обновление',
  'Новая версия DataExpress (от '+objWinHttp.ResponseText+') доступна для скачивания. Загрузить?',
  mtInformation,
  [mbYes,mbNo]) = 6 then
    begin
    debug('Загрузка новой версии...');
    DeleteUrlCacheEntry('http://mydataexpress.ru/files/dx3bsetup.exe');
    Application.ProcessMessages;
    if URLDownloadToFile(0, 'http://mydataexpress.ru/files/dx3bsetup.exe',
    PChar(GetTempDir+'dx3bsetup.exe'), 0, 0)=0 then
    begin
    debug('Установка...');
    ShellExecute('',GetTempDir+'dx3bsetup.exe','','',5)
    end
    else
      begin
      debug('Ошибка. Загрузка обновления не удалась.');
      objWinHttp:=Unassigned;
      exit;
      end;
    end;
 // else exit;
finally
  objWinHttp:=Unassigned;
except;
  debug(ExceptionParam);
  objWinHttp:=Unassigned;
end;
end;

procedure Database_Open;
begin
 CheckAndInstallUpdate;
end;

P.S. Если нет желания получать ошибки в вывод при отсутствии интернета, с последним debug-ом в коде можно поступить вот так:
// debug(ExceptionParam);

Аватара пользователя
kaltsone
Знаток
Сообщения: 530
Зарегистрирован: 16 май 2017, 10:34
Откуда: Киев

Re: Лаунчер для DataExpress с функционалом обновления программы.

Сообщение kaltsone » 07 ноя 2017, 18:43

Код: Выделить всё

var
lbl: TLabel;
pan: TPanel;
T: TTimer;

procedure MSG(S:TObject);
begin
msgbox(' ','А ну не клацай!!!')
end;

procedure CreateComponents(Sender: TObject);
begin
pan:= TPanel.Create(MainWindow.Toolbar);
pan.Parent := MainWindow.Toolbar;
With pan do
 Begin
    Left:=MainWindow.Toolbar.Width;
    Height:=30;
    width:=MainWindow.Toolbar.width-left;
    align:=alRight;
    BevelOuter:=bvNone;
    anchors:=[akRight,akLeft]
 end;
    lbl:=TLabel.Create(pan);
    lbl.Parent := pan;
    With lbl do
      Begin
        Name:='info';
        SetBounds(pan.width-60, 4, 0, 10);
        Font.Style:=[fsBold];
        Font.Name:='Roboto';
        Font.Size:=16;
        Font.Color:=clGreen;
        Anchors:=[akRight];
        Alignment:=taRightJustify;
        OnDblClick:=@msg;
      End;
end;


procedure SetLabelInfo(Sender: TObject);
begin
lbl.Caption := FormatDateTime('hh:mm:ss',TDateTime(Now))+'  '+EvalExpr('WEEKDAY(DATE)',nil)+'  '+DateToStr(TDateTime(Now));
end;

procedure StartTimer;
begin
T := TTimer.Create(nil);
T.Enabled:=true;
T.Interval := 1000;
T.OnTimer:=@SetLabelInfo;
end;



Procedure Database_Open;
var user:String;
Begin
if GetCurrentUser<>'' then user:='; Користувач: '+AnsiUpperCase(GetCurrentUser) else user:='';
     Application.Title:=ExtractFileNameOnly(GetCurrentDatabase);//'Моя супербаза 2';
     Application.MainForm.Caption:='DataExpress -> БД: '+Application.Title+user;
     CreateComponents(nil);
StartTimer;
SetLabelInfo(nil);
End;

procedure Database_Close;
begin
 lbl.Free;
 pan.Free;
 T.Free;
end;

В Main уже кто то живет и ругается компилятор на нового товарища. Как их поженить?
Для сети очень полезная штука.

Аватара пользователя
YurAnt
Эксперт
Сообщения: 3352
Зарегистрирован: 13 апр 2017, 08:57
Поблагодарили: 6 раз
Контактная информация:

Re: Лаунчер для DataExpress с функционалом обновления программы.

Сообщение YurAnt » 07 ноя 2017, 19:01

kaltsone писал(а):Как их поженить?

Код: Выделить всё

var
lbl: TLabel;
pan: TPanel;
T: TTimer;

procedure MSG(S:TObject);
begin
msgbox(' ','А ну не клацай!!!')
end;

procedure CreateComponents(Sender: TObject);
begin
pan:= TPanel.Create(MainWindow.Toolbar);
pan.Parent := MainWindow.Toolbar;
With pan do
 Begin
    Left:=MainWindow.Toolbar.Width;
    Height:=30;
    width:=MainWindow.Toolbar.width-left;
    align:=alRight;
    BevelOuter:=bvNone;
    anchors:=[akRight,akLeft]
 end;
    lbl:=TLabel.Create(pan);
    lbl.Parent := pan;
    With lbl do
      Begin
        Name:='info';
        SetBounds(pan.width-60, 4, 0, 10);
        Font.Style:=[fsBold];
        Font.Name:='Roboto';
        Font.Size:=16;
        Font.Color:=clGreen;
        Anchors:=[akRight];
        Alignment:=taRightJustify;
        OnDblClick:=@msg;
      End;
end;


procedure SetLabelInfo(Sender: TObject);
begin
lbl.Caption := FormatDateTime('hh:mm:ss',TDateTime(Now))+'  '+EvalExpr('WEEKDAY(DATE)',nil)+'  '+DateToStr(TDateTime(Now));
end;

procedure StartTimer;
begin
T := TTimer.Create(nil);
T.Enabled:=true;
T.Interval := 1000;
T.OnTimer:=@SetLabelInfo;
end;


{****************************************************************
                ПРОВЕРКА ОБНОВЛЕНИЙ DX
*****************************************************************}

function URLDownloadToFile(pCaller: cardinal; URL: PChar;
FileName: PChar;Reserved: cardinal; lpfnCB : cardinal): cardinal;
external 'URLDownloadToFileA@urlmon.dll stdcall';

function DeleteUrlCacheEntry(lpszUrlName:PChar):cardinal;
external 'DeleteUrlCacheEntry@wininet.dll stdcall';

procedure CheckAndInstallUpdate;
var Current,New:TDateTime;
objWinHttp:variant;
begin
Current:=StrToDate(FormatDateTime('dd.mm.yyyy',FileDateToDateTime(FileAge(Application.Exename))));
try
    objWinHttp := CreateOleObject('MSXML2.XMLHTTP');
    objWinHttp.Open('GET', 'http://mydataexpress.ru/latest_version.php', false);
    objWinHttp.Send;
  if StrToDate(objWinHttp.ResponseText)<>Current then
 // MsgBox('Проверка обновлений','У вас установлена последняя версия DataExpress.')
 // else
  if MessageDlg(
  'Обновление',
  'Новая версия DataExpress (от '+objWinHttp.ResponseText+') доступна для скачивания. Загрузить?',
  mtInformation,
  [mbYes,mbNo]) = 6 then
    begin
    debug('Загрузка новой версии...');
    DeleteUrlCacheEntry('http://mydataexpress.ru/files/dx3bsetup.exe');
    Application.ProcessMessages;
    if URLDownloadToFile(0, 'http://mydataexpress.ru/files/dx3bsetup.exe',
    PChar(GetTempDir+'dx3bsetup.exe'), 0, 0)=0 then
    begin
    debug('Установка...');
    ShellExecute('',GetTempDir+'dx3bsetup.exe','','',5)
    end
    else
      begin
      debug('Ошибка. Загрузка обновления не удалась.');
      objWinHttp:=Unassigned;
      exit;
      end;
    end;
 // else exit;
finally
  objWinHttp:=Unassigned;
except;
 // debug(ExceptionParam);
  objWinHttp:=Unassigned;
end;
end;


Procedure Database_Open;
var user:String;
Begin
if GetCurrentUser<>'' then user:='; Користувач: '+AnsiUpperCase(GetCurrentUser) else user:='';
     Application.Title:=ExtractFileNameOnly(GetCurrentDatabase);//'Моя супербаза 2';
     Application.MainForm.Caption:='DataExpress -> БД: '+Application.Title+user;
     CreateComponents(nil);
StartTimer;
SetLabelInfo(nil);
 CheckAndInstallUpdate; // ПРОВЕРКА ОБНОВЛЕНИЙ DX
End;

procedure Database_Close;
begin
 lbl.Free;
 pan.Free;
 T.Free;
end;


Для проверки функционирования можно временно заменить:
if StrToDate(objWinHttp.ResponseText)<>Current then на
if StrToDate(objWinHttp.ResponseText)=Current then и перезапустить программу.

Аватара пользователя
kaltsone
Знаток
Сообщения: 530
Зарегистрирован: 16 май 2017, 10:34
Откуда: Киев

Re: Лаунчер для DataExpress с функционалом обновления программы.

Сообщение kaltsone » 07 ноя 2017, 19:13

Компилятор отработал. Для проверки установил DataExpress за август. Открылось с ошибкой только рамка. Или эксперимент неудачный?

Аватара пользователя
YurAnt
Эксперт
Сообщения: 3352
Зарегистрирован: 13 апр 2017, 08:57
Поблагодарили: 6 раз
Контактная информация:

Re: Лаунчер для DataExpress с функционалом обновления программы.

Сообщение YurAnt » 07 ноя 2017, 19:23

Попробуйте октябрьскую.

Аватара пользователя
kaltsone
Знаток
Сообщения: 530
Зарегистрирован: 16 май 2017, 10:34
Откуда: Киев

Re: Лаунчер для DataExpress с функционалом обновления программы.

Сообщение kaltsone » 07 ноя 2017, 19:26

YurAnt писал(а):Для проверки функционирования можно временно заменить:
if StrToDate(objWinHttp.ResponseText)<>Current then на
if StrToDate(objWinHttp.ResponseText)=Current then и перезапустить программу.


Все четко отработало. А то раньше приходилось бегать по пользователям обновлять. Перспективно. Спасибо.

Аватара пользователя
rausNT
Специалист
Сообщения: 742
Зарегистрирован: 24 авг 2017, 09:23
Благодарил (а): 116 раз
Поблагодарили: 8 раз

Re: Лаунчер для DataExpress с функционалом обновления программы.

Сообщение rausNT » 07 ноя 2017, 22:40

kaltsone писал(а):
YurAnt писал(а):
А то раньше приходилось бегать по пользователям обновлять.


А я подключил сетевой диск у пользователей с правами на чтение , вывел ярлык на рабочий стол, и меняю екзешник в сетевой папке. Проще же. Это неправильно?

Аватара пользователя
YurAnt
Эксперт
Сообщения: 3352
Зарегистрирован: 13 апр 2017, 08:57
Поблагодарили: 6 раз
Контактная информация:

Re: Лаунчер для DataExpress с функционалом обновления программы.

Сообщение YurAnt » 07 ноя 2017, 22:42

kaltsone писал(а): ........... А то раньше приходилось бегать по пользователям обновлять.

Проще... Но это больше для локалки(vpn-а), а пользователи могут и удаленно через интернет сидеть.
Вопрос только - как они у Вас общий конфиг без ругани используют..?

Аватара пользователя
rausNT
Специалист
Сообщения: 742
Зарегистрирован: 24 авг 2017, 09:23
Благодарил (а): 116 раз
Поблагодарили: 8 раз

Re: Лаунчер для DataExpress с функционалом обновления программы.

Сообщение rausNT » 08 ноя 2017, 10:28

YurAnt писал(а):Вопрос только - как они у Вас общий конфиг без ругани используют..?


конфиг это файл dataexpress.cfg ?

вот все стандартно, что тут может конфликтовать?

Код: Выделить всё

[spoiler][UI]
Language=ru
FormWidth=1061
FormHeight=688
FormState=2
ConfirmExit=0
WasError=0
ExpertMode=1
DebugFormWidth=750
DebugFormHeight=480
ExprFormWidth=847
ExprFormHeight=513

[Connection]
Database=Srv13:C:\FB\DB\DOLJNIK.FDB
Remote=1
Password=mЕЯ+¦€·bЂ

[Folders]
Templates=T:\templates\
Output=

[Apps]
XML=
DOCX=
ODT=
HTML=
ODS=

[Recents]
1=Srv13:C:\FB\DB\DOLJNIK.FDB|1|mЕЯ+¦€·bЂ

[Script Editor]
Width=1000
Height=600
Classes_HideParents=1
Classes_SearchUrl=https://www.google.ru/webhp?sourceid=chrome-instant&ion=1&espv=2&ie=UTF-8#q=VCL+
Classes_Width=217
Modules_Width=231
Messages_Height=81
[/spoiler]