unit1.pas

刻录机源码

unit Unit1;

interface
{ $I DEFINES.INC}
{$IFDEF DELPHI6+}
{$WARN SYMBOL_PLATFORM OFF}
{$WARN UNIT_PLATFORM OFF}
{$IFDEF DELPHI7+}
{$WARN UNSAFE_CODE OFF}
{$WARN UNSAFE_TYPE OFF}
{$ENDIF}
{.$DEFINE USESHELLCTRLS} // Incomplete
{$ENDIF}
//{$D-}
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Math,
  {$IFDEF USESHELLCTRLS} ShellCtrls, {$ENDIF}
  Dialogs, Grids, StdCtrls, ExtCtrls, Mask, mbCDBC, Buttons, ComCtrls,
  mbDrvlib, FileCtrl, Menus, mbISOLib, ShellAPI, mbExDD, IniFiles;
var
  buf: array[0..MaxWord] of Byte;

type                   
  TForm1 = class(TForm)
    pDrivesDir: TPanel;
    Panel2: TPanel;
    DriveCB: TDriveComboBox;
    pDiscFiles: TPanel;
    pTop: TPanel;
    Splitter1: TSplitter;
    cbDrives: TComboBox;
    lDrive: TLabel;
    pTop2: TPanel;
    bQErase: TBitBtn;
    bCErase: TBitBtn;
    pbottom: TPanel;
    Timer1: TTimer;
    bLoad: TBitBtn;
    bReady: TBitBtn;
    Label5: TLabel;
    Label6: TLabel;
    lSize: TLabel;
    bCaps: TBitBtn;
    Panel9: TPanel;
    bBurn: TBitBtn;
    pcd: TProgressBar;
    pHBuf: TProgressBar;
    bEject: TBitBtn;
    Panel11: TPanel;
    Splitter3: TSplitter;
    lbDir: TDirectoryListBox;
    lbFiles: TFileListBox;
    cbSpeed: TComboBox;
    Label1: TLabel;
    PopupMenu1: TPopupMenu;
    ClearAll1: TMenuItem;
    bDisc: TBitBtn;
    Splitter2: TSplitter;
    pBuf: TProgressBar;
    bAdvance: TBitBtn;
    bAbort: TButton;
    PopupMenu2: TPopupMenu;
    Remove1: TMenuItem;
    od: TOpenDialog;
    Memo1: TMemo;
    Panel12: TPanel;
    bNetwork: TBitBtn;
    clBox: TListView;
    Panel4: TPanel;
    bSaveISO: TBitBtn;
    bBurnISO: TBitBtn;
    Panel10: TPanel;
    bClear: TBitBtn;
    cPathInfo: TCheckBox;
    ExplorerDragDrop: TExDragDrop;
    mcdb: TMCDBurner;
    procedure Panel2Resize(Sender: TObject);
    procedure clBoxDragOver(Sender, Source: TObject; X, Y: Integer;
      State: TDragState; var Accept: Boolean);
    procedure Label2DragDrop(Sender, Source: TObject; X, Y: Integer);
    procedure FormShow(Sender: TObject);
    procedure bBurnClick(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure cbDrivesChange(Sender: TObject);
    procedure bQEraseClick(Sender: TObject);
    procedure bLoadClick(Sender: TObject);
    procedure bEjectClick(Sender: TObject);
    procedure bReadyClick(Sender: TObject);
    procedure bClearClick(Sender: TObject);
    procedure bSaveISOClick(Sender: TObject);
    procedure bCEraseClick(Sender: TObject);
    procedure mcdbAddDirName(Sender: TObject; var Name, ISOName: String; var Skip: Boolean);
    procedure bCDHeaderClick(Sender: TObject);
    procedure bCapsClick(Sender: TObject);
    procedure clBoxDragDrop(Sender, Source: TObject; X, Y: Integer);
    procedure cbSpeedDropDown(Sender: TObject);
    procedure ClearAll1Click(Sender: TObject);
    procedure mcdbEraseDone(Sender: TObject; WithErrors: Boolean);
    procedure bDiscClick(Sender: TObject);
    procedure Label1Click(Sender: TObject);
    procedure mcdbFinalizingTrack(Sender: TObject);
    procedure bAbortClick(Sender: TObject);
    procedure ExplorerDragDropDropped(Sender: TObject;
      ItemsCount: Integer);
    procedure Remove1Click(Sender: TObject);
    procedure mcdbAddFile(Sender: TObject; const FullPath: String; var LongFileName, ShortFileName: String; var DateTime: TDateTime; Attr: Integer; FileSize: Int64; var Skip: Boolean);
    procedure bBurnISOClick(Sender: TObject);
    procedure cPathInfoClick(Sender: TObject);
    procedure CopyLog1Click(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure bNetworkClick(Sender: TObject);
    procedure clBoxEditing(Sender: TObject; Item: TListItem; var AllowEdit: Boolean);
    procedure ShellTreeView1Editing(Sender: TObject; Node: TTreeNode; var AllowEdit: Boolean);
    procedure mcdbWriteDone(Sender: TObject; Error: String);
    procedure mcdbDebugMessage(Sender: TObject; Message: String;
      mType: Byte);
  private
    { Private declarations }
    procedure AddFilesToCd;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  SessionToImport: ShortInt;
  QuickSaveISO: Boolean = false;
  ccEject, ccShowFiles, ccImportSession: Boolean;

Const
  MaxFiles = 600000;
  MaxDirs = 20000;
type
  TFormatDescriptor = record
    NumberOfBlocks: Cardinal;
    FormatType: Byte;
  end;
implementation

uses Unit2, DeviceCaps, ImportSession, DiscLayout;
{$IFDEF USESHELLCTRLS}

var
  ShellComboBox: TShellComboBox;
  ShellTreeView: TShellTreeView;
  ShellListView: TShellListView;

{$ENDIF}
{$R *.dfm}

function GetSpeed(Str: String; Medium: Byte): Word;
var
  Divider: Integer;
begin
  if (Str = 'Max') or (Str = '') then
    result := 0
  else
  begin
    if Medium >= mtDVD_ROM then
      Divider := 1385
    else
      Divider := 177;
    result := Round(StrToFloat(Copy(str, 1, Pos('X', str)-1)) * Divider) ;
  end;
end;

procedure TForm1.Panel2Resize(Sender: TObject);
begin
  DriveCB.Width := Panel2.Width - bNetwork.Width-4;
  {$IFDEF USESHELLCTRLS}
  if ShellComboBox <> nil then
  ShellComboBox.Width := Panel2.Width - 48;
  {$ENDIF}  
end;

procedure TForm1.clBoxDragOver(Sender, Source: TObject; X,
  Y: Integer; State: TDragState; var Accept: Boolean);
begin
  Accept := (Source is TDirectoryListBox) or (source is TFileListBox)
  {$IFDEF USESHELLCTRLS}
   or (Source is TShellTreeView) or (Source is TShellListView)
  {$ENDIF}
   ;
  {$IFDEF USESHELLCTRLS}
  if (Source is TShellListView) then
  begin
    if not FileExists(ShellListView.SelectedFolder.PathName) then
      Accept := False;
  end;
  {$ENDIF}
end;

procedure TForm1.Label2DragDrop(Sender, Source: TObject; X, Y: Integer);
begin
  if (Sender is TLabel) and (Source is TListView) then
  begin
    with Sender as TLabel do
    begin
      //Items.Add(DirectoryListBox1.GetItemPath(DirectoryListBox1.ItemIndex));
    end;
  end;
end;

procedure TForm1.FormShow(Sender: TObject);
var
  i: integer;
  State: String;
  ini: TIniFile;
begin
  if TrialMCDB then Caption := Caption + ' (TRIAL VERSION)';
  {$IFDEF USESHELLCTRLS}

  ShellComboBox := TShellComboBox.Create(Self);
  ShellTreeView := TShellTreeView.Create(Self);
  ShellListView := TShellListView.Create(Self);

  ShellTreeView.Parent := pDrivesDir;
  ShellTreeView.Align := alLeft;
  ShellTreeView.Width := 220;
  ShellListView.Parent := Panel11;
  ShellListView.ViewStyle := vsReport;
  ShellListView.Column[1].Width := 0;
  ShellListView.Column[2].Width := 0;
  ShellListView.Align := alClient;
  ShellListView.DragMode := dmAutomatic;
  ShellListView.MultiSelect := True;
  ShellListView.ObjectTypes := [otFolders,otNonFolders,otHidden];
  ShellListView.ShellComboBox := ShellComboBox;
  ShellListView.ShellTreeView := ShellTreeView;
  ShellListView.DragMode := dmAutomatic;
  ShellTreeView.DragMode := dmAutomatic;
  ShellComboBox.Parent := Panel2;
  ShellComboBox.Width := Panel2.Width - 2 - 48;
  ShellComboBox.Left := 0;
  ShellComboBox.Top := 2;
  lbFiles.Visible := False;
  lbDir.Visible := False;
  {$ENDIF}
  mcdb.DebugMsg('>>> '+Caption, 0);
  mcdb.InitializeASPI(True);

  if not mcdb.ASPIInitialized then
  begin
    pTop.Enabled := False;
    pTop2.Enabled := False;
    ShowMessage('Error initializing ASPI Layer, Please visit support page, http://forum.binarymagics.com for more information');
    exit;
  end;
  if (mcdb.Devices <> nil) and (mcdb.Devices.Count > 0) then
  begin
    cbDrives.Items.Assign(mcdb.Devices);
    cbDrives.ItemIndex := 0;
    cbDrivesChange(Sender);
  end;
  //cbSpeedDropDown(Sender);
  ini := TIniFile.Create('MCDB.ini');
  oArchiveFiles := ini.ReadBool('Options', 'ArchiveFiles', oArchiveFiles);
  oImportSession := ini.ReadBool('Options', 'ImportSession', oImportSession);
  State := ini.ReadString('Options', 'SavePath', '');
  if UpperCase(State) = 'GRAYED' then
    cPathInfo.State := cbGrayed
  else if UpperCase(State) = 'CHECKED' then
    cPathInfo.State := cbChecked
  else
    cPathInfo.State := cbUnchecked;
  mcdb.FinalizeDisc := ini.ReadBool('Options', 'CloseDisc', mcdb.FinalizeDisc);
  mcdb.JolietFileSystem := ini.ReadBool('Options', 'JolietFS', mcdb.JolietFileSystem);
  mcdb.TestWrite := ini.ReadBool('Options', 'TestWrite', mcdb.TestWrite);
  mcdb.PerformOPC := ini.ReadBool('Options', 'PerformOPC', mcdb.PerformOPC);
  QuickSaveISO := ini.ReadBool('Options', 'QuickSaveISO', QuickSaveISO);
  if ini.ReadBool('Options', 'ImportSession', False) = True then
    SessionToImport := ini.ReadInteger('Options', 'SessionNo', mcdb.SessionToImport)
  else
    SessionToImport := 0;
  ccEject := ini.ReadBool('Options', 'EjectDisc', False);
  ccShowFiles := ini.ReadBool('Options', 'ShowFiles', False);
  ccImportSession := ini.ReadBool('Options', 'ImportSession', False);

  mcdb.BootImage := ini.ReadString('Options', 'BootImage', mcdb.BootImage);
  mcdb.Bootable := ini.ReadBool('Options', 'Bootable', mcdb.Bootable);
  mcdb.IdVolume := ini.ReadString('Options', 'VolumeLable', mcdb.IdVolume);
  mcdb.CacheSize := ini.ReadInteger('Options', 'CacheSize', mcdb.CacheSize);
  ini.Free;

  for i:=0 to clBox.Items.Count-1 do
    clBox.Items[i].Checked := True;
  mcdb.DebugMsg(' ', 0);
  mcdb.LockDrive;
end;

procedure TForm1.bBurnClick(Sender: TObject);
var
  a,b: Cardinal;
  str, msg: String;
  speed: Word;
label okDoBurn;
begin
  mcdb.ReadBufferCapacity(a, b);
  pHBuf.Max := a;
  if cbSpeed.ItemIndex = -1 then cbSpeed.ItemIndex := 0;
  str := cbSpeed.Items[cbSpeed.ItemIndex];
  speed := GetSpeed(str, mcdb.DiscType);
  mcdb.WriteSpeed := Speed;
  Application.ProcessMessages;
  mcdb.ClearAll(MaxFiles, MaxDirs);
  AddFilesToCD;
  mcdb.DebugMsg('>>> ADD FILES/DIRS TO CD DONE.', 0);
  Application.ProcessMessages;
  if (mcdb.DirsCount = 0) and (mcdb.FilesCount = 0) then
  begin
    mcdb.DebugMsg('>>> NOTHING TO BURN, ABORTING ...', 0);
    exit;
  end;
  if ccShowFiles then
  begin
    frmDiscLayout := TfrmDiscLayout.Create(Self);
    frmDiscLayout.ShowModal;
  end;
  mcdb.Prepare;
  pcd.Max := mcdb.ImageSize;
  if TrialMCDB and (mcdb.ImageSize > Int64(65024)) then
  begin
    msg := 'You can not write more than 127 MB in trial version of this software'#10#13'Only first 127 MB out of '+
    FormatFloat('#,##0.00', mcdb.ImageSize * 2048 / (1024 * 1024))+
    ' MB will be usable'#10#13'still want to continue ?';
    if Application.MessageBox(@msg[1], 'This is a size limited TRIAL VERSION', MB_DEFBUTTON1+MB_ICONSTOP+MB_YESNO) = ID_YES then
      goto okDoBurn
    else
    begin
      Timer1.Enabled := False;
      exit;
    end;
  end;
  msg := 'Start Writing '+ FormatFloat('#,##0.00', mcdb.ImageSize * 2048 / (1024 * 1024))+' MB';
  if Application.MessageBox(@msg[1], 'Want to Burn the CD ?', MB_DEFBUTTON1+MB_ICONQUESTION+MB_YESNO) = ID_YES then
  begin
okDoBurn:
    bAbort.Visible := True;
    Timer1.Enabled := True;
    mcdb.DebugMsg('>>> STARTING BURNCD ON '+mcdb.Device, 0);
    pTop.Enabled := False;
    pTop2.Enabled := False;
    bBurnISO.Enabled := False;
    bSaveISO.Enabled := False;
    DriveCB.Enabled := False;
    mcdb.BurnCD;
  end
  else
    Timer1.Enabled := False;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  if not mcdb.Erasing then
  begin
    lSize.Caption := FormatFloat('#,##0.00', (mcdb.BytesWritten / (1024 * 1024)))+'/'+FormatFloat('#,##0.00', ((mcdb.ImageSize * 2048) / (1024 * 1024)))+' MB';
    //lSize.Caption := FormatFloat('#,##0.00', (mcdb.BytesWritten ))+'/'+FormatFloat('#,##0.00', ((mcdb.ImageSize * 2048) ))+' MB';
    pbuf.Position := mcdb.BufferProgress;
    pcd.Position := mcdb.BytesWritten div 2048;
    pcd.Max := mcdb.ImageSize;
    if mcdb.DeviceBufferSize >= mcdb.DeviceFreeBufferSize then
      pHBuf.Position := Integer(mcdb.DeviceBufferSize - mcdb.DeviceFreeBufferSize);
  end
  else
  begin
    pcd.Max := 100;                                                       
    pcd.Position := mcdb.EraseProgress;
  end;
end;

procedure TForm1.cbDrivesChange(Sender: TObject);
var
  Letter: Char;
begin
  mcdb.Device := cbDrives.Text;
  cbDrives.Hint := cbDrives.Text;
  Letter := mcdb.DeviceByDriveLetter;
  if Letter = #0 then
    lDrive.Caption := '  Drive :'
  else
    lDrive.Caption := 'Drive '+Letter+':';
  if (dcWriteCDR in mcdb.DeviceCapabilities) or (dcWriteDVDR in mcdb.DeviceCapabilities) or (dcWriteDVDRAM in mcdb.DeviceCapabilities) then
    bBurn.Enabled := True
  else
    bBurn.Enabled := False;
end;

procedure TForm1.bQEraseClick(Sender: TObject);
var
  str: String;
  Speed: Word;
begin
  if not (mcdb.Erasable)and (mcdb.DiscType <> mtDVD_RAM) then
    ShowMessage('Disc is not Erasable')
  else
  if Application.MessageBox('All Data on the CD will be lost', 'Want to Quick Erase the Disc ?', MB_DEFBUTTON2+MB_ICONWARNING+MB_YESNO) = ID_YES then
  begin
    Timer1.Enabled := True;
    str := cbSpeed.Items[cbSpeed.ItemIndex];
    Speed := GetSpeed(str, mcdb.DiscType);
    mcdb.WriteSpeed := speed;
    mcdb.EraseDisc(etQuick);
  end;
end;

procedure TForm1.bLoadClick(Sender: TObject);
begin
  if mcdb.LoadMedium then
    mcdb.DebugMsg('>>> LOAD MEDIUM COMMAND DONE.', 0);
end;

procedure TForm1.bEjectClick(Sender: TObject);
begin
  mcdb.FlushCache;
  mcdb.LockMedium(True);
  if mcdb.LoadMedium(True) then
    mcdb.DebugMsg('>>> EJECT MEDIUM COMMAND DONE.', 0)
  else
    mcdb.DebugMsg('>>> EJECT MEDIUM COMMAND FAILED.', 0);
end;

procedure TForm1.bReadyClick(Sender: TObject);
begin
  if mcdb.TestUnitReady then
    mcdb.DebugMsg('>>> DRIVE IS READY', 0)
  else
    mcdb.DebugMsg('>>> DRIVE IS NOT READY ', 0);
end;

procedure TForm1.AddFilesToCD;
var
  i: Integer;
  Entries: Integer;
  fPath, fName: String;
begin
  if SessionToImport <> 0 then
  begin
    mcdb.SessionToImport := 0;
    mcdb.ImportSession(SessionToImport, nil);
  end;
  Entries := clBox.Items.Count;
  if Entries < 1 then
  begin
    ShowMessage('Atleast one file/directory should be selected');
    exit;
  end;
  for i:=0 to Entries-1 do
  begin
    fPath := ExtractFilePath(clBox.Items[i].SubItems[0]);
    fName := ExtractFileName(clBox.Items[i].SubItems[0]);
    if cPathInfo.State = cbGrayed then
    begin
      mcdb.ParentDirectoryOnly := True;
      if DirectoryExists(clBox.Items[i].SubItems[0]) then
        mcdb.InsertDir(mcdb.RootDir, fPath, '*.*', faAnyFile, clBox.Items[i].Checked, True, oArchiveFiles)
      else
        mcdb.InsertFile('\', fPath+fName, True);
    end
    else
    begin
      mcdb.ParentDirectoryOnly := False;
      if DirectoryExists(clBox.Items[i].SubItems[0]) then
        mcdb.InsertDir(mcdb.RootDir, fPath, '*.*', faAnyFile, clBox.Items[i].Checked, cPathInfo.Checked, oArchiveFiles)
      else
        mcdb.InsertFile('\', fPath+fName, cPathInfo.Checked);
    end;
  end;
  mcdb.RemoveEmptyDirs;
end;

procedure TForm1.bClearClick(Sender: TObject);
begin
  clBox.Items.Clear;
  mcdb.ClearAll(MaxFiles, MaxDirs);
end;

procedure TForm1.bSaveISOClick(Sender: TObject);
var
  FileName: String;
begin
  FileName := mcdb.ISOFileName;
  if InputQuery('Build ISO','Enter ISO File Name to build', FileName) then
  begin