foobarmain.pas

来自「Drag files and Drop to delphi forms 0402」· PAS 代码 · 共 282 行

unit FoobarMain;

interface

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

type
  TFormFileList = class(TForm)
    Panel1: TPanel;
    MemoFileList: TMemo;
    MainMenu1: TMainMenu;
    MenuFile: TMenuItem;
    MenuFileOpen: TMenuItem;
    MenuFileSave: TMenuItem;
    N1: TMenuItem;
    MenuFileExit: TMenuItem;
    MenuSetup: TMenuItem;
    MenuSetupRegister: TMenuItem;
    MenuSetupUnregister: TMenuItem;
    Memo1: TMemo;
    OpenDialog1: TOpenDialog;
    SaveDialog1: TSaveDialog;
    MenuFileSaveAs: TMenuItem;
    MenuFileNew: TMenuItem;
    procedure FormCreate(Sender: TObject);
    procedure MenuSetupRegisterClick(Sender: TObject);
    procedure MenuFileExitClick(Sender: TObject);
    procedure MenuSetupUnregisterClick(Sender: TObject);
    procedure MenuFileOpenClick(Sender: TObject);
    procedure MenuFileSaveClick(Sender: TObject);
    procedure MenuFileSaveAsClick(Sender: TObject);
    procedure MemoFileListChange(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure MenuFileNewClick(Sender: TObject);
  private
    FDirty: boolean;
    FFileName: string;
    procedure SetDirty(const Value: boolean);
    procedure SetFileName(const Value: string);
  public
    property FileName: string read FFileName write SetFileName;
    property Dirty: boolean read FDirty write SetDirty;
    procedure LoadFile(const AFilename: string);
    function SaveFile(const AFilename: string): boolean;
    function Clear: boolean;
  end;

var
  FormFileList: TFormFileList;

implementation

{$R *.DFM}

uses
  ComObj;

resourcestring
  sFileClass = 'FoobarFile';
  sFileType = 'Foobar File List';
  sFileExtension = '.foobar';

  sTitle = 'Foobar List Editor - %s';
  sNewFile = 'new list';
  sSaveMods = 'Your modifications has not been saved.'+#13+'Save now?';
  sUnregisterNotice = 'Remember to also unregister the drop handler DLL';
  sRegisterNotice = 'Remember to also register the drop handler DLL';

{$ifndef VER13_PLUS}
function GetRegStringValue(const Key, ValueName: string): string;
var
  Size: DWord;
  RegKey: HKEY;
begin
  Result := '';
  if RegOpenKey(HKEY_CLASSES_ROOT, PChar(Key), RegKey) = ERROR_SUCCESS then
  try
    Size := 256;
    SetLength(Result, Size);
    if RegQueryValueEx(RegKey, PChar(ValueName), nil, nil, PByte(PChar(Result)), @Size) = ERROR_SUCCESS then
      SetLength(Result, Size - 1) else
      Result := '';
  finally
    RegCloseKey(RegKey);
  end;
end;
{$endif}

procedure TFormFileList.FormCreate(Sender: TObject);
var
  i: integer;

  procedure LoadFileList(const List: string);
  var
    Files: TStringList;
  begin
    Files := TStringList.Create;
    try
      Files.LoadFromFile(List);
      MemoFileList.Lines.AddStrings(Files);
    finally
      Files.Free;
    end;
  end;

begin
  FileName := '';

  // Display command line (for debug purposes).
  Memo1.Lines.Text := CmdLine;

  if (ParamCount > 0) then
  begin
    // First parameter is file list.
    LoadFile(ParamStr(1));

    // Additional parameters are file names which should be added to the list.
    // If a filename starts with @ it indicates that the file contains a list of
    // file names which should be added to the list.
    for i := 2 to ParamCount do
      if (Copy(ParamStr(i), 1, 1) = '@') then
        LoadFileList(Copy(ParamStr(i), 2, MaxInt))
      else
        MemoFileList.Lines.Add(ParamStr(i));
  end;

  // Determine if the file association has already been registered and modify
  // the register menu items accordingly.
  MenuSetupRegister.Enabled := (GetRegStringValue(sFileClass+'\DefaultIcon', '') = '');
  MenuSetupUnregister.Enabled := not MenuSetupRegister.Enabled;
end;

procedure TFormFileList.FormCloseQuery(Sender: TObject;
  var CanClose: Boolean);
begin
  CanClose := Clear;
end;

procedure TFormFileList.MenuSetupRegisterClick(Sender: TObject);
begin
  // Register file association.
  CreateRegKey(sFileExtension, '', sFileClass);
  CreateRegKey(sFileExtension+'\ShellNew', 'NullFile', '');
  CreateRegKey(sFileClass, '', sFileType);
  CreateRegKey(sFileClass+'\shell\open\command', '', Application.ExeName+' "%1"');
  CreateRegKey(sFileClass+'\DefaultIcon', '', Application.ExeName+',0');
  MenuSetupRegister.Enabled := False;
  MenuSetupUnregister.Enabled := True;
  if (GetRegStringValue(sFileClass+'\shellex\DropHandler', '') = '') then
    ShowMessage(sRegisterNotice);
end;

procedure TFormFileList.MenuSetupUnregisterClick(Sender: TObject);
begin
  // Unregister file association.
  DeleteRegKey(sFileClass+'\DefaultIcon');
  DeleteRegKey(sFileClass+'\shell\open\command');
  DeleteRegKey(sFileClass+'\shell\open');
  DeleteRegKey(sFileClass+'\shell');
  DeleteRegKey(sFileClass);
  DeleteRegKey(sFileExtension+'\ShellNew');
  DeleteRegKey(sFileExtension);
  MenuSetupRegister.Enabled := True;
  MenuSetupUnregister.Enabled := False;
  if (GetRegStringValue(sFileClass+'\shellex\DropHandler', '') <> '') then
    ShowMessage(sUnregisterNotice);
end;

procedure TFormFileList.MenuFileExitClick(Sender: TObject);
begin
  Close;
end;

procedure TFormFileList.MenuFileNewClick(Sender: TObject);
begin
  Clear;
end;

procedure TFormFileList.MenuFileOpenClick(Sender: TObject);
begin
  if (Clear) then
  begin
    OpenDialog1.Filename := FileName;
    if (OpenDialog1.Execute) then
      LoadFile(OpenDialog1.Filename);
  end;
end;

procedure TFormFileList.MenuFileSaveAsClick(Sender: TObject);
begin
  SaveFile('');
end;

procedure TFormFileList.MenuFileSaveClick(Sender: TObject);
begin
  SaveFile(FileName);
end;

procedure TFormFileList.LoadFile(const AFilename: string);
begin
  MemoFileList.Lines.LoadFromFile(AFilename);
  FileName := AFilename;
  Dirty := False;
end;

function TFormFileList.SaveFile(const AFilename: string): boolean;
begin
  Result := True;
  if (AFilename = '') then
  begin
    SaveDialog1.Filename := FileName;
    if (SaveDialog1.Execute) then
      FileName := SaveDialog1.Filename
    else
      Result := False;
  end else
    FileName := AFilename;

  if (Result) then
  begin
    MemoFileList.Lines.SaveToFile(Filename);
    Dirty := False;
  end;
end;

function TFormFileList.Clear: boolean;
var
  Answer: word;
begin
  Result := True;
  // Check for unsaved changes and prompt.
  if (Dirty) then
  begin
    Answer := MessageDlg(sSaveMods, mtConfirmation, [mbYes, mbNo, mbCancel], 0);
    case Answer of
      mrYes:
        Result := SaveFile(FileName);
      mrCancel:
        Result := False;
    end;
  end;

  if (Result) then
  begin
    MemoFileList.Lines.Clear;
    FileName := '';
    Dirty := False;
  end;
end;

procedure TFormFileList.MemoFileListChange(Sender: TObject);
begin
  Dirty := True;
end;

procedure TFormFileList.SetDirty(const Value: boolean);
begin
  // Enable the "Save" menu item if the file has been modified and we have a
  // file name for it.
  FDirty := Value;
  MenuFileSave.Enabled := FDirty and (FileName <> '');
end;

procedure TFormFileList.SetFileName(const Value: string);
begin
  FFileName := Value;
  if (FFileName <> '') then
  begin
    Caption := Format(sTitle, [FFileName]);
    MenuFileSave.Enabled := Dirty;
  end else
  begin
    Caption := Format(sTitle, [sNewFile]);
    MenuFileSave.Enabled := False;
  end;
end;

end.