Marco's Web Center

Menu for Development

Site Menu
Object Pascal Handbook
Delphi Handbooks Collection
Mastering Borland Delphi 2005
(Old) White Papers
(Old)Tools
(Old) Conferences

My Other Sites
Italian Site (www.marcocantu.it)
the delphi search

Spirit of delphi

Advertising
Home My Blog Books Object Pascal Marco

Home: Code Repository: Mastering Delphi 6

Chapter 12 - Project Formdll

Project Structure

Formdll.dpr
library FormDLL;

uses
  ScrollF in 'ScrollF.pas' {FormScroll};

exports
  GetColor, ShowColor, SyncApp;

end.
ScrollF.pas
unit ScrollF;

interface

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

type
  TFormScroll = class(TForm)
    ScrollBarRed: TScrollBar;
    ScrollBarGreen: TScrollBar;
    ScrollBarBlue: TScrollBar;
    LabelRed: TLabel;
    LabelGreen: TLabel;
    LabelBlue: TLabel;
    Shape1: TShape;
    Shape2: TShape;
    Shape3: TShape;
    Label1: TLabel;
    Label2: TLabel;
    LabelScroll: TLabel;
    TrackBar1: TTrackBar;
    Panel1: TPanel;
    sbRed: TSpeedButton;
    sbBlue: TSpeedButton;
    sbGreen: TSpeedButton;
    BitBtn1: TBitBtn;
    BitBtn2: TBitBtn;
    spApplication: TSpeedButton;
    procedure ScrollBarsScroll(Sender: TObject; ScrollCode: TScrollCode;
      var ScrollPos: Integer);
    procedure TrackBar1Change(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormActivate(Sender: TObject);
    procedure sbRedClick(Sender: TObject);
    procedure sbBlueClick(Sender: TObject);
    procedure sbGreenClick(Sender: TObject);
    procedure spApplicationClick(Sender: TObject);
  private
    FormHandle: THandle;
    MsgBack: Integer;
    procedure SetSelColor (Col: TColor);
    function GetSelColor: TColor;
  public
    procedure ApplyClick (Sender: TObject);
    property SelectedColor: TColor
      read GetSelColor write SetSelColor;
  end;

// extern DLL functions declarations
function GetColor (Col: LongInt): LongInt; stdcall;
procedure ShowColor (Col: LongInt;
  FormHandle: THandle; MsgBack: Integer); stdcall;
procedure SyncApp (AppHandle: THandle); stdcall;

implementation

{$R *.DFM}

procedure TFormScroll.ScrollBarsScroll(Sender: TObject;
  ScrollCode: TScrollCode; var ScrollPos: Integer);
begin
  (Sender as TScrollBar).Hint := IntToStr(ScrollPos);

  Shape1.Brush.Color := RGB (ScrollBarRed.Position,
    ScrollBarGreen.Position, ScrollBarBlue.Position);
  Shape2.Pen.Color := RGB (ScrollBarRed.Position,
    ScrollBarGreen.Position, ScrollBarBlue.Position);
end;

procedure TFormScroll.TrackBar1Change(Sender: TObject);
begin
  LabelScroll.Caption := 'Scroll by ' + IntToStr(TrackBar1.Position);
  ScrollBarGreen.LargeChange := TrackBar1.Position;
  ScrollBarRed.LargeChange := TrackBar1.Position;
  ScrollBarBlue.LargeChange := TrackBar1.Position;
end;

procedure TFormScroll.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  // used by the modeless form
  Action := caFree;
end;

procedure TFormScroll.FormActivate(Sender: TObject);
begin
  // change buttons for modeless form
  if FormHandle <> 0 then
  begin
    BitBtn1.Caption := 'Apply';
    BitBtn1.OnClick := ApplyClick;
    BitBtn2.Kind := bkClose;
  end;
end;

procedure TFormScroll.ApplyClick(Sender: TObject);
begin
  // notify to the main form
  SendMessage (FormHandle, MsgBack, SelectedColor, 0);
end;

procedure TFormScroll.sbRedClick(Sender: TObject);
begin
  SelectedColor := clRed;
end;

// set and get properties

function TFormScroll.GetSelColor: TColor;
begin
  Result := RGB (ScrollBarRed.Position,
    ScrollBarGreen.Position, ScrollBarBlue.Position);
end;

procedure TFormScroll.SetSelColor (Col: TColor);
var
  RGBCol: Integer;
begin
  RGBCol := ColorToRGB (Col);
  ScrollBarRed.Position := GetRValue (RGBCol);
  ScrollBarGreen.Position := GetGValue (RGBCol);
  ScrollBarBlue.Position := GetBValue (RGBCol);
  Shape1.Brush.Color := Col;
  Shape2.Pen.Color := Col;
end;

procedure TFormScroll.sbBlueClick(Sender: TObject);
begin
  SelectedColor := clBlue;
end;

procedure TFormScroll.sbGreenClick(Sender: TObject);
begin
  SelectedColor := clGreen;
end;

procedure TFormScroll.spApplicationClick(Sender: TObject);
begin
  ShowMessage ('Application Handle: ' +
    IntToStr (Application.Handle));
end;

// extern DLL functions

function GetColor (Col: LongInt): LongInt; stdcall;
var
  FormScroll: TFormScroll;
begin
  // default value
  Result := Col;
  try
    FormScroll := TFormScroll.Create (Application);
    try
      // initialize the data
      FormScroll.SelectedColor := Col;
      // show the form
      if FormScroll.ShowModal = mrOK then
        Result := FormScroll.SelectedColor;
    finally
      FormScroll.Free;
    end;
  except
    on E: Exception do
      MessageDlg ('Error in FormDLL: ' +
        E.Message, mtError, [mbOK], 0);
  end;
end;

procedure ShowColor (Col: LongInt;
  FormHandle: THandle; MsgBack: Integer); stdcall;
var
  FormScroll: TFormScroll;
begin
  FormScroll := TFormScroll.Create (Application);
  try
    // initialize the data
    FormScroll.FormHandle := FormHandle;
    FormScroll.MsgBack := MsgBack;
    FormScroll.SelectedColor := Col;
    // show the form
    FormScroll.Show;
  except
    on E: Exception do
    begin
      MessageDlg ('Error in FormDLL: ' +
        E.Message, mtError, [mbOK], 0);
      FormScroll.Free;
    end;
  end;
end;

procedure SyncApp (AppHandle: THandle); stdcall;
begin
  Application.Handle := AppHandle;
end;

end.
ScrollF.dfm
object FormScroll: TFormScroll
  Left = 215
  Top = 130
  ActiveControl = ScrollBarRed
  BorderStyle = bsDialog
  Caption = 'Scroll Colors'
  ClientHeight = 316
  ClientWidth = 431
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clBlack
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = True
  ShowHint = True
  OnActivate = FormActivate
  OnClose = FormClose
  PixelsPerInch = 96
  TextHeight = 13
  object Shape3: TShape
    Left = 176
    Top = 176
    Width = 145
    Height = 65
  end
  object Shape2: TShape
    Left = 177
    Top = 177
    Width = 143
    Height = 63
    Pen.Color = clBtnFace
    Pen.Width = 40
  end
  object LabelRed: TLabel
    Left = 16
    Top = 56
    Width = 23
    Height = 13
    Caption = 'Red:'
  end
  object LabelGreen: TLabel
    Left = 16
    Top = 88
    Width = 32
    Height = 13
    Caption = 'Green:'
  end
  object LabelBlue: TLabel
    Left = 16
    Top = 120
    Width = 24
    Height = 13
    Caption = 'Blue:'
  end
  object Shape1: TShape
    Left = 16
    Top = 176
    Width = 145
    Height = 65
    Brush.Color = clBtnFace
  end
  object Label1: TLabel
    Left = 176
    Top = 152
    Width = 52
    Height = 13
    Caption = 'Solid color:'
  end
  object Label2: TLabel
    Left = 16
    Top = 152
    Width = 69
    Height = 13
    Caption = 'Dithered color:'
  end
  object LabelScroll: TLabel
    Left = 16
    Top = 269
    Width = 55
    Height = 13
    Caption = 'Scroll by 25'
  end
  object ScrollBarRed: TScrollBar
    Left = 104
    Top = 56
    Width = 305
    Height = 17
    Hint = 'Red'
    LargeChange = 25
    Max = 255
    PageSize = 0
    Position = 192
    TabOrder = 0
    OnScroll = ScrollBarsScroll
  end
  object ScrollBarGreen: TScrollBar
    Left = 104
    Top = 88
    Width = 305
    Height = 17
    Hint = 'Green'
    LargeChange = 25
    Max = 255
    PageSize = 0
    Position = 192
    TabOrder = 1
    OnScroll = ScrollBarsScroll
  end
  object ScrollBarBlue: TScrollBar
    Left = 104
    Top = 120
    Width = 305
    Height = 17
    Hint = 'Blue'
    LargeChange = 25
    Max = 255
    PageSize = 0
    Position = 192
    TabOrder = 2
    OnScroll = ScrollBarsScroll
  end
  object TrackBar1: TTrackBar
    Left = 96
    Top = 264
    Width = 321
    Height = 33
    Ctl3D = True
    Max = 30
    Min = 1
    Orientation = trHorizontal
    ParentCtl3D = False
    Frequency = 1
    Position = 25
    SelEnd = 0
    SelStart = 0
    TabOrder = 3
    TabStop = False
    TickMarks = tmBottomRight
    TickStyle = tsAuto
    OnChange = TrackBar1Change
  end
  object Panel1: TPanel
    Left = 0
    Top = 0
    Width = 431
    Height = 41
    Align = alTop
    TabOrder = 4
    object sbRed: TSpeedButton
      Left = 8
      Top = 8
      Width = 80
      Height = 25
      Hint = 'Set the color'
      Caption = 'Red'
      Flat = True
      OnClick = sbRedClick
    end
    object sbBlue: TSpeedButton
      Left = 96
      Top = 8
      Width = 80
      Height = 25
      Hint = 'Set the color'
      Caption = 'Blue'
      Flat = True
      OnClick = sbBlueClick
    end
    object sbGreen: TSpeedButton
      Left = 184
      Top = 8
      Width = 80
      Height = 25
      Hint = 'Set the color'
      Caption = 'Green'
      Flat = True
      OnClick = sbGreenClick
    end
    object spApplication: TSpeedButton
      Left = 272
      Top = 8
      Width = 80
      Height = 25
      Hint = 'Get the handle'
      Caption = 'Application?'
      Flat = True
      OnClick = spApplicationClick
    end
  end
  object BitBtn1: TBitBtn
    Left = 336
    Top = 176
    Width = 75
    Height = 25
    TabOrder = 5
    Kind = bkOK
  end
  object BitBtn2: TBitBtn
    Left = 336
    Top = 216
    Width = 75
    Height = 25
    TabOrder = 6
    Kind = bkCancel
  end
end