unit
MAIN;
interface
uses Windows, SysUtils, Classes, Graphics, Forms, Controls, Menus,
StdCtrls, Dialogs, Buttons, Messages, ExtCtrls, ComCtrls, StdActns,
ActnList, ToolWin, ImgList;
type
TMainForm = class (TForm)
MainMenu1: TMainMenu;
Window1: TMenuItem;
Help1: TMenuItem;
WindowCascadeItem: TMenuItem;
WindowTileItem: TMenuItem;
WindowArrangeItem: TMenuItem;
HelpAboutItem: TMenuItem;
OpenDialog: TOpenDialog;
WindowMinimizeItem: TMenuItem;
StatusBar: TStatusBar;
ActionList1: TActionList;
FileExit1: TAction;
WindowCascade1: TWindowCascade;
WindowTileHorizontal1: TWindowTileHorizontal;
WindowArrangeAll1: TWindowArrange;
WindowMinimizeAll1: TWindowMinimizeAll;
HelpAbout1: TAction;
WindowTileVertical1: TWindowTileVertical;
WindowTileItem2: TMenuItem;
ImageList1: TImageList;
CoolBar1: TCoolBar;
ToolBar1: TToolBar;
ToolButton12: TToolButton;
ToolButton13: TToolButton;
ToolButton14: TToolButton;
ToolButton15: TToolButton;
ToolButton16: TToolButton;
ToolButton17: TToolButton;
ToolButton18: TToolButton;
ToolButton1: TToolButton;
Image1: TImage;
ToolButton2: TToolButton;
FileNew1: TAction;
ToolButton3: TToolButton;
procedure FileNew1Execute(Sender: TObject);
procedure FileOpen1Execute(Sender: TObject);
procedure HelpAbout1Execute(Sender: TObject);
procedure FileExit1Execute(Sender: TObject);
private
{ Private declarations }
FOldWndProc: TFarProc;
FNewWndProc: TFarProc;
procedure CreateMDIChild( const Name: string );
procedure ClientWndProc( var Message: TMessage);
protected
procedure DrawBG(DC: HDC); virtual ;
procedure CreateWnd; override ;
public
{ Public declarations }
end ;
var
MainForm: TMainForm;
implementation
{ $R *.dfm }
uses CHILDWIN, about;
procedure TMainForm.ClientWndProc( var Message: TMessage);
var
R: TRECT;
procedure Default;
begin
with Message do
Result : = CallWindowProc(FOldWndProc, ClientHandle, Msg, wParam, lParam);
end ;
var
PS: TPaintStruct;
begin
R : = ClientRect;
case Message.Msg of
WM_PAINT:
begin
BeginPaint(ClientHandle, PS);
try
Canvas.Lock;
try
Canvas.Handle : = PS.hdc;
try
Paint;
if ControlCount > 0 then
PaintControls(PS.hdc, Controls[ 0 ]);
finally
Canvas.Handle : = 0 ;
end ;
finally
Canvas.Unlock;
end ;
finally
EndPaint(ClientHandle, PS);
end ;
end ;
WM_ERASEBKGND:
begin
DrawBG(TWMEraseBkGnd(Message).DC);
Message.Result : = 1 ;
end ;
WM_VSCROLL, WM_HSCROLL:
begin
InvalidateRect(ClientHandle, @R, true);
Default;
end ;
WM_SIZE:
begin
InvalidateRect(ClientHandle, @R, true);
Default;
end ;
else
Default;
end ;
end ;
procedure TMainForm.CreateMDIChild( const Name: string );
var
Child: TMDIChild;
begin
{ create a new MDI child window }
Child : = TMDIChild.Create(Application);
Child.Caption : = Name;
if FileExists(Name) then Child.Memo1.Lines.LoadFromFile(Name);
end ;
procedure TMainForm.FileNew1Execute(Sender: TObject);
begin
CreateMDIChild( ' NONAME ' + IntToStr(MDIChildCount + 1 ));
end ;
procedure TMainForm.FileOpen1Execute(Sender: TObject);
begin
if OpenDialog.Execute then
CreateMDIChild(OpenDialog.FileName);
end ;
procedure TMainForm.HelpAbout1Execute(Sender: TObject);
begin
AboutBox.ShowModal;
end ;
procedure TMainForm.CreateWnd;
begin
inherited ;
FNewWndProc : = Forms.MakeObjectInstance(ClientWndProc);
FOldWndProc : = Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC));
SetWindowLong(ClientHandle, GWL_WNDPROC, Longint(FNewWndProc));
end ;
procedure TMainForm.DrawBG(DC: HDC);
var
myRect: TRect;
str: string ;
NewFont, OldFont: Integer;
FontStyle, FontItalic, FontUnderline, FontStrikeout: Integer;
begin
if Brush.Color <> clNone then
FillRect(DC, ClientRect, Brush.Handle);
SetBkMode(DC, TRANSPARENT);
SetTextColor(DC, clRed);
// Set font
FontStyle : = FW_BOLD;
FontItalic : = 1 ;
FontUnderline : = 0 ;
FontStrikeout : = 0 ;
NewFont : = CreateFont( 50 , 0 , 0 , 0 , FontStyle, FontItalic,
FontUnderline, FontStrikeout, DEFAULT_CHARSET,
OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY,
DEFAULT_PITCH, ' Arial ' );
OldFont : = SelectObject(DC, NewFont);
str : = ' GMT ' ;
myRect : = Rect(Width - 200 ,
Height - 200 ,
Width - 20 ,
Height - 20 );
DrawText(DC, PChar(str), Length(str), myRect, DT_CENTER or DT_VCENTER);
SelectObject(DC, OldFont);
DeleteObject(NewFont);
end ;
procedure TMainForm.FileExit1Execute(Sender: TObject);
begin
Close;
end ;
end .
interface
uses Windows, SysUtils, Classes, Graphics, Forms, Controls, Menus,
StdCtrls, Dialogs, Buttons, Messages, ExtCtrls, ComCtrls, StdActns,
ActnList, ToolWin, ImgList;
type
TMainForm = class (TForm)
MainMenu1: TMainMenu;
Window1: TMenuItem;
Help1: TMenuItem;
WindowCascadeItem: TMenuItem;
WindowTileItem: TMenuItem;
WindowArrangeItem: TMenuItem;
HelpAboutItem: TMenuItem;
OpenDialog: TOpenDialog;
WindowMinimizeItem: TMenuItem;
StatusBar: TStatusBar;
ActionList1: TActionList;
FileExit1: TAction;
WindowCascade1: TWindowCascade;
WindowTileHorizontal1: TWindowTileHorizontal;
WindowArrangeAll1: TWindowArrange;
WindowMinimizeAll1: TWindowMinimizeAll;
HelpAbout1: TAction;
WindowTileVertical1: TWindowTileVertical;
WindowTileItem2: TMenuItem;
ImageList1: TImageList;
CoolBar1: TCoolBar;
ToolBar1: TToolBar;
ToolButton12: TToolButton;
ToolButton13: TToolButton;
ToolButton14: TToolButton;
ToolButton15: TToolButton;
ToolButton16: TToolButton;
ToolButton17: TToolButton;
ToolButton18: TToolButton;
ToolButton1: TToolButton;
Image1: TImage;
ToolButton2: TToolButton;
FileNew1: TAction;
ToolButton3: TToolButton;
procedure FileNew1Execute(Sender: TObject);
procedure FileOpen1Execute(Sender: TObject);
procedure HelpAbout1Execute(Sender: TObject);
procedure FileExit1Execute(Sender: TObject);
private
{ Private declarations }
FOldWndProc: TFarProc;
FNewWndProc: TFarProc;
procedure CreateMDIChild( const Name: string );
procedure ClientWndProc( var Message: TMessage);
protected
procedure DrawBG(DC: HDC); virtual ;
procedure CreateWnd; override ;
public
{ Public declarations }
end ;
var
MainForm: TMainForm;
implementation
{ $R *.dfm }
uses CHILDWIN, about;
procedure TMainForm.ClientWndProc( var Message: TMessage);
var
R: TRECT;
procedure Default;
begin
with Message do
Result : = CallWindowProc(FOldWndProc, ClientHandle, Msg, wParam, lParam);
end ;
var
PS: TPaintStruct;
begin
R : = ClientRect;
case Message.Msg of
WM_PAINT:
begin
BeginPaint(ClientHandle, PS);
try
Canvas.Lock;
try
Canvas.Handle : = PS.hdc;
try
Paint;
if ControlCount > 0 then
PaintControls(PS.hdc, Controls[ 0 ]);
finally
Canvas.Handle : = 0 ;
end ;
finally
Canvas.Unlock;
end ;
finally
EndPaint(ClientHandle, PS);
end ;
end ;
WM_ERASEBKGND:
begin
DrawBG(TWMEraseBkGnd(Message).DC);
Message.Result : = 1 ;
end ;
WM_VSCROLL, WM_HSCROLL:
begin
InvalidateRect(ClientHandle, @R, true);
Default;
end ;
WM_SIZE:
begin
InvalidateRect(ClientHandle, @R, true);
Default;
end ;
else
Default;
end ;
end ;
procedure TMainForm.CreateMDIChild( const Name: string );
var
Child: TMDIChild;
begin
{ create a new MDI child window }
Child : = TMDIChild.Create(Application);
Child.Caption : = Name;
if FileExists(Name) then Child.Memo1.Lines.LoadFromFile(Name);
end ;
procedure TMainForm.FileNew1Execute(Sender: TObject);
begin
CreateMDIChild( ' NONAME ' + IntToStr(MDIChildCount + 1 ));
end ;
procedure TMainForm.FileOpen1Execute(Sender: TObject);
begin
if OpenDialog.Execute then
CreateMDIChild(OpenDialog.FileName);
end ;
procedure TMainForm.HelpAbout1Execute(Sender: TObject);
begin
AboutBox.ShowModal;
end ;
procedure TMainForm.CreateWnd;
begin
inherited ;
FNewWndProc : = Forms.MakeObjectInstance(ClientWndProc);
FOldWndProc : = Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC));
SetWindowLong(ClientHandle, GWL_WNDPROC, Longint(FNewWndProc));
end ;
procedure TMainForm.DrawBG(DC: HDC);
var
myRect: TRect;
str: string ;
NewFont, OldFont: Integer;
FontStyle, FontItalic, FontUnderline, FontStrikeout: Integer;
begin
if Brush.Color <> clNone then
FillRect(DC, ClientRect, Brush.Handle);
SetBkMode(DC, TRANSPARENT);
SetTextColor(DC, clRed);
// Set font
FontStyle : = FW_BOLD;
FontItalic : = 1 ;
FontUnderline : = 0 ;
FontStrikeout : = 0 ;
NewFont : = CreateFont( 50 , 0 , 0 , 0 , FontStyle, FontItalic,
FontUnderline, FontStrikeout, DEFAULT_CHARSET,
OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY,
DEFAULT_PITCH, ' Arial ' );
OldFont : = SelectObject(DC, NewFont);
str : = ' GMT ' ;
myRect : = Rect(Width - 200 ,
Height - 200 ,
Width - 20 ,
Height - 20 );
DrawText(DC, PChar(str), Length(str), myRect, DT_CENTER or DT_VCENTER);
SelectObject(DC, OldFont);
DeleteObject(NewFont);
end ;
procedure TMainForm.FileExit1Execute(Sender: TObject);
begin
Close;
end ;
end .