Советы по Delphi
Управление метками томов дисков
Управление метками томов дисков из 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; 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 *** } |
[000628]
