Inno Setup (создание инсталяционных пакетов) - [120] :: Программы

[Code]
type
TProc = procedure(HandleW, msg, idEvent, TimeSys: LongWord);

const
BufferLen = 1024;

DRIVE_UNKNOWN = 0;
DRIVE_NO_ROOT_DIR = 1;
DRIVE_REMOVEABLE = 2;
DRIVE_FIXED = 3;
DRIVE_REMOTE = 4;
DRIVE_CDROM = 5;
DRIVE_RAMDISK = 6;

// MB_ICONINFORMATION = $40;
// MB_ICONEXCLAMATION = $30;
// MB_ICONQUESTION = $20;
// MB_ICONSTOP = $10;
// MB_ICONNONE = $0;

var
ListBox: TListBox;
Text: TNewStaticText;
Memo: TMemo;
Path: string;
FreeMB, TotalMB: Cardinal;
drives: DWORD;
i: integer;
hWnd: Integer;
VolumeName, FileSystemName: string;
VolumeSerialNo: Longint;
MaxComponentLength,
FileSystemFlags: Longint;
res: integer;
NeedSize: double;
RefreshButton: Tbutton;
TimerID: LongWord;
pfunc: LongWord;

function GetLogicalDrives: DWORD;
external 'GetLogicalDrives@kernel32.dll stdcall';

function GetDriveType(nDrive: string): Longint;
external 'GetDriveTypeA@kernel32.dll stdcall';

function MessageBox(hWnd: Integer; lpText, lpCaption: string; uType: Cardinal): Integer;
external 'MessageBoxA@user32.dll stdcall';

function GetVolumeInformation(PathName, VolumeName: PAnsiChar; VolumeNameSize, VolumeSerialNumber, MaxComponentLength, FileSystemFlags: Longint; FileSystemName: PAnsiChar; FileSystemNameSize: Longint): Longint;
external 'GetVolumeInformationA@kernel32.dll stdcall';

function WrapTimerProc(callback: TProc; paramcount: integer): longword;
external 'wrapcallback@files:innocallback.dll stdcall';

function SetTimer(hWnd: LongWord; nIDEvent, uElapse: LongWord; lpTimerFunc: LongWord): LongWord;
external 'SetTimer@user32.dll stdcall';

function KillTimer(hWnd: LongWord; nIDEvent: LongWord): LongWord;
external 'KillTimer@user32.dll stdcall';

Function MorG(MB: Integer; autoGB: Boolean): string; {Перевод числа в строку объёма Мб/Гб (до 3х знаков после запятой)}
Begin If (MB < 1000) or not autoGB then Result:= IntToStr(MB)+ 'Мб' else Result:= FloatToStr(round(MB/1024*1000)/1000)+ 'Гб'; StringChange(Result, ',', '.') End;

function JustifySize(Size1: double; count: integer): string;
var
i, n: integer;
s1, s2, s3: string;
begin
n := 1;
for i := 1 to COunt do
begin
n := n * 10;
end;
s1 := floattostr(round(Size1 * n) / n);

if pos(',', s1) <> 0 then
begin
s2 := copy(s1, 1, pos(',', s1) - 1);
s3 := copy(s1, pos(',', s1) + 1, length(s1) - pos(',', s1));
end
else
begin
s2 := s1;
s3 := '000'
end;
n := length(s2);
if n < 3 then for i := 1 to (3 - n) do s2 := ' ' + s2;
n := length(s3);
if n < Count then for i := 1 to (Count - n) do s3 := s3 + '0';
result := s2 + ',' + s3;
end;

function Proz(One: integer; Two: integer): string;
var m: double;
begin
m := (One / Two);
if m * 100 > 10 then result := inttostr(Round(m * 100)) + '%' else Result := '0' + inttostr(Round(m * 100)) + '%';
end;

function CheckFreeSpace(Size: double; ediniz: integer): string;
var
s: string;
FreeMB, TotalMB: Cardinal;
begin
Path := ExtractFileDrive(WizardForm.DirEdit.Text);
GetSpaceOnDisk(Path, True, FreeMB, TotalMB);
Result := 'результата не будет!';
begin
if ediniz = 0 then
begin
s := 'Для установки приложения необходимо ' + floatTostr(Size) + ' MB,'#13 + 'а на выбранном Вами диске доступно только ' + IntToStr(FreeMB) + ' MB';
end;
if ediniz = 1 then
if FreeMB < 1024 then s := 'Для установки гигабайтного приложения необходимо ' + floatTostr((ROund((Size / 1024) * 1000)) / 1000) + ' GB,'#13 + 'а на выбранном Вами диске доступно только ' + floatToStr(round(FreeMB * 1000) / 1000) + ' MB'
else s := 'Для установки гигабайтного приложения необходимо ' + floatTostr((ROund((Size / 1024) * 1000)) / 1000) + ' GB,'#13 + 'а на выбранном Вами диске доступно только ' + floatToStr(round((FreeMB / 1024) * 1000) / 1000) + ' GB';
end;
result := s;
end;

function GetFileSystemName(Path: string): string;
begin
VolumeName := StringOfChar(' ', BufferLen);
FileSystemName := StringOfChar(' ', BufferLen);
GetVolumeInformation(Path, VolumeName, BufferLen - 1, VolumeSerialNo,
MaxComponentLength,
FileSystemFlags,
FileSystemName,
BufferLen - 1);
Result := Trim(FileSystemName);
end;

procedure ListBoxOnClick(Sender: TObject);
var
NewLetter, OldString: string;
begin
for i := 0 to ListBox.Items.Count - 1 do
begin
if ListBox.Selected[i] then
begin
NewLetter := Copy(ListBox.Items[i], 0, 1);
if GetFileSystemName(NewLetter + ':\') = 'NTFS' then
begin
OldString := Copy(WizardForm.DirEdit.Text, 2, Length(WizardForm.DirEdit.Text));
WizardForm.DirEdit.Text := NewLetter + OldString;
WizardForm.NextButton.Enabled := true;
end else
begin
WizardForm.NextButton.Enabled := false;
MsgBox('Только для файловой системы NTFS!' + #10#13 +
'Выбранный диск имеет файловую систему ' + GetFileSystemName(NewLetter + ':\'), mbInformation, MB_OK);
wizardForm.ComponentsDiskSpaceLabel.Visible := false;
end;
end;
end;
end;

procedure RefreshButtonOnClick(Sender: TObject);
begin
ListBox.Items.clear;
ListBox.Font.Size := 9;
ListBox.Font.Style := [];
ListBox.Color := clWhite;

drives := GetLogicalDrives();
for i := 1 to 31 do
begin
if (drives and (1 shl i)) > 0 then
begin
Path := UpperCase(chr(ord('A') + i) + ':\');
if GetDriveType(Path) = DRIVE_FIXED then
begin
GetSpaceOnDisk(Path, True, FreeMB, TotalMB);
ListBox.Items.Add(Copy(Path, 1, 2) + PadL(MorG(TotalMB,True),10) +' всего| '+ PadL(MorG(FreeMB,True),9)+ PadL(FloatToStr(round(FreeMB/TotalMB*100)),4)+ '% своб| ' + PadL(GetFileSystemName(Path),5))
end;
end;
end;
end;

procedure InitializeListBoxRefresh(mb_count :integer);
begin
NeedSize := mb_count; //Прописать, сколько мегабайт необходимо

Text := TNewStaticText.Create(WizardForm);
Text.Top := 102;
Text.Width := 332;
Text.Height := 14;
Text.Caption := 'Список жестких дисков и свободного места';
Text.Parent := WizardForm.SelectDirPage;
if NeedSize < 1024 then WizardForm.DiskSpaceLabel.Caption := 'Необходимо для установки не менее чем ' + JustifySize(NeedSize/1024, 3) + ' MB свободного места.'
else WizardForm.DiskSpaceLabel.Caption := 'Необходимо для установки не менее чем ' + JustifySize(NeedSize/1024, 3) + ' GB свободного места.';

Text := TNewStaticText.Create(WizardForm);
Text.Top := 195;
Text.left := 0;
Text.Width := 332;
Text.Height := 14;
Text.Caption := 'Устанавливать на раздел с файловой системой NTFS!!!';
Text.Font.Color := clRed;
Text.Font.Style := [fsBold]
Text.Parent := WizardForm.SelectDirPage;

ListBox := TListBox.Create(WizardForm);
ListBox.Top := 120;
ListBox.Width := ScaleX(332);
ListBox.Height := ScaleY(65);

ListBox.Parent := WizardForm.SelectDirPage;
ListBox.OnClick := @ListBoxOnClick;
ListBox.Font.Name:= 'Courier New';

ListBox.Font.Size := 9;
ListBox.Font.Style:= []
ListBox.Color := clWhite;

drives := GetLogicalDrives();
for i := 1 to 31 do
begin
if (drives and (1 shl i)) > 0 then
begin
Path := UpperCase(chr(ord('A') + i) + ':\');
if GetDriveType(Path) = DRIVE_FIXED then
begin
GetSpaceOnDisk(Path, True, FreeMB, TotalMB);
// ListBox.Items.Add(Copy(Path, 1, 3) + ' ' + JustifySize((TotalMB / 1024), 3) + ' GB' + ' |(' + Proz(FreeMB, TotalMB) + ')| ' + JustifySize((FreeMB / 1024), 3) + ' GB' + ' | ' + GetFileSystemName(Path))
ListBox.Items.Add(Copy(Path, 1, 2) + PadL(MorG(TotalMB,True),10) +' всего| '+ PadL(MorG(FreeMB,True),9)+ PadL(FloatToStr(round(FreeMB/TotalMB*100)),4)+ '% своб| ' + PadL(GetFileSystemName(Path),5))
end;
end;
end;
end;

procedure OnTimer(HandleW, msg, idEvent, TimeSys: LongWord);
begin
RefreshButtonOnClick(RefreshButton);
end;

procedure CurPageChangedListBoxRefresh(CurPageID: Integer);
begin
if CurPageID = wpSelectDir then
begin
pfunc := WrapTimerProc(@OnTimer, 4);
TimerID := SetTimer(0, 0, 10000, pfunc); // 1000 = 1 second
end
else
begin
KillTimer(0, TimerID);
end;
end;

function NextButtonClickListBoxRefresh(CurPageID: Integer): Boolean;
var
Path, s: string;
FreeMB, TotalMB: Cardinal;
begin
Result := True;
if CurPageID = wpSelectDir then
begin
Path := ExtractFileDrive(WizardForm.DirEdit.Text);
GetSpaceOnDisk(Path, True, FreeMB, TotalMB);
if freeMB < variant(NeedSize) then
begin
if NeedSize < 1024 then
begin
MessageBox(hWnd, CheckFreeSpace(NeedSize, 0), 'Недостаточно места на диске', MB_OK or $10);
result := false;
exit;
end
else
begin
MessageBox(hWnd, CheckFreeSpace(NeedSize, 1), 'Недостаточно на диске', MB_OK or $10);
result := false;
exit;
end;
end;
end;
end;

procedure DeinitializeSetupListBoxRefresh();
begin
KillTimer(0, TimerID);
end;

Модерирует : gyra, Maz
batva (20-05-2011 20:48): Inno Setup (создание инсталяционных пакетов)	Версия для печати • Подписаться • Добавить в закладки
На первую страницу • к этому сообщению • к последнему сообщению