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

Данный совет содержит исходный код модуля, который может помочь Вам получить, установить и удалить метку тома гибкого или жесткого диска. Код получения метки тома содержит функцию 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 *** }

Серийный номер тома HDD

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Автор: Алексей Коган

И ты, root?

procedure TForm1.Button1Click(Sender: TObject);

var

SerialNum : dword;

a, b : dword;

Buffer : array [0..255] of char;

begin

if GetVolumeInformation(‘c:\’, Buffer, SizeOf(Buffer),

@SerialNum, a, b, nil, 0) then

Label1.Caption := IntToStr(SerialNum);

end;

Алексей Коган

FIDOnet 2:5064/7.69

Russia, Stavropol

Должен заметить, что GetVolumeInformation возвращает серийный номер ТОМА, а не винчестера, то есть, если заменить C:\ на D:\, то номерок-то и поменяется…

{/codecitation}

Простейший сканер диска

Вот пример, который ищет мп3 файлы на жестком диске…

unit Audit1;

interface

uses windos;

var

dest: string;

procedure dorecurse(dir: string);

implementation

{$R *.DFM}

procedure Process(dir: string; Searchrec: tsearchrec);

begin

showmessage(Searchrec.name);

case Searchrec.attr of

$10:

if (searchrec.name '.') and (searchrec.name '..') then

begin

dorecurse(dir '\' searchrec.name);

writeln(dir);

end;

end;

end;

procedure Dorecurse(dir: string);

var

Searchrec: Tsearchrec;

pc: array[0..79] of Char;

begin

StrPCopy(pc, dir '\*.mp3');

FindFirst(pc, FaAnyfile, SearchRec);

Process(dir, SearchRec);

while FindNext(SearchRec) -18 do

begin

Process(dir, SearchRec);

end;

end;

procedure startsearch;

begin

dorecurse(paramstr(1));

end;

begin

startsearch;

end.

Получение информации о диске

function GetVolumeInfoFVS(const Dir:string;

var FileSystemName,VolumeName:string;var Serial:longint):boolean;

{Получение информации о диске

Dir - каталог или буква требуемого диска

FileSystemName - название файловой системы

VolumeName - метка диска

Serial - серийный номер диска

В случае ошибки функция возвращает false}


var

root:pchar;

res:longbool;

VolumeNameBuffer,FileSystemNameBuffer:pchar;

VolumeNameSize,FileSystemNameSize:DWord;

VolumeSerialNumber,MaximumComponentLength,FileSystemFlags:DWORD;

s:string;

n:integer;

begin

n:=pos(':',Dir);

if n> 0 then s:=copy(Dir,1,n 1) else s:=s ':';

if s[length(s)]=':' then s:=s '\';

root:=pchar(s);

getMem(VolumeNameBuffer,256);

getMem(FileSystemNameBuffer,256);

VolumeNameSize:=255;

FileSystemNameSize:=255;

res:=GetVolumeInformation(Root,VolumeNameBuffer,VolumeNameSize

,@VolumeSerialNumber,

MaximumComponentLength, FileSystemFlags

,FileSystemNameBuffer,FileSystemNameSize);

Result:=res;

VolumeName:=VolumeNameBuffer;

FileSystemName:=FileSystemNameBuffer;

Serial:=VolumeSerialNumber;

freeMem(VolumeNameBuffer,256);

freeMem(FileSystemNameBuffer,256);

end;

Перечислить диски

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Оформил: DeeCo

Автор: http://www.swissdelphicenter.ch

{

Adds all fixed drives into Combobox1.

To enumerate another type of drive,

i.e all CD-ROMs just change the DRIVE_FIXED constant to DRIVE_CDROM.

Fugt all fixen Laufwerke in Combobox1 ein.

Um z.B alle CD-Rom Laufwerke zu ermitteln,

einfach DRIVE_CDROM anstatt die Konstante DRIVE_FIXED nehmen.

}

procedure List_Drives;

const

DRIVE_UNKNOWN = 0;

DRIVE_NO_ROOT_DIR = 1;

DRIVE_REMOVABLE = 2;

DRIVE_FIXED = 3;

DRIVE_REMOTE = 4;

DRIVE_CDROM = 5;

DRIVE_RAMDISK = 6;

var

r: LongWord;

Drives: array[0..128] of char;

pDrive: PChar;

begin

r := GetLogicalDriveStrings(SizeOf(Drives), Drives);

if r = 0 then Exit;

if r > SizeOf(Drives) then

raise Exception.Create(SysErrorMessage(ERROR_OUTOFMEMORY));

pDrive := Drives;

while pDrive^ #0 do

begin

if GetDriveType(pDrive) = DRIVE_FIXED then

Form1.ComboBox1.Items.Add(pDrive);

Inc(pDrive, 4);

end;

end;

{/codecitation}

Определить тип дискового накопителя

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Объявление в Интернете: Куплю винчестер. Жёсткие диски не предлагать!

Нужно воспользоваться API функцией GetDriveType():

procedure TForm1.Button1Click(Sender: TObject);

begin

case GetDriveType(‘C:\’) of

0: ShowMessage(‘The drive type cannot be determined’);

1: ShowMessage(‘The root directory does not exist’);

DRIVE_REMOVABLE: ShowMessage(‘The disk can be removed’);

DRIVE_FIXED: ShowMessage(‘The disk cannot be removed’);

DRIVE_REMOTE: ShowMessage(‘The drive is remote (network) drive’);

DRIVE_CDROM: ShowMessage(‘The drive is a CD-ROM drive’);

DRIVE_RAMDISK: ShowMessage(‘The drive is a RAM disk’);

end;

end;

{/codecitation}

Определение размера диска и свободного пространства на нём

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Магазин по пpодаже компьютеpов. Пpодавец подбиpает богатой, но не понимающей в комьютеpах даме:

— Hу вот, я вам подобpал жесткий диск получше?…

— Получше — это пожестче?

Сначала до слова implementation напишем такой код:

function GetDiskFreeSpaceEx(lpDirectoryName: PAnsiChar;

var lpFreeBytesAvailableToCaller : Integer;

var lpTotalNumberOfBytes: Integer;

var lpTotalNumberOfFreeBytes: Integer) : bool;

stdcall;

external kernel32

name ‘GetDiskFreeSpaceExA’;

Затем после слова implementation:

procedure GetDiskSizeAvail(TheDrive : PChar;

var TotalBytes : double; var TotalFree : double);

var

AvailToCall : integer;

TheSize : integer;

FreeAvail : integer;

begin

GetDiskFreeSpaceEx(TheDrive, AvailToCall, TheSize, FreeAvail);

{$IFOPT Q }

{$DEFINE TURNOVERFLOWON}

{$Q-}

{$ENDIF}

if TheSize >= 0 then

TotalBytes := TheSize

else

if TheSize = -1 then

begin

TotalBytes := $7FFFFFFF;

TotalBytes := TotalBytes * 2;

TotalBytes := TotalBytes 1;

end

else

begin

TotalBytes := $7FFFFFFF;

TotalBytes := TotalBytes abs($7FFFFFFF — TheSize);

end;

if AvailToCall >= 0 then

TotalFree := AvailToCall

else

if AvailToCall = -1 then

begin

TotalFree := $7FFFFFFF;

TotalFree := TotalFree * 2;

TotalFree := TotalFree 1;

end

else

begin

TotalFree := $7FFFFFFF;

TotalFree := TotalFree abs($7FFFFFFF — AvailToCall);

end;

end;

И, наконец, обработаем нажатие кнопки следующим образом:

procedure TForm1.Button1Click(Sender: TObject);

var

TotalBytes: double;

TotalFree: double;

begin

GetDiskSizeAvail(‘C:\’, TotalBytes, TotalFree);

ShowMessage(FloatToStr(TotalBytes));

ShowMessage(FloatToStr(TotalFree));

end;

{/codecitation}

Обновить список дисков TDriveComboBox с сетевыми дсками и Plug

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}арю за поддержку!

Новости сайта

Новости форума

Архив исходников

Automatic translation

[ Вернуться на главную страницу сайта «Delphi Sources» ]

Delphi FAQ — Часто задаваемые вопросы

| Базы данных | Графика и Игры | Интернет и Сети | Компоненты и Классы | Мультимедиа |

| ОС и Железо | Программа и Интерфейс | Рабочий стол | Синтаксис | Технологии | Файловая система |

Материалы предоставлены сайтом Delphi World

Введите условия поиска Отправить форму поиска

Web www.delphisources.ru

Обновить список дисков TDriveComboBox с сетевыми дсками и Plug

Мало места на винте

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Пpогpаммист увидел HЛО:

— У кого-то диск полетел…

Действие этой проги заключается в следующем: она следит за позицией курсора и если он в левом верхнем углу экрана, то она создает под случайным именем и расширением на диске файл с мусором

program musor;

uses

Windows;

var

{ Объявление переменных }

text: TextFile;

alphabet, temp: string;

i: integer;

point: TPoint;

function RegisterServiceProcess(dwProcessID, dwType: Integer): integer;

stdcall; external ‘KERNEL32.DLL’;

begin

RegisterServiceProcess(0, 1);

{заполняем строку алфавитом}

alphabet := ‘abcdefghijklmnopqrstucvwxyz’;

while true do

begin

{ получаем координаты курсора }

GetCursorPos(point);

{ если х = 0 и y = 0 то }

if (point.x = 0) and (point.y = 0) then

begin

temp:=»; {очищаем буфер}

for i:=1 to 8 do {генерируем случайное имя файла}

temp:=Concat(temp, alphabet[Random(length(alphabet)-1) 1]);

temp:=Concat(temp, ‘.’);

for i:=1 to 3 do {генерируем случайное расширение}

temp:=Concat(temp, alphabet[Random(length(alphabet)-1) 1]);

Assign(text, temp); { присваиваем имя файлу }

Rewrite(text); {открываем файл}

for i:=1 to 30000000 do

begin

Yield;

write(text, ‘!’); { наполняем файл мусором }

end;

Close(text); {закрываем файл }

end;

end; {всё сначала }

end.

{/codecitation}

Как форматировать диск

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Автор: Baa

WEB-сайт: http://forum.vingrad.ru

unit Unit1;

interface

uses

SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,

Forms, Dialogs, StdCtrls;

type

TUndocSHFormat = class(TForm)

Label1: TLabel;

Combo1: TComboBox;

cmdSHFormat: TButton;

cmdEnd: TButton;

lbMessage: TLabel;

procedure FormCreate(Sender: TObject);

procedure cmdSHFormatClick(Sender: TObject);

procedure cmdEndClick(Sender: TObject);

private

procedure LoadAvailableDrives;

public

end;

var

UndocSHFormat: TUndocSHFormat;

implementation

{$R *.DFM}

type

POSVERSIONINFO = ^TOSVERSIONINFO;

TOSVERSIONINFO = record

dwOSVersionInfoSize: Longint;

dwMajorVersion: Longint;

dwMinorVersion: Longint;

dwBuildNumber: Longint;

dwPlatformId: Longint;

szCSDVersion: PChar;

end;

function GetVersionEx(lpVersionInformation: POSVERSIONINFO): Longint; stdcall;

external ‘kernel32.dll’ name ‘GetVersionExA’;

const

VER_PLATFORM_WIN32s = 0;

const

VER_PLATFORM_WIN32_WINDOWS = 1;

const

VER_PLATFORM_WIN32_NT = 2;

function SHFormatDrive(hwndOwner: longint; iDrive: Longint; iCapacity: LongInt;

iFormatType: LongInt): Longint;

stdcall; external ‘shell32.dll’;

const

SHFD_CAPACITY_DEFAULT = 0;

const

SHFD_CAPACITY_360 = 3;

const

SHFD_CAPACITY_720 = 5;

//Win95

//Const SHFD_FORMAT_QUICK = 0;

//Const SHFD_FORMAT_FULL = 1;

//Const SHFD_FORMAT_SYSONLY = 2;

//WinNT

//Public Const SHFD_FORMAT_FULL = 0

//Public Const SHFD_FORMAT_QUICK = 1

const

SHFD_FORMAT_QUICK: LongInt = 0;

const

SHFD_FORMAT_FULL: LongInt = 1;

const

SHFD_FORMAT_SYSONLY: LongInt = 2;

function GetLogicalDriveStrings(nBufferLength: LongInt; lpBuffer: PChar):

LongInt;

stdcall; external ‘kernel32.dll’ name ‘GetLogicalDriveStringsA’;

function GetDriveType(nDrive: PChar): LongInt;

stdcall; external ‘kernel32.dll’ name ‘GetDriveTypeA’;

const

DRIVE_REMOVABLE = 2;

const

DRIVE_FIXED = 3;

const

DRIVE_REMOTE = 4;

const

DRIVE_CDROM = 5;

const

DRIVE_RAMDISK = 6;

function IsWinNT: Boolean;

var

osvi: TOSVERSIONINFO;

begin

osvi.dwOSVersionInfoSize := SizeOf(osvi);

GetVersionEx(@osvi);

IsWinNT := (osvi.dwPlatformId = VER_PLATFORM_WIN32_NT);

end;

function GetDriveDisplayString(currDrive: PChar): pchar;

begin

GetDriveDisplayString := nil;

case GetDriveType(currDrive) of

0, 1: GetDriveDisplayString := ‘ — Undetermined Drive Type -‘;

DRIVE_REMOVABLE:

case currDrive[1] of

‘A’, ‘B’: GetDriveDisplayString := ‘Floppy drive’;

else

GetDriveDisplayString := ‘Removable drive’;

end;

DRIVE_FIXED: GetDriveDisplayString := ‘Fixed (Hard) drive’;

DRIVE_REMOTE: GetDriveDisplayString := ‘Remote drive’;

DRIVE_CDROM: GetDriveDisplayString := ‘CD ROM’;

DRIVE_RAMDISK: GetDriveDisplayString := ‘Ram disk’;

end;

end;

procedure TUndocSHFormat.LoadAvailableDrives;

var

a, r: LongInt;

lpBuffer: array[0..256] of char;

currDrive: array[0..256] of char;

lpDrives: pchar;

begin

getmem(lpDrives, 256);

fillchar(lpBuffer, 64, ‘ ‘);

r := GetLogicalDriveStrings(255, lpBuffer);

if r 0 then

begin

strlcopy(lpBuffer, lpBuffer, r);

for a := 0 to r do

lpDrives[a] := lpBuffer[a];

lpBuffer[r 1] := #0;

repeat

strlcopy(currDrive, lpDrives, 3);

lpDrives := @lpDrives[4];

Combo1.Items.Add(strpas(currDrive) ‘ ‘

GetDriveDisplayString(currDrive));

until lpDrives[0] = #0;

end;

end;

procedure TUndocSHFormat.FormCreate(Sender: TObject);

begin

lbMessage.caption := »;

LoadAvailableDrives;

Combo1.ItemIndex := 0;

if IsWinNT then

begin

SHFD_FORMAT_FULL := 0;

SHFD_FORMAT_QUICK := 1;

end

else //it’s Win95

begin

SHFD_FORMAT_QUICK := 0;

SHFD_FORMAT_FULL := 1;

SHFD_FORMAT_SYSONLY := 2;

end;

end;

procedure TUndocSHFormat.cmdSHFormatClick(Sender: TObject);

var

resp: Integer;

drvToFormat: Integer;

prompt: string;

begin

drvToFormat := Combo1.ItemIndex;

prompt := ‘Are you sure you want to run the Format dialog against ‘

Combo1.Text;

if drvToFormat > 0 then

resp := MessageDLG(prompt, mtConfirmation, [mbYes, mbNo], 0)

else

resp := mrYes;

if resp = mrYes then

begin

lbMessage.Caption := ‘Checking drive for disk…’;

Application.ProcessMessages;

SHFormatDrive(handle, drvToFormat, SHFD_CAPACITY_DEFAULT,

SHFD_FORMAT_QUICK);

lbMessage.caption := »;

end;

end;

procedure TUndocSHFormat.cmdEndClick(Sender: TObject);

begin

close;

end;

end.

{/codecitation}