Shegorat
Advanced Member | Редактировать | Профиль | Сообщение | ICQ | Цитировать | Сообщить модератору
[Setup]
AppName=myApp
AppVerName=MyApp
DefaultDirname={pf}\MyApp
[Files]
Source: compiler:innocallback.dll; DestDir: {tmp}; Flags: dontcopy
[Code]
type
TProc = procedure(HandleW, msg, idEvent, TimeSys: LongWord);
#ifdef UNICODE
PAnsiChar=PChar;
#define A "W"
#else
#define A "A"
#endif
const
BufferLen = 101;
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;
Path: string;
FreeMB, TotalMB: Cardinal;
drives: DWORD;
i: integer;
hWnd: Integer;
VolumeName, FileSystemName: AnsiString;
VolumeSerialNo: Longint;
MaxComponentLength,
FileSystemFlags: Longint;
NeedSize: double;
RefreshButton: Tbutton;
TimerID: LongWord;
pfunc: LongWord;
function GetLogicalDrives: DWORD;
external 'GetLogicalDrives@kernel32.dll stdcall';
function GetDriveType(nDrive: string): Longint;
external 'GetDriveType{#A}@kernel32.dll stdcall';
function MessageBox(hWnd: Integer; lpText, lpCaption: string; uType: Cardinal): Integer;
external 'MessageBox{#A}@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 NumToStr(Float: Extended; Digits: Integer): String;
var i: Integer;
begin
Result:= FloatToStr(Float); StringChange(Result, ',', '.'); i:= Length(Result);
while ((i-Pos('.', Result))>Digits) do begin SetLength(Result, i-1); i:=i-1; end;
while ((Result[i]='0')or(Result[i]='.'))and(Pos('.', Result)>0) do begin SetLength(Result, i-1); i:=i-1; end;
end;
function MbOrTb(Float: Extended): String;
begin
if Float < 1024 then
Result:= NumToStr(Float, 2)+' Мб' else
if Float/1024 < 1024 then
Result:= NumToStr(Round(Float*1000/1024)/1000, 2)+' Гб' else
Result:= NumToStr(Round(Float*1000/1024/1024)/1000, 2)+' Тб'
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 := 'Для установки приложения необходимо ' + NumToStr(Size, 2) + ' Мб,'#13 + 'а на выбранном Вами диске доступно только ' + IntToStr(FreeMB) + ' Мб';
end;
if ediniz = 1 then
if FreeMB < 1024 then s := 'Для установки гигабайтного приложения необходимо ' + NumToStr(Size, 2) + ' Мб,'#13 + 'а на выбранном Вами диске доступно только ' + floatToStr(round(FreeMB * 1000) / 1000) + ' MB'
else s := 'Для установки гигабайтного приложения необходимо ' + NumToStr((Round(Size*1000/1024))/1000, 2) + ' Гб,'#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(PAnsiChar(Path), PAnsiChar(VolumeName), BufferLen - 1, VolumeSerialNo,
MaxComponentLength,
FileSystemFlags,
PAnsiChar(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(MbOrTb(TotalMB),10) +' всего| '+ PadL(MbOrTb(FreeMB),9)+ PadL(NumToStr(FreeMb*100/TotalMb, 0),4)+ '% своб| ' + PadL(GetFileSystemName(Path),5))
end;
end;
end;
end;
procedure InitializeWizard();
begin
NeedSize := 256; //Прописать, сколько мегабайт необходимо
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 := 'Необходимо для установки не менее чем ' + NumToStr(NeedSize, 2) + ' MB свободного места.'
else WizardForm.DiskSpaceLabel.Caption := 'Необходимо для установки не менее чем ' + NumToStr(NeedSize/1024, 2) + ' 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(417);
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, 2) + PadL(MbOrTb(TotalMB),10) +' всего| '+ PadL(MbOrTb(FreeMB),9)+ PadL(NumToStr(FreeMb*100/TotalMb, 0),4)+ '% своб| ' + PadL(GetFileSystemName(Path),5))
end;
end;
end;
end;
procedure OnTimer(HandleW, msg, idEvent, TimeSys: LongWord);
begin
RefreshButtonOnClick(RefreshButton);
end;
procedure CurPageChanged(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 NextButtonClick(CurPageID: Integer): Boolean;
var Path: 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 DeinitializeSetup();
begin
KillTimer(0, TimerID);
end; |
