Componentes.Terceros.RemObjects/internal/6.0.43.801/1/RemObjects Samples/Data Abstract for Delphi/Server/fServerForm.pas

unit fServerForm;

{$I Settings.inc}
{$I DataAbstract.inc}

{$IFDEF USE_ANYDAC}
  {$DEFINE SQLITE}
  {$DEFINE FIREBIRD}
{$ENDIF USE_ANYDAC}

{$IFDEF DELPHI2005UP}
  {$IFNDEF FIREBIRD}
    {$DEFINE FIREBIRD}
  {$ENDIF FIREBIRD}
{$ENDIF DELPHI2005UP}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls,
  uDAPoweredByDataAbstractButton, ComCtrls, uROPoweredByRemObjectsButton,
  ExtCtrls;

const
  WM_LOG = WM_USER + $01;

type
  TServerForm = class(TForm)
    Panel1: TPanel;
    Label1: TLabel;
    lbxConnections: TListBox;
    btClearLog: TButton;
    DAPoweredByDataAbstractButton1: TDAPoweredByDataAbstractButton;
    StatusBar: TStatusBar;
    edLog: TMemo;
    procedure FormCreate(Sender: TObject);
    procedure lbxConnectionsClick(Sender: TObject);
    procedure btClearLogClick(Sender: TObject);
  private
    { Private declarations }
    function GetServerLocation: string;
    function Contains(aStr, aSubStr: string): boolean;
  protected
    procedure WMLog(var Message: TMessage); message WM_LOG;
  public
    { Public declarations }
    procedure LogMessage(msg: String);
  end;

var
  ServerForm: TServerForm;

implementation

{$R *.dfm}

uses StrUtils, uDAInterfaces, fServerDataModule;

const
  SERVER_MACRO = '%SERVER%\';

procedure TServerForm.btClearLogClick(Sender: TObject);
begin
  edLog.Clear;
end;

function TServerForm.Contains(aStr, aSubStr: string): boolean;
begin
{$IFDEF UNICODE}
  Result := ContainsText(aStr, aSubStr);
{$ELSE}
  Result := AnsiContainsText(aStr, aSubStr);
{$ENDIF}
end;

procedure TServerForm.FormCreate(Sender: TObject);
var
  i: Integer;
begin
  lbxConnections.Clear;
  edLog.Clear;
  ServerDataModule.Server.Active := true;
  {$IFNDEF DELPHI2005UP}
  {$IFNDEF USE_ANYDAC}
  with edLog.Lines do begin
    Add('******* WARNING *******');
    Add('Unfortunately, our preferred out-of-the-box databases for');
    Add('this sample, SQLite and Firebird, have problems with');
    Add('accessing Unicode fields in Delphi 7. We are trying to');
    Add('resolve this for a future release, but until then, please');
    Add('set up a Microsoft SQL Server or MSDE sample database with');
    Add('the provided .BAK file, to run these samples. This affects');
    Add('Delphi 7 only. We apologize for the inconvenience.');
    Add(' ');
  end;
  {$ENDIF USE_ANYDAC}
  {$ENDIF DELPHI2005UP}

  with ServerDataModule.ConnectionManager do begin
    for i := 0 to Connections.Count - 1 do begin
      {$IFNDEF USE_ANYDAC}
      if not Contains(Connections[i].Name, 'AnyDAC') then begin
      {$ENDIF}
      {$IFNDEF SQLITE}
      if not Contains(Connections[i].Name, 'sqlite') then begin
      {$ENDIF}
      {$IFNDEF FIREBIRD}
      if not Contains(Connections[i].Name, '.FB') then begin
      {$ENDIF}
        lbxConnections.Items.Add(Connections[i].Name);
        {$IFDEF FIREBIRD}
        if Contains(Connections[i].Name, '.Embedded')
        {$ELSE}
        if Contains(Connections[i].Name, 'MSSQL')
        {$ENDIF FIREBIRD}
        then begin
          lbxConnections.Selected[lbxConnections.Count - 1] := True;
          Connections[i].Default := true;
        end;
      {$IFNDEF FIREBIRD}
      end;
      {$ENDIF}
      {$IFNDEF SQLITE}
      end;
      {$ENDIF}
      {$IFNDEF USE_ANYDAC}
      end;
      {$ENDIF}
    end;
  end;
  if (lbxConnections.ItemIndex < 0) and (lbxConnections.Count > 0)
  then lbxConnections.ItemIndex := 0;
  lbxConnectionsClick(nil);
end;

function TServerForm.GetServerLocation: string;
begin
  Result := ExtractFilePath(ParamStr(0));
end;

procedure TServerForm.lbxConnectionsClick(Sender: TObject);
var
  conn: TDAConnection;
begin
  with ServerDataModule.ConnectionManager do begin
    conn := TDAConnection(Connections.ItemByName(lbxConnections.Items[lbxConnections.ItemIndex]));
    StatusBar.Panels[0].Text := 'Connected to ' + conn.Name;
    conn.Default := True;
    conn.ConnectionString := {$IFDEF UNICODE}ReplaceStr{$ELSE}AnsiReplaceStr{$ENDIF}(conn.ConnectionString, SERVER_MACRO, GetServerLocation);
    try
      LogMessage('Validating connection...');
      NewConnection(GetDefaultConnectionName);
      LogMessage('Connection to ' + GetDefaultConnectionName + ' established.');
      LogMessage('Connection string is: ' + Connections.GetDefaultConnection.ConnectionString);
    except
      on E: Exception do begin
        LogMessage('Connection to ' + GetDefaultConnectionName + ' FAILED!');
        LogMessage('Connection string:');
        LogMessage(Connections.GetDefaultConnection.ConnectionString);
        LogMessage('Please check your settings or try to use another connection.');
        LogMessage('The error message follows:');
        LogMessage(E.Message);
      end;
    end;
  end;
end;

procedure TServerForm.LogMessage(msg: String);
var
  p: PChar;
begin
  GetMem(p, (Length(msg) + 1) {$IFDEF UNICODE} * 2 {$ENDIF});
  Move(msg[1], p^, (Length(msg) + 1) {$IFDEF UNICODE} * 2 {$ENDIF});
  PostMessage(Handle, WM_LOG, 0, integer(p));
end;

procedure TServerForm.WMLog(var Message: TMessage);
var
  p: PChar;
begin
  try
    p := PChar(Message.LParam);
    edLog.Lines.Add(p);
    FreeMem(p);
  except
    on E: Exception do
      edLog.Lines.Add(E.Classname+': '+E.Message);
  end;
end;

end.