Delphi 1
Управление метками томов дисков
Управление метками томов дисков из Delphi-приложений
Данный совет содержит исходный код модуля, который может помочь Вам получить, установить и удалить метку тома гибкого или жесткого диска. Код получения метки тома содержит функцию Delphi FindFirst, код для установки и удаления метки тома использует вызов DOS-прерывания 21h и функции 16h и 13h соответственно. Поскольку функция 16h не поддерживается Windows, она должна вызываться через DPMI-прерывание 31h, функцию 300h.
{ *** НАЧАЛО КОДА МОДУЛЯ VOLLABEL *** }
unit VolLabel; interface uses Classes, SysUtils, WinProcs; type EInterruptError = class(Exception);
EDPMIError = class(EInterruptError);
Str11 = String[11];
procedure SetVolumeLabel(NewLabel: Str11; Drive: Char); function GetVolumeLabel(Drive: Char): Str11; procedure DeleteVolumeLabel(Drv: Char); implementation type PRealModeRegs = ^TRealModeRegs;
TRealModeRegs = record
case Integer of
0: (
EDI, ESI, EBP, EXX, EBX, EDX, ECX, EAX: Longint;
Flags, ES, DS, FS, GS, IP, CS, SP, SS: Word);
1: (
DI, DIH, SI, SIH, BP, BPH, XX, XXH: Word;
case Integer of
0: (
BX, BXH, DX, DXH, CX, CXH, AX, AXH: Word);
1: (
BL, BH, BLH, BHH, DL, DH, DLH, DHH,
CL, CH, CLH, CHH, AL, AH, ALH, AHH: Byte));
end;
PExtendedFCB = ^TExtendedFCB;
TExtendedFCB = Record
ExtendedFCBflag : Byte;
Reserved1 : array[1..5] of Byte;
Attr : Byte;
DriveID : Byte;
FileName : array[1..8] of Char;
FileExt : array[1..3] of Char;
CurrentBlockNum : Word;
RecordSize : Word;
FileSize : LongInt;
PackedDate : Word;
PackedTime : Word;
Reserved2 : array[1..8] of Byte;
CurrentRecNum : Byte;
RandomRecNum : LongInt;
end;
procedure RealModeInt(Int: Byte; var Regs: TRealModeRegs); { процедура работает с прерыванием 31h, функцией 0300h для иммитации } { прерывания режима реального времени для защищенного режима. } var ErrorFlag: Boolean;
beginasm
mov ErrorFlag, 0 { успешное завершение }
mov ax, 0300h { функция 300h }
mov bl, Int { прерывание режима реального времени, которое необходимо выполнить }
mov bh, 0 { требуется }
mov cx, 0 { помещаем слово в стек для копирования, принимаем ноль }
les di, Regs { es:di = Regs }
int 31h { DPMI-прерывание 31h }
jnc @@End { адрес перехода установлен в error }
@@Error:
mov ErrorFlag, 1 { возвращаем false в error }
@@End:
end;
if ErrorFlag then
raise EDPMIError.Create('Неудача при выполнении DPMI-прерывания');
end;function DriveLetterToNumber(DriveLet: Char): Byte; { функция преобразования символа буквы диска в цифровой эквивалент. } begin if DriveLet in ['a'..'z'] then
DriveLet := Chr(Ord(DriveLet) -32);
if not (DriveLet in ['A'..'Z']) then
raise EConvertError.CreateFmt('Не могу преобразовать %s в числовой эквивалент диска',
[DriveLet]);
Result := Ord(DriveLet) - 64;
end;procedure PadVolumeLabel(var Name: Str11); { процедура заполнения метки тома диска строкой с пробелами } var i: integer;
beginfor i := Length(Name) + 1 to 11 do
Name := Name + ' ';
end;function GetVolumeLabel(Drive: Char): Str11; { функция возвращает метку тома диска } var SR: TSearchRec;
DriveLetter: Char;
SearchString: String[7];
P: Byte;
beginSearchString := Drive + ':\*.*';
{ ищем метку тома }
if FindFirst(SearchString, faVolumeID, SR) = 0 then begin
P := Pos('.', SR.Name);
if P > 0 then begin { если у него есть точка... }
Result := ' '; { пространство между именами }
Move(SR.Name[1], Result[1], P - 1); { и расширениями }
Move(SR.Name[P + 1], Result[9], 3);
end
else begin
Result := SR.Name; { в противном случае обходимся без пробелов }
PadVolumeLabel(Result);
end;
end
else
Result := '';
end;procedure DeleteVolumeLabel(Drv: Char); { процедура удаления метки тома с данного диска } var CurName: Str11;
FCB: TExtendedFCB;
ErrorFlag: WordBool;
beginErrorFlag := False;
CurName := GetVolumeLabel(Drv); { получение текущей метки тома }
FillChar(FCB, SizeOf(FCB), 0); { инициализируем FCB нулями }
with FCB do begin
ExtendedFCBflag := $FF; { всегда }
Attr := faVolumeID; { Аттрибут Volume ID }
DriveID := DriveLetterToNumber(Drv); { Номер диска }
Move(CurName[1], FileName, 8); { необходимо ввести метку тома }
Move(CurName[9], FileExt, 3);
end;
asm
push ds { сохраняем ds }
mov ax, ss { помещаем сегмент FCB (ss) в ds }
mov ds, ax
lea dx, FCB { помещаем смещение FCB в dx }
mov ax, 1300h { функция 13h }
Call DOS3Call { вызываем int 21h }
pop ds { восстанавливаем ds }
cmp al, 00h { проверка на успешность выполнения }
je @@End
@@Error: { устанавливаем флаг ошибки }
mov ErrorFlag, 1
@@End:
end;
if ErrorFlag then
raise EInterruptError.Create('Не могу удалить имя тома');
end;procedure SetVolumeLabel(NewLabel: Str11; Drive: Char); { процедура присваивания метки тома диска. Имейте в виду, что } { данная процедура удаляет текущую метку перед установкой новой. } { Это необходимое требование для функции установки метки. } var Regs: TRealModeRegs;
FCB: PExtendedFCB;
Buf: Longint;
beginPadVolumeLabel(NewLabel);
if GetVolumeLabel(Drive) <> '' then { если имеем метку... }
DeleteVolumeLabel(Drive); { удаляем метку }
Buf := GlobalDOSAlloc(SizeOf(PExtendedFCB)); { распределяем реальный буфер }
FCB := Ptr(LoWord(Buf), 0);
FillChar(FCB^, SizeOf(FCB), 0); { инициализируем FCB нулями }
with FCB^ do begin
ExtendedFCBflag := $FF; { требуется }
Attr := faVolumeID; { Аттрибут Volume ID }
DriveID := DriveLetterToNumber(Drive); { Номер диска }
Move(NewLabel[1], FileName, 8); { устанавливаем новую метку }
Move(NewLabel[9], FileExt, 3);
end;
FillChar(Regs, SizeOf(Regs), 0);
with Regs do begin { Сегмент FCB }
ds := HiWord(Buf); { отступ = ноль }
dx := 0;
ax := $1600; { Функция 16h }
end;
RealModeInt($21, Regs); { создаем файл }
if (Regs.al <> 0) then { проверка на успешность выполнения }
raise EInterruptError.Create('Не могу создать метку тома');
end;end. { *** КОНЕЦ КОДА МОДУЛЯ VOLLABEL *** } |
[000628]