//获得CDRom 序列号
function GetdiskserilNum(ADrive: string): string;
//获得CDRom卷标，返回''表示驱动器中没有光盘
function GetCDRomLabel(ADrive: string): string;
//获得第一个CDRom,返回''表示驱动器中没有光盘
function GetFirstCDROM: ShortString;
//获得系统驱动器列表
procedure Getdisks(Strings: TStringList);
//打开光驱
procedure OpenCDRom;
//关闭光驱
procedure CloseCDRom;
//切换光驱自动运行功能,设置在Windows重新启动后将生效
procedure SetCDRomAutoRun(AutoRun:Boolean);
implementation
uses Windows, MMSystem;
//////////////CDRom Utils////////////////////////////
function GetdiskserilNum(ADrive: string): string;
var
VolumeName : array[0..255] of char;
FileSystemType : array[0..255] of char;
SerialNum : DWORD;
MaxFilenameLength : DWORD;
Flags : DWORD;
begin
if (GetVolumeInformation(PChar(ADrive),
VolumeName,
256,
@SerialNum,
MaxFilenameLength,
Flags,
FileSystemType,
256)) then
Result := (IntToHex(SerialNum shr 16, 3) +
IntToHex((SerialNum shl 16) shr 16, 4));
end;
function GetCDRomLabel(ADrive: string): string;
var
VolumeName : array[0..255] of char;
FileSystemType : array[0..255] of char;
SerialNum : DWORD;
MaxFilenameLength : DWORD;
Flags : DWORD;
begin
//Result := '驱动器中没有CDRom';
if (GetVolumeInformation(PChar(ADrive),
VolumeName,
256,
@SerialNum,
MaxFilenameLength,
Flags,
FileSystemType,
256)) then
Result := VolumeName;
end;
function GetFirstCDROM: Shortstring;
var
AList : TStringList;
Counter : integer;
begin
//Result := '驱动器里无CDRom';
AList := TStringList.Create;
Getdisks(AList);
for Counter := 0 to AList.Count-1do
if GetDriveType(PChar(Alist.Strings[Counter])) = DRIVE_CDROM then
Result := Alist.Strings[Counter]
end;
procedure Getdisks(Strings: TStringList);
const BufSize = 256;
var
Buffer : PChar;
P : PChar;
begin
GetMem(Buffer, BufSize);
try
Strings.begin
Update;
try
Strings.Clear;
if GetLogicalDriveStrings(BufSize, Buffer) <> 0 then
begin
P := Buffer;
while P^ <> #0do
begin
Strings.Add(P);
Inc(P, StrLen(P) + 1);
end;
end;
finally
Strings.EndUpdate;
end;
finally
FreeMem(Buffer, BufSize);
end;
end;
procedure OpenCDRom;
begin
mciSendString('Set cdaudiodo
or open wait', nil, 0, 0);//handle);
end;
procedure CloseCDRom;
begin
mciSendString('Set cdaudiodo
or closed wait', nil, 0, 0);//handle);
end;
procedure SetCDRomAutoRun(AutoRun:Boolean);
const
do
AutoRun : 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
if Reg.OpenKey('System/CurrentControlSet/Services/Class/CDROM',FALSE) then
Reg.WriteBinaryData('AutoRun',DoAutoRun[AAutoRun],1);
finally
Reg.Free;
end;
//设置在Windows重新启动后将生效
end;
