Управление метками томов дисков

=== Управление метками томов дисков ===
Данный совет содержит исходный код модуля, который может помочь Вам получить, установить и удалить метку тома гибкого или жесткого диска. Код получения метки тома содержит функцию 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;
{ процедура работает с прерыванием 31h, функцией 0300h для имитации }
{ прерывания режима реального времени для защищенного режима. }
procedure RealModeInt(Int: Byte; var Regs: TRealModeRegs);
var
 ErrorFlag: Boolean;
begin
 asm
 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;
begin
 for 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;
begin
 SearchString := 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;
begin
 ErrorFlag := 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;
begin
 PadVolumeLabel(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 *** }
Source: Взято с http://delphiworld.narod.ru
ID: 01381