user-selectable color and text

Plasmax
Plasmax used Ask the Experts™
on
I want the user to be able to choose a color and font.

I have managed to allow the user to choose the text he wants to send and he can send it.

but he can only use the font and color I allow which I want to change to allow the user to make the choice.
They must be able to choose a choice of say 9 colors from a little color chart..
also the fonts I want to use, 5 in total they need to become the actuall font on radio button select so they can see the cool font while typing.
remember these are little kids and it needs to look this way.
procedure TForm1.frightbutton1Click(Sender: TObject);
begin
  Canv.Font.Name   := 'Bloodsuckers';
  Canv.Font.Size   := 70;
  Canv.Font.Color  := clRED;
  Canv.Brush.Style := bsclear;
  Canv.textout(100, Screen.Height div 2 - 30, (edit1.text));
end;

Open in new window

Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®

Author

Commented:
anyone?
Geert GOracle dba
Top Expert 2009

Commented:
why not 2 comboboxes ?

use it from a other unit like this :

uses uFontColorSelector;

procedure TForm4.Button1Click(Sender: TObject);
var
  aFontName: string;
  aColor: TColor;
begin
  aColor := clYellow;
  aFontName := 'Courier New';
  if GetFontColorSelection(Self, aFontName, aColor) then
  begin
    Memo1.Lines.Add('Selected font = ' + aFontName);
    Memo1.Lines.Add('Selected color = ' + IntToStr(aColor) + ', ' + ColorToString(aColor));
  end;
end;

unit uFontColorSelector;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, ExtCtrls, Buttons;
 
type
  TfrmSelection = class(TForm)
    pnlOptions: TPanel;
    btnOk: TBitBtn;
    btnCancel: TBitBtn;
    pnlSelectFont: TPanel;
    pnlSelectColor: TPanel;
    comboColor: TColorBox;
    comboFont: TComboBox;
    lblSelectFont: TLabel;
    lblSelectedColor: TLabel;
    procedure comboColorGetColors(Sender: TCustomColorBox; Items: TStrings);
  private
    procedure AddFonts;
    function GetSelectedColor: TColor;
    function GetSelectedFont: string;
    procedure SetSelectedColor(const Value: TColor);
    procedure SetSelectedFont(const Value: string);
  public
    constructor Create(AOwner: TComponent); override;
    property SelectedFont: string read GetSelectedFont write SetSelectedFont;
    property SelectedColor: TColor read GetSelectedColor write SetSelectedColor;
  end;
 
var
  frmSelection: TfrmSelection;
 
function GetFontColorSelection(AOwner: TComponent; var aFontName: string; var aColor: TColor): boolean;
 
implementation
 
{$R *.dfm}
 
function GetFontColorSelection(AOwner: TComponent; var aFontName: string; var aColor: TColor): boolean;
var frm: TfrmSelection;
begin
  Result := False;
  frm := TfrmSelection.Create(AOwner);
  try
    with frm do
    begin
      SelectedFont := aFontName;
      SelectedColor := aColor;
      if ShowModal = mrOk then
      begin
        aFontName := SelectedFont;
        aColor := SelectedColor;
        Result := True;
      end;
    end;
  finally
    FreeAndNil(frm);
  end;
end;
 
procedure TfrmSelection.comboColorGetColors(Sender: TCustomColorBox; Items: TStrings);
begin
  Items.AddObject('Black', TObject(clBlack));
  Items.AddObject('Red', TObject(clRed));
  Items.AddObject('Lime', TObject(clLime));
  Items.AddObject('Blue', TObject(clNavy));
  Items.AddObject('Yellow', TObject(clYellow));
end;
 
constructor TfrmSelection.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  AddFonts;
end;
 
function TfrmSelection.GetSelectedColor: TColor;
begin
  Result := clBlack;
  with comboColor do
    if ItemIndex <> -1 then
      Result := TColor(Items.Objects[ItemIndex]);
end;
 
function TfrmSelection.GetSelectedFont: string;
begin
  Result := 'Times New Roman';
  with comboFont do
    if ItemIndex <> -1 then
      Result := Items[ItemIndex];
end;
 
procedure TfrmSelection.SetSelectedColor(const Value: TColor);
begin
  with comboColor do
    ItemIndex := Items.IndexOfObject(TObject(Value));
end;
 
procedure TfrmSelection.SetSelectedFont(const Value: string);
begin
  with comboFont do
    ItemIndex := Items.IndexOf(Value);
end;
 
procedure TfrmSelection.AddFonts;
begin
  with ComboFont.Items do
  begin
    BeginUpdate;
    try
      Clear;
      Add('Courier New');
      Add('Times New Roman');
    finally
      EndUpdate;
    end;
  end;
end;
 
end.
 
-- dfm --
object frmSelection: TfrmSelection
  Left = 0
  Top = 0
  Caption = 'Selection'
  ClientHeight = 135
  ClientWidth = 354
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object pnlOptions: TPanel
    Left = 0
    Top = 96
    Width = 354
    Height = 39
    Align = alBottom
    BevelOuter = bvNone
    TabOrder = 0
    DesignSize = (
      354
      39)
    object btnOk: TBitBtn
      Left = 169
      Top = 8
      Width = 75
      Height = 25
      Anchors = [akTop, akRight]
      DoubleBuffered = True
      Kind = bkOK
      ParentDoubleBuffered = False
      TabOrder = 0
    end
    object btnCancel: TBitBtn
      Left = 257
      Top = 8
      Width = 75
      Height = 25
      Anchors = [akTop, akRight]
      DoubleBuffered = True
      Kind = bkCancel
      ParentDoubleBuffered = False
      TabOrder = 1
    end
  end
  object pnlSelectFont: TPanel
    Left = 0
    Top = 0
    Width = 354
    Height = 41
    Align = alTop
    BevelOuter = bvNone
    TabOrder = 1
    object lblSelectFont: TLabel
      Left = 80
      Top = 16
      Width = 22
      Height = 13
      Caption = 'Font'
    end
    object comboFont: TComboBox
      Left = 112
      Top = 13
      Width = 217
      Height = 21
      Style = csDropDownList
      ItemHeight = 13
      TabOrder = 0
    end
  end
  object pnlSelectColor: TPanel
    Left = 0
    Top = 41
    Width = 354
    Height = 40
    Align = alTop
    BevelOuter = bvNone
    TabOrder = 2
    object lblSelectedColor: TLabel
      Left = 80
      Top = 9
      Width = 25
      Height = 13
      Caption = 'Color'
    end
    object comboColor: TColorBox
      Left = 112
      Top = 6
      Width = 145
      Height = 22
      Selected = clScrollBar
      Style = [cbCustomColors]
      ItemHeight = 16
      TabOrder = 0
      OnGetColors = comboColorGetColors
    end
  end
end

Open in new window

Author

Commented:
thanks for helping me.

I had a look at this today and this is what I have come up with.
I really only want this on 1 form, so I have done the changes, but why the ok and cancel button i am not sure what these are for as the user must just choose the color, then font, then type the text then press send.
the color and font does not work it still just reads red and blood font.

can you have a look for me, also how can I clear the text once send, for example can the next "sent text" auto clear the first text already on screen and how to auto make the screen go black so the text stands out better.?

again thankyou so much for helping

here is entire code.
unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, ExtCtrls, Buttons;
 
 
type
  TForm1 = class(TForm)
 
    combocolor: TColorBox;
    lblselectcolor: TLabel;
    pnloptions: TPanel;
    btnok: TButton;
    btncancel: TButton;
    pnlselectcolor: TPanel;
    pnlselectfont: TPanel;
    combofont: TComboBox;
    lblselectfont: TLabel;
    Edit1: TEdit;
    Button1: TButton;
    procedure comboColorGetColors(Sender: TCustomColorBox; Items: TStrings);
procedure AddFonts;
    function GetSelectedColor: TColor;
    function GetSelectedFont: string;
    procedure SetSelectedColor(const Value: TColor);
    procedure SetSelectedFont(const Value: string);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Button1Click(Sender: TObject);
 
 
 
  public
    constructor Create(AOwner: TComponent); override;
    property SelectedFont: string read GetSelectedFont write SetSelectedFont;
    property SelectedColor: TColor read GetSelectedColor write SetSelectedColor;
  end;
 
 
var
  Form1: TForm1;
    Canv: TCanvas; 
 
  function GetFontColorSelection(AOwner: TComponent; var aFontName: string; var aColor: TColor): boolean;
 
 
implementation
 
 
 
{$R *.dfm}
  procedure TForm1.FormCreate(Sender: TObject);
begin
  Canv := TCanvas.Create;
  Canv.Handle := GetWindowDC(0);
end;
 
procedure TForm1.FormDestroy(Sender: TObject);
begin
  Canv.Free;
end;
 
 function GetFontColorSelection(AOwner: TComponent; var aFontName: string; var aColor: TColor): boolean;
var frm: Tform1;
begin
  Result := False;
  frm := Tform1.Create(AOwner);
  try
    with frm do
    begin
      SelectedFont := aFontName;
      SelectedColor := aColor;
      if ShowModal = mrOk then
      begin
        aFontName := SelectedFont;
        aColor := SelectedColor;
        Result := True;
      end;
    end;
  finally
    FreeAndNil(frm);
  end;
end;
 
   procedure Tform1.comboColorGetColors(Sender: TCustomColorBox; Items: TStrings);
begin
  Items.AddObject('Black', TObject(clBlack));
  Items.AddObject('Red', TObject(clRed));
  Items.AddObject('Lime', TObject(clLime));
  Items.AddObject('Blue', TObject(clNavy));
  Items.AddObject('Yellow', TObject(clYellow));
end;
 
 
 constructor Tform1.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  AddFonts;
end;
 
function Tform1.GetSelectedColor: TColor;
begin
  Result := clBlack;
  with comboColor do
    if ItemIndex <> -1 then
      Result := TColor(Items.Objects[ItemIndex]);
end;
 
function Tform1.GetSelectedFont: string;
begin
  Result := 'Times New Roman';
  with comboFont do
    if ItemIndex <> -1 then
      Result := Items[ItemIndex];
end;
 
procedure Tform1.SetSelectedColor(const Value: TColor);
begin
  with comboColor do
    ItemIndex := Items.IndexOfObject(TObject(Value));
end;
 
procedure Tform1.SetSelectedFont(const Value: string);
begin
  with comboFont do
    ItemIndex := Items.IndexOf(Value);
end;
 
procedure Tform1.AddFonts;
begin
  with ComboFont.Items do
  begin
    BeginUpdate;
    try
      Clear;
      Add('Courier New');
      Add('Times New Roman');
    finally
      EndUpdate;
    end;
  end;
end;
 
 
 
 
 
 
 
procedure TForm1.Button1Click(Sender: TObject);
 
begin
  Canv.Font.Name   := 'Bloodsuckers';
  Canv.Font.Size   := 70;
  Canv.Font.Color  := clRED;
  Canv.Brush.Style := bsclear;
  Canv.textout(100, Screen.Height div 2 - 30, (edit1.text));
end;
 
 
end.
 
 
 
-- dfm --
object form1: Tform1
  Left = 0
  Top = 0
  Caption = 'Selection'
  ClientHeight = 135
  ClientWidth = 354
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object pnlOptions: TPanel
    Left = 0
    Top = 96
    Width = 354
    Height = 39
    Align = alBottom
    BevelOuter = bvNone
    TabOrder = 0
    DesignSize = (
      354
      39)
    object btnOk: TBitBtn
      Left = 169
      Top = 8
      Width = 75
      Height = 25
      Anchors = [akTop, akRight]
      DoubleBuffered = True
      Kind = bkOK
      ParentDoubleBuffered = False
      TabOrder = 0
    end
    object btnCancel: TBitBtn
      Left = 257
      Top = 8
      Width = 75
      Height = 25
      Anchors = [akTop, akRight]
      DoubleBuffered = True
      Kind = bkCancel
      ParentDoubleBuffered = False
      TabOrder = 1
    end
  end
  object pnlSelectFont: TPanel
    Left = 0
    Top = 0
    Width = 354
    Height = 41
    Align = alTop
    BevelOuter = bvNone
    TabOrder = 1
    object lblSelectFont: TLabel
      Left = 80
      Top = 16
      Width = 22
      Height = 13
      Caption = 'Font'
    end
    object comboFont: TComboBox
      Left = 112
      Top = 13
      Width = 217
      Height = 21
      Style = csDropDownList
      ItemHeight = 13
      TabOrder = 0
    end
  end
  object pnlSelectColor: TPanel
    Left = 0
    Top = 41
    Width = 354
    Height = 40
    Align = alTop
    BevelOuter = bvNone
    TabOrder = 2
    object lblSelectedColor: TLabel
      Left = 80
      Top = 9
      Width = 25
      Height = 13
      Caption = 'Color'
    end
    object comboColor: TColorBox
      Left = 112
      Top = 6
      Width = 145
      Height = 22
      Selected = clScrollBar
      Style = [cbCustomColors]
      ItemHeight = 16
      TabOrder = 0
      OnGetColors = comboColorGetColors
    end
  end
end
  
    procedure TForm1.frightbutton1Click(Sender: TObject);
begin
  Canv.Font.Name   := 'Bloodsuckers';
  Canv.Font.Size   := 70;
  Canv.Font.Color  := clRED;
  Canv.Brush.Style := bsclear;
  Canv.textout(100, Screen.Height div 2 - 30, (edit1.text));
end;
 
end.

Open in new window

Amazon Web Services

Are you thinking about creating an Amazon Web Services account for your business? Not sure where to start? In this course you’ll get an overview of the history of AWS and take a tour of their user interface.

Geert GOracle dba
Top Expert 2009

Commented:
what's the canvas for ?
Canv: TCanvas ????

changes ???

basically you want something like the sending of a text to a irc chat channel ?
with choosing font and color ?

Author

Commented:
no no not irc, wow havent been on that for years.

this is just something silly I am working on, to get used to commands and the idea is to make a little halloween program for a client.
all it does is allow myself or who ever decides to run it, send a message to everyone connected on my LAN, its a kind of fun tool.
If you understood our line of work, you would understand why we need things like this to help keep up the spirts of the guys.
Geert GOracle dba
Top Expert 2009

Commented:
our line of work ?
i've done a load of jobs ... spirits were never a problem, especially after work ...

net send * boohoohoo, gotcha !

try that from a command box

you'll have to do
net start messenger
on all pc's to receive the messages
Geert GOracle dba
Top Expert 2009

Commented:
you would need a lot more than this little app
the sending and receiving of the messages is a work on it's own
the layout of your form is the least of your worries

how do you think you will send these messages

you need to handle the following tasks:
* build a app to enter/send/receive message --> ok, you're doing that
* register this app in some way --> easiest is a database in the network on a database server
* select who you send the message to (previous item should take care of who is online/offline)
* send the message (tcp/ip, udp, database, ...)
* receive the message (same as previous)
* keep a history of the messages (so you can get fired if your boss finds this out)

* last was just a joke, but i know 2 people who came across this (they were using msn messenger)

Author

Commented:
i tested it and it worked fine before i started to add color and font

all i am concerned at the momemnt sir is getting it working on my own pc, like I say I have that done, just need to get the color and font to work instead of keep using red, also would like to drop a blackground to cover screen and auto clear text on screen ready for next set of words.

so..  all i need really is the code tweeking you gave me to do that, the first paste i made it worked just was red and only 1 font,   can you help with that?

dont need to bother with neatness i am just going to put it into my already made gui.

Author

Commented:
any help here welcomed I check every few hours but still require help with this.
Geert GOracle dba
Top Expert 2009

Commented:
>>dont need to bother with neatness i am just going to put it into my already made gui.
i allways bother with neatness
it is the core of good programming,
it is the basics of finding matching begin/end pairs, memory leaks on sight,
  understanding flow of the code

the sample i provided is a way of selecting both items you wanted
if you need to change this, then by all means do
but ...
you need to understand the concepts behind what is happening,
you seem to be missing that

if it doesn't work in your allready made gui, then
1: you implemented it wrongly because of the lack of understanding of the concepts
2: you're allready made gui is completely different, in which case you need to post the code (just the relevant pieces, all of them) from the allready made gui for us to help change that

the solution i provided is the answer to this question you asked:
I want the user to be able to choose a color and font.

if the code of your allready made gui is not neat,
then (because this is just how i am and how i code) i will format it according to delphi guidelines
not for your convenience but because this solves a lot of otherwise hidden errors
one of the most misunderstood concepts is try finally and the hint "variable not initialized"
and with the correct formatting this can be detected on sight immediately

so the problem for this seems to be the implementation of the provided solution into your app

Author

Commented:
no,I added your code to a basic delphi form and it complied but nothing worked.
when I say my gui, it is very neat, but I dont use the options you do thats all so just leave them out, just the basic code and I can do the rest.


It still just only allows red color and bloodsuckers font, it will not alow me to select anything else.
it just need to allow a user to choose a color, choose a font, type it out and send using my code.
dont need any other buttons just the one.
So select font from drop down, choose color from dropdown and then type, when you click send, it sends that font, that color and that text.
But is it possible if you can add some code to clear the text once sent because when I send more it just writes it over the old text, so if the new text can clear the old that would be much better, this was not in the example to do but I would like to do this for my own satisfaction.

again sorry for all the questions but thats how I am learning both from here and the many mistakes i create I then resolve.
I am a Police officer during the day and a want to be delphi programmer when I leave the force in a few years, thats why I ask the many questions, as you can tell I am very new to delphi.
sorry for all the questions but thats how I am learning by my mistakes.

Author

Commented:
?
Geert GOracle dba
Top Expert 2009

Commented:
this is the implementation when using a other form:

procedure TForm4.Button1Click(Sender: TObject);
var
  aFontName: string;
  aColor: TColor;
begin
  aColor := clYellow;
  aFontName := 'Courier New';
  if GetFontColorSelection(Self, aFontName, aColor) then
  begin
    // then use aFontName, aColor

this is the implementation when using it in the the sameform:

var
  aFontName: string;
  aColor: TColor;
begin
  aColor := SelectedColor;
  aFontName := SelectedFont;
  // then use aFontName, aColor

your implementation would be:
  Canv.Font.Name   := SelectedFont;
  Canv.Font.Size   := 70;
  Canv.Font.Color  := SelectedColor;
  Canv.Brush.Style := bsclear;
  Canv.textout(100, Screen.Height div 2 - 30, (edit1.text));

Author

Commented:
aww man still not good, what is...  user select color?

can you just paste the code to get this to work, the code I pasted at the question worked fine it just needed to be able to let the user choose the color and font.
cant you just paste the code I can drop in with those changes?

thanks..
Geert GOracle dba
Top Expert 2009

Commented:
post you form, then i will show you what changes
otherwise, this will never end

Author

Commented:
i am in a worse state now then before i started :)

All i wanted to be able to do is have a use select a font, then a color, then type some text in and click go, then that text is sent to write onto the desktop in clear background.
I cant select font, cant select color, when I send text to desktop it has background sometimes even the background of the fonts folder???   and it never refeshes so your typing over old text on the next send to screen.  what a mess...


all code must be converted to function and the output needs to be showmessage(fundtionname);
Please help me if you have time friend.
sorry to be a pest.

unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;
 
type
  TForm1 = class(TForm)
    Button1: TButton;
    Edit1: TEdit;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
 
var
  Form1: TForm1;
  Canv: TCanvas;
 
 
implementation
 
 
 
{$R *.dfm}
  procedure TForm1.FormCreate(Sender: TObject);
begin
  Canv := TCanvas.Create;
  Canv.Handle := GetWindowDC(0);
end;
 
procedure TForm1.FormDestroy(Sender: TObject);
begin
  Canv.Free;
end;
procedure TForm1.button1Click(Sender: TObject);
 
begin
  Canv.Font.Name   := 'Bloodsuckers';
  Canv.Font.Size   := 70;
  Canv.Font.Color  := clRED;
  Canv.Brush.Style := bsclear;
  Canv.textout(100, Screen.Height div 2 - 30, (edit1.text));
end;
 
 
 
end.

Open in new window

Geert GOracle dba
Top Expert 2009

Commented:
why i god's name would you want to write on the Canvas of the desktop ?
it makes no sense at all ...
writing on the desktop canvas is temporary and has unknown effects
the problem is windows refreshes parts as needed.
Everything on the desktop has a window handle, this handle is told to redraw itself
when writing text on the canvas like this, it's a one time thing
your text will not stick and it will disappear from instantly to some parts disappearing
off course this does not work

you should display it in a form or in a window (a bit like a popup from msn messenger)
this stuff will not work

Author

Commented:
I dont mean to be rude sir because you have helped me alot but its my question and I am just asking for an answer to this, I am not looking for "other ways" I know what i want.
I know this works because i have done it.
It writes to the desktop fine. and then if you move your mouse over it or do anything to it then it will go, i know this already.
I am just trying to allow a font and color on select thats it..
everything else works the way I want it to.
If i can get the the text to clear upon sending the next bit of text that would be an added bonus.
Geert GOracle dba
Top Expert 2009

Commented:
you have no control over the clearing, that's just the problem
you would have to ask "windows" to redraw the whole screen
would probably cause some nice flickering

Author

Commented:
can you provide me with working code, I will have a look at this flickdering as it wouldn be a major issue

Author

Commented:
Can anyone else help me with this issue, it seems to be such a quite easy task yet I cant see a simple working example?
The code needed to perform this cant be that complicated.
To send text to desktop, select a font from 3 fonts and select a color of around 9 choices and type the text you want to send and click go?
If the text cant be auto cleared upon next send then create a black background to the screen?
Geert GOracle dba
Top Expert 2009

Commented:
anyone else ?
-> probably
a simple working example ?
-> wouldn't you suffice with working, does it really have to be simple ?
cant be that complicated ?
-> but you ask something complicated !!!

to cut it short ... try this form and see if that's what you want.
it's a little hocus pocus

about your code :
Canv.Handle := GetWindowDC(0);
and what the help says :
The GetWindowDC function retrieves the device context (DC) for the entire window, including title bar, menus, and scroll bars. A window device context permits painting anywhere in a window, because the origin of the device context is the upper-left corner of the window instead of the client area.
Remarks

GetWindowDC is intended for special painting effects within a window's nonclient area. Painting in nonclient areas of any window is not recommended.
The GetSystemMetrics function can be used to retrieve the dimensions of various parts of the nonclient area, such as the title bar, menu, and scroll bars.
After painting is complete, the ReleaseDC function must be called to release the device context. Not releasing the window device context has serious effects on painting requested by applications.

Take special note to these things which you don't do ...
>>Painting in nonclient areas of any window is not recommended
>>the ReleaseDC function must be called
>>Not releasing the window device context has serious effects on painting requested by applications

I tried to come up with a solution which actually paints in a form, but it looks like it's on the desktop.

Keep in mind that when asking for a simple solution,
the "simple" part can not allways be assured
It's like asking something simple to a beginner:
"Please move the mount everest to my backyard".
Don't sack the beginner when he asks if you it with the ice on top ...
in other words, don't ask for a "simple" solution, just ask for a solution
unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls;
 
type
  TfrmMain = class(TForm)
    Image1: TImage;
    Label1: TLabel;
    Timer1: TTimer;
    procedure Timer1Timer(Sender: TObject);
  private
    fFirstBm: TBitmap;
    fStartLeft: Integer;
    fStartTop: Integer;
    fn: Integer;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;
 
var
  frmMain: TfrmMain;
 
implementation
 
{$R *.dfm}
 
{ TfrmMain }
 
constructor TfrmMain.Create(AOwner: TComponent);
var bm: TBitmap;
  dc: HDC;
begin
  inherited Create(AOwner);
  fStartTop := 100;
  fStartLeft := 200;
  fFirstBm := TBitmap.Create;
  fFirstBm.Width := Screen.Width;
  fFirstBm.Height := Screen.Height;
  Top := fStartTop;
  Left := fStartLeft;
  Image1.Picture.Bitmap := TBitmap.Create;
  Image1.Picture.Bitmap.Width := Width;
  Image1.Picture.Bitmap.Height := Height;
  dc := GetWindowDC(0);
  try
    BitBlt(fFirstbm.Canvas.Handle, 0, 0, Width, Height, dc, 0, 0, SRCCOPY);
    BitBlt(Image1.Picture.Bitmap.Canvas.Handle, 0, 0, Width, Height, dc, fStartLeft, fStartTop, SRCCOPY);
  finally
    ReleaseDc(0, dc);
  end;
  fn := 0;
end;
 
destructor TfrmMain.Destroy;
begin
  FreeAndNil(fFirstbm);
  inherited Destroy;
end;
 
procedure TfrmMain.Timer1Timer(Sender: TObject);
begin
  case fn of
    0: label1.Font.Name := 'COURIER NEW';
    1: label1.Font.Style := [fsBold];
    2: label1.Font.Color := clGreen;
    3: label1.Caption := 'not at home';
    4: label1.Font.Size := 48;
    5: label1.Font.Name := 'Times New Roman';
  end;
  Inc(fn);
  if fn > 6 then
    close;
end;
 
end.

Open in new window

Oracle dba
Top Expert 2009
Commented:
dfm
object frmMain: TfrmMain
  Left = 391
  Top = 368
  BorderIcons = []
  BorderStyle = bsNone
  ClientHeight = 116
  ClientWidth = 501
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  FormStyle = fsStayOnTop
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object Image1: TImage
    Left = 0
    Top = 0
    Width = 501
    Height = 116
    Align = alClient
    ExplicitLeft = 128
    ExplicitTop = 64
    ExplicitWidth = 105
    ExplicitHeight = 105
  end
  object Label1: TLabel
    Left = 48
    Top = 24
    Width = 107
    Height = 39
    Caption = 'Try this'
    Color = clBtnFace
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -32
    Font.Name = 'Tahoma'
    Font.Style = []
    ParentColor = False
    ParentFont = False
    Transparent = True
  end
  object Timer1: TTimer
    Interval = 3000
    OnTimer = Timer1Timer
    Left = 240
    Top = 40
  end
end

Open in new window

Geert GOracle dba
Top Expert 2009

Commented:
Plasmax,
you were pushing all the time to get answers fast
and now ... no more responses for over 6 weeks ... ???
no longer interested ???

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial