disqlite3_richedit_fmain.pas

来自「DELPHI 访问SQLITE3 数据库的VCL控件」· PAS 代码 · 共 880 行 · 第 1/2 页

{ This example project demonstrates a simple DISQLite3 GUI, storing Rich Text
  (RTF) in a database. It uses the DISQLite native API.

  Visit the DISQLite3 Internet site for latest information and updates:

    http://www.yunqa.de/delphi/

  Copyright (c) 2005-2007 Ralf Junker, The Delphi Inspiration <[e-mail]>

------------------------------------------------------------------------------ }

unit DISQLite3_RichEdit_fMain;

{$I DI.inc}
{$I DISQLite3.inc}

interface

uses
  Classes, Forms, Menus, ImgList, Controls, StdCtrls, ComCtrls, ExtCtrls, Spin,
  ToolWin,
  DISQLite3Api;

type
  TfrmMain = class(TForm)
    ToolbarImages: TImageList;
    tbFormat: TToolBar;
    btnBold: TToolButton;
    btnItalic: TToolButton;
    btnUnderline: TToolButton;
    btnColor: TToolButton;
    cbxFontName: TComboBox;
    edtFontSize: TSpinEdit;
    btnAlignLeft: TToolButton;
    btnAlignCenter: TToolButton;
    btnAlignRight: TToolButton;
    btnBullets: TToolButton;
    ToolButton1: TToolButton;
    ToolButton2: TToolButton;
    LVItems: TListView;
    menuMain: TMainMenu;
    mnuFile: TMenuItem;
    mnuFile_NewDatabase: TMenuItem;
    mnuFile_OpenDatabase: TMenuItem;
    mnuFile_CloseDatabase: TMenuItem;
    pnlDetails: TPanel;
    edtItemName: TEdit;
    edtItemRtf: TRichEdit;
    Label1: TLabel;
    Label2: TLabel;
    Splitter1: TSplitter;
    mnuData: TMenuItem;
    mnuData_New: TMenuItem;
    mnuData_Delete: TMenuItem;
    mnuData_Save: TMenuItem;
    n1: TMenuItem;
    mnuFile_SaveRtf: TMenuItem;
    mnuFile_LoadRtf: TMenuItem;
    n2: TMenuItem;
    mnuData_Reload: TMenuItem;
    n3: TMenuItem;
    mnuData_Vacuum: TMenuItem;
    procedure lvItems_Data(Sender: TObject; Item: TListItem);
    procedure Form_Create(Sender: TObject);
    procedure mnuFile_NewDatabase_Click(Sender: TObject);
    procedure mnuFile_OpenDatabase_Click(Sender: TObject);
    procedure mnuFile_CloseDatabase_Click(Sender: TObject);
    procedure Form_Destroy(Sender: TObject);
    procedure lvItems_Change(Sender: TObject; Item: TListItem; Change: TItemChange);
    procedure lvItems_Resize(Sender: TObject);
    procedure edtItemName_Change(Sender: TObject);
    procedure edtItemRtf_Change(Sender: TObject);
    procedure edtItemRtf_SelectionChange(Sender: TObject);
    procedure btnBold_Click(Sender: TObject);
    procedure btnItalic_Click(Sender: TObject);
    procedure btnUnderline_Click(Sender: TObject);
    procedure btnBullets_Click(Sender: TObject);
    procedure btnAlignLeft_Click(Sender: TObject);
    procedure btnAlignCenter_Click(Sender: TObject);
    procedure btnAlignRight_Click(Sender: TObject);
    procedure edtFontSize_Change(Sender: TObject);
    procedure cbxFontName_Change(Sender: TObject);
    procedure mnuData_New_Click(Sender: TObject);
    procedure mnuData_Delete_Click(Sender: TObject);
    procedure mnuFile_Click(Sender: TObject);
    procedure mnuData_Click(Sender: TObject);
    procedure mnuData_SaveNow_Click(Sender: TObject);
    procedure mnuFile_SaveRtf_Click(Sender: TObject);
    procedure mnuFile_LoadRtf_Click(Sender: TObject);
    procedure mnuData_Reload_Click(Sender: TObject);
    procedure btnColor_Click(Sender: TObject);
    procedure mnuData_Vacuum_Click(Sender: TObject);
  private
    FDb: TDISQLite3DatabaseHandle;
    FStmt_SelectName: TDISQLite3StatementHandle;
    FStmt_SelectRTF: TDISQLite3StatementHandle;
    FStmt_SelectNameRTF: TDISQLite3StatementHandle;
    FStmt_UpdateNameRTF: TDISQLite3StatementHandle;
    FDbFileName: AnsiString;
    FData: TList;
    FItemIdx: Integer;
    FItemChanged: Boolean; // True if an item was edited and has been changed.
    FReading: Boolean; // True if we are currently reading an item from the database.
    procedure DeleteSelected;
    procedure EnableControls(const AValue: Boolean);
    procedure FinalizeStatements;
    procedure InternalCloseDatabase;
    procedure InternalOpenDatabase(const AFileName: AnsiString; const ACreateNew: Boolean = False);
    procedure PrepareStatements;
    procedure ReadItemFromDB(const AIdx: Integer);
    function ReadNameFromDB(const AIdx: Integer; out AName: AnsiString): Boolean;
    procedure RefreshData;
    procedure WriteItemToDB;
  end;

const
  APP_TITLE = 'DISQLite3: TRichedit Demo';

var
  frmMain: TfrmMain;

implementation

uses
  {$IFDEF COMPILER_6_UP}RTLConsts{$ELSE}Consts{$ENDIF}, SysUtils, Graphics, Dialogs;

{$R *.dfm}

const
  OPEN_DIALOG_OPTIONS = [ofEnableSizing, ofPathMustExist];
  SAVE_DIALOG_OPTIONS = [ofEnableSizing, ofOverwritePrompt, ofPathMustExist];

  DIALOG_DATABASE_DEFAULTEXT = 'db3';
  DIALOG_DATABASE_FILTER = 'SQLite3 Database (*.db3;*db)|*.db3;*db|Any file (*.*)|*.*';

  DIALOG_RTF_DEFAULTEXT = 'rtf';
  DIALOG_RTF_FILTER = 'RTF file (*.rtf)|*.rtf|Any file (*.*)|*.*';

  //------------------------------------------------------------------------------

procedure ListView_ClearSelection(const LV: TListView);
var
  i: Integer;
begin
  with LV, Items do
    begin
      BeginUpdate;
      try
        for i := 0 to Count - 1 do
          Items[i].Selected := False;
      finally
        EndUpdate;
      end;
    end;
end;

type
  //------------------------------------------------------------------------------
  // TSetMemoryStream class
  //------------------------------------------------------------------------------

  { A simple TCustomMemoryStream descendant which can be pointed to an existing
    block of memory which is already allocated. This is a read-only stream. }
  TSetMemoryStream = class(TCustomMemoryStream)
  public
    procedure SetPointer(Ptr: Pointer; Size: Integer);
    function Write(const Buffer; Count: LongInt): LongInt; override;
  end;

procedure TSetMemoryStream.SetPointer(Ptr: Pointer; Size: Integer);
begin
  inherited SetPointer(Ptr, Size);
end;

//------------------------------------------------------------------------------

function TSetMemoryStream.Write(const Buffer; Count: LongInt): LongInt;
begin
  raise EStreamError.Create(SWriteError);
end;

//------------------------------------------------------------------------------
// TfrmMain class
//------------------------------------------------------------------------------

procedure TfrmMain.Form_Create(Sender: TObject);
var
  r: Integer;
begin
  Caption := APP_TITLE;

  cbxFontName.Items.Assign(Screen.Fonts);
  FData := TList.Create;

  InternalOpenDatabase(ExtractFilePath(ParamStr(0)) + 'Products.db');

  r := LVItems.Items.Count;
  if r > 0 then
    begin
      Randomize;
      r := Random(r);
      ListView_ClearSelection(LVItems);
      LVItems.Items[r].Selected := True;
      LVItems.Items[r].Focused := True;
    end;

  edtItemRtf.SelStart := 0; // Force a selection
  edtItemRtf_SelectionChange(nil);
end;

//------------------------------------------------------------------------------

procedure TfrmMain.Form_Destroy(Sender: TObject);
begin
  InternalCloseDatabase;
  FData.Free;
end;

//------------------------------------------------------------------------------

{ Deletes all selected items from the database and updates the controls. }
procedure TfrmMain.DeleteSelected;
var
  Stmt: TDISQLite3StatementHandle;
  i, Idx: Integer;
  LI: TListItem;
begin
  if MessageDlg('Delete selected records?', mtConfirmation, mbOKCancel, 0) <> mrOK then
    Exit;

  LVItems.Items.BeginUpdate;
  try
    sqlite3_exec_fast(FDb, 'BEGIN TRANSACTION');
    sqlite3_check(sqlite3_prepare_v2(
      FDb, // Database handle.
      'DELETE FROM "Items" WHERE "RowID"=?',
      -1, // Length of SQL or -1 if #0-terminated.
      @Stmt, // Pointer to variable storing the prepared statement.
      nil) // Pointer receiving end of SQL statement or nil.
      , FDb);
    try
      if Assigned(Stmt) then
        try
          i := LVItems.Items.Count - 1;
          while i >= 0 do
            begin
              LI := LVItems.Items[i];
              if LI.Selected then
                begin
                  Idx := Integer(FData[i]);
                  sqlite3_check(sqlite3_bind_int(Stmt, 1, Idx), FDb);
                  sqlite3_check(sqlite3_step(Stmt), FDb);
                  sqlite3_check(sqlite3_reset(Stmt), FDb);
                  FData.Delete(i);
                end;
              Dec(i);
            end;
          LVItems.Items.Count := FData.Count;
        finally
          sqlite3_check(sqlite3_finalize(Stmt), FDb);
        end;
      RefreshData;
    finally
      sqlite3_exec_fast(FDb, 'END TRANSACTION');
    end;
  finally
    LVItems.Items.EndUpdate;
  end;
end;

//------------------------------------------------------------------------------

procedure TfrmMain.EnableControls(const AValue: Boolean);
begin
  LVItems.Enabled := AValue;
  edtItemName.Enabled := AValue;
  edtItemRtf.Enabled := AValue;
  tbFormat.Enabled := AValue;
  tbFormat.Invalidate;

  if not AValue then
    begin
      edtItemName.Clear;
      edtItemRtf.Clear;
    end;
end;

//------------------------------------------------------------------------------

{ Finalizes all prepared statements before closing the database. }
procedure TfrmMain.FinalizeStatements;
  procedure FinalizeAndNil(var Stmt: TDISQLite3StatementHandle);
  begin
    sqlite3_check(sqlite3_finalize(Stmt), FDb);
    Stmt := nil;
  end;
begin
  FinalizeAndNil(FStmt_SelectName);
  FinalizeAndNil(FStmt_SelectRTF);
  FinalizeAndNil(FStmt_SelectNameRTF);
  FinalizeAndNil(FStmt_UpdateNameRTF);
end;

//------------------------------------------------------------------------------

{ Closes the database and updates the controls. }
procedure TfrmMain.InternalCloseDatabase;
begin
  if Assigned(FDb) then
    begin
      { Write current item if modified. }
      WriteItemToDB;
      { Clear the controls. }
      EnableControls(False);
      LVItems.Items.Count := 0;
      LVItems.Refresh;
      edtItemName.Clear;
      edtItemRtf.Clear;
      { Clear the data cache. }
      FData.Clear;
      { Finalize all statements and close the database. }
      FinalizeStatements;
      sqlite3_check(sqlite3_close(FDb), FDb);
      FDb := nil;
    end;
end;

//------------------------------------------------------------------------------

{ Creates a new or opens an existing database files. For new files, it
  initializes the database by creating necessary tables and indexes.
  Once opened, it also updates the form's controls to list the records. }
procedure TfrmMain.InternalOpenDatabase(const AFileName: AnsiString; const ACreateNew: Boolean = False);
begin
  InternalCloseDatabase;
  if FileExists(AFileName) or ACreateNew then
    begin
      if ACreateNew then
        DeleteFile(AFileName);
      sqlite3_check(sqlite3_open(PAnsiChar(AFileName), @FDb), FDb);
      FDbFileName := AFileName;

      if ACreateNew then
        sqlite3_exec_fast(FDb,
          'CREATE TABLE IF NOT EXISTS "Items" ("Name" STRING, "RTF" BLOB);' +
          'CREATE INDEX IF NOT EXISTS "Items_Name" ON "Items" ("Name");');

      PrepareStatements;
      FItemChanged := False;
    end;
  RefreshData;
end;

//------------------------------------------------------------------------------

{ Prepares some frequently used SQL database statements. This saves time to
  prepare theses statements many times when they are used repeatedly. }
procedure TfrmMain.PrepareStatements;
  procedure PrepareStatement(const SQL: AnsiString; var Stmt: TDISQLite3StatementHandle);
  begin
    sqlite3_check(sqlite3_prepare_v2(
      FDb, // Database handle.
      PAnsiChar(SQL),
      Length(SQL), // Length of SQL or -1 if #0-terminated.
      @Stmt, // Pointer to variable storing the prepared statement.
      nil) // Pointer receiving end of SQL statement or nil.
      , FDb);
  end;
begin
  PrepareStatement('SELECT "Name" FROM "Items" WHERE "RowID" = ?;', FStmt_SelectName);
  PrepareStatement('SELECT "RTF" FROM "Items" WHERE "RowID"=?;', FStmt_SelectRTF);
  PrepareStatement('SELECT "Name","RTF" FROM "Items" WHERE "RowID"=?;', FStmt_SelectNameRTF);
  PrepareStatement('UPDATE "Items" SET "Name"=?,"RTF"=? WHERE RowID=?;', FStmt_UpdateNameRTF);
end;

//------------------------------------------------------------------------------

{ Reads the name column from the database. }
function TfrmMain.ReadNameFromDB(const AIdx: Integer; out AName: AnsiString): Boolean;
begin
  Result := Assigned(FStmt_SelectName);
  if Result then
    begin
      sqlite3_check(sqlite3_bind_int(FStmt_SelectName, 1, AIdx), FDb);
      Result := sqlite3_check(sqlite3_step(FStmt_SelectName), FDb) = SQLITE_ROW;
      if Result then
        AName := sqlite3_column_str(FStmt_SelectName, 0);
      sqlite3_check(sqlite3_reset(FStmt_SelectName), FDb);
    end;
end;

//------------------------------------------------------------------------------

{ Reads a full item from the database directly into the form's controls. }
procedure TfrmMain.ReadItemFromDB(const AIdx: Integer);
var
  ms: TSetMemoryStream;
begin
  if Assigned(FStmt_SelectNameRTF) then
    try
      FReading := True;
      sqlite3_check(sqlite3_bind_int(FStmt_SelectNameRTF, 1, AIdx), FDb);
      if sqlite3_check(sqlite3_step(FStmt_SelectNameRTF), FDb) = SQLITE_ROW then
        begin
          // Assert(sqlite3_column_type(FStmt_SelectNameRTF, 0) = sqlite_text);
          edtItemName.Text := sqlite3_column_str(FStmt_SelectNameRTF, 0);

          edtItemRtf.Clear;
          edtItemRtf.DefAttributes.Name := 'Tahoma';
          edtItemRtf.DefAttributes.Size := 12;
          edtItemRtf.DefAttributes.Style := [];
          edtItemRtf.DefAttributes.Color := clBlack;

          { Create a memory stream to load the RTF data. }
          // Assert(sqlite3_column_type(FStmt_SelectNameRTF, 1) = sqlite_blob);
          ms := TSetMemoryStream.Create;
          try
            ms.SetPointer(
              sqlite3_column_blob(FStmt_SelectNameRTF, 1),
              sqlite3_column_bytes(FStmt_SelectNameRTF, 1));
            edtItemRtf.Lines.LoadFromStream(ms);
          finally
            ms.Free;
          end;

          sqlite3_check(sqlite3_reset(FStmt_SelectNameRTF), FDb);

          FItemIdx := AIdx;
          FItemChanged := False;
          edtItemRtf_SelectionChange(nil);
        end;
    finally
      FReading := False;
    end;
end;

//------------------------------------------------------------------------------

{ Rereads all records from the database and updates all controls to
  reflect the latest changes. }