Programlama yapalım ve Öğrenelim.

URLLink Component

unit URLLink;

interface

uses

{$IFDEF WIN32} Windows, {$ELSE} WinTypes, WinProcs, {$ENDIF}

Messages, Classes, Graphics, Controls, Forms, StdCtrls, SysUtils,

ShellAPI;

type

TURLLink = class(TLabel)

private

FFocusFont, FSaveFont: TFont;

FLink: String;

FOnMouseEnter, FOnMouseLeave,

OldOnClick: TNotifyEvent;

procedure SetFocusFont(Value: TFont);

procedure ClickThroughLink(Sender: TObject);

protected

procedure CMMouseEnter(var Msg: TMessage); message CM_MouseEnter;

procedure CMMouseLeave(var Msg: TMessage); message CM_MouseLeave;

public

constructor Create(aOwner : TComponent); override;

destructor Destroy; override;

published

property FocusFont: TFont read FFocusFont write SetFocusFont;

property Link: String read FLink write FLink;

property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;

property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;

end;

procedure Register;

implementation

constructor TURLLink.Create(aOwner: TComponent);

begin

inherited Create(aOwner);

FFocusFont := TFont.Create;

FSaveFont := TFont.Create;

FSaveFont.Assign(Font);

OldOnClick := OnClick;

OnClick := ClickThroughLink;

end;

destructor TURLLink.Destroy;

begin

FSaveFont.Free;

FFocusFont.Free;

inherited Destroy;

end;

procedure TURLLink.CMMouseEnter(var Msg: TMessage);

begin

if FSaveFont <> Font then FSaveFont.Assign(Font);

Font.Assign(FFocusFont);

if Assigned(FOnMouseEnter) then OnMouseEnter(Self);

end;

procedure TURLLink.CMMouseLeave(var Msg: TMessage);

begin

Font.Assign(FSaveFont);

if Assigned(FOnMouseLeave) then OnMouseLeave(Self);

end;

procedure TURLLink.SetFocusFont(Value: TFont);

begin

FFocusFont.Assign(Value);

end;

procedure TURLLink.ClickThroughLink(Sender: TObject);

var

PC: Array[0..$FF] of Char;

begin

StrPCopy(PC, FLink);

if FLink <> '' then

ShellExecute(GetDesktopWindow, 'open', PC, nil, nil, sw_ShowNormal);

if Assigned(OldOnClick) then OnClick(Sender);

end;

procedure Register;

begin

RegisterComponents('UtilMind', [TURLLink]);

end;

end.

Delphi - .....................................

Walpaper

unit Walpaper;

interface

uses

{$IFDEF WIN32} Windows, Registry, {$ELSE} WinTypes, WinProcs, IniFiles, {$ENDIF}

Classes, Controls, SysUtils;

type

TWallPaper = class(TComponent)

private

PC: Array[0..$FF] of Char;

{$IFDEF WIN32}

Reg: TRegistry;

{$ELSE}

Reg: TIniFile;

WinIniPath: String;

{$ENDIF}

function GetWallpaper: String;

procedure SetWallpaper(Value: String);

function GetTile: Boolean;

procedure SetTile(Value: Boolean);

function GetStretch: Boolean;

procedure SetStretch(Value: Boolean);

protected

{$IFNDEF WIN32}

constructor Create(aOwner: TComponent); override;

{$ENDIF}

public

published

property Wallpaper: String read GetWallpaper write SetWallpaper;

property Tile: Boolean read GetTile write SetTile;

property Stretch: Boolean read GetStretch write SetStretch;

end;

procedure Register;

implementation

{$IFNDEF WIN32}

constructor TWallpaper.Create(aOwner: TComponent);

begin

inherited Create(aOwner);

GetWindowsDirectory(PC, $FF);

WinIniPath := StrPas(PC) + 'WIN.INI';

end;

{$ENDIF}

function TWallpaper.GetWallpaper: String;

begin

{$IFDEF WIN32}

Reg := TRegistry.Create;

Reg.RootKey := HKEY_CURRENT_USER;

Reg.OpenKey('Control Paneldesktop', False);

Result := Reg.ReadString('Wallpaper');

Reg.Free;

{$ELSE}

Reg := TIniFile.Create(WinIniPath);

Result := Reg.ReadString('Desktop', 'Wallpaper', '');

Reg.Free;

{$ENDIF}

end;

procedure TWallpaper.SetWallpaper(Value: String);

begin

if not (csDesigning in ComponentState) and

not (csLoading in ComponentState) and

not (csReading in ComponentState) then

begin

StrPCopy(PC, Value);

SystemParametersInfo(spi_SetDeskWallpaper, 0, @PC, spif_UpdateIniFile);

end;

function TWallpaper.GetTile: Boolean;

begin

{$IFDEF WIN32}

Reg := TRegistry.Create;

Reg.RootKey := HKEY_CURRENT_USER;

Reg.OpenKey('Control Paneldesktop', False);

Result := Boolean(StrToInt(Reg.ReadString('TileWallpaper')));

Reg.Free;

{$ELSE}

Reg := TIniFile.Create(WinIniPath);

Result := Reg.ReadBool('Desktop', 'TileWallpaper', False);

Reg.Free;

{$ENDIF}

end;

procedure TWallpaper.SetTile(Value: Boolean);

begin

if not (csDesigning in ComponentState) and

not (csLoading in ComponentState) and

not (csReading in ComponentState) then

begin

{$IFDEF WIN32}

Reg := TRegistry.Create;

Reg.RootKey := HKEY_CURRENT_USER;

Reg.OpenKey('Control Paneldesktop', False);

Reg.WriteString('TileWallpaper', IntToStr(Integer(Value)));

Reg.Free;

{$ELSE}

Reg := TIniFile.Create(WinIniPath);

Reg.WriteBool('Desktop', 'TileWallpaper', Value);

Reg.Free;

{$ENDIF}

SetWallpaper(Wallpaper);

end;

function TWallpaper.GetStretch: Boolean;

var

i: Integer;

begin

{$IFDEF WIN32}

Reg := TRegistry.Create;

try

Reg.RootKey := HKEY_CURRENT_USER;

Reg.OpenKey('Control Paneldesktop', False);

i := StrToInt(Reg.ReadString('WallpaperStyle'));

except

end;

Reg.Free;

{$ELSE}

Reg := TIniFile.Create(WinIniPath);

i := Reg.ReadInteger('Desktop', 'WallpaperStyle', 0);

Reg.Free;

{$ENDIF}

Result := i = 2;

end;

procedure TWallpaper.SetStretch(Value: Boolean);

var

v: Integer;

begin

if not (csDesigning in ComponentState) and

not (csLoading in ComponentState) and

not (csReading in ComponentState) then

begin

if Value then v := 2 else v := 0;

{$IFDEF WIN32}

Reg := TRegistry.Create;

Reg.RootKey := HKEY_CURRENT_USER;

Reg.OpenKey('Control Paneldesktop', False);

Reg.WriteString('WallpaperStyle', IntToStr(v));

Reg.Free;

{$ELSE}

Reg := TIniFile.Create(WinIniPath);

Reg.WriteInteger('Desktop', 'WallpaperStyle', v);

Reg.Free;

{$ENDIF}

SetWallpaper(Wallpaper);

end;

procedure Register;

begin

RegisterComponents('UtilMind', [TWallPaper]);

end;

end.

Delphi - .....................................

Wordcap

{$F+,X+}

unit Wordcap;

interface

uses

SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics,

Forms, Dialogs, Controls, {$ifndef win32} Call32NT, {$endif} DsgnIntf;

const

FWordSpacing = 3;

type

TFontKind = (fkCustom, fkSystem, fkSystemI, fkSystemB, fkSystemBI, fkAutoHeight);

TMSOfficeCaption = class;

TCompanyText = class(TPersistent)

private

{ Private declarations }

FCaption : String;

FColorActive : TColor;

FColorInactive: TColor;

FFont : TFont;

FFontKind : TFontKind;

FOwner : TMSOfficeCaption;

FVisible : Boolean;

function StoreFont : Boolean;

protected

{ Protected declarations }

procedure SetColorActive(Value: TColor);

procedure SetColorInactive(Value: TColor);

procedure SetCaption(Value: String); virtual;

procedure SetFont(Value: TFont);

procedure SetFontKind(Value: TFontKind);

procedure SetVisible(Value: Boolean);

procedure SetFontKind_NoRedraw(Value: TFontKind);

public

{ Public declarations }

constructor Create(AOwner: TMSOfficeCaption); virtual;

destructor Destroy; override;

published

{ Published declarations }

property Caption : String read FCaption write SetCaption;

property ColorActive : TColor read FColorActive write SetColorActive default clCaptionText;

property ColorInactive : TColor read FColorInactive write SetColorInactive default clInactiveCaptionText;

property Font : TFont read FFont write SetFont stored StoreFont;

property FontKind : TFontKind read FFontKind write SetFontKind;

property Visible : Boolean read FVisible write SetVisible;

end; { TCompanyText }

TAppNameText = class(TCompanyText)

end; { same as TCompanyText, just show differently in object inspector }

TCaptionText = class(TCompanyText)

protected

function GetCaption: String; virtual;

published

{ Published declarations }

property Caption : String read GetCaption write SetCaption;

end;

TGradEnabled = (geAlways, geNever, geWhenActive, geSmart);

TJustification = (jAuto, jLeft, jCenter, jRight);

TOnDrawCaption = procedure(Sender: TObject; const Canvas: TCanvas; var R: TRect) of object;

TMSOfficeCaption = class(TComponent)

private

{ Private declarations }

FAppNameText : TAppNameText;

FCaptionText : TCaptionText;

FCompanyText : TCompanyText;

FColorLeftActive : TColor;

FColorLeftInActive : TColor;

FColorRightActive : TColor;

FColorRightInActive : TColor;

FEnabled : TGradEnabled;

FHooked : Boolean;

FJustification: TJustification;

FNumColors : integer;

FSystemFont : TFont;

MyOwner : TForm;

MyOwnerHandle : THandle;

FWindowActive : Boolean;

FActiveDefined: Boolean;

FRecreating : Boolean;

FOnDrawCaption: TOnDrawCaption;

function GetVisibleButtons: TBorderIcons;

procedure ExcludeBtnRgn (var R: TRect);

procedure GetSystemFont(F : TFont);

function GetTextRect: TRect;

function GetTitleBarRect: TRect;

procedure GradientFill(DC: HDC; FBeginColor, FEndColor: TColor; R: TRect);

function MeasureText(DC: HDC; R: TRect; FText: TCompanyText): integer;

procedure NewCaptionText;

procedure PaintMenuIcon(DC: HDC; var R: TRect);

procedure PaintCaptionText(DC: HDC; var R: TRect; FText: TCompanyText; Active: Boolean);

{$ifdef win32}

procedure PaintCaptionButtons(DC: HDC; var Rect: TRect);

procedure Perform_NCPaint(var AMsg: TMessage);

procedure Perform_NCActivate(var AMsg: TMessage);

function Handle_WMSetCursor(var Msg: TWMSetCursor): Boolean;

{$endif}

procedure SetAutoFontHeight(F: TFont);

procedure SolidFill(DC: HDC; FColor: TColor; R: TRect);

{$ifndef win32}

function TrimCaptionText(Var S: String; DC:HDC; TextRect: TRect) : Boolean;

{$endif}

function WindowIsActive: Boolean;

protected

{ Protected declarations }

OldWndProc : TFarProc;

NewWndProc : Pointer;

procedure Loaded; override;

procedure SetColorLeftActive(C: TColor);

procedure SetColorLeftInActive(C: TColor);

procedure SetColorRightActive(C: TColor);

procedure SetColorRightInActive(C: TColor);

procedure SetEnabled(Val: TGradEnabled);

procedure SetJustification(Val: TJustification);

procedure SetNumColors(Val: integer);

public

{ Public declarations }

procedure HookWin;

procedure UnhookWin;

procedure HookWndProc(var AMsg: TMessage);

function HookAppWndProc(var AMsg: TMessage): Boolean;

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

procedure UpdateCaption;

function DrawMSOfficeCaption(fActive : boolean) : TRect;

published

{ Published declarations }

property AppNameText : TAppNameText read FAppNameText write FAppNameText;

property CaptionText : TCaptionText read FCaptionText write FCaptionText;

property CompanyText : TCompanyText read FCompanyText write FCompanyText;

property ColorLeftActive : TColor read FColorLeftActive write SetColorLeftActive default clBlack;

property ColorLeftInActive : TColor read FColorLeftInActive write SetColorLeftInActive default clBlack;

property ColorRightActive : TColor read FColorRightActive write SetColorRightActive default clActiveCaption;

property ColorRightInActive : TColor read FColorRightInActive write SetColorRightInActive default clInActiveCaption;

property Enabled : TGradEnabled read FEnabled write SetEnabled default geSmart;

property Justification : TJustification read FJustification write SetJustification default jAuto;

property NumColors : integer read FNumColors write SetNumColors default 64;

property OnDrawCaption: TOnDrawCaption read FOnDrawCaption write FOnDrawCaption;

end;

procedure Register;

implementation

const

WM_WordCapRecreateNotify = WM_USER + 17804;

{ A random number for an internal message used by WordCap exclusively. }

{$ifndef win32}

const

SPI_GETNONCLIENTMETRICS = 41;

SM_CXSMICON = 49;

SM_CYSMICON = 50;

type

TOS_Bits = (os16bit, os32bit);

TW32LogFont = record

lfHeight: longint;

lfWidth: longint;

lfEscapement: longint;

lfOrientation: longint;

lfWeight: longint;

lfItalic: Byte;

lfUnderline: Byte;

lfStrikeOut: Byte;

lfCharSet: Byte;

lfOutPrecision: Byte;

lfClipPrecision: Byte;

lfQuality: Byte;

lfPitchAndFamily: Byte;

lfFaceName: array[0..lf_FaceSize - 1] of Char;

end;

TNONCLIENTMETRICS = record

cbSize: longint;

iBorderWidth: longint;

iScrollWidth: longint;

iScrollHeight: longint;

iCaptionWidth: longint;

iCaptionHeight: longint;

lfCaptionFont: TW32LogFont;

iSmCaptionWidth: longint;

iSmCaptionHeight: longint;

lfSmCaptionFont: TW32LogFont;

iMenuWidth: longint;

iMenuHeight: longint;

lfMenuFont: TW32LogFont;

lfStatusFont: TW32LogFont;

lfMessageFont: TW32LogFont;

end;

TOSVERSIONINFO = record

dwOSVersionInfoSize: longint;

dwMajorVersion: longint;

dwMinorVersion: longint;

dwBuildNumber: longint;

dwPlatformId: longint;

szCSDVersion: array[1..128] of char;

end;

TW32Rect = record

left, top, right, bottom: longint;

end;

var

FOS_Bits : TOS_Bits;

NewStyleControls : Boolean;

W32SystemParametersInfo:

function(uiAction: longint; uiParam:longint; pvParam:TNonClientMetrics; fWinIni:longint; id:longint):longint;

W32GetSystemMetrics:

function(index: longint; id:longint):longint;

GetVersionEx:

function(pvParam:TOSVersionInfo; id:longint):longint;

CopyImage:

function(HImage, uType, cX, cY, flags :longint; id:longint):longint;

DrawIconEx:

function(HDC, left, top, HIcon, Width, Height, frame, FlickFreeBrush, Flags: longint; id:longint):longint;

DrawFrameControl:

function(HWND, R: TW32Rect; uType, uState: longint; id:longint): longint;

id_W32SystemParametersInfo : Longint;

id_W32GetSystemMetrics : Longint;

id_W32GetVersionEx : Longint;

id_W32CopyImage : Longint;

id_W32DrawIconEx : Longint;

id_W32DrawFrameControl : Longint;

{$endif}

constructor TCompanyText.Create(AOwner: TMSOfficeCaption);

begin

inherited Create;

FOwner := AOwner;

FColorActive := (clCaptionText);

FColorInactive := (clInactiveCaptionText);

FFont := TFont.Create;

FFontKind := fkSystem;

FFont.Assign(FOwner.FSystemFont);

FVisible := true;

FCaption := '';

end;

destructor TCompanyText.Destroy;

begin

FFont.Free;

inherited destroy;

end;

procedure TCompanyText.SetColorActive(Value: TColor);

begin

FColorActive := value;

if csDesigning in FOwner.ComponentState then FOwner.UpdateCaption;

end; { TCompanyText.SetColorActive }

procedure TCompanyText.SetColorInactive(Value: TColor);

begin

FColorInactive := value;

if csDesigning in FOwner.ComponentState then FOwner.UpdateCaption;

end; { TCompanyText.SetColorInactive }

procedure TCompanyText.SetCaption(Value: String);

begin

If FCaption = Value then exit;

FCaption := Value;

FOwner.NewCaptionText;

if csDesigning in FOwner.ComponentState then FOwner.UpdateCaption;

end; { TCompanyText.SetCaption }

procedure TCompanyText.SetFont(Value: TFont);

begin

FFont.Assign(Value);

If FFontKind = fkAutoHeight

then FOwner.SetAutoFontHeight(FFont)

else FFontKind := fkCustom;

if csDesigning in FOwner.ComponentState then FOwner.UpdateCaption;

end; { TCompanyText.SetFont }

function TCompanyText.Storefont : Boolean;

begin

result := not (FFontKind in [fkSystem, fkSystemB, fkSystemBI, fkSystemI]);

end; { StoreFont }

procedure TCompanyText.SetFontKind(Value: TFontKind);

begin

SetFontKind_noRedraw(Value);

if csDesigning in FOwner.ComponentState then FOwner.UpdateCaption;

end;

procedure TCompanyText.SetFontKind_NoRedraw(Value: TFontKind);

begin

FFontKind := Value;

case FFontKind of

fkCustom: { do nothing special };

fkSystem: FFont.Assign(FOwner.FSystemFont);

fkSystemI{Italics}: begin

FFont.Assign(FOwner.FSystemFont);

FFont.Style := FFont.Style + [fsItalic];

end;

fkSystemB{Bold}: begin

FFont.Assign(FOwner.FSystemFont);

FFont.Style := FFont.Style + [fsBold];

end;

fkSystemBI: begin

FFont.Assign(FOwner.FSystemFont);

FFont.Style := FFont.Style + [fsItalic, fsBold];

end;

fkAutoHeight: FOwner.SetAutoFontHeight(FFont);

end; { case }

end; { TCompanyText.SetFontKind_noRedraw }

procedure TCompanyText.SetVisible(Value: Boolean);

begin

If FVisible = Value then exit;

FVisible := Value;

FOwner.NewCaptionText;

if csDesigning in FOwner.ComponentState then FOwner.UpdateCaption;

end; { TCompanyText.SetVisible }

{------------------------------------------------------------------------------}

{ TCaptionText Component }

{------------------------------------------------------------------------------}

function TCaptionText.GetCaption: String;

var temp : string;

found : integer;

begin

try

if FOwner.MyOwner = nil then begin result := ''; exit; end;

temp := FOwner.MyOwner.Caption;

If FOwner.FCompanyText.Visible then

begin

found := Pos(FOwner.FCompanyText.Caption, Temp);

if found <> 0 then temp := Copy(temp, found + length(FOwner.FCompanyText.Caption), maxint);

if length(temp) > 0 then if temp[1] = ' ' then temp := Copy(temp, 2, maxint);

end;

If FOwner.FAppNameText.Visible then

begin

found := Pos(FOwner.FAppNameText.Caption, Temp);

if found <> 0 then temp := Copy(temp, found + length(FOwner.FAppNameText.Caption), maxint);

if length(temp) > 0 then if temp[1] = ' ' then temp := Copy(temp, 2, maxint);

end;

result := temp;

except

{$ifdef win32} on EAccessViolation do result := '';

{$endif}

end;

end; { TCaptionText.GetCaption }

{------------------------------------------------------------------------------}

{ TMSOfficeCaption Component }

{------------------------------------------------------------------------------}

constructor TMSOfficeCaption.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

with AOwner as TForm do MyOwner := TForm(AOwner); { My pointer to my owner form }

MyOwnerHandle := MyOwner.Handle;

FWindowActive := true; { assumption }

FActiveDefined := false;

FOnDrawCaption := NIL;

FSystemFont := TFont.Create;

try

GetSystemFont(FSystemFont);

except

{$ifdef win32} On EAccessViolation do begin

{$else} On EGPFault do begin

{$endif}

FSystemFont.Free;

FSystemFont := nil;

raise;

end;

end; { try except }

FCompanyText := TCompanyText.Create(self);

FAppNameText := TAppNameText.Create(self);

FCaptionText := TCaptionText.Create(self);

FColorLeftActive := clBlack;

FColorLeftInActive := clBlack;

FColorRightActive := clActiveCaption;

FColorRightInActive := clInActiveCaption;

FEnabled := geSmart;

FHooked := false;

FJustification := jAuto;

FNumColors := 64;

FRecreating := false;

Hookwin;

if csdesigning in ComponentState then

if not (csReadingState in MyOwner.ControlState) then

begin

{ Set default fonts unless stored user settings are being loaded }

FCompanyText.FCaption := 'Warren''s';

FAppNameText.FCaption := 'Program -';

FCaptionText.FCaption := MyOwner.Caption;

NewCaptionText;

FCaptionText.SetFontKind_noRedraw(fkSystem);

FAppNameText.SetFontkind_noRedraw(fkSystemB); { system + bold }

FCompanyText.SetFontkind_noRedraw(fkSystemBI); { system + bold + italic }

DrawMSOfficeCaption(WindowIsActive); { do the first-time draw }

end;

end; { TMSOfficeCaption.Create }

procedure TMSOfficeCaption.loaded;

begin

inherited loaded;

{ some people have reported problems with TForm's position being poScreenCenter.

this removes the problem (I believe - I've never replicated the problem so I

can't test it). }

If MyOwnerHandle <> MyOwner.Handle then

begin

UnhookWin;

HookWin;

end;

destructor TMSOfficeCaption.Destroy;

begin

UnHookWin;

{ update caption if the parent form is not being destroyed }

If not (csDestroying in MyOwner.ComponentState) then

begin

MyOwner.caption := FCaptionText.Caption;

UpdateCaption;

end;

FAppNameText.Free;

FCaptionText.Free;

FCompanyText.Free;

FSystemFont.Free;

inherited destroy; {Call default processing.}

end; { TMSOfficeCaption.Destroy }

procedure TMSOfficeCaption.HookWin;

begin

MyOwnerHandle := MyOwner.Handle;

OldWndProc := TFarProc(GetWindowLong(MyOwnerHandle, GWL_WNDPROC));

NewWndProc := MakeObjectInstance(HookWndProc);

SetWindowLong(MyOwnerHandle, GWL_WNDPROC, LongInt(NewWndProc));

If not FRecreating then Application.HookMainWindow(HookAppWndProc);

FRecreating := false;

FHooked := true;

end; { HookWin }

procedure TMSOfficeCaption.UnhookWin;

begin

If not FHooked then exit; { don't ever unhook a non-hooked window }

If not FRecreating then Application.UnhookMainWindow(HookAppWndProc);

SetWindowLong(MyOwnerHandle, GWL_WNDPROC, LongInt(OldWndProc));

if assigned(NewWndProc) then FreeObjectInstance(NewWndProc);

NewWndProc := nil;

FHooked := false;

end; { UnHookWin }

function TMSOfficeCaption.WindowIsActive: Boolean;

begin

If FActiveDefined then begin Result := FWindowActive; exit; end;

Result := (MyOwnerHandle = GetActiveWindow);

If (MyOwner.FormStyle = fsMDIChild)

then if Application <> nil

then if Application.Mainform <> nil

then if MyOwner = Application.Mainform.ActiveMDIChild

then if Application.Mainform.HandleAllocated

then if Application.Mainform.Handle = GetActiveWindow

then result := true;

end; { WindowIsActive }

{$ifdef win32}

procedure TMSOfficeCaption.Perform_NCPaint(var AMsg: TMessage);

var

R, WR : TRect;

MyRgn : HRgn;

DC : HDC;

begin

R := DrawMSOfficeCaption(WindowIsActive);

DC := GetWindowDC(MyOwnerHandle);

GetWindowRect(MyOwnerHandle, WR);

MyRgn := CreateRectRgnIndirect(WR);

try

if SelectClipRgn(DC, AMsg.wParam) = ERROR

then SelectClipRgn(DC, MyRgn);

OffsetClipRgn(DC, -WR.Left, -WR.Top);

ExcludeClipRect(DC, R.Left, R.Top, R.Right, R.Bottom);

OffsetClipRgn(DC, WR.Left, WR.Top);

GetClipRgn(DC, MyRgn);

AMsg.Result := CallWindowProc(OldWndProc,MyOwnerHandle, AMsg.Msg, MyRgn, AMsg.lParam);

finally

DeleteObject(MyRgn);

ReleaseDC(MyOwnerHandle, DC);

end;

end; { perform_NCPaint for win32 }

procedure TMSOfficeCaption.Perform_NCActivate(var AMsg: TMessage);

begin

FWindowActive := TWMNCActivate(AMsg).Active;

FActiveDefined := true;

if (not NewStyleControls)

then AMsg.Result := CallWindowProc(OldWndProc, MyOwnerHandle, AMsg.Msg, AMsg.wParam, AMsg.lParam)

else if (MyOwner.FormStyle = fsMDIChild) { cover up hassles with minimized MDI children borders and button redrawing }

then AMsg.Result := CallWindowProc(OldWndProc, MyOwnerHandle, AMsg.Msg, AMsg.wParam, AMsg.lParam);

If MyOwner.FormStyle = fsMDIForm

then if Application <> nil

then if Application.Mainform <> nil

then if Application.Mainform.ActiveMDIChild <> nil

then PostMessage(Application.Mainform.ActiveMDIChild.Handle, WM_NCACTIVATE, longint(TWMNCActivate(AMsg).Active), 0);

{ cause a nc_Paint message to occur (immediately) }

ReDrawWindow(MyOwnerHandle,nil,0,RDW_FRAME or RDW_INVALIDATE or RDW_UPDATENOW);

{ was previously... DrawMSOfficeCaption(TWMNCActivate(AMsg).Active); }

AMsg.Result := 1;

AMsg.wParam := 1; { Tell windows that we have handled the message }

end; { perform_NCActivate for win32 }

{$endif}

procedure TMSOfficeCaption.HookWndProc(var AMsg: TMessage);

begin

{$ifdef win32}

if AMsg.Msg = WM_NCPAINT then

begin Perform_NCPaint(AMsg); exit; end; { NCPaint is handled for win32 }

if AMsg.Msg = WM_NCACTIVATE then

begin Perform_NCActivate(AMsg); exit; end; { NCActivate is handled for win32 }

if AMsg.Msg = WM_SETCURSOR then

begin if Handle_WMSetCursor(TWMSetCursor(AMsg)) then exit; end; { SetCursor is handled for win32 }

{$endif}

if AMsg.Msg = WM_DESTROY then begin

{Note: WM_DESTROY is trapped here when the form itself is destroyed,

and whenever the RecreateWnd method of the form is called }

if not (csDestroying in ComponentState) then

begin

{ We must unhook the WindowProc, and then rehook it later }

FRecreating := True;

UnHookWin;

{ Notify WordCap to rehook the form. A message must be posted so that this

can be done once the form has completed the recreation process. }

PostMessage (Application.Handle, WM_WordCapRecreateNotify, 0, Longint(Self));

{ don't exit. Allow default processing to still occur }

end;

{ now handle all other calls }

AMsg.Result := CallWindowProc(OldWndProc,MyOwnerHandle, AMsg.Msg, AMsg.wParam, AMsg.lParam);

{$ifdef win32}

if AMsg.Msg = WM_SETICON then DrawMSOfficeCaption(WindowIsActive);

{$endif}

{$ifndef win32}

if AMsg.Msg = WM_NCPAINT then DrawMSOfficeCaption(WindowIsActive);

if AMsg.Msg = WM_NCACTIVATE then

begin

FWindowActive := TWMNCActivate(AMsg).Active;

FActiveDefined := true;

DrawMSOfficeCaption(TWMNCActivate(AMsg).Active);

end;

{$endif}

{$ifdef win32}

if ((AMsg.Msg = WM_DISPLAYCHANGE) or

(AMsg.Msg = WM_SysColorChange) or

(AMsg.Msg = WM_WININICHANGE) or

(AMsg.Msg = WM_SETTINGCHANGE)) then

{$else}

if AMsg.Msg = WM_WININICHANGE then

{$endIf}

begin

GetSystemFont(FSystemFont); { update systemfont }

FAppNameText.SetFontkind_noRedraw(FAppNameText.FFontkind);

FCaptionText.SetFontKind_noRedraw(FCaptionText.FFontKind);

FCompanyText.SetFontkind_noRedraw(FCompanyText.FFontkind);

UpdateCaption; {force a NC region redraw};

end;

end; { HookWndProc }

function TMSOfficeCaption.HookAppWndProc(var AMsg: TMessage): Boolean;

begin

Result := False;

if AMsg.Msg = WM_WordCapRecreateNotify then begin

if AMsg.LParam <> longint(self) then exit; { did the message come from this instance or another instance? }

HookWin; { Rehook the form }

If GetActiveWindow = MyOwnerHandle then FWindowActive := true;

UpdateCaption; {}

end;

procedure TMSOfficeCaption.UpdateCaption;

begin

SetWindowPos( MyOwnerHandle, 0, 0, 0, 0, 0,

SWP_FRAMECHANGED or SWP_DRAWFRAME or

SWP_NOZORDER or SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE);

end; { UpdateCaption }

procedure TMSOfficeCaption.GetSystemFont(F : TFont);

var

FNONCLIENTMETRICS : TNONCLIENTMETRICS;

begin

F.Handle := GetStockObject(SYSTEM_FONT);

{$ifndef win32} If (FOS_Bits = os16Bit) then exit; {$endif}

{ if OS is 32bit, get font by calling Win32 API routine }

FNONCLIENTMETRICS.cbSize := Sizeof(TNONCLIENTMETRICS);

{$ifdef win32}

if boolean(SystemParametersInfo( SPI_GETNONCLIENTMETRICS, 0,

@FNONCLIENTMETRICS, 0))

{$else}

if boolean(w32SystemParametersInfo( SPI_GETNONCLIENTMETRICS, 0,

FNONCLIENTMETRICS, 0,

id_w32SystemParametersInfo))

{$endif}

then begin

{ work now with FNonClientMetrics.lfCaptionFont }

F.Name := FNonClientMetrics.lfCaptionFont.lfFacename;

if FNonClientMetrics.lfCaptionFont.lfHeight > 0

then F.Size := FNonClientMetrics.lfCaptionFont.lfHeight

else F.Height := FNonClientMetrics.lfCaptionFont.lfHeight;

F.Style := [];

if FNonClientMetrics.lfCaptionFont.lfItalic <> 0

then F.Style := F.Style + [fsItalic];

if FNonClientMetrics.lfCaptionFont.lfWeight > FW_MEDIUM

then F.Style := F.Style + [fsBold];

F.Pitch := fpDefault;

end;

end; { procedure TMSOfficeCaption.GetSystemFont }

procedure TMSOfficeCaption.NewCaptionText;

var temp: string;

begin

{$ifdef win32} LockWindowUpdate(MyOwnerHandle); {$endif}

temp := '';

If FCompanyText.Visible then temp := temp + FCompanyText.FCaption;

If FCompanyText.Visible and (FCompanyText.Caption <> '')

and (FAppNameText.Visible or FCaptionText.Visible) then temp := temp + ' ';

If FAppNameText.Visible then temp := temp + FAppNameText.FCaption;

If FAppNameText.Visible and (FAppNameText.Caption <> '') and FCaptionText.Visible then temp := temp + ' ';

If FCaptionText.Visible then temp := temp + FCaptionText.FCaption;

MyOwner.Caption := temp;

{$ifdef win32} LockWindowUpdate(0); {$endif}

end; { TMSOfficeCaption.NewCaptionText }

function TMSOfficeCaption.GetTitleBarRect: TRect;

var BS : TFormBorderStyle;

begin

BS:= MyOwner.BorderStyle;

if csDesigning in ComponentState then BS:= bsSizeable;

{ if we have no border style, then just set the rectangle empty. }

if BS = bsNone then begin SetRectEmpty(Result); exit; end;

GetWindowRect(MyOwnerHandle, Result);

{ Convert rect from screen (absolute) to client (0 based) coordinates. }

OffsetRect(Result, -Result.Left, -Result.Top);

{ Shrink rectangle to allow for window border. We let Windows paint the border. }

{ this catches drawing MDI minimised windows caption bars in Win95 }

if IsIconic(MyOwnerHandle)

then begin

{$ifdef win32}

If NewStyleControls

then InflateRect(Result, -GetSystemMetrics(SM_CXFIXEDFRAME),

-GetSystemMetrics(SM_CYFIXEDFRAME))

else {$endif} InflateRect(Result, -GetSystemMetrics(SM_CYBORDER)-GetSystemMetrics(SM_CXDLGFRAME),

-GetSystemMetrics(SM_CYBORDER)-GetSystemMetrics(SM_CYDLGFRAME));

end

else

case BS of

{$ifdef win32} bsToolWindow, bsSingle, bsDialog:

InflateRect(Result, -GetSystemMetrics(SM_CXFIXEDFRAME),

-GetSystemMetrics(SM_CYFIXEDFRAME));

bsSizeToolWin, bsSizeable:

InflateRect(Result, -GetSystemMetrics(SM_CXSIZEFRAME),

-GetSystemMetrics(SM_CYSIZEFRAME));

{$else}

bsDialog:

InflateRect(Result, -(GetSystemMetrics(SM_CXBORDER)+GetSystemMetrics(SM_CXDLGFRAME)),

-(GetSystemMetrics(SM_CYBORDER)+GetSystemMetrics(SM_CYDLGFRAME)) );

bsSingle:

InflateRect(Result, -GetSystemMetrics(SM_CXBORDER),

-GetSystemMetrics(SM_CYBORDER));

bsSizeable:

InflateRect(Result, -GetSystemMetrics(SM_CXFRAME),

-GetSystemMetrics(SM_CYFRAME));

{$endif}

end;

{ Set the appropriate height of caption bar. }

{$ifdef win32}

if BS in [bsToolWindow, bsSizeToolWin] then

Result.Bottom := Result.Top + GetSystemMetrics(SM_CYSMCAPTION) - 1

else {$endif}

Result.Bottom := Result.Top + GetSystemMetrics(SM_CYCAPTION) - 1;

{$ifndef win32} Result.Bottom := Result.Bottom-1; {$endif}

end; { TMSOfficeCaption.GetTitleBarRect }

function TMSOfficeCaption.GetVisibleButtons: TBorderIcons;

var BS : TFormBorderStyle;

begin

Result := [];

if csDesigning in ComponentState then begin result := [biSystemMenu, biMaximize, biMinimize]; exit; end;

BS:= MyOwner.BorderStyle;

if BS = bsNone then exit;

{$ifdef win32}

if not (biSystemMenu in MyOwner.BorderIcons) then exit; { none will be visible }

if BS in [bsToolWindow, bsSizeToolWin]

then begin

Result := [biSystemMenu]; { close icon only }

exit;

end;

{$endif}

{ ? check this carefully for 16-bit accuracy ? }

if (NewStyleControls {$ifdef win32} and (biSystemMenu in MyOwner.BorderIcons) {$endif} )

then Result := [biSystemMenu]; { close icon - this is OS dependant }

{$ifdef win32}

if ((BS = bsDialog) and (biHelp in MyOwner.BorderIcons) and (biSystemMenu in MyOwner.BorderIcons))

then Result := Result + [biHelp]; { help icon }

if ((BS = bsSingle) and (biHelp in MyOwner.BorderIcons)

and (not(biMinimize in MyOwner.BorderIcons))

and (not(biMaximize in MyOwner.BorderIcons)) )

then Result := Result + [biHelp]; { help icon }

if ((BS = bsSizeable) and (biHelp in MyOwner.BorderIcons)

and (not(biMinimize in MyOwner.BorderIcons))

and (not(biMaximize in MyOwner.BorderIcons)) )

then Result := Result + [biHelp]; { help icon }

{$endif}

if BS = bsDialog then exit; { no chance of Min&Max buttons }

if NewStyleControls then

begin

if ((biMinimize in MyOwner.BorderIcons) or (biMaximize in MyOwner.BorderIcons))

then Result := Result + [biMinimize, biMaximize]; { minimise and maximise button }

end

else begin

if (biMinimize in MyOwner.BorderIcons)

then Result := Result + [biMinimize]; { minimise button }

if (biMaximize in MyOwner.BorderIcons)

then Result := Result + [biMaximize]; { maximise button }

end;

end; { TMSOfficeCaption.GetVisibleButtons }

procedure TMSOfficeCaption.ExcludeBtnRgn (var R: TRect);

var BtnWidth: integer;

BI : TBorderIcons;

begin

if ((MyOwner.BorderStyle = bsNone) and (not(csDesigning in ComponentState))) then exit;

{$ifdef win32}

if ((MyOwner.BorderStyle in [bsToolWindow, bsSizeToolWin]) and (not(csDesigning in ComponentState)))

then BtnWidth := GetSystemMetrics(SM_CXSMSIZE)

else {$endif} BtnWidth := GetSystemMetrics(SM_CXSIZE);

BI := GetVisibleButtons;

if (biSystemMenu in BI) then R.Right := R.Right - BtnWidth - 2; { close icon }

if (biMinimize in BI) then R.Right := R.Right - BtnWidth; { minimize icon }

if (biMaximize in BI) then R.Right := R.Right - BtnWidth; { maximize icon }

{$ifdef win32}

if (biHelp in BI) then R.Right := R.Right - BtnWidth - 2; { help icon }

{$endif}

if not NewStyleControls then

if ( ((biSystemMenu in MyOwner.BorderIcons) and (MyOwner.BorderStyle in [bsSingle, bsSizeable]))

or (csDesigning in ComponentState) )

then R.Left := R.Left + BtnWidth; { let windows do the system icon in win3 style }

end; { TMSOfficeCaption.ExcludeBtnRgn }

function TMSOfficeCaption.GetTextRect: TRect;

begin

result := GetTitleBarRect;

ExcludeBtnRgn(result);

If result.Right <= result.Left then {error}

result.Right := result.Left+2; { right must be greater than left- otherwise system resources get lost }

end; { GetTextRect }

{$ifndef win32}

function TMSOfficeCaption.TrimCaptionText(Var S: String; DC:HDC; TextRect: TRect): Boolean;

{ returns true if the text was altered in any way }

var

TheWidth : integer;

textlen : integer;

temp : string;

OldFont: HFont;

P: ^string;

T: String;

R: TRect;

begin

result := false; { assume no truncation of text }

R := Rect(0,0,1000,100);

if FCaptionText.FFont.Handle <> 0

then OldFont := SelectObject(DC, FCaptionText.FFont.Handle)

else OldFont := 0;

try

{------------------------------------------------------------------------}

{Truncate the window caption text, until it will fit into the captionbar.}

{------------------------------------------------------------------------}

Temp := S;

textlen := length(S);

T := S + #0;

P := @T[1];

DrawText(DC, PChar(P), -1, R, DT_LEFT or DT_VCENTER or DT_SINGLELINE or DT_CALCRECT);

TheWidth := R.Right - R.Left;

{ use this to see if the text will fit - if not, remove some chars, add "..." and try again }

{ resize or truncate the text to fit in the caption bar}

while ((TheWidth > (TextRect.right-TextRect.left)) and (TextLen > 1)) do

begin

temp:= Copy(S, 0, Textlen-1); { truncate }

AppendStr(temp, '...'); { add ... onto text }

dec(Textlen);

T := temp + #0;

P := @T[1];

DrawText(DC, PChar(P), -1, R, DT_LEFT or DT_VCENTER or DT_SINGLELINE or DT_CALCRECT);

TheWidth := R.Right - R.Left;

result := true;

end;

S := temp + ' '; { spaces for safety }

finally

{ Clean up all the drawing objects. }

if OldFont <> 0 then SelectObject(DC, OldFont);

end;

end; { TrimCaptionText }

{$endif}

{ Paint the icon for the system menu. Based on code from Brad Stowers }

procedure TMSOfficeCaption.PaintMenuIcon(DC: HDC; var R: TRect);

const

LR_COPYFROMRESOURCE = $4000; { Missing from WINDOWS.PAS! }

var

IconHandle: HIcon;

NewIconHandle: HIcon;

IconNeedsDestroying : Boolean;

IconX, IconY : integer;

{$ifndef win32}

const

IMAGE_ICON = 1;

DI_Normal = 3;

{$endif}

begin

If not NewStyleControls then exit; { a safety catch - shouldn't be needed }

Inc(R.Left, 1);

IconNeedsDestroying := false;

{ Does the form (or application) have an icon assigned to it? }

if MyOwner.Icon.Handle <> 0

then IconHandle := MyOwner.Icon.Handle

else if Application.Icon.Handle <> 0

then IconHandle := Application.Icon.Handle

else begin

IconHandle := LoadIcon(0, IDI_APPLICATION); { system defined application icon. }

IconNeedsDestroying := true;

end;

{$ifdef win32}

IconX := GetSystemMetrics(SM_CXSMICON);

If IconX = 0 then IconX := GetSystemMetrics(SM_CXSIZE);

IconY := GetSystemMetrics(SM_CYSMICON);

If IconY = 0 then IconY := GetSystemMetrics(SM_CYSIZE);

{$else}

IconX := W32GetSystemMetrics(SM_CXSMICON, id_W32GetSystemMetrics);

If IconX = 0 then IconX := W32GetSystemMetrics(SM_CXSIZE, id_W32GetSystemMetrics);

IconY := W32GetSystemMetrics(SM_CYSMICON, id_W32GetSystemMetrics);

If IconY = 0 then IconY := W32GetSystemMetrics(SM_CYSIZE, id_W32GetSystemMetrics);

{$endif}

NewIconHandle := CopyImage(IconHandle,

IMAGE_ICON, { what is it's value??? }

IconX, IconY,

LR_COPYFROMRESOURCE {$ifndef win32},id_W32CopyImage{$endif});

DrawIconEx(DC, R.Left+1, R.Top+1,

NewIconHandle,

0, 0, 0, 0, DI_NORMAL {$ifndef win32},id_W32DrawIconEx{$endif});

DestroyIcon(NewIconHandle);

If IconNeedsDestroying then DestroyIcon(IconHandle);

{$ifdef win32}

Inc(R.Left, GetSystemMetrics(SM_CXSMICON)+1);

{$else}

Inc(R.Left, W32GetSystemMetrics(SM_CXSMICON, id_W32GetSystemMetrics)+1);

{$endif}

end; { procedure TMSOfficeCaption.PaintMenuIcon }

{ based on code from Brad Stowers }

procedure TMSOfficeCaption.PaintCaptionText(DC: HDC; var R: TRect; FText: TCompanyText; Active:Boolean);

var

OldColor: TColorRef;

OldBkMode: integer;

OldFont: HFont;

P: ^string;

S:String;

RTemp: TRect;

begin

Inc(R.Left, FWordSpacing);

RTemp:= R;

if Active

then OldColor := SetTextColor(DC, ColorToRGB(FText.FColorActive))

else OldColor := SetTextColor(DC, ColorToRGB(FText.FColorInActive));

OldBkMode := SetBkMode(DC, TRANSPARENT); { paint text transparently - so gradient can show through }

{ Select in the required font for this text. }

if FText.FFont.Handle <> 0 then

OldFont := SelectObject(DC, FText.FFont.Handle)

else

OldFont := 0;

try

{ Draw the text making it left aligned, centered vertically, allowing no line breaks. }

S := FText.FCaption + #0;

P := @S[1];

DrawText(DC, PChar(P), -1, RTemp, DT_LEFT or DT_VCENTER or DT_SINGLELINE or DT_CALCRECT);

DrawText(DC, PChar(P), -1, R, DT_LEFT or DT_VCENTER or DT_SINGLELINE {$ifdef win32} or DT_END_ELLIPSIS {$endif});

R.Left := RTemp.Right;

finally

{ Clean up all the drawing objects. }

if OldFont <> 0 then

SelectObject(DC, OldFont);

SetBkMode(DC, OldBkMode);

SetTextColor(DC, OldColor);

end;

end; { procedure TMSOfficeCaption.PaintCaptionText }

{$ifdef win32}

{ Paint the min/max/help/close buttons - based on code from Brad Stowers. }

procedure TMSOfficeCaption.PaintCaptionButtons(DC: HDC; var Rect: TRect);

var

BtnWidth: integer;

Flag: UINT;

SrcRect: TRect;

Btns : TBorderIcons;

begin

SrcRect := Rect;

InflateRect(SrcRect, -2, -2);

Btns := GetVisibleButtons;

BtnWidth := GetSystemMetrics(SM_CXSIZE)-2;

{$ifdef win32}

if ((MyOwner.BorderStyle in [bsToolWindow, bsSizeToolWin])

and (not (csDesigning in ComponentState)))

then BtnWidth := GetSystemMetrics(SM_CXSMSIZE)-2;

{$endif}

SrcRect.Left := SrcRect.Right - BtnWidth;

{ Close button }

if biSystemMenu in Btns then

begin

DrawFrameControl(DC, SrcRect, DFC_CAPTION, DFCS_CAPTIONCLOSE);

OffsetRect(SrcRect, -BtnWidth-2, 0);

Dec(Rect.Right,BtnWidth+2);

end;

{ Maximize button }

if biMaximize in Btns then

begin

if IsZoomed(MyOwnerHandle)

then Flag := DFCS_CAPTIONRESTORE

else Flag := DFCS_CAPTIONMAX;

{ if it doesn't have max in style, then it shows up disabled }

if not (biMaximize in MyOwner.BorderIcons) then

Flag := Flag or DFCS_INACTIVE;

DrawFrameControl(DC, SrcRect, DFC_CAPTION, Flag);

OffsetRect(SrcRect, -BtnWidth, 0);

Dec(Rect.Right,BtnWidth);

end;

{ Minimize button }

if biMinimize in Btns then

begin

if IsIconic(MyOwnerHandle)

then Flag := DFCS_CAPTIONRESTORE

else Flag := DFCS_CAPTIONMIN;

{ if it doesn't have min in style, then it shows up disabled }

if not (biMinimize in MyOwner.BorderIcons) then

Flag := Flag or DFCS_INACTIVE;

DrawFrameControl(DC, SrcRect, DFC_CAPTION, Flag);

OffsetRect(SrcRect, -BtnWidth, 0);

Dec(Rect.Right,BtnWidth);

end;

{ Help button }

if (biHelp in Btns) then

begin

DrawFrameControl(DC, SrcRect, DFC_CAPTION, DFCS_CAPTIONHELP);

Dec(Rect.Right,BtnWidth);

end;

Dec(Rect.Right, 3);

end; { procedure TMSOfficeCaption.PaintCaptionButtons }

{$endif}

function TMSOfficeCaption.MeasureText(DC: HDC; R: TRect; FText: TCompanyText): integer;

var

OldFont: HFont;

P: ^string;

S: String;

begin

{ Select in the required font for this text. }

if FText.FFont.Handle <> 0

then OldFont := SelectObject(DC, FText.FFont.Handle)

else OldFont := 0;

try { Measure the text making it left aligned, centered vertically, allowing no line breaks. }

S := FText.FCaption + #0;

P := @S[1];

DrawText(DC, PChar(P), -1, R, DT_LEFT or DT_VCENTER or DT_SINGLELINE or DT_CALCRECT);

Result := R.Right+FWordSpacing - R.Left {-1};

finally

{ Clean up all the drawing objects. }

if OldFont <> 0 then SelectObject(DC, OldFont);

end;

end; { function TMSOfficeCaption.MeasureText }

{******************************************************************************}

{** DrawMSOfficeCaption - the main routine to draw a shaded caption bar. **}

{******************************************************************************}

function TMSOfficeCaption.DrawMSOfficeCaption(fActive : boolean) : TRect;

var

dc,OrigDC : HDC;

rcText : TRect;

rcCaption : TRect;

rgbColorLeft : TColor;

rgbColorRight : TColor;

rgbColorPlain : TColor;

OldBmp : HBitmap;

Bmp : HBitmap;

TotalTextWidth: longint;

SpaceForCompanyText : Boolean;

SpaceForAppNameText : Boolean;

NumColors : longint;

Shaded : Boolean;

BmpCanvas: TCanvas;

{$ifndef win32} CapRect : TW32Rect; {$endif}

begin {DrawMSOfficeCaption}

result := Rect(0,0,0,0); { in case somthing fails - e.g. resource allocation }

If ( (MyOwner.BorderStyle = bsNone) and

(not (csdesigning in ComponentState)) ) then exit; { no drawing to be done }

OrigDC := GetWindowDC(MyOwnerHandle);

if OrigDC = 0 then exit;

DC := CreateCompatibleDC(OrigDC);

if DC = 0 then begin ReleaseDC(MyOwnerHandle, OrigDC); exit; end;

rcText := GetTextRect;

rcCaption := GetTextRect;

{$ifdef win32}

If NewStyleControls then rcCaption := GetTitleBarRect;

{$endif}

Bmp := CreateCompatibleBitmap(OrigDC, rcCaption.Right, rcCaption.Bottom);

If Bmp = 0 then begin ReleaseDC(MyOwnerHandle, OrigDC); DeleteDC(DC); exit; end;

OldBmp := SelectObject(DC, Bmp);

try

result := rcCaption;

{--------------------------------------------------------------------------}

{ Apply Gradient fill (or single color) to all of the Caption Bar area. }

{--------------------------------------------------------------------------}

if fActive then rgbColorPlain := ColorToRGB(clActiveCaption)

else rgbColorPlain := ColorToRGB(clInActiveCaption);

if fActive then rgbColorRight := ColorToRGB(ColorRightActive)

else rgbColorRight := ColorToRGB(ColorRightInactive);

if fActive then rgbColorLeft := ColorToRGB(ColorLeftActive)

else rgbColorLeft := ColorToRGB(ColorLeftInactive);

Case FEnabled of

geAlways : Shaded := true;

geNever : Shaded := false;

geWhenActive : Shaded := fActive;

geSmart : begin

NumColors := GetDeviceCaps(DC, BITSPIXEL);

if fActive then Shaded := NumColors >= 8 else Shaded := NumColors > 8;

{ following pattern shown by MSWord95 }

end;

else Shaded := false;

end; { case of FEnabled }

{$ifdef win32}

If NewStyleControls then

begin

if Shaded

then SolidFill(dc, rgbColorRight, rcCaption)

else SolidFill(dc, rgbColorPlain, rcCaption);

end;

{$endif}

if Shaded

then GradientFill(dc, rgbColorLeft, rgbColorRight, rcText)

else SolidFill(dc, rgbColorPlain, rcText);

{--------------------------------------------------------------------------}

{ Draw the System Menu Icon. ( and window buttons ) }

{--------------------------------------------------------------------------}

if NewStyleControls then { paint system menu in Win95 style }

if ( ((biSystemMenu in MyOwner.BorderIcons) and (MyOwner.BorderStyle in [bsSingle, bsSizeable]))

or (csDesigning in ComponentState) )

then PaintMenuIcon(dc, rcText);

{$ifdef win32}

if NewStyleControls then PaintCaptionButtons(dc, rcCaption);

{$endif}

{--------------------------------------------------------------------------}

{ Fire the OnDrawCaption event. }

{--------------------------------------------------------------------------}

if assigned(FOnDrawCaption) then begin

BmpCanvas := TCanvas.Create;

try

BmpCanvas.Handle := dc;

BmpCanvas.Font.Handle := FSystemFont.Handle;

FOnDrawCaption(Self, BmpCanvas, rcText);

finally

BmpCanvas.Free;

end;

{------------------------------------------------------------------------}

{Determine if there is sufficient space for the CompanyName text and the }

{CompanyName text and the standard caption text to be all drawn onto the }

{working Bitmap (i.e. the caption). If not, is there enough room for }

{the AppName text and the standard caption? }

{------------------------------------------------------------------------}

FCaptionText.FCaption := FCaptionText.Caption; { safety - catches MDI changes }

TotalTextWidth := MeasureText(dc,rcText,FCompanyText) * ord(FCompanyText.Visible)

+ MeasureText(dc,rcText,FAppNameText) * ord(FAppNameText.Visible)

+ MeasureText(dc,rcText,FCaptionText) * ord(FCaptionText.Visible);

SpaceForCompanyText := (TotalTextWidth < (rcText.Right - rcText.Left));

if SpaceForCompanyText then

SpaceForAppNameText := true { space for company ==> space for appname }

else begin

TotalTextWidth := MeasureText(dc,rcText,FAppNameText) * ord(FAppNameText.Visible)

+ MeasureText(dc,rcText,FCaptionText) * ord(FCaptionText.Visible);

SpaceForAppNameText := (TotalTextWidth < (rcText.Right - rcText.Left));

end;

if not SpaceForAppNameText

then TotalTextWidth := MeasureText(dc,rcText,FCaptionText);

Case FJustification of

jLeft : { do nothing at all - it is already setup for this default };

jCenter : if (TotalTextWidth < rcText.right - rcText.left)

then rcText.Left := rcText.left + ((rcText.right - rcText.left - TotalTextWidth) div 2);

jRight : if (TotalTextWidth < rcText.right - rcText.left)

then rcText.Left := rcText.left + (rcText.right - rcText.left - TotalTextWidth);

jAuto : if ((not NewStyleControls) and (TotalTextWidth < rcText.right - rcText.left))

then rcText.Left := rcText.left + ((rcText.right - rcText.left - TotalTextWidth) div 2);

{ FAuto = center caption text only for old style controls/caption }

end;

{------------------------------------------------------------------------}

{ Actually draw the CompanyText, AppNameText, and CaptionText. }

{------------------------------------------------------------------------}

if (SpaceForCompanyText and (FCompanyText.FCaption <> '') and (FCompanyText.FVisible))

then PaintCaptionText(DC, rcText, FCompanyText, fActive);

if ((SpaceForAppNameText) and (FAppNameText.FCaption <> '') and (FAppNameText.FVisible))

then PaintCaptionText(DC, rcText, FAppNameText, fActive);

{Truncate the window caption text, until it will fit into the caption bar.}

{$ifndef win32} TrimCaptionText(FCaptionText.FCaption, dc, rcText); {$endif}

If FCaptionText.FVisible

then PaintCaptionText(DC, rcText, FCaptionText, fActive);

{ copy from temp DC, onto the actual window Caption }

BitBlt(OrigDC, Result.Left, Result.Top, Result.Right-Result.Left, Result.Bottom-Result.Top,

DC, Result.Left, Result.Top, SRCCOPY);

finally

{Clean up device context & free memory}{ Release the working bitmap resources }

Bmp := SelectObject(DC, OldBmp);

DeleteObject(Bmp);

DeleteDC(DC);

ReleaseDC(MyOwnerHandle, OrigDC);

end;

end; { DrawMSOfficeCaption }

{----------------------------------------------------------------------------}

{ Solid fill procedure }

{----------------------------------------------------------------------------}

procedure TMSOfficeCaption.SolidFill(DC: HDC; FColor: TColor; R: TRect);

var

Brush, OldBrush : HBrush;

begin

Brush := CreateSolidBrush(FColor);

OldBrush := SelectObject(DC, Brush);

try

PatBlt(DC, R.Left, R.Top, R.Right-R.Left, R.Bottom-R.Top, PATCOPY);

finally

{ Clean up the brush }

Brush := SelectObject(DC, OldBrush);

DeleteObject(Brush);

end;

end; { SolidFill }

{----------------------------------------------------------------------------}

{ Gradient fill procedure }

{----------------------------------------------------------------------------}

procedure TMSOfficeCaption.GradientFill(DC: HDC; FBeginColor, FEndColor: TColor; R: TRect);

var

{ Set up working variables }

BeginRGBValue : array[0..2] of Byte; { Begin RGB values }

RGBDifference : array[0..2] of integer; { Difference between begin and end }

{ RGB values }

ColorBand : TRect; { Color band rectangular coordinates }

I : Integer; { Color band index }

Red : Byte; { Color band Red value }

Green : Byte; { Color band Green value }

Blue : Byte; { Color band Blue value }

Brush, OldBrush : HBrush;

begin

{ Extract the begin RGB values }

{ Set the Red, Green and Blue colors }

BeginRGBValue[0] := GetRValue (ColorToRGB (FBeginColor));

BeginRGBValue[1] := GetGValue (ColorToRGB (FBeginColor));

BeginRGBValue[2] := GetBValue (ColorToRGB (FBeginColor));

{ Calculate the difference between begin and end RGB values }

RGBDifference[0] := GetRValue (ColorToRGB (FEndColor)) - BeginRGBValue[0];

RGBDifference[1] := GetGValue (ColorToRGB (FEndColor)) - BeginRGBValue[1];

RGBDifference[2] := GetBValue (ColorToRGB (FEndColor)) - BeginRGBValue[2];

{ Calculate the color band's top and bottom coordinates }

{ for Left To Right fills }

begin

ColorBand.Top := R.Top;

ColorBand.Bottom := R.Bottom;

end;

{ Perform the fill }

for I := 0 to FNumColors-1 do

begin { iterate through the color bands }

{ Calculate the color band's left and right coordinates }

ColorBand.Left := R.Left+ MulDiv (I , R.Right-R.Left, FNumColors);

ColorBand.Right := R.Left+ MulDiv (I + 1, R.Right-R.Left, FNumColors);

{ Calculate the color band's color }

if FNumColors > 1 then

begin

Red := BeginRGBValue[0] + MulDiv (I, RGBDifference[0], FNumColors - 1);

Green := BeginRGBValue[1] + MulDiv (I, RGBDifference[1], FNumColors - 1);

Blue := BeginRGBValue[2] + MulDiv (I, RGBDifference[2], FNumColors - 1);

end

else

{ Set to the Begin Color if set to only one color }

begin

Red := BeginRGBValue[0];

Green := BeginRGBValue[1];

Blue := BeginRGBValue[2];

end;

{ Create a brush with the appropriate color for this band }

Brush := CreateSolidBrush(RGB(Red,Green,Blue));

{ Select that brush into the temporary DC. }

OldBrush := SelectObject(DC, Brush);

try

{ Fill the rectangle using the selected brush -- PatBlt is faster than FillRect }

PatBlt(DC, ColorBand.Left, ColorBand.Top, ColorBand.Right-ColorBand.Left, ColorBand.Bottom-ColorBand.Top, PATCOPY);

finally

{ Clean up the brush }

SelectObject(DC, OldBrush);

DeleteObject(Brush);

end;

end; { iterate through the color bands }

end; { GradientFill }

procedure TMSOfficeCaption.SetAutoFontHeight(F : TFont);

var FTextHeight : longint;

FSysTextHeight : longint;

FTextMetrics : TTextMetric;

FSysTextMetrics : TTextMetric;

WrkBMP : TBitmap; { A Bitmap giving us access to the caption bar canvas }

begin

{------------------------------------------------------------------------}

{ Create the working bitmap and set its width and height. }

{------------------------------------------------------------------------}

WrkBmp := TBitmap.Create;

try

WrkBmp.Width := 10;

WrkBmp.Height := 10;

WrkBMP.Canvas.Font.Assign(F);

GetTextMetrics(WrkBmp.Canvas.Handle, FTextMetrics);

WrkBMP.Canvas.Font.Assign(FSystemFont);

GetTextMetrics(WrkBmp.Canvas.Handle, FSysTextMetrics);

FTextHeight := FTextMetrics.tmHeight - FTextMetrics.tmInternalLeading;

FSysTextHeight := FSysTextMetrics.tmHeight - FSysTextMetrics.tmInternalLeading;

F.Height:= F.Height + FTextHeight - FSysTextHeight;

{ test out the new font for accuracy }

WrkBMP.Canvas.Font.Assign(F);

GetTextMetrics(WrkBmp.Canvas.Handle, FTextMetrics);

FTextHeight := FTextMetrics.tmHeight - FTextMetrics.tmInternalLeading;

If (FTextHeight > FSysTextHeight)

then F.Height:= F.Height + FTextHeight - FSysTextHeight;

{ this test allows for some fonts that can't be scaled properly - they must show smaller rather than larger }

finally Wrkbmp.Free;

end; { try finally }

end; { SetAutoFontHeight }

procedure TMSOfficeCaption.SetColorLeftActive(C: TColor);

begin

If FColorLeftActive <> C

then begin

FColorLeftActive := C;

If csDesigning in ComponentState then UpdateCaption;

end;

procedure TMSOfficeCaption.SetColorLeftInActive(C: TColor);

begin

If FColorLeftInActive <> C

then begin

FColorLeftInActive := C;

If csDesigning in ComponentState then UpdateCaption;

end;

procedure TMSOfficeCaption.SetColorRightActive(C: TColor);

begin

If FColorRightActive <> C

then begin

FColorRightActive := C;

If csDesigning in ComponentState then UpdateCaption;

end;

procedure TMSOfficeCaption.SetColorRightInActive(C: TColor);

begin

If FColorRightInActive <> C

then begin

FColorRightInActive := C;

If csDesigning in ComponentState then UpdateCaption;

end;

procedure TMSOfficeCaption.SetEnabled(Val: TGradEnabled);

begin

If Val <> FEnabled then

begin

FEnabled := Val;

If csDesigning in ComponentState then UpdateCaption;

end;

end; { SetEnabled }

procedure TMSOfficeCaption.SetJustification(Val: TJustification);

begin

If Val <> FJustification then

begin

FJustification := Val;

If csDesigning in ComponentState then UpdateCaption;

end;

procedure TMSOfficeCaption.SetNumColors(Val: integer);

begin

If ((Val > 0) and (Val <= 256))

then begin

If Val <> FNumColors then

begin

FNumColors := Val;

If csDesigning in ComponentState then UpdateCaption;

end;

exit;

end;

if Val <= 0

then begin

If csdesigning in ComponentState then

MessageDlg('The number of colors must be at least 1', mtError, [mbOK], 0);

exit;

end;

if Val > 256

then begin

FNumColors := 256;

If csDesigning in ComponentState then UpdateCaption;

If csdesigning in ComponentState then

MessageDlg('The highest number of gradient colors possible is 256', mtError, [mbOK], 0);

end;

end; { SetNumColors }

{$ifdef win32}

function TMSOfficeCaption.Handle_WMSetCursor(var Msg: TWMSetCursor): Boolean;

{returns true if we handled the message }

begin

{ Tell Windows we handled the message }

Msg.Result := 1;

{ Load and display the correct cursor for the border area being hit }

case Msg.HitTest of

HTTOP,

HTBOTTOM: SetCursor(LoadCursor(0, MakeIntResource(IDC_SIZENS)));

HTLEFT,

HTRIGHT: SetCursor(LoadCursor(0, MakeIntResource(IDC_SIZEWE)));

HTTOPRIGHT,

HTBOTTOMLEFT: SetCursor(LoadCursor(0, MakeIntResource(IDC_SIZENESW)));

HTTOPLEFT,

HTBOTTOMRIGHT: SetCursor(LoadCursor(0, MakeIntResource(IDC_SIZENWSE)));

else

{ Wasn't anything we cared about, so tell Windows we didn't handle it. }

Msg.Result := 0;

inherited;

end;

result := (Msg.Result = 1);

end;

{$endif}

procedure Register;

begin

RegisterComponents('Freeware', [TMSOfficeCaption]);

RegisterPropertyEditor(TypeInfo(TCompanyText), nil, '', TClassProperty);

end;

{$ifndef win32}

procedure Set_NewStyleControls;

var win32Ver : TOSVersionInfo;

begin

NewStyleControls := false; { assumption }

Win32Ver.dwOSVersionInfoSize := sizeof(TOSVersionInfo);

If boolean(GetVersionEx(Win32Ver, id_W32GetVersionEx)) then

NewStyleControls := Win32Ver.dwMajorVersion >= 4;

end; { Set_NewStyleControls }

initialization

{ set up the Win32 API function access for a 16 bit app on a 32 bit OS }

@GetVersionEx:=@Call32;

@W32SystemParametersInfo:=@Call32;

@W32GetSystemMetrics:=@Call32;

@CopyImage := @Call32;

@DrawIconEx := @Call32;

@DrawFrameControl := @Call32;

id_W32GetVersionEx:=Declare32('GetVersionEx', 'kernel32', 'p');

id_W32SystemParametersInfo:=Declare32('SystemParametersInfo', 'user32', 'iipi');

{Check if everything went well. Call32NTError=false means no errors at all}

if Call32NTError then begin

NewStyleControls := false; { a safe assumption }

FOS_Bits := os16bit; { one or more 32 bit functions failed - so it's probably a 16bit OS }

end else begin

Set_NewStyleControls;

FOS_Bits := os32bit; { all 32 bit functions worked - so it's definitely a 32bit OS }

end;

{ Icon routines not available on Win32s - so test separately }

id_W32GetSystemMetrics:=Declare32('GetSystemMetrics', 'user32', 'i');

id_W32CopyImage:=Declare32('CopyImage', 'user32', 'iiiii');

id_W32DrawIconEx:=Declare32('DrawIconEx', 'user32', 'iiiiiiiii');

id_W32DrawFrameControl:=Declare32('DrawFrameControl', 'user32', 'wpii');

NewStyleControls := NewStyleControls and not Call32NTError;

{$endif}

end.

Delphi - .....................................

XBaloon Component

unit XBaloon;

interface

uses

{$IFDEF WIN32} Windows, {$ELSE} WinTypes, WinProcs, {$ENDIF}

SysUtils, Messages, Classes, Graphics, Controls, Forms;

{$IFDEF WIN32}

{$R XBALOON.R32}

{$ELSE}

{$R XBALOON.R16}

{$ENDIF}

type

TPShape = (sRoundRect, sRectangle);

TTextAlign = (taCenter, taLeft, taRight);

TBaloonAlign = (alRight, alLeft);

TBaloonWindow = class(TCustomControl)

private

Tail, TailLeft: TBitmap;

Underground: TBitmap;

procedure DrawTransparentBitmap(ahdc: HDC;

xStart, yStart, x1,y1,x2,y2: Word);

procedure Show(var Rect: TRect; x, y: Integer; Text: String; Shape: TPShape;

TextAlign: TTextAlign; DivChar: Char);

procedure WMMouseMove(var Msg: TMessage); message wm_MouseMove;

{$IFDEF WIN32}

procedure WMMouseDown(var Msg: TMessage); message wm_LButtonDown;

{$ENDIF}

protected

procedure CreateParams(var Params: TCreateParams); override;

procedure Paint; override;

public

Align: TBaloonAlign;

Showing: Boolean;

HideIfMouseMove: Boolean;

{$IFDEF WIN32}

HideIfMouseClick: Boolean;

{$ENDIF}

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

procedure Activate(Point: TPoint; Text: String; Shape: TPShape;

TextAlign: TTextAlign; DivChar: Char); virtual;

procedure Deactivate;

end;

TXBaloon = class(TComponent)

private

FAlign: TBaloonAlign;

FColor: TColor;

FFont: TFont;

FDivisionChar: Char;

FHideIfMouseMove: Boolean;

{$IFDEF WIN32}

FHideIfMouseClick: Boolean;

{$ENDIF}

FShape: TPShape;

FTextAlign: TTextAlign;

Baloon: TBaloonWindow;

LastX, LastY: Integer;

protected

public

constructor Create(aOwner: TComponent); override;

destructor Destroy; override;

procedure Show(Point: TPoint; Text: String);

procedure Hide;

function IsShowing: Boolean;

function GetX: Integer;

function GetY: Integer;

published

property Align: TBaloonAlign read FAlign write FAlign;

property Color: TColor read FColor write FColor;

property Font: TFont read FFont write FFont;

property DivisionChar: Char read FDivisionChar write FDivisionChar;

property HideIfMouseMove: Boolean read FHideIfMouseMove write FHideIfMouseMove;

{$IFDEF WIN32}

property HideIfMouseClick: Boolean read FHideIfMouseClick write FHideIfMouseClick;

{$ENDIF}

property Shape: TPShape read FShape write FShape;

property TextAlign: TTextAlign read FTextAlign write FTextAlign;

end;

procedure Register;

implementation

procedure TBaloonWindow.DrawTransparentBitmap(ahdc: HDC;

xStart, yStart, x1,y1,x2,y2: Word);

var

TransparentColor: TColor;

cColor : TColorRef;

bmAndBack,

bmAndObject,

bmAndMem,

bmSave,

bmBackOld,

bmObjectOld,

bmMemOld,

bmSaveOld : HBitmap;

hdcMem,

hdcBack,

hdcObject,

hdcTemp,

hdcSave : HDC;

ptSize : TPoint;

begin

{ set the transparent to black }

TransparentColor := clYellow;

TransparentColor := TransparentColor or $02000000;

hdcTemp := CreateCompatibleDC (ahdc);

if Align = alRight then

SelectObject(hdcTemp, Tail.Handle) { select the bitmap }

else

SelectObject(hdcTemp, TailLeft.Handle);

{ convert bitmap dimensions from device to logical points }

ptSize.x := x2-x1;

ptSize.y := y2-y1;

DPToLP (hdcTemp, ptSize, 1); { convert from device logical points }

{ create some DCs to hold temporary data }

hdcBack := CreateCompatibleDC(ahdc);

hdcObject := CreateCompatibleDC(ahdc);

hdcMem := CreateCompatibleDC(ahdc);

hdcSave := CreateCompatibleDC(ahdc);

{ create a bitmap for each DC }

{ monochrome DC }

bmAndBack := CreateBitmap (ptSize.x, ptSize.y, 1, 1, nil);

bmAndObject := CreateBitmap (ptSize.x, ptSize.y, 1, 1, nil);

bmAndMem := CreateCompatibleBitmap (ahdc, ptSize.x, ptSize.y);

bmSave := CreateCompatibleBitmap (ahdc, ptSize.x, ptSize.y);

{ each DC must select a bitmap object to store pixel data }

bmBackOld := SelectObject (hdcBack, bmAndBack);

bmObjectOld := SelectObject (hdcObject, bmAndObject);

bmMemOld := SelectObject (hdcMem, bmAndMem);

bmSaveOld := SelectObject (hdcSave, bmSave);

{ set proper mapping mode }

SetMapMode (hdcTemp, GetMapMode (ahdc));

{ save the bitmap sent here, because it will be overwritten }

BitBlt (hdcSave, 0, 0, ptSize.x, ptSize.y, hdcTemp, x1, y1, SRCCOPY);

{ set the background color of the source DC to the color.

contained in the parts of the bitmap that should be transparent }

cColor := SetBkColor (hdcTemp, TransparentColor);

{ create the object mask for the bitmap by performing a BitBlt()

from the source bitmap to a monochrome bitmap }

BitBlt (hdcObject, 0, 0, ptSize.x, ptSize.y, hdcTemp, x1, y1, SRCCOPY);

{ set the background color of the source DC back to the original color }

SetBkColor (hdcTemp, cColor);

{ create the inverse of the object mask }

BitBlt (hdcBack, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, NOTSRCCOPY);

{ copy the background of the main DC to the destination }

BitBlt (hdcMem, 0, 0, ptSize.x, ptSize.y, ahdc, xStart, yStart, SRCCOPY);

{ mask out the places where the bitmap will be placed }

BitBlt (hdcMem, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, SRCAND);

{ mask out the transparent colored pixels on the bitmap }

BitBlt (hdcTemp, x1, y1, ptSize.x, ptSize.y, hdcBack, 0, 0, SRCAND);

{ XOR the bitmap with the background on the destination DC }

BitBlt (hdcMem, 0, 0, ptSize.x, ptSize.y, hdcTemp, x1, y1, SRCPAINT);

{ copy the destination to the screen }

BitBlt (ahdc, xStart, yStart, ptSize.x, ptSize.y, hdcMem, 0, 0, SRCCOPY);

{ place the original bitmap back into the bitmap sent here }

BitBlt (hdcTemp, x1, y1, ptSize.x, ptSize.y, hdcSave, 0, 0, SRCCOPY);

{ delete the memory bitmaps }

DeleteObject (SelectObject (hdcBack, bmBackOld));

DeleteObject (SelectObject (hdcObject, bmObjectOld));

DeleteObject (SelectObject (hdcMem, bmMemOld));

DeleteObject (SelectObject (hdcSave, bmSaveOld));

{ delete the memory DCs }

DeleteDC (hdcMem);

DeleteDC (hdcBack);

DeleteDC (hdcObject);

DeleteDC (hdcSave);

DeleteDC (hdcTemp);

end;

{ TBaloonWindow }

constructor TBaloonWindow.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

HideIfMouseMove := TXBaloon(AOwner).HideIfMouseMove;

{$IFDEF WIN32}

HideIfMouseClick := TXBaloon(AOwner).HideIfMouseClick;

{$ENDIF}

Tail := TBitmap.Create;

Tail.Handle := LoadBitmap(hInstance, 'TAIL');

TailLeft := TBitmap.Create;

TailLeft.Handle := LoadBitmap(hInstance, 'TAILLEFT');

Underground := TBitmap.Create;

end;

destructor TBaloonWindow.Destroy;

begin

Underground.Free;

TailLeft.Free;

Tail.Free;

inherited Destroy;

end;

procedure TBaloonWindow.CreateParams(var Params: TCreateParams);

begin

inherited CreateParams(Params);

{$IFDEF WIN32}

with Params do

begin

Style := WS_POPUP;

WindowClass.Style := WindowClass.Style or CS_SAVEBITS;

if NewStyleControls then ExStyle := WS_EX_TOOLWINDOW;

end;

{$ELSE}

with Params do

begin

if HideIfMouseMove then Style := WS_POPUP

else Style := WS_POPUP or WS_DISABLED;

WindowClass.Style := WindowClass.Style or CS_SAVEBITS;

end;

{$ENDIF}

end;

procedure TBaloonWindow.Show(var Rect: TRect; x, y: Integer; Text: String; Shape: TPShape;

TextAlign: TTextAlign; DivChar: Char);

var

Wid, RectBeg, Pix, MirFill, MaxPlus, TextO: Integer;

q, i: Integer;

MaxWidth, FontHeight: Integer;

SL: TStringList;

h: Integer;

DC: hDC;

begin

if Length(Text) <> 0 then

begin

if Align = alRight then

begin

MirFill := 12;

RectBeg := 10;

MaxPlus := 21;

TextO := 15;

Pix := 3;

end

else

begin

RectBeg := 2;

MaxPlus := 13;

TextO := 8;

end;

SL := TStringList.Create;

with Underground.Canvas do

begin

q := 1;

for i := 1 to Length(Text) do

if Text[i] = '@' then

begin

SL.Add(Copy(Text, q, i - q));

q := i + 1;

end;

SL.Add(Copy(Text, q, i));

MaxWidth := 0;

FontHeight := 0;

for i := 0 to SL.Count - 1 do

begin

FontHeight := FontHeight + TextHeight(SL[i]);

h := TextWidth(SL[i]);

if MaxWidth < h then

MaxWidth := h;

end;

Underground.Width := MaxWidth + 23;

Underground.Height := y - (y - FontHeight - 2) + 18;

if Align = alLeft then

begin

Wid := Underground.Width;

dec(x, Wid);

MirFill := Wid - 12;

Pix := Wid - 4;

dec(Wid, 15);

end

else Wid := 0;

DC := GetDC(0);

BitBlt(Underground.Canvas.Handle, 0, 0, Underground.Width, Underground.Height, DC,

x, y - FontHeight - 2, SrcCopy);

ReleaseDC(0, DC);

Brush.Color := clBlack;

if Shape = sRoundRect then

RoundRect(RectBeg + 2, 2,

MaxWidth + MaxPlus + 2, FontHeight + 5, 15, 15)

else

Rectangle(RectBeg + 2, 2,

MaxWidth + MaxPlus + 2, FontHeight + 5);

Brush.Color := Color;

if Shape = sRoundRect then

RoundRect(RectBeg, 0,

MaxWidth + MaxPlus, FontHeight + 3, 15, 15)

else

Rectangle(RectBeg, 0,

MaxWidth + MaxPlus, FontHeight + 3);

DrawTransparentBitmap(Underground.Canvas.Handle,

Wid, FontHeight - 2, 0, 0, 15, 21);

FloodFill(MirFill, FontHeight - 3, clBlack, fsBorder);

Pixels[Pix, FontHeight + 13] := Color;

Pixels[Pix, FontHeight + 14] := Color;

Pixels[Pix + 1, FontHeight + 15] := Color;

h := 1;

for i := 0 to SL.Count - 1 do

begin

if TextAlign = taLeft then

TextOut(TextO, h, SL[i])

else

begin

q := TextWidth(SL[i]);

if TextAlign = taCenter then

begin

q := MaxWidth div 2 - q div 2;

TextOut(q + TextO, h, SL[i])

end

else

TextOut(MaxWidth - q + TextO, h, SL[i]);

end;

inc(h, TextHeight(SL[i]));

end;

SL.Free;

with Rect do

begin

left := x;

top := y - FontHeight - 2;

right := x + MaxWidth + 23;

bottom := y + 18;

end;

procedure TBaloonWindow.WMMouseMove(var Msg: TMessage);

begin

{$IFDEF WIN32}

if HideIfMouseMove then {$ENDIF}

Deactivate;

end;

{$IFDEF WIN32}

procedure TBaloonWindow.WMMouseDown(var Msg: TMessage);

begin

if HideIfMouseClick then Deactivate;

end;

{$ENDIF}

procedure TBaloonWindow.Paint;

begin

Canvas.Draw(0, 0, Underground);

end;

procedure TBaloonWindow.Deactivate;

begin

Showing := False;

DestroyHandle;

end;

procedure TBaloonWindow.Activate(Point: TPoint; Text: String; Shape: TPShape;

TextAlign: TTextAlign;

DivChar: Char);

var

Rect: TRect;

begin

if Showing then DestroyHandle;

Show(Rect, Point.x, Point.y - 15, Text, Shape, TextAlign, DivChar);

BoundsRect := Rect;

SetWindowPos(Handle, HWND_TOPMOST, Rect.Left, Rect.Top, 0,

0, SWP_SHOWWINDOW or SWP_NOACTIVATE or SWP_NOSIZE);

Showing := True;

end;

{ TXBaloon }

constructor TXBaloon.Create(aOwner: TComponent);

begin

inherited Create(aOwner);

FDivisionChar := '@';

FFont := TFont.Create;

FFont.Name := 'MS Sans Serif';

FFont.Size := 8;

FColor := clWindow;

FHideIfMouseMove := True;

end;

destructor TXBaloon.Destroy;

begin

if Baloon <> nil then Hide;

FFont.Free;

inherited Destroy;

end;

procedure TXBaloon.Show(Point: TPoint; Text: String);

begin

if Text <> '' then

begin

if Baloon <> nil then Hide;

Baloon := TBaloonWindow.Create(Self);

Baloon.Underground.Canvas.Font.Assign(Font);

Baloon.Color := FColor;

LastX := Point.x;

LastY := Point.y;

Baloon.Align := Align;

Baloon.Activate(Point, Text, FShape, FTextAlign, FDivisionChar);

end;

procedure TXBaloon.Hide;

begin

if Baloon <> nil then

Baloon.Deactivate;

end;

function TXBaloon.IsShowing: Boolean;

begin

if Baloon <> nil then

Result := Baloon.Showing

else

Result := False;

end;

function TXBaloon.GetX: Integer;

begin

if IsShowing then Result := LastX

else Result := -1;

end;

function TXBaloon.GetY: Integer;

begin

if IsShowing then Result := LastY

else Result := -1;

end;

{ -------- }

procedure Register;

begin

RegisterComponents('Yusuf', [TXBaloon]);

end;

end.

Delphi - .....................................