Вопрос Как при нехватки свободного места на диске(в скрипте) мигало красным цветом?

Yaroslav950 · 11 Авг 2022

Добрый вечер,

Код:

#define NeedSize "75000"

[Setup]
AppName=Test
AppVersion=1.5
DefaultDirName={sd}\Test

[Languages]
Name: russian; MessagesFile: compiler:Languages\Russian.isl

[CustomMessages]
russian.FreeSize=Доступно места на диске:
russian.NeedSize=Требуется места на диске:


[Code]
var
NeedSpaceLabel,FreeSpaceLabel: TLabel;
FreeMB, TotalMB: Cardinal;
NeedSize: Integer;

//================= Диск =================//
function NumToStr(Float: Extended): String;
begin
  Result:= Format('%.2f', [Float]);
  StringChange(Result, ',', '.');
  while ( Pos('.', Result) > 0 ) and ( (Result[Length(Result)] = '0') or (Result[Length(Result)] = '.') ) do
    SetLength(Result, Length(Result) - 1);
end;

function MbOrTb(Float: Extended): String;
begin
  if Float < 1024 then Result:= NumToStr(Float)+' Мб' else
    if Float/1024 < 1024 then Result:= NumToStr(Float/1024)+' Гб' else
      Result:= NumToStr(Float/(1024*1024))+' Тб';
end;

procedure GetFreeSpaceCaption(Sender: TObject);
var
  Path: String;
begin
  Path := ExtractFileDrive(WizardForm.DirEdit.Text);
  GetSpaceOnDisk(Path, True, FreeMB, TotalMB);
  if FreeMB > 1024 then
   FreeSpaceLabel.Caption:= ExpandConstant('{cm:FreeSize} ')+MbOrTb(FreeMB)+' ('+IntToStr(round(FreeMB*100/TotalMB))+'%)';
  if FreeMB < NeedSize then
    WizardForm.NextButton.Enabled := False else
  WizardForm.NextButton.Enabled := True;
end;

procedure GetNeedSpaceCaption;
begin
  if NeedSize > 1024 then
  NeedSpaceLabel.Caption := ExpandConstant('{cm:NeedSize} ')+ NumToStr(round(NeedSize/1024*100)/100) + ' Гб' else
  NeedSpaceLabel.Caption := ExpandConstant('{cm:NeedSize} ')+ IntToStr(NeedSize)+ ' Мб';
end;
//================= Конец - Диска =================//

procedure InitializeWizard;
begin
NeedSize:= {#NeedSize};
NeedSpaceLabel:= TLabel.Create(WizardForm);
NeedSpaceLabel.SetBounds(ScaleX(50),ScaleY(315),ScaleX(300),ScaleY(20))
NeedSpaceLabel.Transparent:= True;
NeedSpaceLabel.Font.Style:= [fsBold]
NeedSpaceLabel.Font.Color:= clLime
NeedSpaceLabel.Font.Size:= 10
NeedSpaceLabel.Parent:= WizardForm

FreeSpaceLabel:= TLabel.Create(WizardForm);
FreeSpaceLabel.SetBounds(ScaleX(295), ScaleY(315), ScaleX(300),ScaleY(20))
FreeSpaceLabel.Transparent:= True;
FreeSpaceLabel.Font.Style:= [fsBold]
FreeSpaceLabel.Font.Color:= clLime
FreeSpaceLabel.Font.Size:= 10
FreeSpaceLabel.Parent:= WizardForm

WizardForm.DirEdit.OnChange:= @GetFreeSpaceCaption;
WizardForm.DirEdit.Text:= WizardForm.DirEdit.Text + #0;

(*
WizardForm.DirEdit.Parent:= WizardForm
WizardForm.DirEdit.Left:= ScaleX(42)
WizardForm.DirEdit.Top:= ScaleY(370)
WizardForm.DirEdit.Width:= ScaleX(250)
WizardForm.DirEdit.Font.Size:= 8
WizardForm.DirEdit.Font.Style:= [fsBold]
*)
end;


procedure CurPageChanged(CurPageID: Integer);
begin
FreeSpaceLabel.Hide;
NeedSpaceLabel.Hide;
case CurPageID of
  wpSelectDir:
  begin
  FreeSpaceLabel.Show; NeedSpaceLabel.Show;
  GetNeedSpaceCaption;
end;
end;
end;

С кодом постоянные ошибки нашёл скрипт Need for Speed Undercover [v.2.4c], там есть такой код,но он сложный,может проще можно сделать. Код который я скинул не надо менять, а просто по этому коду пример сделать.

Nemko · 12 Авг 2022

Yaroslav950, может показаться сложнее, но это кажется, в примере выше просто таймера нет и Preprocessor'a.
Должно работать на Inno EE, Inno VCL, Inno 6.0 >, но и на стандартной ниже 6.0 будет, только нужно CallbackCtrl.dll добавить в код.
За решение с Preprocessor'ом спасибо Shegorat.

Код:

[Setup]
AppName=Test
AppVerName=Test
DefaultDirName={pf}\Test

[CustomMessages]
Need=Нужно
Free=Свободно

[Option]
//Нужный объем МБ (Гб=1024Мб)
#define NeedSize "10240000"

[CallBack_PreProcessor]
#if defined(IS_ENHANCED)
  #define SetCallBack(any Param) (VER < 0x06000000) ? \
    "CallBackAddr('" + Param + "')" : "CreateCallBack(@" + Param + ")"
#else
  #define SetCallBack(any Param) (VER >= 0x06000000) ? \
    "CreateCallBack(@" + Param + ")" : "WrapCallBackAddr(@"  + Param + ", 4)"
#endif

[Code]
{ Module }
function SetTimer(hWnd, nIDEvent, uElapse, lpTimerFunc: LongWord): LongWord; external 'SetTimer@user32.dll stdcall';
function GetSpace(Obj: TLabel): Boolean;
var
  s, Path: String;
  FreeMB, TotalMB: Cardinal;
begin
  Result:= False;
  Path:= ExtractFileDrive(WizardForm.DirEdit.Text);
  GetSpaceOnDisk(Path, True, FreeMB, TotalMB);
  s:=CustomMessage('Free') + ': ';
  if FreeMB > 1024 then s:= s + IntToStr(Round(FreeMB/1024*100)/100) + ' Гб'
    else s:= s + IntToStr(FreeMB) + ' Мб';
  s:=s + ' | ';
  s:=s + CustomMessage('Need') + ': ';
  if {#NeedSize} > 1024 then s:= s + IntToStr(Round({#NeedSize}/1024*100)/100) + ' Гб'
    else s:= s + IntToStr(TotalMB) + ' Мб';
  Obj.Caption:= s;
  Result:= {#NeedSize} >= TotalMB;
end;
{ Code }
var
  Failure: Boolean;
  DiskSpace: TLabel;

function Proc(h: hWnd; Msg, wParam, lParam: LongInt): LongInt;
begin
  if Failure and DiskSpace.Visible then begin
    if DiskSpace.Font.Color <> clWindowText then DiskSpace.Font.Color:= clWindowText
    else DiskSpace.Font.Color:= clRed;
  end;
end;

procedure DirEditChange(Obj: TObject);
begin
  Failure:= GetSpace(DiskSpace);
  if not Failure then DiskSpace.Font.Color:= clWindowText;
end;

procedure InitializeWizard;
begin
  with WizardForm do begin
    SetTimer(0, 0, 200, {#SetCallBack('Proc')});
    DirEdit.OnChange:=@DirEditChange;
    DiskSpace:=TLabel.Create(nil);
    with DiskSpace do begin
      Parent:=WizardForm;
      SetBounds(16, 355, 260, 22);
    end;
  end;
end;

procedure CurPageChanged(Page: Integer);
begin
  if Page = wpSelectDir then begin
    Failure:= GetSpace(DiskSpace);
    DiskSpace.Show;
  end else DiskSpace.Hide;
end;

Nemko · 12 Авг 2022

Yaroslav950, я тут подумал, чуть не уснул - можно так сократить:

Код:

[Setup]
AppName=Test
AppVerName=Test
DefaultDirName={pf}\Test

[CustomMessages]
Need=Нужно
Free=Свободно

[Option]
//Нужный объем МБ (Гб=1024Мб)
#define NeedSize "10240"

[CallBack_PreProcessor]
#define A = (Defined UNICODE) ? "W" : "A"
#if defined(IS_ENHANCED)
  #define SetCallBack(any Param) (VER < 0x06000000) ? \
    "CallBackAddr('" + Param + "')" : "CreateCallBack(@" + Param + ")"
#else
  #define SetCallBack(any Param) (VER >= 0x06000000) ? \
    "CreateCallBack(@" + Param + ")" : "WrapCallBackAddr(@"  + Param + ", 4)"
#endif

[Code]
{ Module }
function SetTimer(hWnd, nIDEvent, uElapse, lpTimerFunc: LongWord): LongWord; external 'SetTimer@user32.dll stdcall';
function GetDriveType(nDrive: String): LongInt; external 'GetDriveType{#A}@kernel32.dll stdcall';

{ Code }
var
  OldPath: String;
  FreeMB: Cardinal;
  DiskSpace: TLabel;

function Proc(h: hWnd; Msg, wParam, lParam: LongInt): LongInt;
var
  s, Path: String;
  null: Cardinal;
begin
  with DiskSpace do begin
    if OldPath <> WizardForm.DirEdit.Text then begin
      Font.Color:= clWindowText;
      OldPath:=WizardForm.DirEdit.Text;
      Path:= ExtractFileDrive(WizardForm.DirEdit.Text);
      GetSpaceOnDisk(Path, True, FreeMB, null);
      if GetDriveType(Path) = 5 then FreeMB:=0;
      s:=CustomMessage('Free') + ': ';

      if FreeMB > 1024 then s:= s + IntToStr(Round(FreeMB/1024*100)/100) + ' Гб'
        else s:= s + IntToStr(FreeMB) + ' Мб';
      s:=s + ' | ' + CustomMessage('Need') + ': ';
      if {#NeedSize} > 1024 then s:= s + IntToStr(Round({#NeedSize}/1024*100)/100) + ' Гб'
        else s:= s + IntToStr({#NeedSize}) + ' Мб';
      Caption:= s;
    end;
    if ({#NeedSize} >= FreeMB) then
    if Font.Color <> clWindowText then Font.Color:= clWindowText
    else Font.Color:= clRed;
  end;
end;

procedure InitializeWizard;
begin
  DiskSpace:=TLabel.Create(nil);
  with DiskSpace do begin
    Parent:=WizardForm;
    SetBounds(16, 355, 260, 22);
  end;
  SetTimer(0, 0, 200, {#SetCallBack('Proc')});
end;

procedure CurPageChanged(Page: Integer);
begin
  if Page = wpSelectDir then DiskSpace.Show else DiskSpace.Hide;
end;

Yaroslav950 · 12 Авг 2022

@Nemko,все класно даже нет торможения при смене цвета,но
CustomMessage('Need') + ': ' как данную строчку сместить вправо на несколько позиций (слишком близко находятся)?

vint56 · 12 Авг 2022

Вот пример с миганием свободного места автор примера YURSHAT Need for Speed™ Undercover 2.0

Nemko · 12 Авг 2022

Yaroslav950, пробелов добавить в строку (ниже):

s:=s + ' | (сюды) ' + CustomMessage('Need') + ': ';

Вопрос Как при нехватки свободного места на диске(в скрипте) мигало красным цветом?

Yaroslav950

Участник

Nemko

Дилетант

Nemko

Дилетант

Yaroslav950

Участник

vint56

Ветеран

Вложения

Nemko

Дилетант