Checke om CD er åben

HEJ,

Jeg har en løsning hjemme (er på job nu - skriver senere (i aften).

KRISTIAN

http://www.eksperten.dk/spm/637938 - findes allerede ?

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;


//Source.....
//http://www.swissdelphicenter.ch/en/showcode.php?id=135

Hej ,

her er et projekt som virker:

Funktionen  FUNCTION LokCD() : Char; finder de(t) aktuelle CD drev (og er taget med for oversigtens skyld).

Disse 2 funks viser brugen (mine CD/DVD'er hedder 'J' og 'K', som du kan skifte ud til dine/dit drev )


procedure TForm1.Button1Click(Sender: TObject);
begin
  OpenCD('J');
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  CloseCD('J');
end;

 

HER ER KODEN:



unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
  FUNCTION OpenCD(Drive : Char) : Boolean;
  FUNCTION CloseCD(Drive : Char) : Boolean;
  FUNCTION LokCD() : Char;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);







  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

FUNCTION TForm1.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 TForm1.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;

FUNCTION TForm1.LokCD() : Char;
VAR
  Drv                    : String;
  DrvU                    : Pchar;
  Fundet                  : Boolean;

BEGIN
  Fundet := False;
  Drv := 'C' + ':' + #0;
  REPEAT
      DrvU := Pchar(Drv);
      IF GetDriveType(DrvU) = DRIVE_CDROM THEN
        Fundet := True
      ELSE
        Inc(Drv[1]);
  UNTIL ((Fundet = True) OR (Char(Drv[1]) = 'Z'));
  IF Char(Drv[1]) = 'Z' THEN
      Result := #0
  ELSE
      Result := Char(Drv[1]);
END;

procedure TForm1.Button1Click(Sender: TObject);
begin
  OpenCD('J');
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  CloseCD('J');
end;

END.


TESTET PÅ d-7 ENTerprise og funker...


KR

stone-> det eksempel viser kun status på CD drevet. Det hverken åbner eller lukker drevet

snestrup-> din kode kan både åbne og lukke, men desværre er det ikke helt nok.

Det mit program skal kunne er:
Finde første drev
Hvis skuffen er lukket - åbn den
Hvis skuffen er åbnet - luk den
Afslutte program

Det der er hele problemet er sådan set at kunne se om skuffen er åbnet.

HEJ,

til HugoP:

Tak for kommentaren:

Hvis du bruger LOKCD, finder du dine CDer.

  Result := Char(Drv[1]);  // Find 1. CD --> 'D --->  Z'

Kør  " OpenCD(Char(Drv[1])), "    2 gange, så er dit CD-drev åbent og du har en status på dit drev.

Og skulle det være åbent initialt, vil 1. kørsel lukke det.

Det eneste (måske irriterende), er at CD_skuffen må åbnes og lukkes mindst een gang for at hente status, (og enig, det kan være irriterende.. )

KR

I så fald skulle programmet se ud som følger.
Eller er der noget jeg helt har misforstået?

program CDEject;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  ComObj, Dialogs, StrUtils, SysUtils,
  MMSystem, Windows;

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;

function LokCD(): Char;
var
  Drv: string;
  DrvU: Pchar;
  Fundet: Boolean;
begin
  Fundet := False;
  Drv := 'C' + ':' + #0;
  repeat
    DrvU := Pchar(Drv);
    if GetDriveType(DrvU) = DRIVE_CDROM then
      Fundet := True
    else
      Inc(Drv[1]);
  until ((Fundet = True) OR (Char(Drv[1]) = 'Z'));
  if Char(Drv[1]) = 'Z' then
    Result := #0
  else
    Result := Char(Drv[1]);
end;


// ****************************************************************************
var
  Drive: char;
begin
    try
    if ParamStr(1) <> '' then
      Drive := ParamStr(1)[1]
    else
      Drive := LokCD;
    OpenCD(Drive);
    OpenCD(Drive);
  except
  end;
end.

Hej

til:  HugoP,

(Jeg har en eller anden INDBYGGET SLÅFEJL at skrive korrket istedet for KORREKT- bær over med det... !)

Brugte aftenen sammen med konen, TV, kaffe, hygge, smøreost og en lille smule delphi.

Hentede mit program (skrevet for Delp-4 i 2003) og gennemgik koden for at (prøve) at huske hvad det var prgm. skulle gøre.

Efter nogen tid:

Prgm, skulle ved opstart checke begge CD-drev om det var den korrekte CD i et af disse drev. Hvis dette ikke var tilfældet (altså fejl CD eller ingen CD ) skulle programmet skrive en fejl-meddelelse (HTML) til bruger, åbne CD-skuffen i første CD-drev og vente på tilbagemelding, og gentage "requesten" indtil korrekt CD (altså en uendelig sløjfe - afbrudt af indlæggelse af korrket CD eller PRGM-afslutning).

Jeg husker også (hjulpet af dokumentationen (!) ), at jeg lagde CloseCD funktionen ind (som en service overfor brugeren).

Jeg har gennemgået din udgave af prgm. på virtuelt plan og påtænker at lægget det ind i D7 i løbet af dagen.
Jeg finder ikke umiddelbart noget galt. Jeg vil melde tilbage i løbet af dagen (eller evt. i morgen).


KR

Kender godt den problematik med konen :-)

Min kode virker ikke efter hensigten desværre.
Problemet er at den ikke kan konstatere om drevet er åbnet ved start.

HEJ Igen,

Klokken er nu 11:21.

Har prøvet koden på D7.

1. Kørsel (initialt: CD_skuffen lukket)

Aktuelle CD-drev klikker en gang (forsøger at lukke drevet, som er lukket), blinker med CD-LED'en og åbner skuffen.

2: Kørsel: (initialt: CD_skuffen ÅBEN )

Aktuelle CD-drev blinker med CD-led og lukker skuffen. og efter ca. 3-4 sekunder Blinker med CD-LED'en og åbner skuffen.


KR

HEj

Jeg husker at jeg et eller andet sted så en masse ASSEMBLER (386 ASM) på styringen af et CD-rom drev. Fandt koden interessant og downloadede det på en ÆLDGAMMEL Compaq -75 ( 50 MHZ 486 PC), men om jeg stadig har koden (og PC'en) ved jeg ikke (i så fald er det dybest i kælderen, derinde hvor de rigtige mus holder til....).

Men det kunne måske være anledningen til den længe ønskede oprydning ?  (Og så ved jeg at konen bliver (mere) lykkelig (he he) )


KR

Kan du komme afsted med at mail den kode du har til at virke til mig på

oz8hp  snabela  hotmail  punktum  com

så vil jeg lige tage et kig.

Måske er det en Windows 7 ting.

HEJ

Ja, men jeg kan ikke nu.

Skal ud af huset (haster)


Kommer i løbet af dagen (senere )

K

Er du kommet tilbage til huset igen?

HEJ ,

"Ud af huset" , ja mon ikke...

Det tog næsten en uge. Var nordpå i arbejdssaammenhænge.

Arbejder med programmet nu og forventer at det kommer i løbet af minutter.

KR

Selv om det ikke kom til at fungere efter hensigten har jeg givet dig fortjente points for indsatsen.

Kan simpelthen ikke få den til at lukke skuffen hvis den står åben når programmet køres.