[Back to DELPHI SWAG index] [Back to Main SWAG index] [Original]

    This document contains the source code for a unit that is useful for
    getting, setting, and deleting volume labels from a floppy or hard disk.
    The code for getting a volume label uses the Delphi FindFirst function,
    and the code for setting and deleting volume labels involves calling DOS
    interrupt 21h, functions 16h and 13h respectively.  Since function 16h
    isn't supported by Windows, it must be called through DPMI interrupt 31h,
    function 300h.

    { *** BEGIN CODE FOR VOLLABEL UNIT *** }

    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);
    { procedure invokes int 31h function 0300h to simulate a real mode }

    { interrupt  from protected mode. }
    var
      ErrorFlag: Boolean;
    begin
      asm
        mov ErrorFlag, 0       { assume success }
        mov ax, 0300h          { function 300h }
        mov bl, Int            { real mode interrupt to execute }
        mov bh, 0              { required }
        mov cx, 0              { stack words to copy, assume zero }
        les di, Regs           { es:di = Regs }
        int 31h                { DPMI int 31h }
        jnc @@End              { carry flag set on error }

      @@Error:
        mov ErrorFlag, 1       { return false on error }
      @@End:
      end;
      if ErrorFlag then
        raise EDPMIError.Create('Failed to execute DPMI interrupt');
    end;

    function DriveLetterToNumber(DriveLet: Char): Byte;
    { function converts a character drive letter into its numerical equiv. }
    begin
      if DriveLet in ['a'..'z'] then
        DriveLet := Chr(Ord(DriveLet) -32);
      if not (DriveLet in ['A'..'Z']) then
        raise EConvertError.CreateFmt('Cannot convert %s to drive number',

                                      [DriveLet]);
      Result := Ord(DriveLet) - 64;
    end;

    procedure PadVolumeLabel(var Name: Str11);
    { procedure pads Volume Label string with spaces }
    var
      i: integer;
    begin
      for i := Length(Name) + 1 to 11 do
        Name := Name + ' ';
    end;

    function GetVolumeLabel(Drive: Char): Str11;
    { function returns volume label of a disk }
    var
      SR: TSearchRec;
      DriveLetter: Char;
      SearchString: String[7];
      P: Byte;
    begin
      SearchString := Drive + ':\*.*';

      { find vol label }
      if FindFirst(SearchString, faVolumeID, SR) = 0 then begin
        P := Pos('.', SR.Name);
        if P > 0 then begin                      { if it has a dot... }
          Result := '           ';               { pad spaces between name }
          Move(SR.Name[1], Result[1], P - 1);    { and extension }
          Move(SR.Name[P + 1], Result[9], 3);
        end
        else begin
          Result := SR.Name;                     { otherwise, pad to end }
          PadVolumeLabel(Result);

        end;
      end
      else
        Result := '';
    end;

    procedure DeleteVolumeLabel(Drv: Char);
    { procedure deletes volume label from given drive }
    var
      CurName: Str11;
      FCB: TExtendedFCB;
      ErrorFlag: WordBool;
    begin
      ErrorFlag := False;
      CurName := GetVolumeLabel(Drv);        { get current volume label }
      FillChar(FCB, SizeOf(FCB), 0);         { initialize FCB with zeros }
      with FCB do begin
        ExtendedFCBflag := $FF;              { always }
        Attr := faVolumeID;                  { Volume ID attribute }

        DriveID := DriveLetterToNumber(Drv); { Drive number }
        Move(CurName[1], FileName, 8);       { must enter volume label }
        Move(CurName[9], FileExt, 3);
      end;
      asm
        push ds                              { preserve ds }
        mov ax, ss                           { put seg of FCB (ss) in ds }
        mov ds, ax
        lea dx, FCB                          { put offset of FCB in dx }
        mov ax, 1300h                        { function 13h }
        Call DOS3Call                        { invoke int 21h }

        pop ds                               { restore ds }
        cmp al, 00h                          { check for success }
        je @@End
      @@Error:                               { set flag on error }
        mov ErrorFlag, 1
      @@End:
      end;
      if ErrorFlag then
        raise EInterruptError.Create('Failed to delete volume name');
    end;

    procedure SetVolumeLabel(NewLabel: Str11; Drive: Char);
    { procedure sets volume label of a disk.  Note that this procedure }
    { deletes the current label before setting the new one.  This is }

    { required for the set function to work. }
    var
      Regs: TRealModeRegs;
      FCB: PExtendedFCB;
      Buf: Longint;
    begin
      PadVolumeLabel(NewLabel);
      if GetVolumeLabel(Drive) <> '' then           { if has label... }
        DeleteVolumeLabel(Drive);                   { delete label }
      Buf := GlobalDOSAlloc(SizeOf(PExtendedFCB));  { allocate real buffer }
      FCB := Ptr(LoWord(Buf), 0);
      FillChar(FCB^, SizeOf(FCB), 0);               { init FCB with zeros }
      with FCB^ do begin

        ExtendedFCBflag := $FF;                     { required }
        Attr := faVolumeID;                         { Volume ID attribute }
        DriveID := DriveLetterToNumber(Drive);      { Drive number }
        Move(NewLabel[1], FileName, 8);             { set new label }
        Move(NewLabel[9], FileExt, 3);
      end;
      FillChar(Regs, SizeOf(Regs), 0);
      with Regs do begin                            { SEGMENT of FCB }
        ds := HiWord(Buf);                          { offset = zero }

        dx := 0;
        ax := $1600;                                { function 16h }
      end;
      RealModeInt($21, Regs);                       { create file }
      if (Regs.al <> 0) then                        { check for success }
        raise EInterruptError.Create('Failed to create volume label');
    end;

    end.
    { *** END CODE FOR VOLLABEL UNIT *** }

[Back to DELPHI SWAG index] [Back to Main SWAG index] [Original]