unitmain.pas

使用DELPHI制作地虚拟光驱

unit UnitMain;

interface

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

type
  //回调函数类型
  TCallBackProc = procedure(const Pos:Int64) of object;

  TFormMain = class(TForm)
    cbCDROM: TComboBox;
    Label1: TLabel;
    ggProgress: TGauge;
    sDlg: TSaveDialog;
    btnSaveToFile: TButton;
    procedure btnSaveToFileClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
  private
    { Private declarations }
    procedure GetCDROMs(List : TStrings);
    procedure CallBack(const Pos:Int64);
  public
    { Public declarations }
  end;



var
  FormMain: TFormMain;

implementation

{$R *.dfm}

//读取光盘扇区的每个字节到虚拟光盘文件的每个字节
procedure CDROMToFile(const hFile, hDriver: THandle;
                      const DriverSize:Int64;
                      const CallbackProc:TCallBackProc;
                      const CallBackoften:Integer = 10);
const
  BufSize = 4096;
var
  hCDROM : THandle;
  Pos    : Int64;
  Buf    : array[0..BufSize-1] of Byte;
  LastSize: Integer;
begin
  //hCDROM := FileOpen();
  LastSize := DriverSize mod BufSize;
  FileSeek(hFile, 0, FILE_BEGIN);
  FileSeek(hDriver, 0, FILE_BEGIN);
  Pos := 0;
  while Pos <(DriverSize - LastSize) do
  begin
    FileRead (hDriver,Buf,BufSize);
    FileWrite(hFile,  Buf,BufSize);
    Inc(Pos, BufSize);
    if Pos mod CallBackoften = 0 then
      callbackProc(Pos);
  end;
  FileRead (hDriver,Buf,LastSize);
  FileWrite(hFile,  Buf,LastSize);
  Inc(Pos, LastSize);
  callbackProc(Pos);
end;

//检测光盘是否准备好
function CDROMReady(ADriver : String;var Vol:String):Boolean;
var
  i:dword;
  buf:array[0..MAX_PATH] of char;
  pd:DWORD;
begin
  pd:=0;
  ZeroMemory(@buf, MAX_PATH);
  GetVolumeInformation(PChar(ADriver),buf,i,@pd,i,i,buf,i);
  Result := pd<>0;
  Vol := Buf;
end;

//获取光盘内容的大小
function GetCDROMSize(ADriver:String):Int64;
var
  sector,byte,free, total:DWORD;
begin
  GetDiskFreeSpace(PChar(ADriver),
                   sector,
                   byte,
                   free,
                   total);
  Result := total *sector * byte;
end;

{ TFormMain }

procedure TFormMain.btnSaveToFileClick(Sender: TObject);
var
  hFile, hDriver: THandle;
  Vol           : String;
  CDROMSize     : LARGE_INTEGER;
begin
  if not CDROMReady(cbCDROM.Text + '\', Vol) then
  begin
    MessageBox(Self.Handle,'请放入光盘！','',MB_OK or MB_ICONERROR);
    Exit;
  end;

  //ShowMessage(Vol);
  if Vol<>'' then
    sDlg.FileName := Vol + '.ISO';
  if not sDlg.Execute() then
    Exit;
  hFile := FileCreate(sDlg.FileName);
  if hFile = INVALID_HANDLE_VALUE then
  begin
    MessageBox(Self.Handle,'创建虚拟光驱文件出错！','',MB_OK or MB_ICONERROR);
    Exit;
  end;
  hDriver := CreateFile (PChar('\\.\'+cbCDROM.Text),
                         GENERIC_READ,
                         FILE_SHARE_READ,
                         0,
                         OPEN_EXISTING,
                         0,
                         0);
  if hDriver = INVALID_HANDLE_VALUE then
  begin
    FileClose(hFile);
    MessageBox(Self.Handle,'读取光驱出错！','',MB_OK or MB_ICONERROR);
    Exit;
  end;
  //获取光盘占用的大小.并且设置进度条
  CDROMSize.QuadPart  := GetCDROMSize(cbCDROM.Text);
  ggProgress.MinValue := 0;
  ggProgress.MaxValue := CDROMSize.QuadPart-1;
  ggProgress.Progress := 0;


  //写到文件
  CDROMToFile(hFile, hDriver, CDROMSize.QuadPart, CallBack, 100);


  FileClose(hDriver);
  FileClose(hFile);
  MessageBox(Self.Handle,'虚拟光驱文件制作完成！','恭喜',MB_OK or MB_ICONINFORMATION);
end;

procedure TFormMain.CallBack(const Pos: Int64);
begin
  ggProgress.Progress := Pos;
  Application.ProcessMessages;
end;

procedure TFormMain.FormShow(Sender: TObject);
begin
  GetCDROMs(cbCDROM.Items);
  if cbCDROM.Items.Count >0 then
  begin
    cbCDROM.ItemIndex := 0;
  end;
end;

procedure TFormMain.GetCDROMs(List: TStrings);
var
  I      : Char;
  Driver : String;
begin
  for I := 'A' to 'Z' do
  begin
    Driver := I+':';
    if GetDriveType(PChar(Driver)) = DRIVE_CDROM then
    begin
      List.Add(Driver);
    end;
  end;
end;

end.