- Se quitan unidades que sobran.

- Se traducen botones al castellano.

git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.TMSSoftware@12 ccf39c52-e665-a648-be6a-52d81bcb5567
This commit is contained in:
David Arranz 2009-03-02 19:25:57 +00:00
parent c491ee6970
commit 25b0ff104d
41 changed files with 48 additions and 14006 deletions

View File

@ -1,668 +0,0 @@
{***************************************************************************}
{ TAdvGroupBox component }
{ for Delphi & C++Builder }
{ }
{ written by TMS Software }
{ copyright © 2007 - 2008 }
{ Email : info@tmssoftware.com }
{ Web : http://www.tmssoftware.com }
{ }
{ The source code is given as is. The author is not responsible }
{ for any possible damage done due to the use of this code. }
{ The component can be freely used in any application. The complete }
{ source code remains property of the author and may not be distributed, }
{ published, given or sold in any form as such. No parts of the source }
{ code can be included in any other component or application without }
{ written authorization of the author. }
{***************************************************************************}
unit AdvGroupBox;
{$I TMSDEFS.INC}
interface
uses
Classes, Windows, Forms, Dialogs, Controls, Graphics, Messages, ExtCtrls,
SysUtils, Math, StdCtrls, ImgList;
const
MAJ_VER = 1; // Major version nr.
MIN_VER = 0; // Minor version nr.
REL_VER = 0; // Release nr.
BLD_VER = 1; // Build nr.
// version history
// v1.0.0.0 : first release
// v1.0.0.1 : fixed issue for XP theming
type
TCaptionPosition = (cpTopLeft, cpTopRight, cpTopCenter, cpBottomLeft, cpBottomRight, cpBottomCenter);
TBorderStyle = (bsNone, bsSingle, bsDouble);
TWinCtrl = class(TWinControl)
public
procedure PaintCtrls(DC: HDC; First: TControl);
end;
TAdvCustomGroupBox = class(TCustomGroupBox)
private
FTransparent: Boolean;
FBorderColor: TColor;
FImageIndex: Integer;
FImages: TCustomImageList;
FBorderStyle: TBorderStyle;
FCaptionPosition: TCaptionPosition;
FRoundEdges: Boolean;
Procedure WMEraseBkGnd( Var msg: TWMEraseBkGnd ); message WM_ERASEBKGND;
procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
procedure SetTransparent(const Value: Boolean);
procedure SetBorderColor(const Value: TColor);
procedure SetImageIndex(const Value: Integer);
procedure SetImages(const Value: TCustomImageList);
function GetVersion: string;
procedure SetVersion(const Value: string);
procedure SetBorderStyle(const Value: TBorderStyle);
procedure SetCaptionPosition(const Value: TCaptionPosition);
procedure SetRoundEdges(const Value: Boolean);
protected
procedure Loaded; override;
procedure Paint; override;
procedure Notification(AComponent: TComponent; AOperation: TOperation); override;
procedure AdjustClientRect(var Rect: TRect); override;
procedure CreateParams(var Params: TCreateParams); override;
function GetCaptionHeight: Integer;
function GetCaptionRect: TRect;
function GetBorderWidth: Integer;
function GetBorderRect: TRect;
property CaptionPosition: TCaptionPosition read FCaptionPosition write SetCaptionPosition default cpTopLeft;
property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
property Transparent: Boolean read FTransparent write SetTransparent default true;
property BorderColor: TColor read FBorderColor write SetBorderColor default clSilver;
property Images: TCustomImageList read FImages write SetImages;
property ImageIndex: Integer read FImageIndex write SetImageIndex default -1;
property Version: string read GetVersion write SetVersion stored false;
property RoundEdges: Boolean read FRoundEdges write SetRoundEdges default False;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetVersionNr: integer;
end;
TAdvGroupBox = class(TAdvCustomGroupBox)
published
property BorderColor;
property BorderStyle;
property CaptionPosition;
property Images;
property ImageIndex;
property Transparent;
property RoundEdges;
property Version;
property Align;
property Anchors;
property BiDiMode;
property Caption;
property Color;
property Constraints;
property Ctl3D default False;
property DockSite;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Font;
{$IFDEF DELPHI7_LVL}
property ParentBackground default True;
{$ENDIF}
property ParentBiDiMode;
property ParentColor;
property ParentCtl3D default False;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property TabOrder;
property TabStop;
property Visible;
property OnClick;
property OnContextPopup;
property OnDblClick;
property OnDragDrop;
property OnDockDrop;
property OnDockOver;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnGetSiteInfo;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnStartDock;
property OnStartDrag;
property OnUnDock;
end;
implementation
//------------------------------------------------------------------------------
{TWinCtrl}
procedure TWinCtrl.PaintCtrls(DC: HDC; First: TControl);
begin
PaintControls(DC, First);
end;
//------------------------------------------------------------------------------
{ TAdvCustomGroupBox }
constructor TAdvCustomGroupBox.Create(AOwner: TComponent);
begin
inherited;
ControlStyle := ControlStyle - [csOpaque];
FTransparent := True;
FImages := nil;
FImageIndex := -1;
FBorderStyle := bsSingle;
FCaptionPosition := cpTopLeft;
FRoundEdges := false;
// Ctl3D := false;
// ParentCtl3D := false;
FBorderColor := clSilver;
end;
//------------------------------------------------------------------------------
procedure TAdvCustomGroupBox.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams( params );
//params.ExStyle := params.ExStyle or WS_EX_TRANSPARENT;
end;
//------------------------------------------------------------------------------
destructor TAdvCustomGroupBox.Destroy;
begin
inherited;
end;
//------------------------------------------------------------------------------
procedure TAdvCustomGroupBox.Loaded;
begin
inherited;
end;
//------------------------------------------------------------------------------
procedure TAdvCustomGroupBox.Notification(AComponent: TComponent;
AOperation: TOperation);
begin
inherited;
if not (csDestroying in ComponentState) and (AOperation = opRemove) then
begin
if (AComponent = Images) then
begin
Images := nil;
end;
end;
end;
//------------------------------------------------------------------------------
procedure TAdvCustomGroupBox.AdjustClientRect(var Rect: TRect);
var
R: TRect;
begin
R := Rect;
inherited AdjustClientRect(Rect);
Rect := R;
if CaptionPosition in [cpTopLeft, cpTopCenter, cpTopRight] then
begin
Inc(Rect.Top, Max(GetBorderWidth,GetCaptionHeight));
Rect := Classes.Rect(Rect.Left + GetBorderWidth, Rect.Top, Rect.Right -GetBorderWidth, Rect.Bottom-GetBorderWidth);
end
else if CaptionPosition in [cpBottomLeft, cpBottomCenter, cpBottomRight] then
begin
Dec(Rect.Bottom, Max(GetBorderWidth,GetCaptionHeight));
Rect := Classes.Rect(Rect.Left + GetBorderWidth, Rect.Top + GetBorderWidth, Rect.Right -GetBorderWidth, Rect.Bottom);
end;
InflateRect(Rect, -1, -1);
end;
//------------------------------------------------------------------------------
procedure TAdvCustomGroupBox.Paint;
var
R, CapR: TRect;
i, rt: Integer;
P: TPoint;
bmp: TBitmap;
begin
if Transparent then
begin
i := SaveDC(Canvas.Handle);
p := ClientOrigin;
Windows.ScreenToClient(Parent.Handle, p);
p.x := -p.x;
p.y := -p.y;
MoveWindowOrg(Canvas.Handle, p.x, p.y);
SendMessage(Parent.Handle, WM_ERASEBKGND, Canvas.Handle, 0);
// transparency ?
SendMessage(Parent.Handle, WM_PAINT, Canvas.Handle, 0);
if (Parent is TWinCtrl) then
begin
(Parent as TWinCtrl).PaintCtrls(Canvas.Handle, nil);
end;
RestoreDC(Canvas.Handle, i);
end;
R := ClientRect;
CapR := GetCaptionRect;
bmp := TBitmap.Create;
bmp.Height := (CapR.Bottom - CapR.Top);
bmp.Width := (CapR.Right - CapR.Left) + 2;
i := CapR.Left;
rt := 6;
//--- Draw Image
if Assigned(Images) and (ImageIndex >= 0) then
begin
Images.Draw(Canvas, CapR.Left, CapR.Top, ImageIndex, Enabled);
i := CapR.Left + Images.Width + 3;
end;
Canvas.Brush.Style := bsClear;
//--- Draw Caption
if (Caption <> '') then
begin
Canvas.Font.Assign(Self.Font);
R := Rect(i, CapR.Top, CapR.Right, CapR.Bottom);
DrawText(Canvas.Handle,PChar(Caption),Length(Caption), R, DT_SINGLELINE or DT_LEFT or DT_VCENTER);
end;
bmp.Canvas.CopyRect(Rect(0, 0, bmp.Width, bmp.Height), Canvas, Rect(CapR.Left-1, CapR.Top, CapR.Right+1, CapR.Bottom));
R := GetBorderRect;
//--- Draw Borders
case BorderStyle of
bsSingle:
begin
(*
if Ctl3D then
begin
Canvas.Brush.Style := bsClear;
Canvas.Pen.Color := clWhite;
R.Left := R.Left + 1;
R.Top := R.Top + 1;
if FRoundEdges then
Canvas.RoundRect(R.Left, R.Top, R.Right, R.Bottom, rt, rt)
else
Canvas.Rectangle(R);
Canvas.Pen.Color := clGray;
R.Bottom := R.Bottom -1;
R.Right := R.Right - 1;
R.Left := R.Left - 1;
R.Top := R.Top - 1;
if FRoundEdges then
Canvas.RoundRect(R.Left, R.Top, R.Right, R.Bottom, rt, rt)
else
Canvas.Rectangle(R);
end
else
*)
begin
Canvas.Brush.Style := bsClear;
Canvas.Pen.Color := BorderColor;
if FRoundEdges then
Canvas.RoundRect(R.Left, R.Top, R.Right, R.Bottom, rt, rt)
else
Canvas.Rectangle(R);
end;
end;
bsDouble:
begin
if Ctl3D then
begin
Canvas.Brush.Style := bsClear;
Canvas.Pen.Color := clWhite;
R.Left := R.Left + 1;
R.Top := R.Top + 1;
if FRoundEdges then
Canvas.RoundRect(R.Left, R.Top, R.Right, R.Bottom, rt, rt)
else
Canvas.Rectangle(R);
Canvas.Pen.Color := clGray;
R.Bottom := R.Bottom -1;
R.Right := R.Right - 1;
R.Left := R.Left - 1;
R.Top := R.Top - 1;
if FRoundEdges then
Canvas.RoundRect(R.Left, R.Top, R.Right, R.Bottom, rt, rt)
else
Canvas.Rectangle(R);
R.Bottom := R.Bottom +1;
R.Right := R.Right + 1;
R := Rect(R.Left+2, R.Top+2, R.Right-2, R.Bottom-2);
Canvas.Pen.Color := clWhite;
R.Left := R.Left + 1;
R.Top := R.Top + 1;
if FRoundEdges then
Canvas.RoundRect(R.Left, R.Top, R.Right, R.Bottom, rt, rt)
else
Canvas.Rectangle(R);
Canvas.Pen.Color := clGray;
R.Bottom := R.Bottom -1;
R.Right := R.Right - 1;
R.Left := R.Left - 1;
R.Top := R.Top - 1;
if FRoundEdges then
Canvas.RoundRect(R.Left, R.Top, R.Right, R.Bottom, rt, rt)
else
Canvas.Rectangle(R);
end
else
begin
Canvas.Brush.Style := bsClear;
Canvas.Pen.Color := BorderColor;
if FRoundEdges then
Canvas.RoundRect(R.Left, R.Top, R.Right, R.Bottom, rt, rt)
else
Canvas.Rectangle(R);
R := Rect(R.Left+2, R.Top+2, R.Right-2, R.Bottom-2);
if FRoundEdges then
Canvas.RoundRect(R.Left, R.Top, R.Right, R.Bottom, rt, rt)
else
Canvas.Rectangle(R);
end;
end;
end;
if ((Caption <> '') or (Assigned(Images) and (ImageIndex >= 0))) then
begin
Canvas.CopyRect(Rect(CapR.Left-1, CapR.Top, CapR.Right+1, CapR.Bottom), bmp.Canvas, Rect(0, 0, bmp.Width, bmp.Height));
end;
bmp.Free;
end;
//------------------------------------------------------------------------------
procedure TAdvCustomGroupBox.SetBorderColor(const Value: TColor);
begin
if (FBorderColor <> Value) then
begin
FBorderColor := Value;
Invalidate;
end;
end;
//------------------------------------------------------------------------------
procedure TAdvCustomGroupBox.SetImageIndex(const Value: Integer);
begin
if (FImageIndex <> Value) then
begin
FImageIndex := Value;
Invalidate;
Realign;
end;
end;
//------------------------------------------------------------------------------
procedure TAdvCustomGroupBox.SetImages(const Value: TCustomImageList);
begin
if (FImages <> Value) then
begin
FImages := Value;
if not Assigned(FImages) then
begin
ImageIndex := -1;
end;
Invalidate;
Realign;
end;
end;
//------------------------------------------------------------------------------
procedure TAdvCustomGroupBox.SetTransparent(const Value: Boolean);
begin
if (FTransparent <> Value) then
begin
FTransparent := Value;
Invalidate;
end;
end;
//------------------------------------------------------------------------------
procedure TAdvCustomGroupBox.WMEraseBkGnd(var msg: TWMEraseBkGnd);
begin
inherited;
//SetBkMode( msg.DC, TRANSPARENT );
//msg.result := 1;
end;
//------------------------------------------------------------------------------
function TAdvCustomGroupBox.GetVersion: string;
var
vn: Integer;
begin
vn := GetVersionNr;
Result := IntToStr(Hi(Hiword(vn)))+'.'+IntToStr(Lo(Hiword(vn)))+'.'+IntToStr(Hi(Loword(vn)))+'.'+IntToStr(Lo(Loword(vn)));
end;
//------------------------------------------------------------------------------
function TAdvCustomGroupBox.GetVersionNr: integer;
begin
Result := MakeLong(MakeWord(BLD_VER,REL_VER),MakeWord(MIN_VER,MAJ_VER));
end;
//------------------------------------------------------------------------------
procedure TAdvCustomGroupBox.SetVersion(const Value: string);
begin
end;
//------------------------------------------------------------------------------
function TAdvCustomGroupBox.GetCaptionHeight: Integer;
var
R: TRect;
begin
R := GetCaptionRect;
Result := Max(GetBorderWidth, R.Bottom - R.Top);
end;
//------------------------------------------------------------------------------
function TAdvCustomGroupBox.GetBorderWidth: Integer;
begin
Result := 0;
case BorderStyle of
bsNone: Result := 1;
bsSingle:
begin
Result := 1;
if Ctl3D then
Result := Result + 1;
end;
bsDouble:
begin
Result := 2;
if Ctl3D then
Result := Result + 2;
end;
end;
end;
//------------------------------------------------------------------------------
function TAdvCustomGroupBox.GetBorderRect: TRect;
begin
Result := ClientRect;
if CaptionPosition in [cpTopLeft, cpTopCenter, cpTopRight] then
begin
Result.Top := Result.Top + (GetCaptionHeight div 2);
end
else if CaptionPosition in [cpBottomLeft, cpBottomCenter, cpBottomRight] then
begin
if ((Caption <> '') or (Assigned(Images) and (ImageIndex >= 0))) then
begin
Result.Bottom := Result.Bottom - (GetCaptionHeight div 2);
if (BorderStyle = bsDouble) then
Result.Bottom := Result.Bottom + 1;
end;
end;
end;
//------------------------------------------------------------------------------
function TAdvCustomGroupBox.GetCaptionRect: TRect;
var
ImgH, ImgW, CapH, CapW, sp, st, w, h: Integer;
R: TRect;
begin
Result := Rect(0, 0, 0, 0);
ImgH := 0;
ImgW := 0;
CapH := 0;
CapW := 0;
st := 8;
sp := 0;
if (Caption <> '') then
begin
Canvas.Font.Assign(Self.Font);
R := Rect(0, 0, 1000, 100);
DrawText(Canvas.Handle,PChar(Caption),Length(Caption), R, DT_CALCRECT or DT_LEFT or DT_SINGLELINE);
CapH := R.Bottom - R.Top;
CapW := R.Right - R.Left;
end;
if Assigned(Images) and (ImageIndex >= 0) then
begin
ImgH := Images.Height;
ImgW := Images.Width;
end;
if (CapW > 0) and (ImgW > 0) then
begin
sp := 3;
end;
w := ImgW + sp + CapW;
h := Max(ImgH, CapH) + 2;
case CaptionPosition of
cpTopLeft:
begin
Result.Left := st;
Result.Right := Result.Left + w;
Result.Bottom := Result.Top + h;
end;
cpTopRight:
begin
Result.Right := Width - st;
Result.Left := Result.Right - w;
Result.Bottom := Result.Top + h;
end;
cpTopCenter:
begin
Result.Left := (Width - w) div 2;
Result.Right := Result.Left + w;
Result.Bottom := Result.Top + h;
end;
cpBottomLeft:
begin
Result.Left := st;
Result.Right := Result.Left + w;
Result.Top := Height - h;
Result.Bottom := Result.Top + h;
end;
cpBottomRight:
begin
Result.Right := Width - st;
Result.Left := Result.Right - w;
Result.Top := Height - h;
Result.Bottom := Result.Top + h;
end;
cpBottomCenter:
begin
Result.Left := (Width - w) div 2;
Result.Right := Result.Left + w;
Result.Top := Height - h;
Result.Bottom := Result.Top + h;
end;
end;
end;
//------------------------------------------------------------------------------
procedure TAdvCustomGroupBox.CMCtl3DChanged(var Message: TMessage);
begin
inherited;
end;
//------------------------------------------------------------------------------
procedure TAdvCustomGroupBox.SetBorderStyle(const Value: TBorderStyle);
begin
if (FBorderStyle <> Value) then
begin
FBorderStyle := Value;
Invalidate;
Realign;
end;
end;
//------------------------------------------------------------------------------
procedure TAdvCustomGroupBox.SetCaptionPosition(
const Value: TCaptionPosition);
begin
if (FCaptionPosition <> Value) then
begin
FCaptionPosition := Value;
Invalidate;
Realign;
end;
end;
//------------------------------------------------------------------------------
procedure TAdvCustomGroupBox.SetRoundEdges(const Value: Boolean);
begin
if (FRoundEdges <> Value) then
begin
FRoundEdges := Value;
Invalidate;
end;
end;
//------------------------------------------------------------------------------
{$IFDEF FREEWARE}
{$I TRIAL.INC}
{$ENDIF}
end.

File diff suppressed because it is too large Load Diff

View File

@ -1,48 +0,0 @@
 <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
<PropertyGroup>
<ProjectGuid>{79C894D4-A16D-4924-81DC-BB8F72238C44}</ProjectGuid>
</PropertyGroup>
<ItemGroup>
<Projects Include="TaskDialogPkgD2009R.dproj">
<Dependencies/>
</Projects>
<Projects Include="TaskDialogPkgD2009D.dproj">
<Dependencies/>
</Projects>
</ItemGroup>
<ProjectExtensions>
<Borland.Personality>Default.Personality.12</Borland.Personality>
<Borland.ProjectType/>
<BorlandProject>
<Default.Personality/>
</BorlandProject>
</ProjectExtensions>
<Target Name="TaskDialogPkgD2009R">
<MSBuild Projects="TaskDialogPkgD2009R.dproj"/>
</Target>
<Target Name="TaskDialogPkgD2009R:Clean">
<MSBuild Targets="Clean" Projects="TaskDialogPkgD2009R.dproj"/>
</Target>
<Target Name="TaskDialogPkgD2009R:Make">
<MSBuild Targets="Make" Projects="TaskDialogPkgD2009R.dproj"/>
</Target>
<Target Name="TaskDialogPkgD2009D">
<MSBuild Projects="TaskDialogPkgD2009D.dproj"/>
</Target>
<Target Name="TaskDialogPkgD2009D:Clean">
<MSBuild Targets="Clean" Projects="TaskDialogPkgD2009D.dproj"/>
</Target>
<Target Name="TaskDialogPkgD2009D:Make">
<MSBuild Targets="Make" Projects="TaskDialogPkgD2009D.dproj"/>
</Target>
<Target Name="Build">
<CallTarget Targets="TaskDialogPkgD2009R;TaskDialogPkgD2009D"/>
</Target>
<Target Name="Clean">
<CallTarget Targets="TaskDialogPkgD2009R:Clean;TaskDialogPkgD2009D:Clean"/>
</Target>
<Target Name="Make">
<CallTarget Targets="TaskDialogPkgD2009R:Make;TaskDialogPkgD2009D:Make"/>
</Target>
<Import Project="$(BDS)\Bin\CodeGear.Group.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Group.Targets')"/>
</Project>

View File

@ -0,0 +1,21 @@
unit SpanishContst;
interface
resourcestring
SSpanishMsgDlgOK = 'OK';
SSpanishMsgDlgYes = '&Si';
SSpanishMsgDlgNo = '&No';
SSpanishMsgDlgCancel = 'Cancelar';
SSpanishMsgDlgAbort = '&Abortar';
SSpanishMsgDlgRetry = '&Reintentar';
SSpanishMsgDlgWarning = 'Aviso';
SSpanishMsgDlgError = 'Error';
SSpanishMsgDlgInformation = 'Información';
SSpanishMsgDlgConfirm = 'Confirmación';
implementation
end.

View File

@ -549,6 +549,9 @@ procedure Register;
implementation
uses
SpanishContst;
{$I HTMLENGO.PAS}
const
@ -4772,18 +4775,18 @@ end;
initialization
//cbOK, cbYes, cbNo, cbCancel, cbRetry, cbClose);
ButtonCaptions[cbOK] := @SMsgDlgOK;
ButtonCaptions[cbYes] := @SMsgDlgYes;
ButtonCaptions[cbNo] := @SMsgDlgNo;
ButtonCaptions[cbCancel] := @SMsgDlgCancel;
ButtonCaptions[cbRetry] := @SMsgDlgRetry;
ButtonCaptions[cbClose] := @SMsgDlgAbort;
ButtonCaptions[cbOK] := @SSpanishMsgDlgOK;
ButtonCaptions[cbYes] := @SSpanishMsgDlgYes;
ButtonCaptions[cbNo] := @SSpanishMsgDlgNo;
ButtonCaptions[cbCancel] := @SSpanishMsgDlgCancel;
ButtonCaptions[cbRetry] := @SSpanishMsgDlgRetry;
ButtonCaptions[cbClose] := @SSpanishMsgDlgAbort;
Captions[tiBlank] := nil;
Captions[tiWarning] := @SMsgDlgWarning;
Captions[tiQuestion] := @SMsgDlgConfirm;
Captions[tiError] := @SMsgDlgError;
Captions[tiShield] := @SMsgDlgInformation;
Captions[tiWarning] := @SSpanishMsgDlgWarning;
Captions[tiQuestion] := @SSpanishMsgDlgConfirm;
Captions[tiError] := @SSpanishMsgDlgError;
Captions[tiShield] := @SSpanishMsgDlgInformation;
{$IFDEF FREEWARE}

View File

@ -1,300 +0,0 @@
{***************************************************************************}
{ TTaskDialogEx component }
{ for Delphi & C++Builder }
{ }
{ written by TMS Software }
{ copyright © 2007 - 2008 }
{ Email : info@tmssoftware.com }
{ Web : http://www.tmssoftware.com }
{ }
{ The source code is given as is. The author is not responsible }
{ for any possible damage done due to the use of this code. }
{ The component can be freely used in any application. The complete }
{ source code remains property of the author and may not be distributed, }
{ published, given or sold in any form as such. No parts of the source }
{ code can be included in any other component or application without }
{ written authorization of the author. }
{***************************************************************************}
unit TaskDialogEx;
{$I TMSDEFS.INC}
interface
uses
Classes, Windows, Messages, Forms, Dialogs, SysUtils, StdCtrls, Graphics, Consts, Math,
ExtCtrls, Controls, TaskDialog, AdvGlowButton, AdvOfficeButtons;
type
TButtonCreatedEvent = procedure(Sender: TObject; Button: TAdvGlowButton) of object;
TAdvTaskDialogEx = class(TAdvTaskDialog)
private
FOnButtonCreated: TButtonCreatedEvent;
FAppearance: TGlowButtonAppearance;
protected
function CreateRadioButton(AOwner: TComponent): TWinControl; override;
procedure SetRadioButtonState(Btn: TWinControl; Checked: boolean); override;
procedure SetRadioButtonCaption(Btn: TWinControl; Value: string); override;
function CreateButton(AOwner: TComponent): TWinControl; override;
procedure InitRadioButton(AOwner: TForm; Btn: TWinControl; btnIndex: Integer; OnClickEvent : TNotifyEvent); override;
procedure SetButtonCaption(aButton: TWinControl; Value: TCaption); override;
procedure SetButtonCancel(aButton: TWinControl; Value: Boolean); override;
procedure SetButtonDefault(aButton: TWinControl; Value: Boolean); override;
procedure SetButtonModalResult(aButton: TWinControl; Value: Integer); override;
function GetButtonModalResult(aButton: TWinControl): Integer; override;
public
property Appearance: TGlowButtonAppearance read FAppearance write FAppearance;
property OnButtonCreated:TButtonCreatedEvent read FOnButtonCreated write FOnButtonCreated;
end;
TAdvInputTaskDialogEx = class(TAdvInputTaskDialog)
private
FOnButtonCreated: TButtonCreatedEvent;
FAppearance: TGlowButtonAppearance;
protected
function CreateRadioButton(AOwner: TComponent): TWinControl; override;
procedure SetRadioButtonState(Btn: TWinControl; Checked: boolean); override;
procedure SetRadioButtonCaption(Btn: TWinControl; Value: string); override;
function CreateButton(AOwner: TComponent): TWinControl; override;
procedure InitRadioButton(AOwner: TForm; Btn: TWinControl; btnIndex: Integer; OnClickEvent : TNotifyEvent); override;
procedure SetButtonCaption(aButton: TWinControl; Value: TCaption); override;
procedure SetButtonCancel(aButton: TWinControl; Value: Boolean); override;
procedure SetButtonDefault(aButton: TWinControl; Value: Boolean); override;
procedure SetButtonModalResult(aButton: TWinControl; Value: Integer); override;
function GetButtonModalResult(aButton: TWinControl): Integer; override;
public
property Appearance: TGlowButtonAppearance read FAppearance write FAppearance;
property OnButtonCreated:TButtonCreatedEvent read FOnButtonCreated write FOnButtonCreated;
end;
procedure Register;
implementation
//------------------------------------------------------------------------------
procedure Register;
begin
RegisterComponents('TMS',[TAdvTaskDialogEx]);
end;
//------------------------------------------------------------------------------
{ TAdvTaskDialogEx }
function TAdvTaskDialogEx.CreateButton(AOwner: TComponent): TWinControl;
begin
Result := TAdvGlowButton.Create(AOwner);
if Assigned(FAppearance) then
(Result as TAdvGlowButton).Appearance := FAppearance;
(Result as TAdvGlowButton).TabStop := true;
if Assigned(FOnButtonCreated) then
FOnButtonCreated(Self,(Result as TAdvGlowButton));
end;
//------------------------------------------------------------------------------
function TAdvTaskDialogEx.CreateRadioButton(AOwner: TComponent): TWinControl;
begin
Result := TAdvOfficeRadioButton.Create(AOwner);
end;
//------------------------------------------------------------------------------
function TAdvTaskDialogEx.GetButtonModalResult(
aButton: TWinControl): Integer;
begin
Result := mrNone;
if not Assigned(aButton) or not (aButton is TAdvGlowButton) then
Exit;
Result := TAdvGlowButton(aButton).ModalResult;
end;
//------------------------------------------------------------------------------
procedure TAdvTaskDialogEx.SetButtonCancel(aButton: TWinControl;
Value: Boolean);
begin
if not Assigned(aButton) or not (aButton is TAdvGlowButton) then
Exit;
TAdvGlowButton(aButton).Cancel := Value;
end;
//------------------------------------------------------------------------------
procedure TAdvTaskDialogEx.SetButtonCaption(aButton: TWinControl;
Value: TCaption);
begin
if not Assigned(aButton) or not (aButton is TAdvGlowButton) then
Exit;
TAdvGlowButton(aButton).Caption := Value;
end;
//------------------------------------------------------------------------------
procedure TAdvTaskDialogEx.SetButtonDefault(aButton: TWinControl;
Value: Boolean);
begin
if not Assigned(aButton) or not (aButton is TAdvGlowButton) then
Exit;
TAdvGlowButton(aButton).Default := Value;
end;
//------------------------------------------------------------------------------
procedure TAdvTaskDialogEx.SetButtonModalResult(aButton: TWinControl;
Value: Integer);
begin
if not Assigned(aButton) or not (aButton is TAdvGlowButton) then
Exit;
TAdvGlowButton(aButton).ModalResult := Value;
end;
//------------------------------------------------------------------------------
procedure TAdvTaskDialogEx.SetRadioButtonCaption(Btn: TWinControl;
Value: string);
begin
TAdvOfficeRadioButton(Btn).Caption := Value;
end;
//------------------------------------------------------------------------------
procedure TAdvTaskDialogEx.SetRadioButtonState(Btn: TWinControl;
Checked: boolean);
begin
TAdvOfficeRadioButton(Btn).Checked := Checked;
end;
//------------------------------------------------------------------------------
procedure TAdvTaskDialogEx.InitRadioButton(AOwner: TForm; Btn: TWinControl; btnIndex: Integer; OnClickEvent : TNotifyEvent);
begin
with TRadioButton(Btn) do
begin
Name := 'Radio' + inttostr(btnIndex);
Parent := AOwner;
Font.Name := AOwner.Canvas.Font.Name;
Font.Size := 8;
BiDiMode := AOwner.BiDiMode;
OnClick := OnClickEvent;
{
BoundsRect := TextRect;
Left := FHorzParaMargin + FHorzMargin; //ALeft + FHorzMargin;
Top := Y;
Width := Self.Width - Left - 4;
GetTextSize(Canvas, Caption, k, l);
w := Max(w, Left + k + FHorzMargin + 20);
}
end;
end;
{ TAdvInputTaskDialogEx }
//------------------------------------------------------------------------------
function TAdvInputTaskDialogEx.CreateButton(AOwner: TComponent): TWinControl;
begin
Result := TAdvGlowButton.Create(AOwner);
if Assigned(FAppearance) then
(Result as TAdvGlowButton).Appearance := FAppearance;
(Result as TAdvGlowButton).TabStop := true;
if Assigned(FOnButtonCreated) then
FOnButtonCreated(Self,(Result as TAdvGlowButton));
end;
function TAdvInputTaskDialogEx.CreateRadioButton(
AOwner: TComponent): TWinControl;
begin
Result := TAdvOfficeRadioButton.Create(AOwner);
end;
function TAdvInputTaskDialogEx.GetButtonModalResult(
aButton: TWinControl): Integer;
begin
Result := mrNone;
if not Assigned(aButton) or not (aButton is TAdvGlowButton) then
Exit;
Result := TAdvGlowButton(aButton).ModalResult;
end;
procedure TAdvInputTaskDialogEx.SetButtonCancel(aButton: TWinControl;
Value: Boolean);
begin
if not Assigned(aButton) or not (aButton is TAdvGlowButton) then
Exit;
TAdvGlowButton(aButton).Cancel := Value;
end;
procedure TAdvInputTaskDialogEx.SetButtonCaption(aButton: TWinControl;
Value: TCaption);
begin
if not Assigned(aButton) or not (aButton is TAdvGlowButton) then
Exit;
TAdvGlowButton(aButton).Caption := Value;
end;
procedure TAdvInputTaskDialogEx.SetButtonDefault(aButton: TWinControl;
Value: Boolean);
begin
if not Assigned(aButton) or not (aButton is TAdvGlowButton) then
Exit;
TAdvGlowButton(aButton).Default := Value;
end;
procedure TAdvInputTaskDialogEx.SetButtonModalResult(aButton: TWinControl;
Value: Integer);
begin
if not Assigned(aButton) or not (aButton is TAdvGlowButton) then
Exit;
TAdvGlowButton(aButton).ModalResult := Value;
end;
procedure TAdvInputTaskDialogEx.SetRadioButtonCaption(Btn: TWinControl;
Value: string);
begin
TAdvOfficeRadioButton(Btn).Caption := Value;
end;
procedure TAdvInputTaskDialogEx.SetRadioButtonState(Btn: TWinControl;
Checked: boolean);
begin
TAdvOfficeRadioButton(Btn).Checked := Checked;
end;
procedure TAdvInputTaskDialogEx.InitRadioButton(AOwner: TForm; Btn: TWinControl; btnIndex: Integer; OnClickEvent : TNotifyEvent);
begin
with TRadioButton(Btn) do
begin
Name := 'Radio' + inttostr(btnIndex);
Parent := AOwner;
Font.Name := AOwner.Canvas.Font.Name;
Font.Size := 8;
BiDiMode := AOwner.BiDiMode;
OnClick := OnClickEvent;
{
BoundsRect := TextRect;
Left := FHorzParaMargin + FHorzMargin; //ALeft + FHorzMargin;
Top := Y;
Width := Self.Width - Left - 4;
GetTextSize(Canvas, Caption, k, l);
w := Max(w, Left + k + FHorzMargin + 20);
}
end;
end;
end.

View File

@ -1,4 +1,4 @@
package TaskDialogPkgD2009D;
package TaskDialogPkg;
{$R *.res}
{$ALIGN 8}
@ -28,12 +28,13 @@ package TaskDialogPkgD2009D;
requires
rtl,
vcl,
designide,
dbrtl,
vcldb;
designide;
contains
TaskDialogRegDE in 'TaskDialogRegDE.pas',
TaskDialogEx in 'TaskDialogEx.pas';
SpanishContst in 'SpanishContst.pas',
TaskDialog in 'TaskDialog.pas',
TaskDialogDE in 'TaskDialogDE.pas',
picturecontainer in 'picturecontainer.pas';
end.

View File

@ -1,7 +1,7 @@
 <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
<PropertyGroup>
<ProjectGuid>{322e4f51-9fd5-43be-8659-42e8edcc60b1}</ProjectGuid>
<MainSource>TaskDialogPkgD2009D.dpk</MainSource>
<MainSource>TaskDialogPkg.dpk</MainSource>
<Configuration Condition=" '$(Configuration)' == '' ">Release</Configuration>
<Platform Condition=" '$(Platform)' == '' ">AnyCPU</Platform>
<DCC_DCCCompiler>DCC32</DCC_DCCCompiler>
@ -13,8 +13,7 @@
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="'$(Base)'!=''">
<DCC_UnitSearchPath>..\Lib\D12;$(DCC_UnitSearchPath)</DCC_UnitSearchPath>
<DCC_DependencyCheckOutputName>..\Lib\D12\TaskDialogPkgD2009D.bpl</DCC_DependencyCheckOutputName>
<DCC_DependencyCheckOutputName>..\Lib\D12\TaskDialogPkg.bpl</DCC_DependencyCheckOutputName>
<DCC_ImageBase>00400000</DCC_ImageBase>
<DesignOnlyPackage>false</DesignOnlyPackage>
<DCC_BplOutput>..\Lib\D12</DCC_BplOutput>
@ -66,23 +65,24 @@
<VersionInfoKeys Name="Comments"/>
</VersionInfoKeys>
<Source>
<Source Name="MainSource">TaskDialogPkgD2009D.dpk</Source>
<Source Name="MainSource">TaskDialogPkg.dpk</Source>
</Source>
</Delphi.Personality>
</BorlandProject>
<ProjectFileVersion>12</ProjectFileVersion>
</ProjectExtensions>
<ItemGroup>
<DelphiCompile Include="TaskDialogPkgD2009D.dpk">
<DelphiCompile Include="TaskDialogPkg.dpk">
<MainSource>MainSource</MainSource>
</DelphiCompile>
<DCCReference Include="rtl.dcp"/>
<DCCReference Include="vcl.dcp"/>
<DCCReference Include="designide.dcp"/>
<DCCReference Include="dbrtl.dcp"/>
<DCCReference Include="vcldb.dcp"/>
<DCCReference Include="TaskDialogRegDE.pas"/>
<DCCReference Include="TaskDialogEx.pas"/>
<DCCReference Include="SpanishContst.pas"/>
<DCCReference Include="TaskDialog.pas"/>
<DCCReference Include="TaskDialogDE.pas"/>
<DCCReference Include="picturecontainer.pas"/>
<BuildConfiguration Include="Base">
<Key>Base</Key>
</BuildConfiguration>

View File

@ -1,47 +0,0 @@
package TaskDialogPkgD2009R;
{$R *.res}
{$ALIGN 8}
{$ASSERTIONS ON}
{$BOOLEVAL OFF}
{$DEBUGINFO OFF}
{$EXTENDEDSYNTAX ON}
{$IMPORTEDDATA ON}
{$IOCHECKS ON}
{$LOCALSYMBOLS OFF}
{$LONGSTRINGS ON}
{$OPENSTRINGS ON}
{$OPTIMIZATION ON}
{$OVERFLOWCHECKS OFF}
{$RANGECHECKS OFF}
{$REFERENCEINFO OFF}
{$SAFEDIVIDE OFF}
{$STACKFRAMES OFF}
{$TYPEDADDRESS OFF}
{$VARSTRINGCHECKS ON}
{$WRITEABLECONST OFF}
{$MINENUMSIZE 1}
{$IMAGEBASE $400000}
{$DESCRIPTION 'TMS TaskDialog'}
{$IMPLICITBUILD OFF}
requires
rtl,
vcl,
designide,
dbrtl,
vcldb;
contains
TaskDialog in 'TaskDialog.pas',
PictureContainer in 'PictureContainer.pas',
TaskDialogDE in 'TaskDialogDE.pas',
advgdip in 'advgdip.pas',
advglowbutton in 'advglowbutton.pas',
AdvGroupBox in 'AdvGroupBox.pas',
advhintinfo in 'advhintinfo.pas',
AdvOfficeButtons in 'AdvOfficeButtons.pas',
advstyleif in 'advstyleif.pas',
gdipicture in 'gdipicture.pas';
end.

View File

@ -1,98 +0,0 @@
 <Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
<PropertyGroup>
<ProjectGuid>{322e4f51-9fd5-43be-8659-42e8edcc60b1}</ProjectGuid>
<MainSource>TaskDialogPkgD2009R.dpk</MainSource>
<Configuration Condition=" '$(Configuration)' == '' ">Release</Configuration>
<Platform Condition=" '$(Platform)' == '' ">AnyCPU</Platform>
<DCC_DCCCompiler>DCC32</DCC_DCCCompiler>
<DCC_DependencyCheckOutputName>..\Lib\D11\TaskDialogPkgD2007.bpl</DCC_DependencyCheckOutputName>
<ProjectVersion>12.0</ProjectVersion>
<Config Condition="'$(Config)'==''">Base</Config>
</PropertyGroup>
<PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''">
<Base>true</Base>
</PropertyGroup>
<PropertyGroup Condition="'$(Base)'!=''">
<DCC_DependencyCheckOutputName>..\Lib\D12\TaskDialogPkgD2009R.bpl</DCC_DependencyCheckOutputName>
<DCC_ImageBase>00400000</DCC_ImageBase>
<DesignOnlyPackage>false</DesignOnlyPackage>
<DCC_BplOutput>..\Lib\D12</DCC_BplOutput>
<DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols>
<DCC_Description>TMS TaskDialog</DCC_Description>
<DCC_DebugInformation>false</DCC_DebugInformation>
<DCC_OutputNeverBuildDcps>true</DCC_OutputNeverBuildDcps>
<DCC_DcpOutput>..\Lib\D12</DCC_DcpOutput>
<GenDll>true</GenDll>
<DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo>
<GenPackage>true</GenPackage>
<DCC_DcuOutput>..\Lib\D12</DCC_DcuOutput>
</PropertyGroup>
<ProjectExtensions>
<Borland.Personality>Delphi.Personality.12</Borland.Personality>
<Borland.ProjectType>Package</Borland.ProjectType>
<BorlandProject>
<Delphi.Personality>
<Parameters>
<Parameters Name="UseLauncher">False</Parameters>
<Parameters Name="LoadAllSymbols">True</Parameters>
<Parameters Name="LoadUnspecifiedSymbols">False</Parameters>
</Parameters>
<VersionInfo>
<VersionInfo Name="IncludeVerInfo">True</VersionInfo>
<VersionInfo Name="AutoIncBuild">False</VersionInfo>
<VersionInfo Name="MajorVer">1</VersionInfo>
<VersionInfo Name="MinorVer">0</VersionInfo>
<VersionInfo Name="Release">0</VersionInfo>
<VersionInfo Name="Build">0</VersionInfo>
<VersionInfo Name="Debug">False</VersionInfo>
<VersionInfo Name="PreRelease">False</VersionInfo>
<VersionInfo Name="Special">False</VersionInfo>
<VersionInfo Name="Private">False</VersionInfo>
<VersionInfo Name="DLL">False</VersionInfo>
<VersionInfo Name="Locale">2067</VersionInfo>
<VersionInfo Name="CodePage">1252</VersionInfo>
</VersionInfo>
<VersionInfoKeys>
<VersionInfoKeys Name="CompanyName"/>
<VersionInfoKeys Name="FileDescription"/>
<VersionInfoKeys Name="FileVersion">1.0.0.0</VersionInfoKeys>
<VersionInfoKeys Name="InternalName"/>
<VersionInfoKeys Name="LegalCopyright"/>
<VersionInfoKeys Name="LegalTrademarks"/>
<VersionInfoKeys Name="OriginalFilename"/>
<VersionInfoKeys Name="ProductName"/>
<VersionInfoKeys Name="ProductVersion">1.0.0.0</VersionInfoKeys>
<VersionInfoKeys Name="Comments"/>
</VersionInfoKeys>
<Source>
<Source Name="MainSource">TaskDialogPkgD2009R.dpk</Source>
</Source>
</Delphi.Personality>
</BorlandProject>
<ProjectFileVersion>12</ProjectFileVersion>
</ProjectExtensions>
<ItemGroup>
<DelphiCompile Include="TaskDialogPkgD2009R.dpk">
<MainSource>MainSource</MainSource>
</DelphiCompile>
<DCCReference Include="rtl.dcp"/>
<DCCReference Include="vcl.dcp"/>
<DCCReference Include="designide.dcp"/>
<DCCReference Include="dbrtl.dcp"/>
<DCCReference Include="vcldb.dcp"/>
<DCCReference Include="TaskDialog.pas"/>
<DCCReference Include="PictureContainer.pas"/>
<DCCReference Include="TaskDialogDE.pas"/>
<DCCReference Include="advgdip.pas"/>
<DCCReference Include="advglowbutton.pas"/>
<DCCReference Include="AdvGroupBox.pas"/>
<DCCReference Include="advhintinfo.pas"/>
<DCCReference Include="AdvOfficeButtons.pas"/>
<DCCReference Include="advstyleif.pas"/>
<DCCReference Include="gdipicture.pas"/>
<BuildConfiguration Include="Base">
<Key>Base</Key>
</BuildConfiguration>
</ItemGroup>
<Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/>
</Project>

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

View File

@ -1,91 +0,0 @@
{***************************************************************************}
{ TAdvHintInfo component }
{ for Delphi & C++Builder }
{ }
{ written by TMS Software }
{ copyright © 2006 - 2008 }
{ Email : info@tmssoftware.com }
{ Web : http://www.tmssoftware.com }
{ }
{ The source code is given as is. The author is not responsible }
{ for any possible damage done due to the use of this code. }
{ The component can be freely used in any application. The complete }
{ source code remains property of the author and may not be distributed, }
{ published, given or sold in any form as such. No parts of the source }
{ code can be included in any other component or application without }
{ written authorization of the author. }
{***************************************************************************}
unit AdvHintInfo;
interface
uses
Classes, GDIPicture;
type
TAdvHintInfo = class(TPersistent)
private
FPicture: TGDIPPicture;
FShowHelp: boolean;
FNotes: TStrings;
FTitle: string;
FWideTitle: widestring;
FWideNotes: widestring;
procedure SetNotes(const Value: TStrings);
procedure SetPicture(const Value: TGDIPPicture);
public
constructor Create;
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
property WideTitle: widestring read FWideTitle write FWideTitle;
property WideNotes: widestring read FWideNotes write FWideNotes;
published
property Title: string read FTitle write FTitle;
property Notes: TStrings read FNotes write SetNotes;
property Picture: TGDIPPicture read FPicture write SetPicture;
property ShowHelp: boolean read FShowHelp write FShowHelp default false;
end;
implementation
{ TAdvHintInfo }
procedure TAdvHintInfo.Assign(Source: TPersistent);
begin
if (Source is TAdvHintInfo) then
begin
Title := (Source as TAdvHintInfo).Title;
Notes.Assign((Source as TAdvHintInfo).Notes);
ShowHelp := (Source as TAdvHintInfo).ShowHelp;
Picture.Assign((Source as TAdvHintInfo).Picture);
WideTitle := (Source as TAdvHintInfo).WideTitle;
WideNotes := (Source as TAdvHintInfo).WideNotes;
end;
end;
constructor TAdvHintInfo.Create;
begin
inherited;
FNotes := TStringList.Create;
FPicture := TGDIPPicture.Create;
end;
destructor TAdvHintInfo.Destroy;
begin
FNotes.Free;
FPicture.Free;
inherited;
end;
procedure TAdvHintInfo.SetNotes(const Value: TStrings);
begin
FNotes.Assign(Value);
end;
procedure TAdvHintInfo.SetPicture(const Value: TGDIPPicture);
begin
FPicture.Assign(Value);
end;
end.

View File

@ -1,63 +0,0 @@
{***************************************************************************}
{ TAdvStyleIF interface }
{ for Delphi & C++Builder }
{ version 1.0 }
{ }
{ written by TMS Software }
{ copyright © 2006 }
{ Email : info@tmssoftware.com }
{ Web : http://www.tmssoftware.com }
{ }
{ The source code is given as is. The author is not responsible }
{ for any possible damage done due to the use of this code. }
{ The component can be freely used in any application. The complete }
{ source code remains property of the author and may not be distributed, }
{ published, given or sold in any form as such. No parts of the source }
{ code can be included in any other component or application without }
{ written authorization of the author. }
{***************************************************************************}
unit AdvStyleIF;
interface
uses
Classes;
type
TTMSStyle = (tsOffice2003Blue, tsOffice2003Silver, tsOffice2003Olive, tsOffice2003Classic,
tsOffice2007Luna, tsOffice2007Obsidian, tsWindowsXP, tsWhidbey, tsCustom, tsOffice2007Silver);
//
// ['{E1199D64-5AF9-4DB7-B363-FABE5D1EEE0F}']
// function GetComponentStyle: TTMSStyle;
ITMSStyle = interface
['{11AC2DDC-C087-4298-AB6E-EA1B5017511B}']
procedure SetComponentStyle(AStyle: TTMSStyle);
end;
function IsVista: boolean;
implementation
uses
Windows;
//------------------------------------------------------------------------------
function IsVista: boolean;
var
hKernel32: HMODULE;
begin
hKernel32 := GetModuleHandle('kernel32');
if (hKernel32 > 0) then
begin
Result := GetProcAddress(hKernel32, 'GetLocaleInfoEx') <> nil;
end
else
Result := false;
end;
end.

View File

@ -1,420 +0,0 @@
{***************************************************************************}
{ TGDIPPicture class }
{ for Delphi & C++Builder }
{ }
{ written by TMS Software }
{ copyright © 2006 - 2008 }
{ Email : info@tmssoftware.com }
{ Web : http://www.tmssoftware.com }
{ }
{ The source code is given as is. The author is not responsible }
{ for any possible damage done due to the use of this code. }
{ The component can be freely used in any application. The complete }
{ source code remains property of the author and may not be distributed, }
{ published, given or sold in any form as such. No parts of the source }
{ code can be included in any other component or application without }
{ written authorization of the author. }
{***************************************************************************}
unit GDIPicture;
interface
uses
Windows, Classes, Graphics, Controls , SysUtils, AdvGDIP, ComObj, ActiveX;
{$I TMSDEFS.INC}
type
TGDIPPicture = class(TGraphic)
private
{ Private declarations }
FDatastream: TMemoryStream;
FIsEmpty: Boolean;
FWidth, FHeight: Integer;
FDoubleBuffered: Boolean;
FBackgroundColor: TColor;
FOnClear: TNotifyEvent;
protected
{ Protected declarations }
function GetEmpty: Boolean; override;
function GetHeight: Integer; override;
function GetWidth: Integer; override;
procedure SetHeight(Value: Integer); override;
procedure SetWidth(Value: Integer); override;
procedure ReadData(Stream: TStream); override;
procedure WriteData(Stream: TStream); override;
public
{ Public declarations }
constructor Create; override;
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
procedure DrawImage(Graphics: TGPGraphics; X,Y: integer);
procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
procedure LoadFromFile(const FileName: string); override;
procedure LoadFromStream(Stream: TStream); override;
procedure SaveToStream(Stream: TStream); override;
procedure LoadFromResourceName(Instance: THandle; const ResName: String);
procedure LoadFromResourceID(Instance: THandle; ResID: Integer);
procedure LoadFromURL(url:string);
procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
APalette: HPALETTE); override;
procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
var APalette: HPALETTE); override;
property DoubleBuffered: Boolean read FDoubleBuffered write FDoubleBuffered;
property BackgroundColor: TColor read FBackgroundColor write FBackgroundColor;
function GetImageSizes: boolean;
published
{ Published declarations }
property OnClear: TNotifyEvent read FOnClear write FOnClear;
end;
implementation
{ TGDIPPicture }
procedure TGDIPPicture.Assign(Source: TPersistent);
var
st: TMemoryStream;
begin
FIsEmpty := True;
if Source = nil then
begin
FDataStream.Clear;
FIsEmpty := true;
if Assigned(OnChange) then
OnChange(Self);
if Assigned(OnClear) then
OnClear(self);
end
else
begin
if Source is TGDIPPicture then
begin
FDataStream.LoadFromStream(TGDIPPicture(Source).FDataStream);
FIsEmpty := fdatastream.Size = 0;
if Assigned(OnChange) then
OnChange(self);
end
else
if Source is TBitmap then
begin
st := TMemoryStream.Create;
(Source as TBitmap).SaveToStream(st);
st.Position := 0;
FDataStream.LoadFromStream(st);
st.Free;
FIsEmpty := false;
if Assigned(OnChange) then
OnChange(self);
end
else
if (Source is TPicture) then
begin
st := TMemoryStream.Create;
(Source as TPicture).Graphic.SaveToStream(st);
st.Position := 0;
FDataStream.LoadFromStream(st);
st.Free;
FIsEmpty := false;
if Assigned(OnChange) then
OnChange(self);
end;
GetImageSizes;
end;
end;
constructor TGDIPPicture.Create;
begin
inherited;
FDataStream := TMemoryStream.Create;
FIsEmpty := True;
end;
destructor TGDIPPicture.Destroy;
begin
FDataStream.Free;
inherited;
end;
procedure TGDIPPicture.DrawImage(Graphics: TGPGraphics; X,Y: integer);
var
multi: TGPImage;
pstm: IStream;
hGlobal: THandle;
pcbWrite: Longint;
begin
if Empty then
Exit;
if FDataStream.Size = 0 then
Exit;
hGlobal := GlobalAlloc(GMEM_MOVEABLE, FDataStream.Size);
if (hGlobal = 0) then
raise Exception.Create('Could not allocate memory for image');
try
pstm := nil;
// Create IStream* from global memory
CreateStreamOnHGlobal(hGlobal, TRUE, pstm);
pstm.Write(FDataStream.Memory, FDataStream.Size,@pcbWrite);
multi := TGPImage.Create(pstm);
graphics.DrawImage(multi, x,y);
multi.Free;
finally
GlobalFree(hGlobal);
end;
end;
procedure TGDIPPicture.Draw(ACanvas: TCanvas; const Rect: TRect);
var
dc: HDC;
multi: TGPImage;
graphic: TGPgraphics;
pstm: IStream;
hGlobal: THandle;
pcbWrite: Longint;
bmp: tbitmap;
begin
if Empty then
Exit;
if FDataStream.Size = 0 then
Exit;
hGlobal := GlobalAlloc(GMEM_MOVEABLE, FDataStream.Size);
if (hGlobal = 0) then
raise Exception.Create('Could not allocate memory for image');
try
pstm := nil;
// Create IStream* from global memory
CreateStreamOnHGlobal(hGlobal, TRUE, pstm);
pstm.Write(FDataStream.Memory, FDataStream.Size,@pcbWrite);
dc := ACanvas.Handle;
graphic:= TGPgraphics.Create(dc);
multi := TGPImage.Create(pstm);
if multi.GetFormat = ifBMP then
begin // use this alternative for easy bitmap auto transparent drawing
bmp := TBitmap.Create;
FDataStream.Position := 0;
bmp.LoadFromStream(FDataStream);
bmp.TransparentMode := tmAuto;
bmp.Transparent := true;
ACanvas.Draw(Rect.Left,Rect.Top, bmp);
bmp.Free;
end
else
begin
FWidth := multi.GetWidth;
FHeight := multi.GetHeight;
graphic.DrawImageRect(multi, Rect.Left, Rect.Top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top);
end;
multi.Free;
graphic.Free;
finally
GlobalFree(hGlobal);
end;
end;
function TGDIPPicture.GetImageSizes: boolean;
var
multi: TGPImage;
pstm: IStream;
hGlobal: THandle;
pcbWrite: Longint;
begin
Result := false;
if Empty then
Exit;
if FDataStream.Size = 0 then
Exit;
hGlobal := GlobalAlloc(GMEM_MOVEABLE, FDataStream.Size);
if (hGlobal = 0) then
raise Exception.Create('Could not allocate memory for image');
try
pstm := nil;
// Create IStream* from global memory
CreateStreamOnHGlobal(hGlobal, TRUE, pstm);
pstm.Write(FDataStream.Memory, FDataStream.Size,@pcbWrite);
multi := TGPImage.Create(pstm);
FWidth := multi.GetWidth;
FHeight := multi.GetHeight;
Result := true;
multi.Free;
finally
GlobalFree(hGlobal);
end;
end;
function TGDIPPicture.GetEmpty: Boolean;
begin
Result := FIsEmpty;
end;
function TGDIPPicture.GetHeight: Integer;
begin
Result := FHeight;
end;
function TGDIPPicture.GetWidth: Integer;
begin
Result := FWidth;
end;
procedure TGDIPPicture.LoadFromFile(const FileName: string);
begin
try
FDataStream.LoadFromFile(Filename);
FIsEmpty := False;
if Assigned(OnClear) then
OnClear(self);
GetImageSizes;
if Assigned(OnChange) then
OnChange(self);
except
FIsEmpty:=true;
end;
end;
procedure TGDIPPicture.LoadFromStream(Stream: TStream);
begin
if Assigned(Stream) then
begin
FDataStream.LoadFromStream(Stream);
FIsEmpty := False;
GetImageSizes;
if Assigned(OnChange) then
OnChange(self);
end;
end;
procedure TGDIPPicture.ReadData(Stream: TStream);
begin
if Assigned(Stream) then
begin
FDataStream.LoadFromStream(stream);
FIsEmpty := False;
end;
end;
procedure TGDIPPicture.SaveToStream(Stream: TStream);
begin
if Assigned(Stream) then
FDataStream.SaveToStream(Stream);
end;
procedure TGDIPPicture.SetHeight(Value: Integer);
begin
{$IFDEF DELPHI6_LVL}
inherited;
{$ENDIF}
end;
procedure TGDIPPicture.SetWidth(Value: Integer);
begin
{$IFDEF DELPHI6_LVL}
inherited;
{$ENDIF}
end;
procedure TGDIPPicture.LoadFromResourceName(Instance: THandle; const ResName: string);
var
Stream: TCustomMemoryStream;
begin
if FindResource(Instance,PChar(ResName),RT_RCDATA) <> 0 then
begin
Stream := TResourceStream.Create(Instance, ResName, RT_RCDATA);
try
LoadFromStream(Stream);
finally
Stream.Free;
end;
end;
end;
procedure TGDIPPicture.LoadFromResourceID(Instance: THandle; ResID: Integer);
var
Stream: TCustomMemoryStream;
begin
Stream := TResourceStream.CreateFromID(Instance, ResID, RT_RCDATA);
try
LoadFromStream(Stream);
finally
Stream.Free;
end;
end;
procedure TGDIPPicture.WriteData(Stream: TStream);
begin
if Assigned(Stream) then
begin
FDataStream.SaveToStream(stream);
end;
end;
procedure TGDIPPicture.LoadFromURL(url: string);
begin
if (pos('RES://',UpperCase(url))=1) then
begin
Delete(url,1,6);
if (url<>'') then
LoadFromResourceName(hinstance,url);
Exit;
end;
if (pos('FILE://',uppercase(url))=1) then
begin
Delete(url,1,7);
if (url<>'')
then LoadFromFile(url);
end;
end;
procedure TGDIPPicture.LoadFromClipboardFormat(AFormat: Word;
AData: THandle; APalette: HPALETTE);
begin
end;
procedure TGDIPPicture.SaveToClipboardFormat(var AFormat: Word;
var AData: THandle; var APalette: HPALETTE);
begin
end;
end.