Статьи по Delphi - CD-ROM, Работа с CD-ROM и иже с ним Опции

[yuansw]

Активизация или отключение автоматического проигрывания CD

Код

uses
  Registry;

procedure CDSetAutoPlay(SioNo: Boolean);
var
  Reg: TRegistry;
begin
  try
    Reg := TRegistry.Create;
    Reg.RootKey := HKEY_LOCAL_MACHINE;
    if Reg.KeyExists('Software\Classes\AudioCD\') then
      if Reg.OpenKey('Software\Classes\AudioCD\Shell\', False) then
        if SioNo then Reg.WriteString('', 'play')
        else
           Reg.WriteString('', '');
  finally
    Reg.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  {Activate  AutoPlay}
  CDSetAutoPlay(True);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  {Deactivate Autoplay}
  CDSetAutoPlay(False);
end;

Добавлено yuansw в [mergetime]1126655052[/mergetime]

Блокировка и разблокировка CD-ROM

Код

procedure TMainForm.CD_Lock(Locked: Boolean, DriveLetter: string);
const
 IOCTL_STORAGE_MEDIA_REMOVAL = $002D4804;
var
 hDrive: THandle;
 Returned: DWORD;
 DisableEject: boolean;
begin
 hDrive := CreateFile(PChar('\\.\' + DriveLetter), GENERIC_READ,
   FILE_SHARE_READ, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL,
   0);
 if GetLastError <> 0 then
   MessageDlg('Error:' + IntToStr(GetLastError), mtError, [mbOK], 0);
 try
   DisableEject := Locked;
   if not DeviceIoControl(hDrive,
     IOCTL_STORAGE_MEDIA_REMOVAL, // PREVENT_MEDIA_REMOVAL,
     @DisableEject,
     SizeOf(DisableEject),
     nil,
     0,
     Returned,
     nil) then
     MessageDlg('Ошибка:' + IntToStr(GetLastError), mtError, [mbOK], 0)
 finally
   CloseHandle(hDrive)
 end;
end;

CD_Lock(True) - блокирует CD-ROM
CD_Lock(False) - разблокирует CD-ROM

Для полного веселья можно заблокировать все CD-ROMы в системе через это:

Код

procedure TMainForm.LockCDROMs;
var
 w: dword;
 Root: string;
 i: byte;
begin
 w := GetLogicalDrives;
 Root := '#:\';
 for i := 0 to 25 do
 begin
   Root[1] := Char(Ord('A') + i);
   if (W and (1 shl i)) > 0 then
     if GetDriveType(PChar(Root)) = DRIVE_CDROM then
     begin
       DriveLetter := Copy(Root, 1, Length(Root) - 1);
       CD_Lock(True, DriveLetter)
     end
 end;
end;

Включен ли автозапуск CD

Код

procedure TForm1.SetCDAutoRun(AAutoRun: Boolean);
const
  DoAutoRun: array[Boolean] of Integer = (0, 1);
var
  Reg: TRegistry;
begin
  try
    Reg := TRegistry.Create;
    Reg.RootKey := HKEY_LOCAL_MACHINE;
    if Reg.KeyExists('System\CurrentControlSet\Services\Class\CDROM') then
    begin
      if Reg.OpenKey('System\CurrentControlSet\Services\Class\CDROM', False) then
        Reg.WriteBinaryData('AutoRun', DoAutoRun[AAutoRun], 1);
    end
  finally
    Reg.Free;
  end;
  ShowMessage('Your settings will take effect on the next reboot of Windows.');
end;

Как загрузить иконку CD-ROM

Код

function GetCDIcon(Drive: Char): TIcon;
var
 ico: TIcon;
 ini: TIniFile;
 s, p: string;
 i, j: Integer;
begin
 //Abbrechen wenn "AutoRun.Inf" nicht existiert.
 //Abort if "AutoRun.inf" doesn't exists.
 if FileExists(Drive + ':\autorun.inf') = False then
   Exit;

 //"AutoRun.inf" offnen
 //Opens the "AutoRun.inf"
 ini := TIniFile.Create(Drive + ':\autorun.inf');
 ico := TIcon.Create;

 try
   //Dateinamen lesen
   //Read the filename
   s := ini.ReadString('Autorun', 'ICON', '');

   //Abbrechen, wenn kein Icon festgelegt wurde
   //Abort if there is no icon specified
   if s = '' then
     Exit;

   //Icon von Datei laden
   //load the icon from a file
   if FileExists(s) then
     ico.LoadFromFile(s);
   if FileExists(Drive + ':\' + s) then
     ico.LoadFromFile(Drive + ':\' + s);

   //Icon aus einer Resource laden
   //Load the icon from a Win32 resource
   if (FileExists(s) = False) and (FileExists(Drive + ':\' + s) = False) then
   begin
     for j := (Pos(',', s) + 1) to Length(s) do
     begin
       p := p + s[j];
     end;
     i := StrToInt(p);
     for j := Length(s) downto (Pos(',', s)) do
       Delete(s, j, Length(s));

     if FileExists(s) = False then
       s := Drive + ':\' + s;

     ico.Handle := ExtractIcon(hinstance, PChar(s), i);
   end;

   Result := ico;
 finally
   ini.Free;
 end;
end;

Как узнать есть ли в заданном CD-ROMе Audio CD
Можно использовать функцию Windows API GetDriveType() чтобы определить является ли дисковод CD-ROM'мом. И функцию API GetVolumeInformation() чтобы проверить VolumeName на равенство 'Audio CD'.

Код

function IsAudioCD(Drive : char) : bool;
var
 DrivePath : string;
 MaximumComponentLength : DWORD;
 FileSystemFlags : DWORD;
 VolumeName : string;
begin
 sult := false;
 DrivePath := Drive + ':\';
 if GetDriveType(PChar(DrivePath)) <> DRIVE_CDROM then
   exit;
 SetLength(VolumeName, 64);
 GetVolumeInformation(PChar(DrivePath),PChar(VolumeName),
 Length(VolumeName),nil,MaximumComponentLength,FileSystemFlags,nil,0);
 if lStrCmp(PChar(VolumeName),'Audio-CD') = 0 then // или 'Audio CD'
   result := true;
end;

function PlayAudioCD(Drive : char) : bool;
var
 mp : TMediaPlayer;
begin
 result := false;
 Application.ProcessMessages;
 if not IsAudioCD(Drive) then
   exit;
 mp := TMediaPlayer.Create(nil);
 mp.Visible := false;
 mp.Parent := Application.MainForm;
 mp.Shareable := true;
 mp.DeviceType := dtCDAudio;
 mp.FileName := Drive + ':';
 mp.Shareable := true;
 mp.Open;
 Application.ProcessMessages;
 mp.Play;
 Application.ProcessMessages;
 mp.Close;
 Application.ProcessMessages;
 mp.free;
 result := true;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
 if not PlayAudioCD('D') then
   ShowMessage('Not an Audio CD');
end;

Обработать момент вставки и вытаскивания CD

Код

 Some applications need to know when the user inserts or
 removes a compact disc or DVD from a CD-ROM drive without
 polling for media changes. Windows provide a way to notify these
 applications through the WM_DEVICECHANGE message.
}

type
  TForm1 = class(TForm)
  private
    procedure WMDeviceChange(var Msg: TMessage); message WM_DEVICECHANGE;
  public

  end;

{...}

implementation

{$R *.DFM}

procedure TForm1.WMDeviceChange(var Msg: TMessage);
const
  DBT_DEVICEARRIVAL = $8000; // system detected a new device
 DBT_DEVICEREMOVECOMPLETE = $8004;  // device is gone
var
  myMsg: string;
begin
  inherited;
  case Msg.wParam of
    DBT_DEVICEARRIVAL: myMsg  := 'CD inserted!';
    DBT_DEVICEREMOVECOMPLETE: myMsg := 'CD removed!';
  end;
  ShowMessage(myMsg);
end;


{*********************************************}

// Advanced Code:
// When the device is of type volume, then we can get some device specific
// information, namely specific information about a logical volume.
// by Juergen Kantz

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    label1: TLabel;
  private
    procedure WMDeviceChange(var Msg: TMessage); message WM_DeviceChange;
    { Private declarations }
  public
    { Public declarations }
  end;

const
    DBT_DeviceArrival = $8000;
  DBT_DeviceRemoveComplete = $8004;
  DBTF_Media = $0001;
  DBT_DevTyp_Volume = $0002;

type
  PDevBroadcastHdr = ^TDevBroadcastHdr;
  TDevBroadcastHdr = packed record
    dbcd_size: DWORD;
    dbcd_devicetype: DWORD;
    dbcd_reserved: DWORD;
  end;

type
  PDevBroadcastVolume = ^TDevBroadcastVolume;
  TDevBroadcastVolume = packed record
    dbcv_size: DWORD;
    dbcv_devicetype: DWORD;
    dbcv_reserved: DWORD;
    dbcv_unitmask: DWORD;
    dbcv_flags: Word;
  end;

var
  Form1: TForm1;


implementation

{$R *.dfm}


function GetDrive(pDBVol: PDevBroadcastVolume): string;
var
  i: Byte;
  Maske: DWORD;
begin
  if (pDBVol^.dbcv_flags and DBTF_Media) = DBTF_Media then
  begin
    Maske := pDBVol^.dbcv_unitmask;
    for i := 0 to 25 do
    begin
      if (Maske and 1) = 1 then
        Result := Char(i + Ord('A')) + ':';
      Maske := Maske shr 1;
    end;
  end;
end;

procedure TForm1.WMDeviceChange(var Msg: TMessage);
var
  Drive: string;
begin
  case Msg.wParam of
    DBT_DeviceArrival:
      if PDevBroadcastHdr(Msg.lParam)^.dbcd_devicetype = DBT_DevTyp_Volume then
      begin
        Drive := GetDrive(PDevBroadcastVolume(Msg.lParam));
        label1.Caption := 'CD inserted in Drive ' + Drive;
      end;
    DBT_DeviceRemoveComplete:
      if PDevBroadcastHdr(Msg.lParam)^.dbcd_devicetype = DBT_DevTyp_Volume then
      begin
        Drive := GetDrive(PDevBroadcastVolume(Msg.lParam));
        label1.Caption := 'CD removed from Drive ' + Drive;
      end;
  end;
end;


end.

Определить букву CD-ROM

Код

procedure TForm1.Button1Click(Sender: TObject);
var
 w: dword;
 Root: string;
 i: integer;
begin
 w := GetLogicalDrives;
 Root := '#:\';
 for i := 0 to 25 do
 begin
   Root[1] := Char(Ord('A') + i);
   if (W and (1 shl i)) > 0 then
     if GetDriveType(Pchar(Root)) = DRIVE_CDROM then
       Form1.Label1.Caption := Root;
 end;
end;

Определить букву первого CD-ROM

Код

function GetFirstCDROM: string;
{возвращает букву 1-го привода CD-ROM или пустую строку}
var
 w: dword;
 Root: string;
 i: integer;
begin
 w := GetLogicalDrives;
 Root := '#:\';
 for i := 0 to 25 do
 begin
   Root[1] := Char(Ord('A') + i);
   if (W and (1 shl i)) > 0 then
     if GetDriveType(Pchar(Root)) = DRIVE_CDROM then
     begin
       Result := Root[1];
       exit;
     end;
 end;
 Result := '';
end;

Открытие и закрытие нескольких приводов CD-ROM

Код

unit DriveTools;

interface

uses

 Windows, SysUtils, MMSystem;

function CloseCD(Drive: Char): Boolean;
function OpenCD(Drive: Char): Boolean;

implementation

function OpenCD(Drive: Char): Boolean;
var

 Res: MciError;
 OpenParm: TMCI_Open_Parms;
 Flags: DWord;
 S: string;
 DeviceID: Word;
begin

 Result := false;
 S := Drive + ':';
 Flags := mci_Open_Type or mci_Open_Element;
 with OpenParm do
 begin
   dwCallback := 0;
   lpstrDeviceType := 'CDAudio';
   lpstrElementName := PChar(S);
 end;
 Res := mciSendCommand(0, mci_Open, Flags, Longint(@OpenParm));
 if Res <> 0 then
   exit;
 DeviceID := OpenParm.wDeviceID;
 try
   Res := mciSendCommand(DeviceID, MCI_SET, MCI_SET_DOOR_OPEN, 0);
   if Res = 0 then
     exit;
   Result := True;
 finally
   mciSendCommand(DeviceID, mci_Close, Flags, Longint(@OpenParm));
 end;
end;

function CloseCD(Drive: Char): Boolean;
var

 Res: MciError;
 OpenParm: TMCI_Open_Parms;
 Flags: DWord;
 S: string;
 DeviceID: Word;
begin

 Result := false;
 S := Drive + ':';
 Flags := mci_Open_Type or mci_Open_Element;
 with OpenParm do
 begin
   dwCallback := 0;
   lpstrDeviceType := 'CDAudio';
   lpstrElementName := PChar(S);
 end;
 Res := mciSendCommand(0, mci_Open, Flags, Longint(@OpenParm));
 if Res <> 0 then
   exit;
 DeviceID := OpenParm.wDeviceID;
 try
   Res := mciSendCommand(DeviceID, MCI_SET, MCI_SET_DOOR_CLOSED, 0);
   if Res = 0 then
     exit;
   Result := True;
 finally
   mciSendCommand(DeviceID, mci_Close, Flags, Longint(@OpenParm));
 end;
end;

end.

Получить букву или номер CD-ROM

Код

function GetFirstCDROMDrive: char;
var
  drivemap, mask: DWORD;
  i: integer;
  root: string;
begin
  Result := #0;
  root := 'A:\';
  drivemap := GetLogicalDrives;
  mask := 1;
  for i := 1 to 32 do
  begin
    if (mask and drivemap) <> 0 then
      if GetDriveType(PChar(root)) = DRIVE_CDROM then
      begin
        Result := root[1];
        Break;
      end;
    mask := mask shl 1;
    Inc(root[1]);
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  ShowMessage(GetFirstCDROMDrive);
end;

{********************************}

function GetNumberOfCDDrives: Byte;
var
  drivemap, mask: DWORD;
  i: integer;
  root: string;
begin
  Result := 0;
  root := 'A:\';
  drivemap := GetLogicalDrives;
  mask := 1;
  for i := 1 to 32 do
  begin
    if (mask and drivemap) <> 0 then
      if GetDriveType(PChar(root)) = DRIVE_CDROM then
      begin
        Inc(Result);
      end;
    mask := mask shl 1;
    Inc(root[1]);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Label1.Caption := IntToStr(GetNumCDDrives);
end;

Проверить, открыт ли CD-ROM

Код

uses
  mmsystem;

  procedure TForm1.Button1Click(Sender: TObject);
var
  s: array[0..64] of Char;
  error: Cardinal;
  Text: array[0..255] of Char;
begin
  error := mciSendstring('open cdaudio alias geraet', nil, 0, Handle);
  if error <> 0 then
  begin
    mciGetErrorstring(error, @Text, 255);
    ShowMessage(Text);
    mciSendstring('close geraet', nil, 0, Handle);
    Exit;
  end;

  error := mciSendstring('status geraet mode', @s, SizeOf(s), Handle);
  if error <> 0 then
  begin
    mciGetErrorstring(error, @Text, 255);
    ShowMessage(Text);
    mciSendstring('close geraet', nil, 0, Handle);
    Exit;
  end;

  mciSendstring('close geraet', nil, 0, Handle);
  ShowMessage('Message: ' + s);
end;

Программа показа инфо о CD-R
На форме Form1 размещаем элементы: ListBox1 (категория), ListBox2 (список программ), RichEdit1 (описание программы), BitBtn1 (запуск/инсталляция), BitBtn2 (выход), BitBtn3 (О программе), Label1 (объясню позже). Вместо TBitBtn можно использовать TButton. Теперь щелкаем по форме, в инспекторе объектов Object Inspector выбираем закладку Events (события) и, дважды кликнув по полю открывающегося списка, получаем в исходном тексте заготовку: procedure TForm1.FormActivate(Sender: TObject). Тут-то мы и начнем писать свой код:

Код

var // здесь размещаются переменные, которые будут доступны из всех процедур
 RunPathList: array[1..999] of string; // список путей к запускаемым файлам
 DescriptionList: array[1..999] of string;
   // список описаний или пути к описаниям
 ListFile: array[1..99] of string; // список файлов с информацией
 Path: string; // корневой каталог диска

procedure TForm1.FormActivate(Sender: TObject); // сама процедура
var // тут размещаются переменные, которые будут доступны в пределах этой процедуры
 i, n, k, Found: integer; // различные переменные счетчиков
 SearchRec: TSearchRec; // переменная, используемая при поиске
 ini: TIniFile; // готовимся к работе с .ini-файлами
 Category, Name, Description, RunPath: string; // думаю, ясно из названий
begin
 label1.Caption := '0'; // тут будет количество найденных программ
 Path := ParamStr(0);
   // ParamStr(n), где n0. При n=0 возвращает путь и имя файла к нашей запущенной программе. При n>0
 возвращает параметры, которые были переданы программе при запуске(например:
   autorun.exe / param1 name).Функция ParamCount
   возвращает количество параметров, разделенных пробелом(т.е.n =
     0...ParamCount)
   Path := Path[1] + ':\';
     // выделяем логический диск. Это первый символ. К нему добавляем приставку :\
 i := 1;
 Found := FindFirst(Path + 'list??.ini', faVolumeID, SearchRec);
   // поиск первого файла по маске х:\list??.ini
 while Found = 0 do // зацикливаемся, пока есть новые файлы
 begin
   if FileExists(Path + SearchRec.Name) = true then
     // проверяем, что найден файл
   begin
     ListFile[i] := Path + SearchRec.Name;
       // добавляем найденныйй файл в список
     Inc(i); // увеличиваем переменную ? на единицу
   end;
   Found := FindNext(SearchRec); // выполняем поиск следующего файла
 end;
 FindClose(SearchRec); // освобождаем память которую занимает SearchRec
 ListFile[i] := 'END';
   // добавляем текст END в список файлов. Это затем, чтобы потом быстро определить конец списка
 if ListFile[1] = 'END' then
   ShowMessage('На диске ' + Path +
     ' не найдено ни одного конфигурационного файла.'); // если в
 первой строчке списка значится
end, значит, не найдено ни одного файла.В траурной рамочке выводим сообщение
k := 1;
for i := 1 to 99 do // перебираем список от 1 до 99 в цикле:
begin
 if ListFile[i] = 'END' then
   Break; //:пока не встретим END
 ini := TIniFile.Create(ListFile[i]); //открываем файл
 label1.Caption := IntToStr(StrToInt(label1.Caption) + ini.ReadInteger('MAIN',
   'ProgramsCount', 0)); // увеличиваем общее
 число программ
   for n := 1 to ini.ReadInteger('MAIN', 'ProgramsCount', 0) do
     // Перебираем все записи от 1 до значения ProgramsCount,
   указаного в файле
 begin
   Category := ini.ReadString('Program' + Format('%.3d', [n]), 'Category',
     'без категории'); // Считываем категорию. Функцией
   Format в данном случае задается формат чисел типа: 001, 002, 003...
   if ListBox1.Items.IndexOf(Category) = -1 then
     // выполняем поиск такой же категории среди уже находящейся в списке
     ListBox1.В случае удачи функция возвращает номер позиции, в противном
       случае - 1
   begin
     ListBox1.Items.Add(Category); // если нету - добавляем
   end;
 end;
end;
ini.Free;
label1.Caption := 'На этом диске ' + label1.Caption + ' программ(а).';
// делаем надпись более информативной для пользователя
end;

Следующим нашим шагом будет заполнение списка программ выбранной пользователем категории. Двойным щелчком мыши по ListBox1 получаем заготовку и заполняем ее:

Код

procedure TForm1.ListBox1Click(Sender: TObject);
var
 ini: TIniFile;
 i, n, k: integer;
 Category: string;
begin
 k := 1;
 ListBox2.Items.Clear;
 RichEdit1.Text :=;
 Label1.Caption :=;
 for i := 1 to 99 do
 begin
   if ListFile[i] =
 end then Break;
 ini := TIniFile.Create(ListFile[i]);
 for n := 1 to ini.ReadInteger(MAIN, ProgramsCount, 0) do
 begin
   Category := ini.ReadString(program + Format(%.3 d, [n]), Category, без
     категории);
   if Category = ListBox1.Items.Strings[ListBox1.ItemIndex] then
   begin
     ListBox2.Items.Add(ini.ReadString(program + Format(%.3 d, [n]), Name, без
       имени));
     RunPathList[k] := Path + ini.ReadString(program + Format(%.3 d, [n]),
       Path, неизвестно);
     DescriptionList[k]
       := ini.ReadString(program + Format(%.3 d, [n]), Description, По одному
         названию все ясно!);
     Inc(k);
   end;
 end;
end;
ini.Free;
end;

Когда пользователь выберет программу, щелкнув по ней, нужно вывести ее описание и подготовить путь для запуска. Этим займется следующая процедура:

Код

procedure TForm1.ListBox2Click(Sender: TObject);
var
 n: integer;
begin
 screen.Cursor := crHourGlass;
 Label1.Caption := RunPathList[ListBox2.ItemIndex + 1];
 if
   FileExists(Path + DescriptionList[ListBox2.ItemIndex + 1]) then
   RichEdit1.Lines.LoadFromFile(Path + DescriptionList[ListBox2.ItemIndex + 1])
 else
   RichEdit1.Text := DescriptionList[ListBox2.ItemIndex + 1];
 screen.Cursor := crDefault;
end;

Теперь, когда все готово к запуску, пользователь может нажать кнопку BitBtn1 и запустить программу:

Код

procedure TForm1.BitBtn1Click(Sender: TObject);
var
 Result: Integer;
begin
 Result := Windows.WinExec(PChar(Label1.caption), SW_SHOWDEFAULT);
 if Result = 0 then
   MessageDlg(Недостаточно ресурсов для
     запуска программы, mtError, [mbOk], 0);
 if Result = ERROR_BAD_FORMAT then
   MessageDlg(Неправильный формат.ЕХЕ файла, mtError, [mbOk], 0);
 if Result = ERROR_FILE_NOT_FOUND then
   MessageDlg(Файл не найден#13#10+Label1.Caption, mtError, [mbOk], 0);
 if Result = ERROR_PATH_NOT_FOUND then
   MessageDlg(Неверный указанный путь#13#10+Label1.Caption, mtError, [mbOk],
     0);
end;

Теперь о самом конфигурационном файле. Он должен иметь имя list??.ini, где ?? - это номер от 01 до 99. Обратите внимание: числа от 1 до 9 имеют <незначащий> ноль. Структура файла соответствует стандартной для .ini-файла. В разделе [MAIN] конфигурационного файла параметр ProgramsCount указывает на количество программ в этом файле. Каждая программа располагается в своем разделе с уникальным трехзначным номером (от 001 до 999) в формате [Program???]. Вот пример файла для нашей программы:

Код

[MAIN]
     ProgramsCount=3
     [Program001]
     Category="Категория"
     Name="Название программы"
     Description="Описание программы, или путь к описанию"
     Path="путь к программе\имя файла.exe"
     [Program002]
     Category="Мои программы"
     Name="Программа-меню для компакт-дисков"
     Description="Описание моей программы"
     Path="MyPrograms\autorun.exe"
     [Program003]
     Category="Мои программы"
     Name="Моя лучшая программа"
     Description="MyPrograms\readme.rtf"
     Path="MyPrograms\MyProgram.exe"

Когда вы вставляете уже записанный компакт-диск в CD/DVD-ROM, по умолчанию операционка начинает поиск файла autorun.inf в корневом каталоге диска. Содержимое этого файла напоминает структуру конфигурационного - думаю, назначение полей вам будет понятно Код:

Код

[autorun]
     open=autorun.exe
     icon=autorun.ico

Сообщение отредактировал yuansw - 14.09.2005 - 02:58