Determine a CD-Rom-Drive

Question

Q:
How can i determine if a CD-ROM drive is on the machine. I tried using the WIN API GetDriveType but it return the same number (4) if it is a CD-ROM or a network drive.

Answer

A:
This should do the trick..

function IsCDROM(DriveNum: Integer): Boolean; assembler;
asm
  MOV   AX,1500h { look for MSCDEX }
  XOR   BX,BX
  INT   2fh
  OR    BX,BX
  JZ    @Finish
  MOV   AX,150Bh { check for using CD driver }
  MOV   CX,DriveNum
  INT   2fh
  OR    AX,AX
  @Finish:
end;

BTW under Win32 GetDriveType properly returns a CD-ROM drive.

A:
Function IsCdRom(DriveNum : Word) : Boolean;
Var
   F : WordBool;
Begin
   asm
      mov ax, 1500h      { test for presence of MSCDEX }
      xor bx, bx
      int 2fh
      mov ax, bx         { if bx = zero, MSCDEX is not present }
      or  ax, ax         { return FALSE }
      jz  @no_mscdex
      mov ax, 150bh      { MSCDEX drive check }
      mov cx, DriveNum   { cx contains drive }
      int 2fh
      @no_mscdex:
      mov f,ax
   end;
   Result := F;          { Assign function return value }
End;

Need help on overriding Sys Err

Question

Want the app. to read and recognize a drive not ready (i.e., user selects a
floppy drive with no disk in drive) -  then want the app to display the error
box rather than Windows System Error display box.

Answer

A:
Here's a routine that will do the trick for diskette drives:

 function DisketteDriveReady (DisketteDrive: char): boolean;
{----------------------------------------------------------------}
{ Returns true if specified Diskette drive [A/a or B/b] is ready }
{ with a diskette inserted, otherwise false.  From a Delphi-Talk }
{ posting by Per Ola Svensson    }
{----------------------------------------------------------------}
  var
   Drive: byte;
   PrevInt24, DiscardReturnValue: word;
 begin
   DisketteDriveReady := false;    {until proven otherwise}
   case DisketteDrive of
     'A', 'a':  Drive := 1;
     'B', 'b':  Drive := 2;
     else Exit;
   end; {case}
   PrevInt24 := SetErrorMode(SEM_FAILCRITICALERRORS);
   if DiskFree(Drive) <> -1 then
     DisketteDriveReady := true;
   DiscardReturnValue := SetErrorMode(PrevInt24);
 end; {DisketteDriveReady}

Hard disk serial number

Question

Is there anyone who knows how to obtain the hard disk serial number?

Answer

I have an unit to get the Hd Name and the Hd Serial number for Borland
Pascal 7.0. I don't know if it's working with Delphi and the other thing is
that it is in dutch and I don't have time to translate it in englisch. Mayby
you can use it, otherwise drop it out of the window.

Unit HardDisk;

INTERFACE

FUNCTION  GetHardDiskNaam               : STRING;
FUNCTION  GetHardDiskSerieNummer        : STRING;
FUNCTION  GetHardDiskControlleNummer    : STRING;
PROCEDURE GetHardDiskGegevens;

CONST
  CodeerTabel : ARRAY[0..24] OF BYTE =
(3,1,2,1,4,1,3,2,6,4,6,5,1,2,6,4,2,6,3,4,6,2,4,1,2);

TYPE
  CharArray = ARRAY[0..24] OF CHAR;

VAR
  HardDiskGegevens          : ARRAY[1..256] OF INTEGER;
  HardDiskNaam              : CharArray;
  SerieNummer               : CharArray;
  ControlleNummer           : CharArray;
  C_HardDiskNaam            : STRING;
  C_HardDiskSerieNummer     : STRING;
  C_HardDiskControlleNummer : STRING;
  C_LicentieNaam            : STRING;

IMPLEMENTATION

 FUNCTION GetHardDiskNaam : STRING;
 VAR
   Teller : INTEGER;
   Lus    : INTEGER;
 BEGIN
    GetHardDiskNaam := '';
    Teller := 1;
    FOR Lus := 1 TO 18 DO
    BEGIN
      HardDiskNaam[Teller] := CHR( ( HardDiskGegevens[27+Lus] DIV 256 ));
      Inc(Teller);
      HardDiskNaam[Teller] := CHR( ( HardDiskGegevens[27+Lus] MOD 256 ));
      Inc(Teller);
    END;
    GetHardDiskNaam := HardDiskNaam;
 END;

 FUNCTION GetHardDiskSerieNummer : STRING;
 VAR
   Teller : INTEGER;
   Lus    : INTEGER;
 BEGIN
    GetHardDiskSerieNummer := '';
    Teller := 1;
    FOR Lus := 1 TO 8 DO
    BEGIN
      SerieNummer[Teller] := CHR( ( HardDiskGegevens[10+Lus] DIV 256 ));
      Inc(Teller);
      SerieNummer[Teller] := CHR( ( HardDiskGegevens[10+Lus] MOD 256 ));
      Inc(Teller);
    END;
    GetHardDiskSerieNummer := SerieNummer;
 END;

 FUNCTION GetHardDiskControlleNummer : STRING;
 VAR
   Teller : INTEGER;
   Lus    : INTEGER;
 BEGIN
    GetHardDiskControlleNummer := '';
    Teller := 1;
    FOR Lus := 1 TO 3 DO
    BEGIN
      ControlleNummer[Teller] := CHR( ( HardDiskGegevens[23+Lus] DIV 256 ));
      Inc(Teller);
      ControlleNummer[Teller] := CHR( ( HardDiskGegevens[23+Lus] MOD 256 ));
      Inc(Teller);
    END;
    GetHardDiskControlleNummer := ControlleNummer;
 END;

 PROCEDURE GetHardDiskGegevens;
 VAR
   Lus    : INTEGER;
 BEGIN
   WHILE ( Port[$1f7] <> $50) DO ;
   Port[$1F6] := $A0 ;
   Port[$1F7] := $EC ;
   WHILE ( Port[$1f7] <> $58 ) DO ;
   FOR Lus := 1 TO 256 DO
   BEGIN
     HardDiskGegevens[Lus] := Portw[$1F0] ;
   END;
 END;

END.


A:
unit Chiunit4;

interface

function Chk...(ParamIn ... ,=20
         ParamDatabaseNamePchar: pchar ): longint; export;

implementation

uses  SysUtils, DBTables, ExtCtrls ;

const
  ide_drive_C           =3D $00A0;
  ide_Data              =3D $1F0;
  ide_Error             =3D $1F1;
  ide_DriveAndHead      =3D $1F6;
  ide_Command           =3D $1F7;
  ide_command_readpar   =3D $EC;
  ide_Status            =3D $1F7;
  ide_status_busy       =3D $80;
  ide_status_ready      =3D $40;
  ide_status_error      =3D $01;
  ide_Fixed             =3D $3F6;
  ide_Fixed_Irq         =3D $02;

  IntervalleMinimum  =3D 0.0000232;
  { 0.000011574 =3D 1 seconde (.0001 (hh.mmss) (->DEG=3D.0002777) / 24) }
  { .0000174 =3D 1 1/2 sec }  { .0000232 =3D 2 sec }

type
  tIdeRec =3D Record
    rec : array[0..255] of word;
  end;

var
  ExitSave :  Pointer;
  IdeRec :    tIdeRec;

function ConvertToString : string;
var
   i,j : integer;
begin
     FillChar( Result, 20, ' ' ); Result[0] :=3D #20;
     for i :=3D 1 to 20 do
       begin
         j :=3D Trunc( (i-1) /2 )  +10 ;
         if Lo(IdeRec.Rec[j]) =3D (0)
            then Result[i]:=3D ' '
            else
            Result[i]:=3D Chr ( Lo( IdeRec.Rec[j] ) ) ;
         i :=3D i +1;
         if Hi(IdeRec.Rec[j]) =3D (0)
            then Result[i]:=3D ' '
            else
            Result[i]:=3D Chr ( Hi( IdeRec.Rec[j] ) ) ;
       end;
end;

function DoIt(Numero: string) : longint;
var
  portchar    :byte;
  boo         :Boolean;
  i           :integer;
  S,S1        :String;
begin
  Result:=3D 19 ; { fail per default }
  FillChar( IdeRec.Rec, 512, ' ' ) ;

  { en premier lieu v=E9rifier l'=E9tat }
         boo :=3D true;
         { poll DRQ wait }
         i :=3D 5000 ;
         repeat
           i :=3D i -1;
           portchar :=3D Lo(port[ide_status]) ; { get status }
         until
         ( i < 1 ) or not
         ( ( portchar AND ide_status_busy ) =3D ide_status_busy ) ;
         if i < 1 then
              begin
                 { Result:=3D 'status allways busy'; }
                 Result :=3D 180 ;
                 boo :=3D false;
              end;

  if boo then
  try
    { premi=E8rement disable drive interrupts }
  port[ide_Fixed] :=3D 0;

  port[ide_DriveAndHead] :=3D ide_drive_C ;  { set drive }
  portchar :=3D Lo(port[ide_status]) ; { get status }
  if portchar =3D $ff then begin
                         { Result:=3D 'set drive status $ff'; }
                         Result :=3D 11 ;
                         boo :=3D false;
                         end;

  if boo then
     begin
         { poll DRQ wait }
         i :=3D 1024 ;
         repeat
           i :=3D i -1;
           portchar :=3D Lo(port[ide_status]) ;
         until
         ( i < 1 ) or not
         ( ( portchar AND ide_status_busy ) =3D ide_status_busy ) ;
         if i < 1 then
              begin
                 { Result:=3D 'status allways busy'; }
                 Result :=3D 181 ;
                 boo :=3D false;
              end;
     end;

  if boo then
         { check if ready }
         if ( portchar AND ide_status_ready ) =3D 0
            then begin
                 { Result:=3D 'set drive status not ready'; }
                 Result :=3D 12 ;
                 boo :=3D false;
                 end;

  if boo then
         { ok now want to readIDE }
         { send ReadParameters command }
         port[ide_Command] :=3D ide_command_readpar ;

         { poll DRQ wait }
         i :=3D 5000 ;
         repeat
           i :=3D i -1;
           portchar :=3D Lo(port[ide_status]) ;
         until
         ( i < 1 ) or not
         ( ( portchar AND ide_status_busy ) =3D ide_status_busy ) ;
         if i < 1 then
              begin
                 { Result:=3D 'status allways busy'; }
                 Result :=3D 182 ;
                 boo :=3D false;
              end;

  if boo then
         { check if no error}
         if ( portchar AND ide_status_error ) =3D ide_status_error
            then begin
                 { Result:=3D 'drive status error after ReadPar'; }
                 Result :=3D 13 ;
                 boo :=3D false;
                 end;

  if boo then
         { check if ready }
         if ( portchar AND ide_status_ready ) =3D 0
            then begin
                 { Result:=3D 'after ReadPar drive status not ready'; }
                 Result :=3D 14 ;
                 boo :=3D false;
                 end;

  if boo then
        try
        { ok now read the buffer 256 word }
         for i :=3D 0 to 255 do
             begin
             IdeRec.Rec[i] :=3D ( portw[ide_Data] ) ;
             end;
        except
          on Exception do begin
                          { ShowMessage( 'Erreur portw i=3D '+intToStr(i)=
 ) ; }
                          boo :=3D false;
                          Result :=3D 15 ;
                          end;
          else begin
               boo :=3D false;
               Result :=3D 16 ;
               raise;
               end;
        end;

  if boo Then
     begin
      S :=3D ConvertToString;
      if length(Numero) < 20 then S1:=3D Numero +'                    '
                             else S1:=3D Numero;
      if CompareStr ( S, Copy(S1,1,20) ) =3D 0
         then Result :=3D 10
         else Result :=3D 17 ;
             { Result :=3D '('+S+')<>('+Copy(S1,1,20)+')' ; }
     end;
  finally
  { re-enable disk interrupts }
  port[ide_Fixed] :=3D ide_Fixed_Irq ;
  end;
END;

procedure MyExit; far;
{ reset disk parameters so other disk operations won't be desturbed in ca=
se
  of program abort }
begin
  ExitProc :=3D ExitSave;        { restore previous exitproc }
{  Port[ide_Command]:=3D$10;      { send command: reset current drive }
end;

function GetParam(ParamAlias: string): String;
var
   i : integer ;
   t : TTable ;
   S : String ;
begin
 Result :=3D '';
 try
  t :=3D nil;
  t :=3D TTable.Create(nil);
  t.DatabaseName :=3D ParamAlias;
  t.TableName :=3D  ...;
  t.TableType :=3D ttPARADOX;
  t.open;
...
 finally
  if Assigned(t) then t.free ;
 end;
end;

function FixParam(ParamAlias: string): boolean;
var
   i : integer ;
   t : TTable ;
   S : String ;
begin
 Result :=3D False;
 try
  t :=3D nil;
  t :=3D TTable.Create(nil);
  t.DatabaseName :=3D ParamAlias;
  t.TableName :=3D  ;
  t.TableType :=3D ttPARADOX;
  t.open;
  if=20
    begin
...         t.Edit;
         t.setFields([nil, S]);
         t.post;
    end;
  t.close;
  Result :=3D True;
 finally
  if Assigned(t) then t.free ;
 end;
end;

  {----------------------------------------------------}

function Chk...(ParamIn: ;
                  ParamDatabaseNamePchar: pchar ): longInt ;
var
   ParamString :  String; =20
   Temps :        Real;
   Ok :           boolean;
   i:             integer;
   S :            string[20];
   S6 :           string[6];
   r :            longInt;

Label
     Jump;
BEGIN
  Result:=3D 0 ;  { par d=E9faut }
 if Ok then
       i :=3D 0;
       repeat
           begin
           i :=3D i +1 ;
           r :=3D DoIt(Copy(ParamString,54,20)) ;
           if r =3D 10 then begin
                          Ok :=3D True ;
                          break
                          end
                     else begin
                          Ok :=3D False ;
                          Result:=3D r;
                          Continue;
                          end;
           end;
       until i =3D 3 ;
  If Ok
     then begin
          Ok :=3D FixParam(ParamDatabaseName) ;
          If Ok then else { Result :=3D 'FixParam fail'; }
                          Result :=3D 2 ;
          end;
  If Ok then Result :=3D 1 ;
END;

Begin
  ExitSave:=3D ExitProc;
  ExitProc:=3D @MyExit;
end.

System Ram / CMOS

Question

Does anyone have any source code for extracting from the BIOS or any
other way the amount of RAM fitted to a system.

Answer

A:
You can try this... It will return the amount of extended mem from
the CMOS (Total K's minus the first Mb).

  Function MyGetExt: Integer; Assembler;
  asm
    Mov  AX,$3031;
    Out  $70,AL;
    NOP;
    IN   AL,$71;
    XCHG AH,AL;
    Out  $70,AL;
    NOP;
    IN   AL,$71;
  end;


A:
Attention CMOS-busters:

Here's what's happening for those not so sharp on their assembly language
directives.

To read from CMOS do the following:

        write to port $70 with the address value to read or write.
        write to port $71 with the new value or read the value of interest
from port $71.

CMOS is reasnably generic in some locations.  Most noteable are the
locations $0-$F, (the time,date and timer settings) and the locations from
$10-$1F, (general system settings).  The locations above $20 are usually
more subject to the whims of mfg's than the others which are reasonably
standard.

My example will be in C as ASM was just represented!  I'll get to Delphi in
a minute.

write to port $70 (hex) with the address value of the CMOS memory location
that you are interested

outp(0x70,0x31);     { tells CMOS we want to 'talk' to CMOS location 31hex }

next, read the desired value at port $71 or write a new value to the port.

outp(0x71, 0x10);      { this writes the value 10 hex (16
dec) to CMOS location 31as previously defined }

                        OR

x = inp(0x71);             { this reads the hex value from
CMOS location 31 as previously declared }

it is also good form to include a delay between the write to
port 70 and the read or write at port 71.  This is more important in
assembly routines and maybe real fast cpu's then in higher level languages.
That's the purpose of the NOP in Leif's code example and also generally
recommended.

You will note that in Leif's ASM code two locations are stuffed into the
AX, 30 and 31.  This is to allow for a quick load to search two addresses.
This code contains two instances, both CMOS reads.  The memory values are
stored in two consecutive locations but I believe it's a case of most
significant byte last.  And they also only concern the amount of memory
beyond 1 Mb as also stated below.

OK, ok, I know this is supposed to be Delphi but I'm a C programmer
reasonably new to Delphi and Pascal so to do this in Delphi probably
involves using Port or PortW but I haven't tried it yet so don't know exact
syntax.  Probably pretty similar to C style though.  Would be interested in
hearing from anyone that has done it that way.  Couldn't really find an
example yet and haven't had time for exploring.

Of a rather important note, it should be pointed out that this method will
only read so much memory.  Back in the old days, no one considered the vast
amounts of RAM available today system-wise and I believe that certain large
sizes of RAM will not be correctly loaded into CMOS.  Therefore this is not
a cure-all concept.  Some of this is caused by BIOS
shortcomings/short-sightings.  Also, you will need a CMOS map to show what
locations are loaded for which system parameters.  Some differences can
exist between different mfg's.  This can be a rather messy job...

Here's the most important thing for budding CMOS editors to remember:

       IF you edit a location between $10 and $2F then you WILL NEED to
calculate the NEW checksum by adding together all the location values from
$10-$2F and THEN WRITE the new value to $3E, $3F or YOU WILL GET A CMOS
CHECKSUM ERROR WHEN YOU REBOOT!  GUARANTEED!!!  THIS should concern you... 

        Also, don't try to test the values $0 - $1F.  Time marches on, don't
you know...

A:
There is no way of getting from the BIOS the total amount fo memory. The
BIOS will only report you that if you have 640K or minus (i.e. 256K...).
Since the real memory is virtualized, expecially in Windows enviroment,
you can only test for the presence of EMS, XMS, or DPMI memory using the
interrupt calls of this services, that reports you the free mem for every
one of this. I don't know if there is a way of know the phisical memory
fitted in the system under Win. Don't result to me there is an API function
providing this; you can only test for the total virtualized memory
(including swap files, etc.). I think under Win95 there is a method.
If you want, I can send you interrupt protocols for obtaining EMS etc., but
I don't think it can be useful to you under Win.

Disk Serial Numbers

Question

It is a C++ Class for reading/writing disk volume labels and serial numbers.
Any C++ gurus out there that can convert to DELPHI?

Answer

A:
This is not a conversion, but here's a Delphi unit with a function
that reads them. To write them,  you can change the AX value to $6901
and fill the buffer with your values before calling the interrupt.  
DOS 4.00+ required.



unit Sernumu;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls;

type
  TMediaID = Record
    InfoLevel : Word;
    SerialNumber : LongInt;
    VolumeLabel : Array[0..10] of Char;
    SysName : Array[0..7] of Char;
    End;
  TForm1 = class(TForm)
    Button1: TButton;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
    MediaID : TMediaID;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

type
  DPMIRegisters =
    record
      DI : LongInt;
      SI : LongInt;
      BP : LongInt;
      Reserved : LongInt;
      BX : LongInt;
      DX : LongInt;
      CX : LongInt;
      AX : LongInt;
      Flags : Word;
      ES : Word;
      DS : Word;
      FS : Word;
      GS : Word;
      IP : Word;
      CS : Word;
      SP : Word;
      SS : Word;
    end;


  function RealIntr(IntNo : Byte; var Regs : DPMIRegisters) : Word; Assembler;
  asm
    xor     bx,bx
    mov     bl,IntNo
    xor     cx,cx        {StackWords = 0}
    les     di,Regs
    mov     ax,0300h
    int     31h
    jc      @@ExitPoint
    xor     ax,ax
  @@ExitPoint:
  end;


function GetDiskInfo(Drive : Word; var MediaID : TMediaID) : Boolean;
type
  tLong = Record
    LoWord, HiWord : Word;
    End;
var
  Regs : DPMIRegisters;
  dwAddress : LongInt;
  Address : tLong absolute dwAddress;
begin
  Result := False;
  FillChar(MediaID, SizeOf(MediaID), 0);
  dwAddress := GlobalDosAlloc(SizeOf(MediaID)); { two paragraphs of DOS memory }
  if dwAddress = 0
    then            { address is zero if error occurred }
      exit;

  With Regs do
    begin
      bx := Drive;
      cx := $66;
      ds := Address.HiWord;
      ax := $6900;
      dx := 0;
      es := 0;
      flags := 0;
    end;
  If RealIntr($21, Regs) <> 0
    Then
      Exit;
  Move(ptr(Address.LoWord, 0)^, MediaID, SizeOf(MediaID));
  GlobalDosFree(Address.LoWord)     { free DOS memory block }
  Result := True;
end;



procedure TForm1.Button1Click(Sender: TObject);
begin
  GetDiskInfo(1, MediaID);
  With MediaID do
    Begin
      Label1.Caption := IntToHex(SerialNumber, 8);
      Label2.Caption := VolumeLabel;
      Label3.Caption := SysName;
    End;
end;

end.

Reading a byte from the parallel port

Question

I needed to read a byte from the parallel port (0x379).  I did it using inline
assemble language.  I noticed their is no way of doing it using the Windows API.
I have a sensor attached to this port.  It works fine but, is it safe to address
hardware directly in windows.  Windows is intercepting the call anyway (I
think).

Var
    BytesRead : BYTE;
begin
              asm                { Read port (LPT1) via Inline asm  }
                MOV dx,$379;
                IN  al,dx;
                MOV BytesRead,al;
              end;
BytesRead:=(BytesRead OR $07);   { OR and then XOR the data }
BytesRead:=(BytesRead XOR $80);  { to mask the unused bits  }

Answer

It's no problem, use the Turbo Pascal command ...

 value:=port[$379]; { read from port }

and

 port[$379]:=value; { write to port }

The port command doesn't seem to be documented in online help, but it
certainly works!

Getting disk information

Question

I was tring to get the serial number of a disk using Delphi, but the code does
not seem to work. It works only on a DOS window.

Answer

A:
I didn't find info regarding function 69h but I wrote something using
4409h:

type
  MIDPtr = ^MIDRec;
  MIDRec = Record
    InfoLevel: word;
    SerialNum: LongInt;
    VolLabel: Packed Array [0..10] of Char;
    FileSysType: Packed Array [0..7] of Char;
  end;

function GetDriveSerialNum(MID: MIDPtr; drive: Word): Boolean; assembler;
asm
  push  DS    { Just for safety, I dont think its really needed }
  mov   ax,440Dh { Function Get Media ID }
  mov   bx,drive    { drive no (0-Default, 1-A ...) } 
  mov   cx,0866h  { category and minor code }
  lds   dx,MID      { Load pointeraddr. } 
  call  DOS3Call   { Supposed to be faster than INT 21H } 
  jc    @@err
  mov   al,1           { No carry so return TRUE }
  jmp   @@ok
 @@err:
  mov   al,0           { Carry set so return FALSE }
 @@ok:
  pop   DS            { Restore DS, were not supposed to change it }
end;

procedure TForm1.NrBtnClick(Sender: TObject);
var
  Info: MIDRec;
begin
  Info.InfoLevel:=0; { Information Level }
  If GetDriveSerialNum(@Info,0) then  { Do something with it... }
    ListBox.Items.Add(IntToStr(Info.SerialNum)+' '+Info.VolLabel);
end;

Setting PC Clock

Question

Who can tell me how to SET the pc real time clock from a delphi program?

Answer

A:
{ SetDate sets the current date in the operating system. Valid  }
{ parameter ranges are: Year 1980-2099, Month 1-12 and Day      }
{ 1-31. If the date is not valid, the function call is ignored. }
procedure SetDate(Year, Month, Day: Word); assembler;
asm
	MOV	CX,Year
	MOV	DH,BYTE PTR Month
	MOV	DL,BYTE PTR Day
	MOV	AH,2BH
	INT	21H
end;

{ SetTime sets the time in the operating system. Valid          }
{ parameter ranges are: Hour 0-23, Minute 0-59, Second 0-59 and }
{ Sec100 (hundredths of seconds) 0-99. If the time is not       }
{ valid, the function call is ignored.                          }
procedure SetTime(Hour, Minute, Second, Sec100: Word); assembler;
asm
	MOV	CH,BYTE PTR Hour
	MOV	CL,BYTE PTR Minute
	MOV	DH,BYTE PTR Second
	MOV	DL,BYTE PTR Sec100
	MOV	AH,2DH
	INT	21H
end;

function SetSystemDateTime(Year, Month, Day, Hour, Minute, Second: word): integer;   export;
begin
  SetDate(Year, Month, Day);
  SetTime(Hour, Minute + 1, Second, 0);
  result := 1;
end;

Detecting Disk in Drive A:

Question

I am very new to delphi, so i apologize if this is an easy
question. What i need is to be able to detect if there is a disk in
drive A: and display a message if there is. Obviously, i do not want
the system to do anything if the drive is empty. Every way i have
tried this, i get a Windows Cancel/Retry message appearing when the
drive is empty.

Answer

This function should do the trick.

function DiskInDrive(Drive: Char): Boolean;
var
   ErrorMode: word;

begin
   if Drive in ['a'..'z'] then Dec(Drive, $20);
   if not (Drive in ['A'..'Z']) then
     raise EConvertError.Create('Not a valid drive ID');
   ErrorMode := SetErrorMode(SEM_FailCriticalErrors);
   try
    if DiskSize(Ord(Drive) - $40) = -1 then
      Result := False
    else
      Result := True;
    finally
      SetErrorMode(ErrorMode);
    end;
end;

Port and mem

Question

Does anyone knows how to access the port and mem arrays? The
documentation talks (very little) about them but don't say in what unit
they are.

Answer

For the ports in Delphi 2 I use

procedure OutPort( port :word; value :byte );
begin
  asm
    mov   dx,port
    mov   al,value
    out   dx,al
  end;
end;

function InPort( port :word ) :byte;
begin
  asm
    mov   dx,port
    in    al,dx
    mov   result,al
  end;
end;

Managing disk volume labels

Question

How to manage disk volume labels?

Answer

{
 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.
}

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 aa 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);
    ennd;
  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.

How to check if a drive is ready

Question

How to check if a drive is ready?

Answer

{
  The following function accepts a drive letter as a parameter,
  and it will return a boolean value that indicates whether
  or not there is a disk in the drive.
}
function DiskInDrive(Drive: Char): Boolean;
var
  ErrorMode: word;
begin
  { make it upper case }
  if Drive in ['a'..'z'] then Dec(Drive, $20);
  { make sure it's a letter }
  if not (Drive in ['A'..'Z']) then
    raise EConvertError.Create('Not a valid drive ID');
  { turn off critical errors }
  ErrorMode := SetErrorMode(SEM_FailCriticalErrors);
  try
    { drive 1 = a, 2 = b, 3 = c, etc. }
    if DiskSize(Ord(Drive) - $40) = -1 then
      Result := False
    else
      Result := True;
  finally
    { restore old error mode }
    SetErrorMode(ErrorMode);
  end;
end;

Detecting a Pentium processor

Question

How to detect a Pentium processor?

Answer

{
Here is a Delphi unit to detect the CPU type, modified from Intel's
code. Use should be fairly obvious.  If not, send me email, and I can
send you an example program.  Because Delphi's assembler is 16-bit,
the code looks a little wierd.  Try using a 32-bit disassembler to see
the 32-bit instructions (or read the comments).
}

unit CpuId;

{ This code comes from Intel, and has been modified for Delphi's
  inline assembler.  Since Intel made the original code freely
  available, I am making my changes freely available.

  Share and enjoy!

  Ray Lischner
  Tempest Software
  6/18/95
}

interface

type
  { All the types currently known.  As new types are created,
    add suitable names, and extend the case statement in
    CpuTypeString.
  }
  TCpuType = (cpu8086, cpu80286, cpu386, cpu486, cpuPentium);

{ Return the type of the current CPU }
function CpuType: TCpuType;

{ Return the type as a short string }
function CpuTypeString: String;

implementation

uses SysUtils;

function CpuType: TCpuType; assembler;
asm
  push DS

{ First check for an 8086 CPU }
{ Bits 12-15 of the FLAGS register are always set on the }
{ 8086 processor. }
  pushf				       { save EFLAGS }
  pop		bx		          { store EFLAGS in BX }
  mov		ax,0fffh		    { clear bits 12-15 }
  and		ax,bx		       { in EFLAGS }
  push	ax			       { store new EFLAGS value on stack }
  popf	 			       { replace current EFLAGS value }
  pushf				       { set new EFLAGS }
  pop		ax		          { store new EFLAGS in AX }
  and		ax,0f000h	    { if bits 12-15 are set, then CPU }
  cmp		ax,0f000h	    { is an 8086/8088 }
  mov 	ax, cpu8086     { turn on 8086/8088 flag }
  je		@@End_CpuType

  { 80286 CPU check }
  { Bits 12-15 of the FLAGS register are always clear on the }
  { 80286 processor. }
  or		bx,0f000h	    { try to set bits 12-15 }
  push 	bx
  popf
  pushf
  pop		ax
  and		ax,0f000h	      { if bits 12-15 are cleared, CPU=80286 }
  mov 	ax, cpu80286      { turn on 80286 flag }
  jz		@@End_CpuType

  { To test for 386 or better, we need to use 32 bit instructions,
    but the 16-bit Delphi assembler does not recognize the 32 bit opcodes
    or operands.  Instead, use the 66H operand size prefix to change
    each instruction to its 32-bit equivalent. For 32-bit immediate
    operands, we also need to store the high word of the operand immediately
    following the instruction.  The 32-bit instruction is shown in a comment
    after the 66H instruction.
  }

  { i386 CPU check }
  { The AC bit, bit #18, is a new bit introduced in the EFLAGS }
  { register on the i486 DX CPU to generate alignment faults. }
  { This bit can not be set on the i386 CPU. }

  db 66h                    { pushfd }
  pushf
  db 66h                    { pop eax }
  pop	ax		                { get original EFLAGS }
  db 66h                    { mov ecx, eax }
  mov	cx,ax		             { save original EFLAGS }
  db 66h                    { xor eax,40000h }
  xor	ax,0h	                { flip AC bit in EFLAGS }
  dw 0004h
  db 66h                    { push eax }
  push ax			          { save for EFLAGS }
  db 66h                    { popfd }
  popf				          { copy to EFLAGS }
  db 66h                    { pushfd }
  pushf				          { push EFLAGS }
  db 66h                    { pop eax }
  pop	ax		                { get new EFLAGS value }
  db 66h                    { xor eax,ecx }
  xor	ax,cx		             { can't toggle AC bit, CPU=Intel386 }
  mov ax, cpu386            { turn on 386 flag }
  je @@End_CpuType

{ i486 DX CPU / i487 SX MCP and i486 SX CPU checking }
{ Checking for ability to set/clear ID flag (Bit 21) in EFLAGS }
{ which indicates the presence of a processor }
{ with the ability to use the CPUID instruction. }
  db 66h                    { pushfd }
  pushf				          { push original EFLAGS }
  db 66h                    { pop eax }
  pop	ax		                { get original EFLAGS in eax }
  db 66h                    { mov ecx, eax }
  mov	cx,ax		             { save original EFLAGS in ecx }
  db 66h                    { xor eax,200000h }
  xor	ax,0h	                { flip ID bit in EFLAGS }
  dw 0020h
  db 66h                    { push eax }
  push ax			          { save for EFLAGS }
  db 66h                    { popfd }
  popf				          { copy to EFLAGS }
  db 66h                    { pushfd }
  pushf                     { push EFLAGS }
  db 66h                    { pop eax }
  pop	ax		                { get new EFLAGS value }
  db 66h                    { xor eax, ecx }
  xor ax, cx
  mov ax, cpu486            { turn on i486 flag }
  je @@End_CpuType	       { if ID bit cannot be changed, CPU=486
}
  { without CPUID instruction functionality }

{ Execute CPUID instruction to determine vendor, family, }
{ model and stepping.  The use of the CPUID instruction used }
{ in this program can be used for B0 and later steppings }
{ of the P5 processor. }
   db 66h                  { mov eax, 1 }
   mov ax, 1			      { set up for CPUID instruction }
   dw 0
   db 66h                  { cpuid }
	db	0Fh	              { Hardcoded opcode for CPUID instruction }
	db	0a2h
   db 66h                  { and eax, 0F00H }
	and ax, 0F00H	         { mask everything but family }
   dw 0
   db 66h                  { shr eax, 8 }
	shr ax, 8               { shift the cpu type down to the low byte }
   sub ax, 1               { subtract 1 to map to TCpuType }

@@End_CpuType:
   pop ds
end;

function CpuTypeString: String;
var
  kind: TCpuType;
begin
  kind := CpuType;
  case kind of
  cpu8086:
    Result := '8086';
  cpu80286:
    Result := '80286';
  cpu386:
    Result := '386';
  cpu486:
    Result := '486';
  cpuPentium:
    Result := 'Pentium';
  else
    { Try to be flexible for future cpu types, e.g., P6. }
    Result := Format('P%d', [Ord(kind)]);
  end;
end;

end.

Determining drive type

Question

How to determining drive types?

Answer

When dealing with multiple drives, it is helpful to know 
whether a drive is associated with a  is attached to a letter 
(A, B, C, etc), and what its type is.  This code uses the API
GetDriveType function to do that.

function ShowDriveType(DriveLetter: char): string;
var
  i: word;
begin
  if DriveLetter in ['A'..'Z'] then {Make it lower case.}
    DriveLetter := chr(ord(DriveLetter) + $20);
  i := GetDriveType(ord(DriveLetter) - ord('a'));
  case i of
    DRIVE_REMOVABLE: result := 'floppy';
    DRIVE_FIXED: result := 'hard disk';
    DRIVE_REMOTE: result := 'network drive';
    else result := 'does not exist';
  end;
end;

DISCLAIMER: You have the right to use this technical information
subject to the terms of the No-Nonsense License Statement that
you received with the Borland product to which this information
pertains.