{ Create: 29.09.2008 20:11 } unit Widgets; {$TYPEINFO ON} {$R-,T-,H+,X+} interface uses Windows, Messages, SysUtils, Classes, CommCtrl, ShelApix, GdipApi, GdipObj, WStrUtils, MMSystem, ActiveX; var WidgetAtom: TAtom; type PARGB = ^TARGB; TARGB = record case Integer of 0: (R, G, B, A: Byte); // Dikkat, Sirasi onemli. 1: (Color: Cardinal); end; PARGBArray = ^TARGBArray; TARGBArray = array[0..MaxInt div SizeOf(TARGB) - 1] of TARGB; const WINDOWS_OLD = $0000; WINDOWS_XP = $0501; WINDOWS_XP_SP2 = $0502; WINDOWS_VISTA = $0600; var WindowsVersion: Integer; const SC_DRAGMOVE = $F012; const { Widget Massage Ranges } CM_WIDGETBASE = WM_USER + $1331; CM_RESTOREAPP = CM_WIDGETBASE + 1; CM_EXITAPP = CM_WIDGETBASE + 2; CM_RESTARTAPP = CM_WIDGETBASE + 3; CM_INSTTHEME = CM_WIDGETBASE + 4; CM_STARTSERVER = CM_WIDGETBASE + 5; CM_STOPSERVER = CM_WIDGETBASE + 6; CM_RESTARTSERVER = CM_WIDGETBASE + 7; CM_BASE = CM_WIDGETBASE + 100; const WM_MOUSEENTER = WM_APP + $0146; WM_MOUSETIMER = WM_APP + $0147; const FS_NORMAL = 0; FS_BOLD = 1; FS_ITALIC = 2; FS_UNDERLINE = 4; type TColor = -$7FFFFFFF-1..$7FFFFFFF; const clScrollBar = TColor(COLOR_SCROLLBAR or $80000000); clBackground = TColor(COLOR_BACKGROUND or $80000000); clActiveCaption = TColor(COLOR_ACTIVECAPTION or $80000000); clInactiveCaption = TColor(COLOR_INACTIVECAPTION or $80000000); clMenu = TColor(COLOR_MENU or $80000000); clWindow = TColor(COLOR_WINDOW or $80000000); clWindowFrame = TColor(COLOR_WINDOWFRAME or $80000000); clMenuText = TColor(COLOR_MENUTEXT or $80000000); clWindowText = TColor(COLOR_WINDOWTEXT or $80000000); clCaptionText = TColor(COLOR_CAPTIONTEXT or $80000000); clActiveBorder = TColor(COLOR_ACTIVEBORDER or $80000000); clInactiveBorder = TColor(COLOR_INACTIVEBORDER or $80000000); clAppWorkSpace = TColor(COLOR_APPWORKSPACE or $80000000); clHighlight = TColor(COLOR_HIGHLIGHT or $80000000); clHighlightText = TColor(COLOR_HIGHLIGHTTEXT or $80000000); clBtnFace = TColor(COLOR_BTNFACE or $80000000); clBtnShadow = TColor(COLOR_BTNSHADOW or $80000000); clGrayText = TColor(COLOR_GRAYTEXT or $80000000); clBtnText = TColor(COLOR_BTNTEXT or $80000000); clInactiveCaptionText = TColor(COLOR_INACTIVECAPTIONTEXT or $80000000); clBtnHighlight = TColor(COLOR_BTNHIGHLIGHT or $80000000); cl3DDkShadow = TColor(COLOR_3DDKSHADOW or $80000000); cl3DLight = TColor(COLOR_3DLIGHT or $80000000); clInfoText = TColor(COLOR_INFOTEXT or $80000000); clInfoBk = TColor(COLOR_INFOBK or $80000000); clBlack = TColor($000000); clMaroon = TColor($000080); clGreen = TColor($008000); clOlive = TColor($008080); clNavy = TColor($800000); clPurple = TColor($800080); clTeal = TColor($808000); clGray = TColor($808080); clSilver = TColor($C0C0C0); clRed = TColor($0000FF); clLime = TColor($00FF00); clYellow = TColor($00FFFF); clBlue = TColor($FF0000); clFuchsia = TColor($FF00FF); clAqua = TColor($FFFF00); clLtGray = TColor($C0C0C0); clDkGray = TColor($808080); clWhite = TColor($FFFFFF); clNone = TColor($1FFFFFFF); clDefault = TColor($20000000); clMoneyGreen = TColor($C0DCC0); clSkyBlue = TColor($F0CAA6); clCream = TColor($F0FBFF); clMedGray = TColor($A4A0A0); BP_CENTER = 0; BP_STRETCH = 1; BP_TILE = 2; type { Generic window message record } PWidgetMessage = ^TWidgetMessage; TWidgetMessage = packed record Wnd: HWND; Msg: Cardinal; case Integer of 0: ( WParam: Longint; LParam: Longint; Result: Longint); 1: ( WParamLo: Word; WParamHi: Word; LParamLo: Word; LParamHi: Word; ResultLo: Word; ResultHi: Word); end; type TCreateParamsW = record Caption: PWideChar; Style: DWORD; ExStyle: DWORD; X, Y: Integer; Width, Height: Integer; WndParent: HWnd; Param: Pointer; WindowClass: TWndClassW; WinClassName: array[0..63] of WideChar; end; type { TWidgetObject } TWidgetGraphicObject = class(TObject) end; { TWidgetBrush } TWidgetBrush = class(TWidgetGraphicObject) end; { TWidgetSolidBrush } TWidgetSolidBrush = class(TWidgetBrush) private FHandle: TGPSolidBrush; procedure Allocate; procedure Release; procedure SetColor(const Value: Cardinal); procedure SetOpacity(const Value: Byte); function GetOpacity: Byte; function GetColor: Cardinal; public constructor Create; destructor Destroy; override; property Color: Cardinal read GetColor write SetColor; property Opacity: Byte read GetOpacity write SetOpacity; property Handle: TGPSolidBrush read FHandle; end; { TWidgetPen } TWidgetPen = class(TWidgetGraphicObject) private FHandle: TGPPen; FColor: Cardinal; FWidth: Single; FStyle: TDashStyle; FOpacity: Byte; procedure Allocate; procedure Release; procedure SetColor(const Value: Cardinal); procedure SetWidth(const Value: Single); procedure SetOpacity(const Value: Byte); procedure SetStyle(const Value: TDashStyle); public constructor Create; destructor Destroy; override; procedure SetProps(const AColor, AWidth: Integer; AStyle: TDashStyle); property Color: Cardinal read FColor write SetColor; property Width: Single read FWidth write SetWidth; property Style: TDashStyle read FStyle write SetStyle; property Opacity: Byte read FOpacity write SetOpacity; property Handle: TGPPen read FHandle; end; { TWidgetStringFormat } TWidgetStringFormat = class(TWidgetGraphicObject) private FHandle: TGPStringFormat; FFormatFlags: Integer; FAlignment: TStringAlignment; FHotkeyPrefix: THotkeyPrefix; FLineAlignment: TStringAlignment; FTrimming: TStringTrimming; procedure Allocate; procedure Release; procedure SetFormatFlags(const Value: Integer); procedure SetAlignment(const Value: TStringAlignment); procedure SetHotkeyPrefix(const Value: THotkeyPrefix); procedure SetLineAlignment(const Value: TStringAlignment); procedure SetTrimming(const Value: TStringTrimming); public constructor Create; destructor Destroy; override; property FormatFlags: Integer read FFormatFlags write SetFormatFlags; property Alignment: TStringAlignment read FAlignment write SetAlignment; property HotkeyPrefix: THotkeyPrefix read FHotkeyPrefix write SetHotkeyPrefix; property LineAlignment: TStringAlignment read FLineAlignment write SetLineAlignment; property Trimming: TStringTrimming read FTrimming write SetTrimming; property Handle: TGPStringFormat read FHandle; end; { TFontName } TFontName = type string; { TWidgetFont } TWidgetFont = class(TWidgetGraphicObject) private FHandle: TGPFont; FName: TFontName; FSize: Integer; FStyle: Integer; FBrush: TWidgetSolidBrush; FFormat: TWidgetStringFormat; procedure Allocate; procedure Release; procedure Reallocate; procedure SetColor(const Value: Cardinal); procedure SetName(const Value: TFontName); procedure SetSize(const Value: Integer); procedure SetStyle(const Value: Integer); procedure SetOpacity(const Value: Byte); function GetOpacity: Byte; function GetColor: Cardinal; public constructor Create; destructor Destroy; override; procedure SetProps(const AName: string; ASize: Integer; AStyle: Integer; AColor: Integer; AAlignment, ALineAlignment: StringAlignment); published property Name: TFontName read FName write SetName; property Size: Integer read FSize write SetSize; property Style: Integer read FStyle write SetStyle; property Color: Cardinal read GetColor write SetColor; property Opacity: Byte read GetOpacity write SetOpacity; property Brush: TWidgetSolidBrush read FBrush; property Format: TWidgetStringFormat read FFormat; property Handle: TGPFont read FHandle; end; TWidgetImageFrom = (wifFile, wifResource); { TWidgetImage } TWidgetImage = class(TWidgetGraphicObject) private FHandle: TGPBitmap; FFileName: WideString; procedure Allocate; procedure AllocateAdapter; procedure Release; function GetHeight: Cardinal; function GetWidth: Cardinal; public constructor Create(const FileName: WideString; Option: TWidgetImageFrom = wifFile); destructor Destroy; override; procedure LoadFromFile(const FileName: WideString); published property Width: Cardinal read GetWidth; property Height: Cardinal read GetHeight; property Handle: TGPBitmap read FHandle; end; { TWidgetBitmap } TWidgetBitmap = class(TWidgetImage) end; { TWidgetCanvas } TWidgetCanvas = class(TWidgetGraphicObject) private FBitmap: TGPBitmap; FCachedBitmap: TGPCachedBitmap; FGraphics: TGPGraphics; FWidth: Integer; FHeight: Integer; FFont: TWidgetFont; FBrush: TWidgetSolidBrush; FPen: TWidgetPen; procedure SetHeight(const Value: Integer); procedure SetWidth(const Value: Integer); function GetTextRenderingHint: TTextRenderingHint; procedure SetTextRenderingHint(const Value: TTextRenderingHint); public constructor Create(const AWidth, AHeight: Integer); destructor Destroy; override; procedure Allocate; procedure Release; procedure Reallocate(const AWidth, AHeight: Integer); procedure Clear; function GetHDC: HDC; procedure ReleaseHDC(DC: HDC); // DrawLine(s) procedure DrawLine(X1, Y1, X2, Y2: Integer); overload; procedure DrawLine(const P1, P2: TGPPoint); overload; procedure DrawLines(Points: PGPPoint; Count: Integer); overload; procedure DrawLine(const P1, P2: TPoint); overload; // DrawArc procedure DrawArc(X, Y, Width, Height: Integer; StartAngle, SweepAngle: Single); overload; procedure DrawArc(const Rect: TGPRect; StartAngle, SweepAngle: Single); overload; procedure DrawArc(const Rect: TRect; StartAngle, SweepAngle: Single); overload; // DrawRectangle(s) procedure DrawRectangle(const Rect: TGPRect); overload; procedure DrawRectangle(X, Y, Width, Height: Integer); overload; procedure DrawRectangles(Rects: PGPRect; Count: Integer); overload; procedure DrawRectangle(const Rect: TRect); overload; // DrawEllipse procedure DrawEllipse(const Rect: TGPRect); overload; procedure DrawEllipse(X, Y, Width, Height: Integer); overload; procedure DrawEllipse(const Rect: TRect); overload; // DrawPie procedure DrawPie(const Rect: TGPRect; StartAngle, SweepAngle: Single); overload; procedure DrawPie(X, Y, Width, Height: Integer; StartAngle, SweepAngle: Single); overload; procedure DrawPie(const Rect: TRect; StartAngle, SweepAngle: Single); overload; // FillRectangle(s) procedure FillRectangle(const Rect: TGPRect); overload; procedure FillRectangle(X, Y, Width, Height: Integer); overload; procedure FillRectangles(Rects: PGPRect; Count: Integer); overload; procedure FillRectangle(const Rect: TRect); overload; // FillEllipse procedure FillEllipse(const Rect: TGPRect); overload; procedure FillEllipse(X, Y, Width, Height: Integer); overload; procedure FillEllipse(const Rect: TRect); overload; // FillPie procedure FillPie(const Rect: TGPRect; StartAngle, SweepAngle: Single); overload; procedure FillPie(X, Y, Width, Height: Integer; StartAngle, SweepAngle: Single); overload; procedure FillPie(const Rect: TRect; StartAngle, SweepAngle: Single); overload; // DrawString procedure DrawString(const Text: WideString; X, Y: Integer); overload; procedure DrawString(const Text: WideString; R: TRect); overload; procedure DrawString(const Text: WideString; P: TPoint); overload; // DrawImage procedure DrawImage(Image: TGPBitmap; X, Y, Width, Height: Integer); overload; procedure DrawImage(Image: TGPBitmap; X, Y, Width, Height: Integer; Opacity: Byte); overload; //procedure A; procedure TextOut(X, Y: Integer; const Text: WideString); procedure TextRect(Rect: TRect; X, Y: Integer; const Text: WideString); function TextExtent(const Text: WideString): TSize; procedure FillRect(const Rect: TRect); property TextRenderingHint: TTextRenderingHint read GetTextRenderingHint write SetTextRenderingHint; property Bitmap: TGPBitmap read FBitmap; property Graphics: TGPGraphics read FGraphics; property Handle: TGPGraphics read FGraphics; property Font: TWidgetFont read FFont; property Brush: TWidgetSolidBrush read FBrush; property Pen: TWidgetPen read FPen; property Width: Integer read FWidth write SetWidth; property Height: Integer read FHeight write SetHeight; end; type { Events } TNotifyEvent = procedure(Sender: TObject) of object; TMouseEvent = procedure(Sender: TObject; Keys: Integer; X, Y: Integer) of object; TMouseMoveEvent = procedure(Sender: TObject; Keys: Integer; X, Y: Integer) of object; TMouseWheelEvent = procedure(Sender: TObject; Keys, WheelDelta: Integer; X, Y: Integer) of object; TSizingEvent = procedure(Sender: TObject; Edge: Integer; var Rect: TRect) of object; TSizeEvent = procedure(Sender: TObject; Flag: Integer; NewWidth, NewHeight: Integer) of object; TMoveEvent = procedure(Sender: TObject; X, Y: Integer) of object; TMovingEvent = procedure(Sender: TObject; Side: Integer; P: PRect) of object; { Forward Declaration } TControl = class; { IControlReference } IControlReference = interface ['{01F4F892-5F8B-4DC9-8A25-003A98908C33}'] function GetControl: TControl; safecall; end; {.$METHODINFO ON} { TControl } TControl = class(TComponent, IControlReference) private FHandle: HWND; FParent: TControl; FDefaultProc: Pointer; FCursor: HCURSOR; FLeft: Integer; FTop: Integer; FWidth: Integer; FHeight: Integer; FStyle: DWORD; FExStyle: DWORD; FText: PWideChar; FTag: LongInt; FVisible: Boolean; FInWindow: Boolean; FEnabled: Boolean; FTabStop: Boolean; FParentWindow: HWND; FClientWidth: Integer; FClientHeight: Integer; FClientOrigin: TPoint; FIsClicked: Boolean; FOnMouseMove: TMouseEvent; FOnMouseHover: TMouseEvent; FOnMouseEnter: TMouseEvent; FOnMouseLeave: TMouseEvent; FOnMouseDown: TMouseEvent; FOnMouseUp: TMouseEvent; FOnClick: TMouseEvent; FOnMouseWheel: TMouseWheelEvent; FOnSizing: TSizingEvent; FOnSize: TSizeEvent; FOnMove: TMoveEvent; FOnMoving: TMovingEvent; FOnSysTimer: TNotifyEvent; FOnSetFocus: TNotifyEvent; FOnKillFocus: TNotifyEvent; FShowHint: Boolean; FHint: WideString; function GetTextLen: Integer; function GetTextBuf(Buffer: PWideChar; BufSize: Integer): Integer; procedure SetTextBuf(Buffer: PWideChar); procedure SetCursor(const Value: HCURSOR); procedure SetHeight(const Value: Integer); procedure SetWidth(const Value: Integer); procedure SetLeft(const Value: Integer); procedure SetTop(const Value: Integer); procedure SetEnabled(const Value: Boolean); procedure SetParentWindow(const Value: HWND); procedure SetVisible(const Value: Boolean); procedure SetClientHeight(const Value: Integer); procedure SetClientOrigin(const Value: TPoint); procedure SetClientWidth(const Value: Integer); procedure SetStyle(const Value: Cardinal); procedure SetExStyle(const Value: Cardinal); function GetControlCount: Integer; function GetHandle: HWND; procedure SetClientRect(const Value: TRect); function GetHint: WideString; procedure SetHint(const Value: WideString); function GetShowHint: Boolean; procedure SetShowHint(const Value: Boolean); function GetExStyle: Cardinal; function GetStyle: Cardinal; function GetText: WideString; procedure SetText(const Value: WideString); protected { IWidgetControlRef } function GetControl: TControl; safecall; procedure SetParent(AParent: TControl); virtual; procedure CallDefaultProc(var Message: TWidgetMessage); virtual; procedure CreateWnd; virtual; procedure CreateParams(var Params: TCreateParamsW); virtual; procedure CreateSubClass(var Params: TCreateParamsW; ControlClassName: PWideChar); procedure CreateWindowHandle(const Params: TCreateParamsW); virtual; procedure DestroyHandle; procedure DestroyWindowHandle; virtual; procedure DestroyWnd; virtual; { Messages } procedure WndProc(var Message: TWidgetMessage); virtual; procedure WMCreate(var Message: TWidgetMessage); virtual; procedure WMDestroy(var Message: TWidgetMessage); virtual; procedure WMNCCreate(var Message: TWidgetMessage); virtual; procedure WMSetCursor(var Message: TWidgetMessage); virtual; procedure WMMouseHover(var Message: TWidgetMessage); virtual; procedure WMMouseEnter(var Message: TWidgetMessage); virtual; procedure WMMouseLeave(var Message: TWidgetMessage); virtual; procedure WMMouseMove(var Message: TWidgetMessage); virtual; procedure WMTimer(var Message: TWidgetMessage); virtual; procedure WMSizing(var Message: TWidgetMessage); virtual; procedure WMSize(var Message: TWidgetMessage); virtual; procedure WMMove(var Message: TWidgetMessage); virtual; procedure WMMoving(var Message: TWidgetMessage); virtual; procedure WMMouseDown(var Message: TWidgetMessage); virtual; procedure WMMouseUp(var Message: TWidgetMessage); virtual; procedure WMSysTimer(var Message: TWidgetMessage); virtual; procedure WMSetFocus(var Message: TWidgetMessage); virtual; procedure WMKillFocus(var Message: TWidgetMessage); virtual; procedure WMMouseWheel(var Message: TWidgetMessage); virtual; procedure WMShowWindow(var Message: TWidgetMessage); virtual; procedure WMGetDlgCode(var Message: TWidgetMessage); virtual; procedure WMCancelMode(var Message: TWidgetMessage); virtual; procedure WMWindowPosChanged(var Message: TWidgetMessage); virtual; procedure WMWindowPosChanging(var Message: TWidgetMessage); virtual; procedure WMNCHitTest(var Message: TWidgetMessage); virtual; procedure WMGetText(var Message: TWidgetMessage); virtual; procedure WMGetTextLength(var Message: TWidgetMessage); virtual; procedure WMSetText(var Message: TWidgetMessage); virtual; procedure WMHScroll(var Message: TWidgetMessage); virtual; procedure WMVScroll(var Message: TWidgetMessage); virtual; procedure WMNotify(var Message: TWidgetMessage); virtual; procedure WMCtlColor(var Message: TWidgetMessage); virtual; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure HandleNeeded; virtual; procedure CreateHandle; virtual; function HandleAllocated: Boolean; function Perform(Msg: Cardinal; WParam, LParam: Longint): Longint; procedure CallWndProc(var Message: TWidgetMessage); procedure AddToolTip; procedure DelToolTip; function GetClientRect: TRect; function GetWindowRect: TRect; procedure Show; procedure Hide; procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); virtual; procedure Move(ALeft, ATop: Integer); procedure Grow(AWidth, AHeight: Integer); procedure Paint; virtual; procedure Repaint; procedure Refresh; procedure Update; virtual; procedure ModifyStyle(const ClearValue, SetValue: DWORD); function FirstChild: TControl; function LastChild: TControl; function NextChild(const Current: TControl): TControl; function PrevChild(const Current: TControl): TControl; function HasChildren: Boolean; property DefaultProc: Pointer read FDefaultProc write FDefaultProc; property WindowText: PWideChar read FText write FText; published property Caption: WideString read GetText write SetText; property Cursor: HCURSOR read FCursor write SetCursor; property Handle: HWND read GetHandle;// write SetHandle; property Left: Integer read FLeft write SetLeft; property Top: Integer read FTop write SetTop; property Width: Integer read FWidth write SetWidth; property Height: Integer read FHeight write SetHeight; property Enabled: Boolean read FEnabled write SetEnabled; property Visible: Boolean read FVisible write SetVisible; property Tag: LongInt read FTag write FTag; property Parent: TControl read FParent write FParent; property ParentWindow: HWND read FParentWindow write SetParentWindow; property ControlCount: Integer read GetControlCount; property ClientOrigin: TPoint read FClientOrigin write SetClientOrigin; property ClientWidth: Integer read FClientWidth write SetClientWidth; property ClientHeight: Integer read FClientHeight write SetClientHeight; property Style: Cardinal read GetStyle write SetStyle; property ExStyle: Cardinal read GetExStyle write SetExStyle; property ClientRect: TRect read GetClientRect write SetClientRect; property WindowRect: TRect read GetWindowRect;// write SetClientRect; property ShowHint: Boolean read GetShowHint write SetShowHint; property Hint: WideString read GetHint write SetHint; property OnMouseMove: TMouseEvent read FOnMouseMove write FOnMouseMove; property OnMouseEnter: TMouseEvent read FOnMouseEnter write FOnMouseEnter; property OnMouseLeave: TMouseEvent read FOnMouseLeave write FOnMouseLeave; property OnMouseHover: TMouseEvent read FOnMouseHover write FOnMouseHover; property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown; property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp; property OnClick: TMouseEvent read FOnClick write FOnClick; property OnMouseWheel: TMouseWheelEvent read FOnMouseWheel write FOnMouseWheel; property OnSizing: TSizingEvent read FOnSizing write FOnSizing; property OnSize: TSizeEvent read FOnSize write FOnSize; property OnMove: TMoveEvent read FOnMove write FOnMove; property OnMoving: TMovingEvent read FOnMoving write FOnMoving; property OnSysTimer: TNotifyEvent read FOnSysTimer write FOnSysTimer; property OnSetFocus: TNotifyEvent read FOnSetFocus write FOnSetFocus; property OnKillFocus: TNotifyEvent read FOnKillFocus write FOnKillFocus; end; { Events } TPaintEvent = procedure(Sender: TObject; Canvas: TWidgetCanvas) of object; { TWidgetControl } TWidgetControl = class(TControl) private FCanvas: TWidgetCanvas; FOpacity: Byte; FOpacityChanged: Boolean; FOnPaint: TPaintEvent; procedure SetOpacity(const Value: Byte); protected { Messages } procedure WMSize(var Message: TWidgetMessage); override; procedure WMShowWindow(var Message: TWidgetMessage); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Paint; override; procedure PaintWindow; virtual; procedure PaintChildren; procedure PaintCanvas; procedure Update; override; published property Canvas: TWidgetCanvas read FCanvas; property Opacity: Byte read FOpacity write SetOpacity; property OnPaint: TPaintEvent read FOnPaint write FOnPaint; end; { Events } TCloseAction = (caNone, caHide, caFree, caMinimize); TCloseEvent = procedure(Sender: TObject; var Action: TCloseAction) of object; TActivateEvent = procedure(Sender: TObject; Activation: Word) of object; TMouseActivateEvent = procedure(Sender: TObject; HitTest, MouseButton: Word; var Result: Integer) of object; { TWidgetForm } TWidgetForm = class(TWidgetControl) private FUpdating: Boolean; FOnCreate: TNotifyEvent; FOnDestroy: TNotifyEvent; FOnClose: TCloseEvent; FOnActivate: TActivateEvent; FOnMouseActivate: TMouseActivateEvent; protected procedure WndProc(var Message: TWidgetMessage); override; procedure CreateParams(var Params: TCreateParamsW); override; procedure WMCreate(var Message: TWidgetMessage); override; procedure WMClose(var Message: TWidgetMessage); virtual; procedure WMDestroy(var Message: TWidgetMessage); override; procedure WMActivate(var Message: TWidgetMessage); virtual; procedure WMMouseActivate(var Message: TWidgetMessage); virtual; procedure WMWindowPosChanging(var Message: TWidgetMessage); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure CreateForm; virtual; procedure UpdateForm; procedure Update; override; property OnCreate: TNotifyEvent read FOnCreate write FOnCreate; property OnClose: TCloseEvent read FOnClose write FOnClose; property OnActivate: TActivateEvent read FOnActivate write FOnActivate; property OnMouseActivate: TMouseActivateEvent read FOnMouseActivate write FOnMouseActivate; end; { TGraphicObject } TGraphicObject = class(TObject) private FOnChange: TNotifyEvent; protected procedure Changed; dynamic; public procedure Assign(Source: TGraphicObject); virtual; property OnChange: TNotifyEvent read FOnChange write FOnChange; end; { TPen } TPen = class(TGraphicObject) private FHandle: HPEN; FColor: TColor; //FMode: Integer; FStyle: Integer; FWidth: Integer; procedure SetHandle(const Value: HPEN); procedure SetColor(const Value: TColor); procedure SetWidth(const Value: Integer); procedure SetStyle(const Value: Integer); protected procedure Release; procedure Allocate; public destructor Destroy; override; property Handle: HPEN read FHandle write SetHandle; property Color: TColor read FColor write SetColor; property Width: Integer read FWidth write SetWidth; property Style: Integer read FStyle write SetStyle; end; { TBrush } TBrush = class(TGraphicObject) private FHandle: HBRUSH; FColor: TColor; FStyle: Integer; procedure SetColor(const Value: TColor); procedure SetHandle(const Value: HBRUSH); procedure SetStyle(const Value: Integer); protected procedure Release; procedure Allocate; public constructor Create; destructor Destroy; override; procedure Assign(Source: TGraphicObject); override; property Handle: HBRUSH read FHandle write SetHandle; property Color: TColor read FColor write SetColor; property Style: Integer read FStyle write SetStyle; end; { TFont } TFont = class(TGraphicObject) private FHandle: HFONT; FSize: Integer; FName: WideString; FStyle: UINT; FColor: TColor; procedure SetName(const Value: WideString); procedure SetSize(const Value: Integer); procedure SetStyle(const Value: UINT); procedure SetColor(const Value: TColor); procedure SetHandle(const Value: HFONT); protected procedure Allocate; procedure Release; public constructor Create; destructor Destroy; override; procedure Assign(Source: TGraphicObject); override; property Size: Integer read FSize write SetSize; property Name: WideString read FName write SetName; property Style: UINT read FStyle write SetStyle; property Color: TColor read FColor write SetColor; property Handle: HFONT read FHandle write SetHandle; end; TWinControl = class; { TCanvas } TCanvas = class(TObject) private FOnChange: TNotifyEvent; FHandle: HDC; FControl: TWinControl; FFont: TFont; FBrush: TBrush; FPen: TPen; procedure SetControl(const Value: TWinControl); procedure BrushChange(Sender: TObject); procedure FontChange(Sender: TObject); procedure PenChange(Sender: TObject); procedure SetHandle(const Value: HDC); protected procedure Changed; virtual; public constructor Create; destructor Destroy; override; function HandleAllocated: Boolean; procedure TextOut(X, Y: Integer; const Text: WideString); procedure FillRect(const Rect: TRect); procedure Rectangle(X1, Y1, X2, Y2: Integer); procedure MoveTo(X, Y: Integer); procedure LineTo(X, Y: Integer); procedure BeginPath; procedure EndPath; procedure StrokeAndFillPath; procedure AngleArc(X, Y: Integer; Radius: DWORD; StartAngle, SweepAngle: Single); procedure DrawFrameControl(const Rect: TRect; uType, State: UINT); property OnChange: TNotifyEvent read FOnChange write FOnChange; property Handle: HDC read FHandle write SetHandle; property Control: TWinControl read FControl write SetControl; property Font: TFont read FFont; property Brush: TBrush read FBrush; property Pen: TPen read FPen; end; { TWinControl } TWinControl = class(TControl) private FFont: TFont; FBrush: TBrush; FPen: TPen; function GetColor: TColor; procedure SetColor(const Value: TColor); procedure FontChanged(Sender: TObject); procedure BrushChange(Sender: TObject); procedure PenChange(Sender: TObject); protected procedure CreateWnd; override; procedure WndProc(var Message: TWidgetMessage); override; procedure WMPaint(var Message: TWidgetMessage); virtual; procedure WMNCPaint(var Message: TWidgetMessage); virtual; procedure WMEraseBkGnd(var Message: TWidgetMessage); virtual; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Invalidate; property Font: TFont read FFont; property Brush: TBrush read FBrush; property Pen: TPen read FPen; property Color: TColor read GetColor write SetColor; end; { TWinForm } TWinForm = class(TWinControl) private FOnCreate: TNotifyEvent; FOnDestroy: TNotifyEvent; FOnClose: TCloseEvent; FOnActivate: TActivateEvent; FOnMouseActivate: TMouseActivateEvent; FOpacity: Byte; FCanvas: TCanvas; procedure SetOpacity(const Value: Byte); procedure CanvasChange(Sender: TObject); protected procedure WndProc(var Message: TWidgetMessage); override; procedure CreateParams(var Params: TCreateParamsW); override; procedure WMCreate(var Message: TWidgetMessage); override; procedure WMClose(var Message: TWidgetMessage); virtual; procedure WMDestroy(var Message: TWidgetMessage); override; procedure WMActivate(var Message: TWidgetMessage); virtual; procedure WMMouseActivate(var Message: TWidgetMessage); virtual; procedure WMPaint(var Message: TWidgetMessage); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure CreateForm; virtual; property OnCreate: TNotifyEvent read FOnCreate write FOnCreate; property OnClose: TCloseEvent read FOnClose write FOnClose; property OnActivate: TActivateEvent read FOnActivate write FOnActivate; property OnMouseActivate: TMouseActivateEvent read FOnMouseActivate write FOnMouseActivate; property Opacity: Byte read FOpacity write SetOpacity; property Canvas: TCanvas read FCanvas; end; const TTM_ADJUSTRECT = (WM_USER + 31); TTS_NOFADE = $20; TTS_BALLOON = $40; TTS_CLOSE = $80; type { TWidgetToolTip } TWidgetToolTip = class(TWinControl) private function GetBackColor: Cardinal; function GetTextColor: Cardinal; procedure SetBackColor(const Value: Cardinal); procedure SetTextColor(const Value: Cardinal); protected procedure CreateParams(var Params: TCreateParamsW); override; procedure WndProc(var Message: TWidgetMessage); override; procedure WMNotify(var Message: TWidgetMessage); override; procedure WMGetDispInfo(var Message: TWidgetMessage); virtual; procedure WMToolTipShow(var Message: TWidgetMessage); virtual; procedure WMToolTipPop(var Message: TWidgetMessage); virtual; procedure WMCustomDraw(var Message: TWidgetMessage); virtual; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure SetDelayTime(const Duration: Cardinal; const Delay: Word); property BackColor: Cardinal read GetBackColor write SetBackColor; property TextColor: Cardinal read GetTextColor write SetTextColor; end; const WM_TRAY_MESSAGE = CM_BASE + 100; type TBalloonFlags = (bfNone = NIIF_NONE, bfInfo = NIIF_INFO, bfWarning = NIIF_WARNING, bfError = NIIF_ERROR); { TWidgetTray } TWidgetTray = class(TWinForm) private FData: TNotifyIconDataW; FIsClicked: Boolean; FIcon: HICON; FPopupMenu: HMENU; FHintText: WideString; FOnMouseMove: TMouseMoveEvent; FOnClick: TNotifyEvent; FOnDblClick: TNotifyEvent; FOnMouseDown: TMouseEvent; FOnMouseUp: TMouseEvent; FBalloonHint: WideString; FBalloonTitle: WideString; FBalloonFlags: TBalloonFlags; FVisibleTray: Boolean; FOnAnimate: TNotifyEvent; function GetBalloonTimeout: Integer; procedure SetBalloonHint(const Value: WideString); procedure SetBalloonTimeout(const Value: Integer); procedure SetBalloonTitle(const Value: WideString); procedure SetIcon(const Value: HICON); procedure SetHintText(const Value: WideString); procedure SetVisibleTray(const Value: Boolean); protected procedure CreateParams(var Params: TCreateParamsW); override; procedure WndProc(var Message: TWidgetMessage); override; procedure WMTrayMessage(var Message: TWidgetMessage); virtual; procedure WMDestroy(var Message: TWidgetMessage); override; function Refresh(Message: Integer): Boolean; overload; procedure Refresh; overload; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure CreateForm; override; procedure ShowBalloonHint; virtual; property HintText: WideString read FHintText write SetHintText; property BalloonHint: WideString read FBalloonHint write SetBalloonHint; property BalloonTitle: WideString read FBalloonTitle write SetBalloonTitle; property BalloonTimeout: Integer read GetBalloonTimeout write SetBalloonTimeout default 3000; property BalloonFlags: TBalloonFlags read FBalloonFlags write FBalloonFlags default bfNone; property Icon: HICON read FIcon write SetIcon; property PopupMenu: HMENU read FPopupMenu write FPopupMenu; property VisibleTray: Boolean read FVisibleTray write SetVisibleTray default False; property OnClick: TNotifyEvent read FOnClick write FOnClick; property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick; property OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove; property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp; property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown; property OnAnimate: TNotifyEvent read FOnAnimate write FOnAnimate; end; { TStreamAdapter: Bug fixed. See "Stat" function } { Implements OLE IStream on VCL TStream } TStreamOwnership = (soReference, soOwned); { TStreamAdapter } TStreamAdapter = class(TInterfacedObject, IStream) private FStream: TStream; FOwnership: TStreamOwnership; public constructor Create(Stream: TStream; Ownership: TStreamOwnership = soReference); destructor Destroy; override; function Read(pv: Pointer; cb: Longint; pcbRead: PLongint): HResult; virtual; stdcall; function Write(pv: Pointer; cb: Longint; pcbWritten: PLongint): HResult; virtual; stdcall; function Seek(dlibMove: Largeint; dwOrigin: Longint; out libNewPosition: Largeint): HResult; virtual; stdcall; function SetSize(libNewSize: Largeint): HResult; virtual; stdcall; function CopyTo(stm: IStream; cb: Largeint; out cbRead: Largeint; out cbWritten: Largeint): HResult; virtual; stdcall; function Commit(grfCommitFlags: Longint): HResult; virtual; stdcall; function Revert: HResult; virtual; stdcall; function LockRegion(libOffset: Largeint; cb: Largeint; dwLockType: Longint): HResult; virtual; stdcall; function UnlockRegion(libOffset: Largeint; cb: Largeint; dwLockType: Longint): HResult; virtual; stdcall; function Stat(out statstg: TStatStg; grfStatFlag: Longint): HResult; virtual; stdcall; { Bug fixed } function Clone(out stm: IStream): HResult; virtual; stdcall; property Stream: TStream read FStream; property StreamOwnership: TStreamOwnership read FOwnership write FOwnership; end; { TWidgetDesktop } TWidgetDesktop = class(TComponent) private function GetDesktopTop: Integer; function GetDesktopLeft: Integer; function GetDesktopHeight: Integer; function GetDesktopWidth: Integer; function GetDesktopRect: TRect; function GetWorkAreaRect: TRect; function GetWorkAreaHeight: Integer; function GetWorkAreaLeft: Integer; function GetWorkAreaTop: Integer; function GetWorkAreaWidth: Integer; function GetWidth: Integer; function GetHeight: Integer; public property DesktopRect: TRect read GetDesktopRect; property DesktopHeight: Integer read GetDesktopHeight; property DesktopLeft: Integer read GetDesktopLeft; property DesktopTop: Integer read GetDesktopTop; property DesktopWidth: Integer read GetDesktopWidth; property WorkAreaRect: TRect read GetWorkAreaRect; property WorkAreaHeight: Integer read GetWorkAreaHeight; property WorkAreaLeft: Integer read GetWorkAreaLeft; property WorkAreaTop: Integer read GetWorkAreaTop; property WorkAreaWidth: Integer read GetWorkAreaWidth; property Height: Integer read GetHeight; property Width: Integer read GetWidth; end; {.$METHODINFO OFF} var Desktop: TWidgetDesktop = nil; ToolTip: TWidgetToolTip = nil; var WidgetToolTipHandle: HWND = 0; { MakePointF } function MakePointF(const P: TPoint): TGPPointF; { MakeRectF } function MakeRectF(const R: TRect): TGPRectF; overload; { ChangeImageColor } procedure ChangeImageColor(ABitmap: TGPBitmap; Color: Cardinal); { ChangeImageOpacity } procedure ChangeImageOpacity(ABitmap: TGPBitmap; Opacity: Byte); { ChangeImage } procedure ChangeImage(ABitmap: TGPBitmap; Color: Cardinal; Opacity: Byte); { FindControl } function FindControl(Parent: TControl; Source: HWND): TWinControl; { CenterDesktop } procedure CenterDesktop(hDlg: HWND); { LoadFromResource } procedure LoadFromResource(const ResType, Resource: WideString; Stream: TStream); implementation var UniqueIndex: Integer = 0; TimeCaps: TTimeCaps; { CheckWin32VersionXP } function CheckWin32VersionXP(AMajor: Integer; AMinor: Integer = 0): Boolean; begin Result := (Win32MajorVersion > AMajor) or ((Win32MajorVersion = AMajor) and (Win32MinorVersion >= AMinor)); end; { CheckVersionXP } function CheckVersionXP: Boolean; begin Result := (Win32MajorVersion = 5) and (Win32MinorVersion = 1); end; { CheckVersionXPSP2 } function CheckVersionXPSP2: Boolean; begin Result := CheckVersionXP and (CompareText(Win32CSDVersion, 'Service Pack 2') >= 0); end; { CheckVersionXPAbove } function CheckVersionXPAbove: Boolean; begin Result := (Win32MajorVersion > 5) or ((Win32MajorVersion = 5) and (Win32MinorVersion > 1)); end; { InitWindowsVersion } procedure InitWindowsVersion; begin if CheckVersionXPAbove then WindowsVersion := WINDOWS_VISTA else if CheckVersionXPSP2 then WindowsVersion := WINDOWS_XP_SP2 else if CheckVersionXP then WindowsVersion := WINDOWS_XP else WindowsVersion := WINDOWS_OLD; end; { InitWidgetAtom } procedure InitWidgetAtom; begin WidgetAtom := GlobalAddAtom('Widget.WindowAtom.3.1'); end; { DoneWidgetAtom } procedure DoneWidgetAtom; begin GlobalDeleteAtom(WidgetAtom); end; { InitTimeCaps } procedure InitTimeCaps; begin timeGetDevCaps(@TimeCaps, SizeOf(TimeCaps)); timeBeginPeriod(TimeCaps.wPeriodMin); { Required for Sleep() function } end; { DoneTimeCaps } procedure DoneTimeCaps; begin timeEndPeriod(TimeCaps.wPeriodMin); end; { InitWidgetSystem } procedure InitWidgetSystem; begin InitWidgetAtom; InitWindowsVersion; InitTimeCaps; end; { DoneWidgetSystem } procedure DoneWidgetSystem; begin DoneTimeCaps; DoneWidgetAtom; end; { MakeUniqueName } function MakeUniqueName: TComponentName; begin Randomize; Result := 'Widget_' + IntToStr(UniqueIndex); end; { MakePointF } function MakePointF(const P: TPoint): TGPPointF; begin Result.X := P.X; Result.Y := P.Y; end; { MakeRectF } function MakeRectF(const R: TRect): TGPRectF; overload; begin Result.X := R.Left; Result.Y := R.Top; Result.Width := R.Right - R.Left; Result.Height := R.Bottom - R.Top; end; { ChangeImageDataOpacity } procedure ChangeImageDataOpacity(Data: TBitmapData; Opacity: Byte); var x, y: Cardinal; Pixel: PARGB; begin for y := 0 to Data.Height - 1 do begin Pixel := PARGB(Cardinal(Data.Scan0) + Data.Width * 4 * y); for x := 0 to Data.Width - 1 do begin Pixel^.A := Pixel^.A * Opacity shr $08; Inc(Pixel); end; end; end; { ChangeImageOpacity } procedure ChangeImageOpacity(ABitmap: TGPBitmap; Opacity: Byte); var Data: TBitmapData; R: TGPRect; begin if not IsAlphaPixelFormat(ABitmap.GetPixelFormat) then Exit; R := MakeRect(Rect(0, 0, ABitmap.GetWidth, ABitmap.GetHeight)); ABitmap.LockBits(R, ImageLockModeRead or ImageLockModeWrite, PixelFormat32bppARGB, Data); try ChangeImageDataOpacity(Data, Opacity); finally ABitmap.UnlockBits(Data); end; end; { ChangeImageDataColor } procedure ChangeImageDataColor(Data: TBitmapData; Color: Cardinal); var X, Y: Cardinal; Pixel: Widgets.PARGB; R, G, B: Byte; begin R := GetRValue(Color); G := GetGValue(Color); B := GetBValue(Color); for Y := 0 to Data.Height - 1 do begin Pixel := Widgets.PARGB(Cardinal(Data.Scan0) + Data.Width * 4 * Y); for X := 0 to Data.Width - 1 do begin Pixel^.R := Pixel^.R * R shr $07; Pixel^.G := Pixel^.G * G shr $07; Pixel^.B := Pixel^.B * B shr $07; //Pixel^.A := Pixel^.A * Opacity shr $08; Inc(Pixel); end; end; end; { ChangeImageColor } procedure ChangeImageColor(ABitmap: TGPBitmap; Color: Cardinal); var Data: TBitmapData; R: TGPRect; begin if not IsAlphaPixelFormat(ABitmap.GetPixelFormat) then Exit; R := MakeRect(Rect(0, 0, ABitmap.GetWidth, ABitmap.GetHeight)); ABitmap.LockBits(R, ImageLockModeRead or ImageLockModeWrite, PixelFormat32bppARGB, Data); try ChangeImageDataColor(Data, Color); finally ABitmap.UnlockBits(Data); end; end; { ChangeImageData } procedure ChangeImageData(Data: TBitmapData; Colorize: Cardinal; Opacity: Byte); var x, y: Cardinal; Pixel: PARGB; R, G, B: Byte; begin R := GetRValue(Colorize); G := GetGValue(Colorize); B := GetBValue(Colorize); for y := 0 to Data.Height - 1 do begin Pixel := PARGB(Cardinal(Data.Scan0) + Data.Width * 4 * y); for x := 0 to Data.Width - 1 do begin Pixel^.R := Pixel^.R * R shr $07; Pixel^.G := Pixel^.G * G shr $07; Pixel^.B := Pixel^.B * B shr $07; Pixel^.A := Pixel^.A * Opacity shr $08; Inc(Pixel); end; end; end; { ChangeImage } procedure ChangeImage(ABitmap: TGPBitmap; Color: Cardinal; Opacity: Byte); var Data: TBitmapData; R: TGPRect; begin if not IsAlphaPixelFormat(ABitmap.GetPixelFormat) then Exit; R := MakeRect(Rect(0, 0, ABitmap.GetWidth, ABitmap.GetHeight)); ABitmap.LockBits(R, ImageLockModeRead or ImageLockModeWrite, PixelFormat32bppARGB, Data); try ChangeImageData(Data, Color, Opacity); finally ABitmap.UnlockBits(Data); end; end; { ColorToRGB } function ColorToRGB(Color: TColor): Longint; begin if Color < 0 then Result := GetSysColor(Color and $000000FF) else Result := Color; end; { FindControl } function FindControl(Parent: TControl; Source: HWND): TWinControl; procedure FindSubControl(Parent: TControl; Source: HWND); var Child: HWND; Window: HWND; Control: TWinControl; begin if Assigned(Parent) then begin Child := GetWindow(Parent.Handle, GW_CHILD); if Child <> 0 then begin Window := GetWindow(Child, GW_HWNDLAST); while Window <> 0 do begin Control := TWinControl(GetPropW(Window, MakeIntAtomW(WidgetAtom))); if Source = Window then begin Result := Control; Break; end else if GetWindow(Window, GW_CHILD) <> 0 then FindSubControl(Control, Source); Window := GetWindow(Window, GW_HWNDPREV); end; end; end; end; begin Result := nil; FindSubControl(Parent, Source); end; { CenterDesktop } procedure CenterDesktop(hDlg: HWND); var B, R: TRect; X, Y: Integer; begin SystemParametersInfo(SPI_GETWORKAREA, 0, @R, 0); GetWindowRect(hDlg, B); X := (((R.Right - R.Left) - (B.Right - B.Left)) div 2); Y := (((R.Bottom - R.Top) - (B.Bottom - B.Top)) div 2); MoveWindow(hDlg, X, Y, B.Right - B.Left, B.Bottom - B.Top, True); end; { LoadFromResource } procedure LoadFromResource(const ResType, Resource: WideString; Stream: TStream); var hResInfo: HRSRC; hResData: HGLOBAL; dwResSize: Cardinal; PResData: PChar; dwTotal, dwSize: DWORD; szBuffer: array[0..16383] of Char; begin hResInfo := FindResourceW(MainInstance, PWideChar(Resource), PWideChar(ResType)); if hResInfo <> 0 then begin hResData := LoadResource(MainInstance, hResInfo); if hResData <> 0 then begin PResData := LockResource(hResData); if Assigned(PResData) then begin dwResSize := SizeOfResource(MainInstance, hResInfo); if Assigned(Stream) then begin dwTotal := 0; repeat FillChar(szBuffer, SizeOf(szBuffer), 0); dwSize := SizeOf(szBuffer); if dwTotal + dwSize > dwResSize then dwSize := dwResSize - dwTotal; System.Move(Pointer(PResData + dwTotal)^, szBuffer, dwSize); Stream.Write(szBuffer, dwSize); Inc(dwTotal, dwSize); until (dwTotal = dwResSize); Stream.Seek(0, soFromBeginning); end; UnlockResource(hResData); end; FreeResource(hResData); end; end; end; var WindowClassW: TWndClassW = ( style: 0; lpfnWndProc: @DefWindowProcW; cbClsExtra: 0; cbWndExtra: SizeOf(TObject); { Onemli. Bunu unutma! } hInstance: 0; hIcon: 0; hCursor: 0; hbrBackground: 0; lpszMenuName: nil; lpszClassName: 'TControlClass'); { WidgetWindowProc } function WidgetWindowProc(Wnd: HWND; uMsg: UINT; wParam, lParam: LongInt): LRESULT; stdcall; var Control: TControl; Msg: TWidgetMessage; CS: PCreateStructW; begin Result := 0; Msg.Wnd := Wnd; Msg.Msg := uMsg; Msg.WParam := wParam; Msg.LParam := lParam; Msg.Result := Integer(Result); Control := TControl(GetPropW(Wnd, MakeIntAtomW(WidgetAtom))); if Assigned(Control) then begin if uMsg = WM_NCDESTROY then begin if Assigned(Control.DefaultProc) then SetWindowLongW(Wnd, GWL_WNDPROC, LongInt(@Control.DefaultProc)); Control.WndProc(Msg); RemovePropW(Wnd, MakeIntAtomW(WidgetAtom)); end else Control.WndProc(Msg); end else begin if uMsg = WM_CREATE then begin CS := PCreateStructW(lParam); Control := TControl(CS^.lpCreateParams); if Assigned(Control) then Control.WndProc(Msg); end else Msg.Result := DefWindowProcW(Wnd, uMsg, wParam, lParam); end; Result := Msg.Result; end; { TControl } procedure TControl.AddToolTip; var ti: TOOLINFOW; begin if HandleAllocated and (WidgetToolTipHandle <> 0) then begin FillChar(ti, SizeOf(ti), 0); ti.cbSize := SizeOf(TOOLINFOW); ti.uFlags := TTF_IDISHWND or TTF_SUBCLASS; ti.hwnd := WidgetToolTipHandle;//GetToolTipManager;//FHandle;// ti.hinst := 0; ti.uId := FHandle; ti.lpszText := LPSTR_TEXTCALLBACKW; SendMessageW(WidgetToolTipHandle, TTM_ADDTOOLW, 0, Integer(@ti)); end; end; procedure TControl.CallDefaultProc(var Message: TWidgetMessage); begin if Assigned(FDefaultProc) and HandleAllocated then with Message do Result := CallWindowProcW(FDefaultProc, FHandle, Msg, WParam, LParam); end; procedure TControl.CallWndProc(var Message: TWidgetMessage); begin WndProc(Message); end; constructor TControl.Create(AOwner: TComponent); begin inherited Create(AOwner); Name := MakeUniqueName; FParent := nil; FEnabled := True; FHint := ''; //FWidth := 16; //FHeight := 16; Inc(UniqueIndex); end; procedure TControl.CreateHandle; begin if FHandle = 0 then begin CreateWnd; SetPropW(FHandle, MakeIntAtomW(WidgetAtom), THandle(Self)); if Parent <> nil then SetWindowPos(FHandle, HWND_TOP, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE); end; end; procedure TControl.CreateParams(var Params: TCreateParamsW); begin FillChar(Params, SizeOf(Params), 0); with Params do begin Param := Self; Caption := FText; Style := WS_CHILD or WS_CLIPSIBLINGS; if not FEnabled then Style := Style or WS_DISABLED; if FTabStop then Style := Style or WS_TABSTOP; X := FLeft; Y := FTop; Width := FWidth; Height := FHeight; if Parent <> nil then WndParent := Parent.GetHandle else WndParent := FParentWindow; WindowClass.style := CS_VREDRAW or CS_HREDRAW or CS_DBLCLKS;// + CS_NOCLOSE; WindowClass.lpfnWndProc := @DefWindowProcW; WindowClass.hCursor := LoadCursor(0, IDC_ARROW); WindowClass.hbrBackground := COLOR_WINDOW + 1;//COLOR_BTNFACE + 1;// WindowClass.hInstance := HInstance; WindowClass.cbWndExtra := SizeOf(TControl); StrPCopyW(WinClassName, Self.ClassName); end; end; procedure TControl.CreateSubClass(var Params: TCreateParamsW; ControlClassName: PWideChar); const CS_OFF = CS_OWNDC or CS_CLASSDC or CS_PARENTDC or CS_GLOBALCLASS; CS_ON = CS_VREDRAW or CS_HREDRAW; var SaveInstance: THandle; begin if ControlClassName <> nil then with Params do begin SaveInstance := WindowClass.hInstance; if not GetClassInfoW(HInstance, ControlClassName, WindowClass) and not GetClassInfoW(0, ControlClassName, WindowClass) and not GetClassInfoW(MainInstance, ControlClassName, WindowClass) then GetClassInfoW(WindowClass.hInstance, ControlClassName, WindowClass); WindowClass.hInstance := SaveInstance; WindowClass.style := WindowClass.style and not CS_OFF or CS_ON; StrCopyW(WinClassName, ControlClassName); end; end; procedure TControl.CreateWindowHandle(const Params: TCreateParamsW); begin with Params do FHandle := CreateWindowExW(ExStyle, WinClassName, Caption, Style, X, Y, Width, Height, WndParent, 0, WindowClass.hInstance, Param); end; procedure TControl.CreateWnd; const SParentRequired = 'Parent Required %s'; var Params: TCreateParamsW; TempClass: TWndClassW; ClassRegistered: Boolean; begin CreateParams(Params); with Params do begin if (WndParent = 0) and (Style and WS_CHILD <> 0) then if (Owner <> nil) and (csReading in Owner.ComponentState) and (Owner is TControl) then WndParent := TControl(Owner).FHandle // ??? else raise EInvalidOperation.CreateFmt(SParentRequired, [Name]); FDefaultProc := WindowClass.lpfnWndProc; ClassRegistered := GetClassInfoW(WindowClass.hInstance, WinClassName, TempClass); if not ClassRegistered then begin if ClassRegistered then Windows.UnregisterClassW(WinClassName, WindowClass.hInstance); WindowClass.lpfnWndProc := @WidgetWindowProc; WindowClass.lpszClassName := WinClassName; if Windows.RegisterClassW(WindowClass) = 0 then RaiseLastOSError; end; CreateWindowHandle(Params); if FHandle = 0 then RaiseLastOSError; { EDIT, BUTTON gibi SubClasslar icin. } if ClassRegistered and (GetWindowLongW(FHandle, GWL_WNDPROC) <> Integer(@WidgetWindowProc)) then begin FDefaultProc := TempClass.lpfnWndProc; SetWindowLongW(FHandle, GWL_WNDPROC, Integer(@WidgetWindowProc)); end; if (GetWindowLongW(FHandle, GWL_STYLE) and WS_CHILD <> 0) and (GetWindowLongW(FHandle, GWL_ID) = 0) then SetWindowLongW(FHandle, GWL_ID, FHandle); end; StrDisposeW(FText); FText := nil; end; procedure TControl.DelToolTip; var ti: TOOLINFOW; begin if HandleAllocated and (WidgetToolTipHandle <> 0) then begin FillChar(ti, SizeOf(ti), 0); ti.cbSize := SizeOf(TOOLINFOW); ti.uFlags := TTF_IDISHWND; ti.hwnd := WidgetToolTipHandle;//GetToolTipManager;//FHandle;// ti.uId := FHandle; SendMessageW(WidgetToolTipHandle, TTM_DELTOOLW, 0, Integer(@ti)); end; end; destructor TControl.Destroy; begin if Assigned(FText) then StrDisposeW(FText); inherited Destroy; end; procedure TControl.DestroyHandle; begin if FHandle <> 0 then DestroyWnd; end; procedure TControl.DestroyWindowHandle; begin if not Windows.DestroyWindow(FHandle) then RaiseLastOSError; FHandle := 0; end; procedure TControl.DestroyWnd; begin DestroyWindowHandle; end; function TControl.FirstChild: TControl; var Child, Window: HWND; begin Result := nil; Child := GetWindow(FHandle, GW_CHILD); if Child <> 0 then begin Window := GetWindow(Child, GW_HWNDFIRST); if Window <> 0 then Result := TControl(GetPropW(Window, MakeIntAtomW(WidgetAtom))); end; end; function TControl.GetClientRect: TRect; begin Windows.GetClientRect(FHandle, Result); end; function TControl.GetControl: TControl; begin Result := Self; end; function TControl.GetControlCount: Integer; var Child: HWND; begin Result := 0; Child := GetWindow(FHandle, GW_CHILD); while Child <> 0 do begin Inc(Result); Child := GetWindow(Child, GW_HWNDNEXT); end; end; function TControl.GetExStyle: Cardinal; begin Result := 0; if HandleAllocated then Result := GetWindowLong(Self.FHandle, GWL_EXSTYLE); end; function TControl.GetHandle: HWND; begin HandleNeeded; Result := FHandle; end; function TControl.GetHint: WideString; begin Result := FHint; end; function TControl.GetShowHint: Boolean; begin Result := FShowHint; end; function TControl.GetStyle: Cardinal; begin Result := 0; if HandleAllocated then Result := GetWindowLong(Self.FHandle, GWL_STYLE); end; function TControl.GetText: WideString; var Len: Integer; begin Len := GetTextLen; SetString(Result, PWideChar(nil), Len); if Len <> 0 then GetTextBuf(PWideChar(Result), Len + 1); end; function TControl.GetTextBuf(Buffer: PWideChar; BufSize: Integer): Integer; begin Result := Perform(WM_GETTEXT, BufSize, Longint(Buffer)); end; function TControl.GetTextLen: Integer; begin Result := Perform(WM_GETTEXTLENGTH, 0, 0); end; function TControl.GetWindowRect: TRect; begin Result := Classes.Rect(FLeft, FTop, FLeft + FWidth, FTop + FHeight); end; procedure TControl.Grow(AWidth, AHeight: Integer); begin if (FWidth <> AWidth) or (FHeight <> AHeight) then begin FWidth := AWidth; FHeight := AHeight; if HandleAllocated then SetWindowPos(FHandle, 0, 0, 0, FWidth, FHeight, SWP_NOACTIVATE or SWP_NOZORDER or SWP_NOMOVE); end; end; function TControl.HandleAllocated: Boolean; begin Result := IsWindow(FHandle); end; procedure TControl.HandleNeeded; begin if FHandle = 0 then begin if Parent <> nil then Parent.HandleNeeded; CreateHandle; end; end; function TControl.HasChildren: Boolean; begin Result := False; if HandleAllocated then Result := GetWindow(FHandle, GW_CHILD) <> 0; end; procedure TControl.Hide; begin Visible := False; end; function TControl.LastChild: TControl; var Child, Window: HWND; begin Result := nil; Child := GetWindow(FHandle, GW_CHILD); if Child <> 0 then begin Window := GetWindow(Child, GW_HWNDLAST); if Window <> 0 then Result := TControl(GetPropW(Window, MakeIntAtomW(WidgetAtom))); end; end; procedure TControl.ModifyStyle(const ClearValue, SetValue: DWORD); begin { if Style and ClearValue <> 0 then Style := Style and not ClearValue; if Style and SetValue = 0 then Style := Style or SetValue; if HandleAllocated then begin SetWindowLong(FHandle, GWL_STYLE, FStyle); SetWindowPos(FHandle, 0, 0, 0, 0, 0, SWP_NOACTIVATE or SWP_NOZORDER or SWP_NOMOVE or SWP_NOSIZE or SWP_FRAMECHANGED); end; } end; procedure TControl.Move(ALeft, ATop: Integer); begin if (FLeft <> ALeft) or (FTop <> ATop) then begin FLeft := ALeft; FTop := ATop; if HandleAllocated then SetWindowPos(FHandle, 0, FLeft, FTop, 0, 0, SWP_NOACTIVATE or SWP_NOZORDER or SWP_NOSIZE); end; end; function TControl.NextChild(const Current: TControl): TControl; var Window: HWND; begin Result := nil; if Assigned(Current) then begin Window := GetWindow(Current.FHandle, GW_HWNDNEXT); if Window <> 0 then Result := TControl(GetPropW(Window, MakeIntAtomW(WidgetAtom))); end; end; procedure TControl.Paint; begin end; function TControl.Perform(Msg: Cardinal; WParam, LParam: Integer): Longint; var Message: TWidgetMessage; begin Message.Wnd := FHandle; Message.Msg := Msg; Message.WParam := WParam; Message.LParam := LParam; Message.Result := 0; if Self <> nil then WndProc(Message); Result := Message.Result; end; function TControl.PrevChild(const Current: TControl): TControl; var Window: HWND; begin Result := nil; if Assigned(Current) then begin Window := GetWindow(Current.FHandle, GW_HWNDPREV); if Window <> 0 then Result := TControl(GetPropW(Window, MakeIntAtomW(WidgetAtom))); end; end; procedure TControl.Refresh; begin Repaint; end; procedure TControl.Repaint; begin try Paint; finally end; end; procedure TControl.SetBounds(ALeft, ATop, AWidth, AHeight: Integer); begin if HandleAllocated then begin FLeft := ALeft; FTop := ATop; FWidth := AWidth; FHeight := AHeight; MoveWindow(FHandle, FLeft, FTop, FWidth, FHeight, True); end; end; procedure TControl.SetClientHeight(const Value: Integer); begin FClientHeight := Value; end; procedure TControl.SetClientOrigin(const Value: TPoint); begin FClientOrigin := Value; end; procedure TControl.SetClientRect(const Value: TRect); begin FLeft := Value.Left; FTop := Value.Top; FWidth := Value.Right - FLeft; FHeight := Value.Bottom - FTop; if HandleAllocated then SetBounds(FLeft, FTop, FWidth, FHeight); end; procedure TControl.SetClientWidth(const Value: Integer); begin FClientWidth := Value; end; procedure TControl.SetCursor(const Value: HCURSOR); begin if FCursor <> Value then begin if FCursor > 0 then DestroyCursor(FCursor); FCursor := Value; end; end; procedure TControl.SetEnabled(const Value: Boolean); begin if FEnabled <> Value then begin FEnabled := Value; if HandleAllocated then EnableWindow(FHandle, FEnabled); end; end; procedure TControl.SetExStyle(const Value: Cardinal); begin FExStyle := Value; if HandleAllocated then SetWindowLong(Self.FHandle, GWL_EXSTYLE, FExStyle); end; procedure TControl.SetHeight(const Value: Integer); begin if FHeight <> Value then begin FHeight := Value; if HandleAllocated then SetWindowPos(FHandle, 0, 0, 0, FWidth, FHeight, SWP_NOACTIVATE or SWP_NOZORDER or SWP_NOMOVE); end; end; procedure TControl.SetHint(const Value: WideString); var ti: TOOLINFOW; begin if HandleAllocated and (WidgetToolTipHandle <> 0) then begin FHint := Value; if FShowHint then begin FillChar(ti, SizeOf(ti), 0); ti.cbSize := SizeOf(TOOLINFOW); ti.uFlags := TTF_IDISHWND; ti.hwnd := WidgetToolTipHandle;//GetToolTipManager;//FHandle;// ti.uId := FHandle; ti.lpszText := LPSTR_TEXTCALLBACKW; SendMessageW(WidgetToolTipHandle, TTM_UPDATETIPTEXTW, 0, Integer(@ti)); end; end; end; procedure TControl.SetLeft(const Value: Integer); begin if FLeft <> Value then begin FLeft := Value; if HandleAllocated then SetWindowPos(FHandle, 0, FLeft, FTop, 0, 0, SWP_NOACTIVATE or SWP_NOZORDER or SWP_NOSIZE); end; end; procedure TControl.SetParent(AParent: TControl); begin FParent := AParent; end; procedure TControl.SetParentWindow(const Value: HWND); begin FParentWindow := Value; end; procedure TControl.SetShowHint(const Value: Boolean); begin if FShowHint <> Value then begin FShowHint := Value; if FShowHint then AddToolTip else DelToolTip; end; end; procedure TControl.SetStyle(const Value: Cardinal); begin FStyle := Value; if HandleAllocated then SetWindowLong(Self.FHandle, GWL_STYLE, FStyle); end; procedure TControl.SetText(const Value: WideString); begin if GetText <> Value then SetTextBuf(PWideChar(Value)); end; procedure TControl.SetTextBuf(Buffer: PWideChar); begin Perform(WM_SETTEXT, 0, Longint(Buffer)); end; procedure TControl.SetTop(const Value: Integer); begin if FTop <> Value then begin FTop := Value; if HandleAllocated then SetWindowPos(FHandle, 0, FLeft, FTop, 0, 0, SWP_NOACTIVATE or SWP_NOZORDER or SWP_NOSIZE); end; end; procedure TControl.SetVisible(const Value: Boolean); const CmdShow: array[Boolean] of Integer = (SW_HIDE, SW_SHOW); begin if FVisible <> Value then begin FVisible := Value; ShowWindow(Handle, CmdShow[FVisible]); { Artik Handle gecerli olsun. } end; end; procedure TControl.SetWidth(const Value: Integer); begin if FWidth <> Value then begin FWidth := Value; if HandleAllocated then SetWindowPos(FHandle, 0, 0, 0, FWidth, FHeight, SWP_NOACTIVATE or SWP_NOZORDER or SWP_NOMOVE); end; end; procedure TControl.Show; begin Visible := True; end; procedure TControl.Update; begin end; procedure TControl.WMCancelMode(var Message: TWidgetMessage); begin if Message.Wnd > 0 then; end; procedure TControl.WMCreate(var Message: TWidgetMessage); begin if FHandle = 0 then FHandle := Message.Wnd; end; procedure TControl.WMCtlColor(var Message: TWidgetMessage); begin if Assigned(Parent) and Parent.HandleAllocated then with Message do Result := SendMessageW(Parent.Handle, Msg, WParam, LParam); end; procedure TControl.WMDestroy(var Message: TWidgetMessage); begin end; procedure TControl.WMGetDlgCode(var Message: TWidgetMessage); begin with Message do Result := DLGC_WANTALLKEYS; end; procedure TControl.WMGetText(var Message: TWidgetMessage); var P: PWideChar; begin with Message do begin if FText <> nil then P := FText else P := ''; Result := StrLenW(StrLCopyW(PWideChar(LParam), P, WParam - 1)); end; end; procedure TControl.WMGetTextLength(var Message: TWidgetMessage); begin with Message do if FText = nil then Result := 0 else Result := StrLenW(FText); end; procedure TControl.WMHScroll(var Message: TWidgetMessage); begin if Assigned(Parent) and Parent.HandleAllocated then with Message do Result := SendMessageW(Parent.Handle, Msg, WParam, LParam); end; procedure TControl.WMKillFocus(var Message: TWidgetMessage); begin if Assigned(FOnKillFocus) then FOnKillFocus(Self); end; procedure TControl.WMMouseDown(var Message: TWidgetMessage); begin with Message do begin if Assigned(FOnMouseDown) then FOnMouseDown(Self, WParam, SmallInt(LParamLo), SmallInt(LParamHi)); FIsClicked := (WParam and MK_LBUTTON) <> 0; end; end; procedure TControl.WMMouseEnter(var Message: TWidgetMessage); begin FInWindow := True; with Message do if Assigned(FOnMouseEnter) then FOnMouseEnter(Self, WParam, LParamLo, LParamHi); end; procedure TControl.WMMouseHover(var Message: TWidgetMessage); begin FInWindow := True; with Message do if Assigned(FOnMouseHover) then FOnMouseHover(Self, WParam, LParamLo, LParamHi); end; procedure TControl.WMMouseLeave(var Message: TWidgetMessage); begin FInWindow := False; with Message do if Assigned(FOnMouseLeave) then FOnMouseLeave(Self, WParam, LParamLo, LParamHi); end; procedure TControl.WMMouseMove(var Message: TWidgetMessage); var Event: TTrackMouseEvent; begin if Assigned(FOnMouseMove) then with Message do FOnMouseMove(Self, WParam, LParamLo, LParamHi); with Message do begin if not FInWindow then begin FInWindow := True; Event.cbSize := SizeOf(TTrackMouseEvent); Event.dwFlags := TME_LEAVE or TME_HOVER; Event.hwndTrack := Wnd; Event.dwHoverTime := 100; _TrackMouseEvent(@Event); PostMessageW(Wnd, WM_MOUSEENTER, 0, 0); end; end; end; procedure TControl.WMMouseUp(var Message: TWidgetMessage); var R: TRect; P: TPoint; Param: DWORD; begin with Message do begin Param := WParam; case Msg of WM_LBUTTONUP: Param := Param or MK_LBUTTON; WM_RBUTTONUP: Param := Param or MK_RBUTTON; WM_MBUTTONUP: Param := Param or MK_MBUTTON; end; if Assigned(FOnMouseUp) then FOnMouseUp(Self, Param, SmallInt(LParamLo), SmallInt(LParamHi)); if FIsClicked and ((WParam and MK_LBUTTON) = 0) and Assigned(FOnClick) then begin Windows.GetClientRect(Wnd, R); MapWindowPoints(Wnd, HWND_DESKTOP, R, 2); GetCursorPos(P); if PtInRect(R, P) then begin FOnClick(Self, Param, SmallInt(LParamLo), SmallInt(LParamHi)); FIsClicked := False; end; end; end; end; procedure TControl.WMMouseWheel(var Message: TWidgetMessage); begin with Message do if Assigned(FOnMouseWheel) then FOnMouseWheel(Self, WParamLo, WParamHi, LParamLo, LParamHi); end; procedure TControl.WMMove(var Message: TWidgetMessage); begin { Guzel bir bug daha buldum. Bug Fixed! } FLeft := SmallInt(Message.LParamLo); FTop := SmallInt(Message.LParamHi); with Message do begin FClientOrigin.X := SmallInt(LParamLo); FClientOrigin.Y := SmallInt(LParamHi); end; if Assigned(FOnMove) then with Message do FOnMove(Self, SmallInt(LParamLo), SmallInt(LParamHi)); end; procedure TControl.WMMoving(var Message: TWidgetMessage); begin if Assigned(FOnMoving) then with Message do FOnMoving(Self, WParam, PRect(LParam)); end; procedure TControl.WMNCCreate(var Message: TWidgetMessage); begin with Message do Result := Integer(True); end; procedure TControl.WMNCHitTest(var Message: TWidgetMessage); begin end; procedure TControl.WMNotify(var Message: TWidgetMessage); begin if Assigned(Parent) and Parent.HandleAllocated then with Message do Result := SendMessageW(Parent.Handle, Msg, WParam, LParam); end; procedure TControl.WMSetCursor(var Message: TWidgetMessage); begin with Message do case LoWord(LParam) of HTCLIENT: if FCursor > 0 then begin Windows.SetCursor(FCursor); Result := Integer(True); end; //HTERROR:; end; end; procedure TControl.WMSetFocus(var Message: TWidgetMessage); begin if Assigned(FOnSetFocus) then FOnSetFocus(Self); end; procedure TControl.WMSetText(var Message: TWidgetMessage); var P: PWideChar; begin P := StrNewW(PWideChar(Message.LParam)); StrDisposeW(FText); FText := P; end; procedure TControl.WMShowWindow(var Message: TWidgetMessage); begin end; procedure TControl.WMSize(var Message: TWidgetMessage); var R: TRect; begin R := GetWindowRect; { Guzel bir bug daha buldum. Bug Fixed! } FWidth := R.Right - R.Left; FHeight := R.Bottom - R.Top; with Message do begin FClientWidth := SmallInt(LParamLo); FClientHeight := SmallInt(LParamHi); end; if Assigned(FOnSize) then with Message do FOnSize(Self, WParam, SmallInt(LParamLo), SmallInt(LParamHi)); end; procedure TControl.WMSizing(var Message: TWidgetMessage); begin if Assigned(FOnSizing) then with Message do FOnSizing(Self, WParam, PRect(LParam)^); end; procedure TControl.WMSysTimer(var Message: TWidgetMessage); begin if Assigned(FOnSysTimer) then FOnSysTimer(Self); end; procedure TControl.WMTimer(var Message: TWidgetMessage); begin end; procedure TControl.WMVScroll(var Message: TWidgetMessage); begin if Assigned(Parent) and Parent.HandleAllocated then with Message do Result := SendMessageW(Parent.Handle, Msg, WParam, LParam); end; procedure TControl.WMWindowPosChanged(var Message: TWidgetMessage); begin end; procedure TControl.WMWindowPosChanging(var Message: TWidgetMessage); begin end; procedure TControl.WndProc(var Message: TWidgetMessage); begin case Message.Msg of WM_CTLCOLORMSGBOX..WM_CTLCOLORSTATIC: begin WMCtlColor(Message); Exit; end; WM_NOTIFY: WMNotify(Message); WM_HSCROLL: WMHScroll(Message); WM_VSCROLL: WMVScroll(Message); WM_GETTEXT: WMGetText(Message); WM_GETTEXTLENGTH: WMGetTextLength(Message); WM_SETTEXT: WMSetText(Message); WM_SHOWWINDOW: begin WMShowWindow(Message); Exit; end; WM_MOUSEWHEEL: begin WMMouseWheel(Message); Exit; end; WM_LBUTTONDOWN, WM_MBUTTONDOWN, WM_RBUTTONDOWN: begin WMMouseDown(Message); //Exit; end; WM_LBUTTONUP, WM_MBUTTONUP, WM_RBUTTONUP: begin WMMouseUp(Message); //Exit; end; WM_WINDOWPOSCHANGED: begin WMWindowPosChanged(Message); //Exit; end; WM_WINDOWPOSCHANGING: begin WMWindowPosChanging(Message); Exit; end; WM_MOVE: begin WMMove(Message); Exit; end; WM_MOVING: begin WMMoving(Message); Message.Result := Integer(True); Exit; end; WM_SIZE: begin WMSize(Message); Exit; end; WM_SIZING: begin WMSizing(Message); Message.Result := Integer(True); Exit; end; WM_MOUSEENTER: begin WMMouseEnter(Message); Exit; end; WM_MOUSEMOVE: begin WMMouseMove(Message); //Exit; end; WM_MOUSELEAVE: begin WMMouseLeave(Message); Exit; end; WM_MOUSEHOVER: begin WMMouseHover(Message); //Exit; end; WM_SETCURSOR: begin WMSetCursor(Message); if Message.Result = Integer(True) then Exit; end; WM_CANCELMODE: begin WMCancelMode(Message); //Exit; end; end; CallDefaultProc(Message); end; { TWidgetSolidBrush } procedure TWidgetSolidBrush.Allocate; begin FHandle := TGPSolidBrush.Create($FF000000); end; constructor TWidgetSolidBrush.Create; begin inherited Create; Allocate; end; destructor TWidgetSolidBrush.Destroy; begin Release; inherited Destroy; end; function TWidgetSolidBrush.GetColor: Cardinal; begin FHandle.GetColor(Result); end; function TWidgetSolidBrush.GetOpacity: Byte; begin Result := Byte(GetColor shr AlphaShift); end; procedure TWidgetSolidBrush.Release; begin if Assigned(FHandle) then FreeAndNil(FHandle); end; procedure TWidgetSolidBrush.SetColor(const Value: Cardinal); begin if GetColor <> Value then FHandle.SetColor(Value); end; procedure TWidgetSolidBrush.SetOpacity(const Value: Byte); begin if GetOpacity <> Value then FHandle.SetColor((GetColor() and $00FFFFFF) or (Cardinal(Value) shl AlphaShift)); end; { TWidgetPen } procedure TWidgetPen.Allocate; begin FHandle := TGPPen.Create(FColor, FWidth); FHandle.SetDashStyle(FStyle); FHandle.SetAlignment(PenAlignmentInset); //FHandle.SetLineJoin(LineJoinRound); end; constructor TWidgetPen.Create; begin inherited Create; FColor := $FF000000; FWidth := 1.0; FOpacity := $FF; FStyle := DashStyleSolid; Allocate; end; destructor TWidgetPen.Destroy; begin Release; inherited Destroy; end; procedure TWidgetPen.Release; begin if Assigned(FHandle) then FreeAndNil(FHandle); end; procedure TWidgetPen.SetColor(const Value: Cardinal); begin if FColor <> Value then begin FColor := Value; FHandle.SetColor(FColor); end; end; procedure TWidgetPen.SetOpacity(const Value: Byte); begin if FOpacity <> Value then begin FOpacity := Value; FColor := (FColor and $00FFFFFF) or (Cardinal(FOpacity) shl AlphaShift); FHandle.SetColor(FColor); end; end; procedure TWidgetPen.SetProps(const AColor, AWidth: Integer; AStyle: TDashStyle); begin Release; FColor := AColor; FWidth := AWidth; FStyle := AStyle; Allocate; end; procedure TWidgetPen.SetStyle(const Value: TDashStyle); begin if FStyle <> Value then begin FStyle := Value; FHandle.SetDashStyle(FStyle); end; end; procedure TWidgetPen.SetWidth(const Value: Single); begin if FWidth <> Value then begin FWidth := Value; FHandle.SetWidth(FWidth); end; end; { TWidgetStringFormat } procedure TWidgetStringFormat.Allocate; begin FHandle := TGPStringFormat.Create; end; constructor TWidgetStringFormat.Create; begin inherited Create; FFormatFlags := 0; FAlignment := StringAlignmentNear; FHotkeyPrefix := HotkeyPrefixNone; FLineAlignment := StringAlignmentNear; FTrimming := StringTrimmingNone; Allocate; end; destructor TWidgetStringFormat.Destroy; begin Release; inherited Destroy; end; procedure TWidgetStringFormat.Release; begin if Assigned(FHandle) then FreeAndNil(FHandle); end; procedure TWidgetStringFormat.SetAlignment(const Value: TStringAlignment); begin if FAlignment <> Value then begin FAlignment := Value; FHandle.SetAlignment(FAlignment); end; end; procedure TWidgetStringFormat.SetFormatFlags(const Value: Integer); begin if FFormatFlags <> Value then begin FFormatFlags := Value; FHandle.SetFormatFlags(FFormatFlags); end; end; procedure TWidgetStringFormat.SetHotkeyPrefix(const Value: THotkeyPrefix); begin if FHotkeyPrefix <> Value then begin FHotkeyPrefix := Value; FHandle.SetHotkeyPrefix(FHotkeyPrefix); end; end; procedure TWidgetStringFormat.SetLineAlignment( const Value: TStringAlignment); begin if FLineAlignment <> Value then begin FLineAlignment := Value; FHandle.SetLineAlignment(FLineAlignment); end; end; procedure TWidgetStringFormat.SetTrimming(const Value: TStringTrimming); begin if FTrimming <> Value then begin FTrimming := Value; FHandle.SetTrimming(FTrimming); end; end; { TWidgetFont } procedure TWidgetFont.Allocate; begin FHandle := TGPFont.Create(FName, FSize, FStyle); end; constructor TWidgetFont.Create; begin inherited Create; FName := 'Arial'; FSize := 10; FStyle := FontStyleRegular; FBrush := TWidgetSolidBrush.Create; FFormat := TWidgetStringFormat.Create; Allocate; end; destructor TWidgetFont.Destroy; begin FFormat.Free; FBrush.Free; Release; inherited Destroy; end; function TWidgetFont.GetColor: Cardinal; begin Result := FBrush.Color; end; function TWidgetFont.GetOpacity: Byte; begin Result := FBrush.Opacity; end; procedure TWidgetFont.Reallocate; begin Release; Allocate; end; procedure TWidgetFont.Release; begin if Assigned(FHandle) then FreeAndNil(FHandle); end; procedure TWidgetFont.SetColor(const Value: Cardinal); begin if FBrush.Color <> Value then FBrush.SetColor(Value); end; procedure TWidgetFont.SetName(const Value: TFontName); begin if FName <> Value then begin FName := Value; Reallocate; end; end; procedure TWidgetFont.SetOpacity(const Value: Byte); begin if FBrush.Opacity <> Value then FBrush.Opacity := Value; end; procedure TWidgetFont.SetProps(const AName: string; ASize, AStyle, AColor: Integer; AAlignment, ALineAlignment: StringAlignment); begin Release; FName := AName; FSize := ASize; FStyle := AStyle; FBrush.Color := AColor; FFormat.Alignment := AAlignment; FFormat.LineAlignment := ALineAlignment; Allocate; end; procedure TWidgetFont.SetSize(const Value: Integer); begin if FSize <> Value then begin FSize := Value; Reallocate; end; end; procedure TWidgetFont.SetStyle(const Value: Integer); begin if FStyle <> Value then begin FStyle := Value; Reallocate; end; end; { TWidgetImage } procedure TWidgetImage.Allocate; begin if FileExists(FFileName) then FHandle := TGPBitmap.Create(FFileName); end; procedure TWidgetImage.AllocateAdapter; var Stream: TStream; begin Stream := TMemoryStream.Create; try LoadFromResource('PNG', FFileName, Stream); FHandle := TGPBitmap.Create(TStreamAdapter.Create(Stream, soOwned) as IStream); finally //Stream.Free; { soOwned } end; end; constructor TWidgetImage.Create(const FileName: WideString; Option: TWidgetImageFrom = wifFile); begin inherited Create; FFileName := FileName; if Option = wifFile then Allocate else AllocateAdapter; end; destructor TWidgetImage.Destroy; begin Release; inherited Destroy; end; function TWidgetImage.GetHeight: Cardinal; begin Result := 0; if Assigned(FHandle) then Result := FHandle.GetHeight(); end; function TWidgetImage.GetWidth: Cardinal; begin Result := 0; if Assigned(FHandle) then Result := FHandle.GetWidth(); end; procedure TWidgetImage.LoadFromFile(const FileName: WideString); begin Release; FFileName := FileName; Allocate; end; procedure TWidgetImage.Release; begin if Assigned(FHandle) then FreeAndNil(FHandle); end; { TWidgetCanvas } procedure TWidgetCanvas.Allocate; begin FBitmap := TGPBitmap.Create(FWidth, FHeight, PixelFormat32bppARGB); FGraphics := TGPGraphics.Create(FBitmap); { Vista da bunu yapmayi unutma } if WindowsVersion >= WINDOWS_VISTA then FGraphics.SetTextRenderingHint(TextRenderingHintAntiAliasGridFit) else FGraphics.SetTextRenderingHint(TextRenderingHintSystemDefault); FCachedBitmap := TGPCachedBitmap.Create(FBitmap, FGraphics); end; procedure TWidgetCanvas.Clear; begin FGraphics.Clear($00000000); end; constructor TWidgetCanvas.Create(const AWidth, AHeight: Integer); begin inherited Create; FWidth := AWidth; FHeight := AHeight; Allocate; FFont := TWidgetFont.Create; FBrush := TWidgetSolidBrush.Create; FPen := TWidgetPen.Create; end; destructor TWidgetCanvas.Destroy; begin FBrush.Free; FPen.Free; FFont.Free; Release; inherited Destroy; end; procedure TWidgetCanvas.DrawArc(const Rect: TGPRect; StartAngle, SweepAngle: Single); begin FGraphics.DrawArc(FPen.Handle, Rect, StartAngle, SweepAngle); end; procedure TWidgetCanvas.DrawArc(const Rect: TRect; StartAngle, SweepAngle: Single); begin FGraphics.DrawArc(FPen.Handle, MakeRect(Rect), StartAngle, SweepAngle); end; procedure TWidgetCanvas.DrawArc(X, Y, Width, Height: Integer; StartAngle, SweepAngle: Single); begin FGraphics.DrawArc(FPen.Handle, X, Y, Width, Height, StartAngle, SweepAngle); end; procedure TWidgetCanvas.DrawEllipse(const Rect: TRect); begin FGraphics.DrawEllipse(FPen.Handle, MakeRect(Rect)); end; procedure TWidgetCanvas.DrawEllipse(X, Y, Width, Height: Integer); begin FGraphics.DrawEllipse(FPen.Handle, X, Y, Width, Height); end; procedure TWidgetCanvas.DrawEllipse(const Rect: TGPRect); begin FGraphics.DrawEllipse(FPen.Handle, Rect); end; procedure TWidgetCanvas.DrawImage(Image: TGPBitmap; X, Y, Width, Height: Integer); begin FGraphics.DrawImage(Image, X, Y, Width, Height); end; procedure TWidgetCanvas.DrawImage(Image: TGPBitmap; X, Y, Width, Height: Integer; Opacity: Byte); begin ChangeImageOpacity(Image, Opacity); FGraphics.DrawImage(Image, X, Y, Width, Height); end; procedure TWidgetCanvas.DrawLine(const P1, P2: TGPPoint); begin FGraphics.DrawLine(FPen.Handle, P1, P2); end; procedure TWidgetCanvas.DrawLine(const P1, P2: TPoint); begin FGraphics.DrawLine(FPen.Handle, MakePoint(P1.X, P1.Y), MakePoint(P2.X, P2.Y)); end; procedure TWidgetCanvas.DrawLine(X1, Y1, X2, Y2: Integer); begin FGraphics.DrawLine(FPen.Handle, X1, Y1, X2, Y2); end; procedure TWidgetCanvas.DrawLines(Points: PGPPoint; Count: Integer); begin FGraphics.DrawLines(FPen.Handle, Points, Count); end; procedure TWidgetCanvas.DrawPie(const Rect: TRect; StartAngle, SweepAngle: Single); begin FGraphics.DrawPie(FPen.Handle, MakeRect(Rect), StartAngle, SweepAngle); end; procedure TWidgetCanvas.DrawPie(X, Y, Width, Height: Integer; StartAngle, SweepAngle: Single); begin FGraphics.DrawPie(FPen.Handle, X, Y, Width, Height, StartAngle, SweepAngle); end; procedure TWidgetCanvas.DrawPie(const Rect: TGPRect; StartAngle, SweepAngle: Single); begin FGraphics.DrawPie(FPen.Handle, Rect, StartAngle, SweepAngle); end; procedure TWidgetCanvas.DrawRectangle(X, Y, Width, Height: Integer); begin FGraphics.DrawRectangle(FPen.Handle, X, Y, Width, Height); end; procedure TWidgetCanvas.DrawRectangle(const Rect: TGPRect); begin FGraphics.DrawRectangle(FPen.Handle, Rect); end; procedure TWidgetCanvas.DrawRectangle(const Rect: TRect); begin FGraphics.DrawRectangle(FPen.Handle, MakeRect(Rect)); end; procedure TWidgetCanvas.DrawRectangles(Rects: PGPRect; Count: Integer); begin FGraphics.DrawRectangles(FPen.Handle, Rects, Count); end; procedure TWidgetCanvas.DrawString(const Text: WideString; X, Y: Integer); begin FGraphics.DrawString(Text, Length(Text), FFont.Handle, MakePoint(X * 1.00, Y * 1.00), FFont.Format.Handle, FFont.Brush.Handle); end; procedure TWidgetCanvas.DrawString(const Text: WideString; R: TRect); begin FGraphics.DrawString(Text, Length(Text), FFont.Handle, MakeRectF(R), FFont.Format.Handle, FFont.Brush.Handle); end; procedure TWidgetCanvas.DrawString(const Text: WideString; P: TPoint); begin FGraphics.DrawString(Text, Length(Text), FFont.Handle, MakePointF(P), FFont.Format.Handle, FFont.Brush.Handle); end; procedure TWidgetCanvas.FillEllipse(const Rect: TGPRect); begin FGraphics.FillEllipse(FBrush.Handle, Rect); end; procedure TWidgetCanvas.FillEllipse(const Rect: TRect); begin FGraphics.FillEllipse(FBrush.Handle, MakeRect(Rect)); end; procedure TWidgetCanvas.FillEllipse(X, Y, Width, Height: Integer); begin FGraphics.FillEllipse(FBrush.Handle, X, Y, Width, Height); end; procedure TWidgetCanvas.FillPie(const Rect: TGPRect; StartAngle, SweepAngle: Single); begin FGraphics.FillPie(FBrush.Handle, Rect, StartAngle, SweepAngle); end; procedure TWidgetCanvas.FillPie(const Rect: TRect; StartAngle, SweepAngle: Single); begin FGraphics.FillPie(FBrush.Handle, MakeRect(Rect), StartAngle, SweepAngle); end; procedure TWidgetCanvas.FillPie(X, Y, Width, Height: Integer; StartAngle, SweepAngle: Single); begin FGraphics.FillPie(FBrush.Handle, X, Y, Width, Height, StartAngle, SweepAngle); end; procedure TWidgetCanvas.FillRect(const Rect: TRect); begin FGraphics.FillRectangle(FBrush.Handle, MakeRect(Rect)); end; procedure TWidgetCanvas.FillRectangle(const Rect: TGPRect); begin FGraphics.FillRectangle(FBrush.Handle, Rect); end; procedure TWidgetCanvas.FillRectangle(X, Y, Width, Height: Integer); begin FGraphics.FillRectangle(FBrush.Handle, X, Y, Width, Height); end; procedure TWidgetCanvas.FillRectangle(const Rect: TRect); begin FGraphics.FillRectangle(FBrush.Handle, MakeRect(Rect)); end; procedure TWidgetCanvas.FillRectangles(Rects: PGPRect; Count: Integer); begin FGraphics.FillRectangles(FBrush.Handle, Rects, Count); end; function TWidgetCanvas.GetHDC: HDC; begin Result := FGraphics.GetHDC; end; function TWidgetCanvas.GetTextRenderingHint: TTextRenderingHint; begin Result := FGraphics.GetTextRenderingHint; end; procedure TWidgetCanvas.Reallocate(const AWidth, AHeight: Integer); begin Release; FWidth := AWidth; FHeight := AHeight; Allocate; end; procedure TWidgetCanvas.Release; begin if Assigned(FCachedBitmap) then FreeAndNil(FCachedBitmap); if Assigned(FBitmap) then FreeAndNil(FBitmap); if Assigned(FGraphics) then FreeAndNil(FGraphics); end; procedure TWidgetCanvas.ReleaseHDC(DC: HDC); begin FGraphics.ReleaseHDC(DC); end; procedure TWidgetCanvas.SetHeight(const Value: Integer); begin FHeight := Value; end; procedure TWidgetCanvas.SetTextRenderingHint( const Value: TTextRenderingHint); begin FGraphics.SetTextRenderingHint(Value); end; procedure TWidgetCanvas.SetWidth(const Value: Integer); begin FWidth := Value; end; function TWidgetCanvas.TextExtent(const Text: WideString): TSize; begin //FGraphics.MeasureString(Text, Length(Text), FFont.Handle, ) end; procedure TWidgetCanvas.TextOut(X, Y: Integer; const Text: WideString); begin FGraphics.DrawString(Text, Length(Text), FFont.Handle, MakePoint(X * 1.00, Y * 1.00), FFont.Format.Handle, FFont.Brush.Handle); end; procedure TWidgetCanvas.TextRect(Rect: TRect; X, Y: Integer; const Text: WideString); begin FGraphics.DrawString(Text, Length(Text), FFont.Handle, MakeRectF(Rect), FFont.Format.Handle, FFont.Brush.Handle); end; { TWidgetForm } constructor TWidgetForm.Create(AOwner: TComponent); begin inherited Create(AOwner); Width := 320; Height := 240; end; procedure TWidgetForm.CreateForm; begin if Assigned(FOnCreate) then FOnCreate(Self); end; procedure TWidgetForm.CreateParams(var Params: TCreateParamsW); begin inherited CreateParams(Params); with Params do begin Style := WS_POPUP; if not Enabled then Style := Style or WS_DISABLED; ExStyle := WS_EX_LAYERED or WS_EX_TOOLWINDOW;// or WS_EX_TOPMOST; end; end; destructor TWidgetForm.Destroy; begin inherited Destroy; end; procedure TWidgetForm.Update; begin if FUpdating then Exit; FUpdating := True; try Repaint; UpdateForm; finally FUpdating := False; end; end; procedure TWidgetForm.UpdateForm; var ScrDC, MemDC: HDC; BitmapHandle, PrevBitmap: HBITMAP; BlendFunc: _BLENDFUNCTION; Size: TSize; P, S: TPoint; begin ScrDC := CreateCompatibleDC(0); MemDC := CreateCompatibleDC(ScrDC); Canvas.Bitmap.GetHBITMAP(0, BitmapHandle); PrevBitmap := SelectObject(MemDC, BitmapHandle); Size.cx := Width; Size.cy := Height; P := Point(Left, Top); S := Point(0, 0); with BlendFunc do begin BlendOp := AC_SRC_OVER; BlendFlags := 0; SourceConstantAlpha := Self.Opacity; AlphaFormat := AC_SRC_ALPHA; end; UpdateLayeredWindow(Self.FHandle, ScrDC, @P, @Size, MemDC, @S, 0, @BlendFunc, ULW_ALPHA);//ULW_OPAQUE);// SelectObject(MemDC, PrevBitmap); DeleteObject(BitmapHandle); DeleteDC(MemDC); DeleteDC(ScrDC); end; procedure TWidgetForm.WMActivate(var Message: TWidgetMessage); begin if Assigned(FOnActivate) then with Message do FOnActivate(Self, WParamLo); end; procedure TWidgetForm.WMClose(var Message: TWidgetMessage); var Action: TCloseAction; begin Action := caFree; if Assigned(FOnClose) then FOnClose(Self, Action); case Action of caFree: DestroyWindow(FHandle); caHide: Hide; caMinimize:; end; end; procedure TWidgetForm.WMCreate(var Message: TWidgetMessage); begin inherited WMCreate(Message); CreateForm; end; procedure TWidgetForm.WMDestroy(var Message: TWidgetMessage); begin inherited WMDestroy(Message); if Assigned(FOnDestroy) then FOnDestroy(Self); end; procedure TWidgetForm.WMMouseActivate(var Message: TWidgetMessage); begin with Message do begin Result := MA_ACTIVATE; if Assigned(FOnMouseActivate) then FOnMouseActivate(Self, LParamLo, LParamHi, Result); end; end; { DrawAlphaBlendBitmapXP } procedure DrawAlphaBlendBitmapXP(SrcBitmap, DestBitmap: HBITMAP; DestX, DestY: Integer; Alpha: Byte); var DC, SrcDC, DestDC: HDC; PrevDestBitmap, PrevSrcBitmap: HBITMAP; SrcInfo: Windows.TBitmap; BlendFunc: _BLENDFUNCTION; begin DC := GetDC( GetDesktopWindow() ); SrcDC := CreateCompatibleDC( DC ); DestDC := CreateCompatibleDC( DC ); ReleaseDC( GetDesktopWindow(), DC ); PrevSrcBitmap := SelectObject( SrcDC, SrcBitmap ); PrevDestBitmap := SelectObject( DestDC, DestBitmap ); GetObject( SrcBitmap, SizeOf(Windows.TBitmap), @SrcInfo ); with BlendFunc do begin Blendop := AC_SRC_OVER; BlendFlags := 0; SourceConstantAlpha := Alpha; AlphaFormat := AC_SRC_ALPHA; end; with SrcInfo do AlphaBlend( DestDC, DestX, DestY, bmWidth, bmHeight, SrcDC, 0, 0, bmWidth, bmHeight, BlendFunc ); SelectObject( SrcDC, PrevSrcBitmap ); SelectObject( DestDC, PrevDestBitmap ); DeleteDC( SrcDC ); DeleteDC( DestDC ); end; procedure TWidgetForm.WMWindowPosChanging(var Message: TWidgetMessage); var Control: TControl; C: TComponent; P: TPoint; WindowPos: PWINDOWPOS; I: Integer; begin inherited WMWindowPosChanging(Message); for I := 0 to ComponentCount - 1 do begin C := Components[I]; if C is TWinForm then begin Control := C as TWinForm; WindowPos := PWINDOWPOS(Message.LParam); if (WindowPos^.flags and SWP_NOMOVE = 0) and (Assigned(Control.Parent)) then begin P.X := Control.Left - Control.Parent.Left; P.Y := Control.Top - Control.Parent.Top; Control.Move(WindowPos^.x + P.X, WindowPos^.y + P.Y); end; end; end; end; procedure TWidgetForm.WndProc(var Message: TWidgetMessage); begin case Message.Msg of WM_CREATE: WMCreate(Message); WM_CLOSE: WMClose(Message); WM_DESTROY: WMDestroy(Message); WM_ACTIVATE: WMActivate(Message); WM_MOUSEACTIVATE: WMMouseActivate(Message); else inherited WndProc(Message); end; end; { TWidgetDesktop } function TWidgetDesktop.GetDesktopHeight: Integer; begin Result := GetSystemMetrics(SM_CYVIRTUALSCREEN); end; function TWidgetDesktop.GetDesktopLeft: Integer; begin Result := GetSystemMetrics(SM_XVIRTUALSCREEN); end; function TWidgetDesktop.GetDesktopRect: TRect; begin Result := Bounds(DesktopLeft, DesktopTop, DesktopWidth, DesktopHeight); end; function TWidgetDesktop.GetDesktopTop: Integer; begin Result := GetSystemMetrics(SM_YVIRTUALSCREEN); end; function TWidgetDesktop.GetDesktopWidth: Integer; begin Result := GetSystemMetrics(SM_CXVIRTUALSCREEN); end; function TWidgetDesktop.GetHeight: Integer; begin Result := GetSystemMetrics(SM_CYSCREEN); end; function TWidgetDesktop.GetWidth: Integer; begin Result := GetSystemMetrics(SM_CXSCREEN); end; function TWidgetDesktop.GetWorkAreaHeight: Integer; begin with WorkAreaRect do Result := Bottom - Top; end; function TWidgetDesktop.GetWorkAreaLeft: Integer; begin Result := WorkAreaRect.Left; end; function TWidgetDesktop.GetWorkAreaRect: TRect; begin SystemParametersInfo(SPI_GETWORKAREA, 0, @Result, 0); end; function TWidgetDesktop.GetWorkAreaTop: Integer; begin Result := WorkAreaRect.Top; end; function TWidgetDesktop.GetWorkAreaWidth: Integer; begin with WorkAreaRect do Result := Right - Left; end; { TWidgetToolTip } constructor TWidgetToolTip.Create(AOwner: TComponent); begin inherited Create(AOwner); end; procedure TWidgetToolTip.CreateParams(var Params: TCreateParamsW); begin inherited CreateParams(Params); CreateSubClass(Params, TOOLTIPS_CLASS); with Params do begin ExStyle := WS_EX_LAYERED or WS_EX_TOPMOST;// or WS_EX_RTLREADING or WS_EX_RIGHT; Style := WS_POPUP or TTS_NOPREFIX or TTS_ALWAYSTIP or TTS_NOFADE; end; end; destructor TWidgetToolTip.Destroy; begin inherited Destroy; end; function TWidgetToolTip.GetBackColor: Cardinal; begin Result := 0; if HandleAllocated then Result := SendMessageW(Self.FHandle, TTM_GETTIPBKCOLOR, 0, 0); end; function TWidgetToolTip.GetTextColor: Cardinal; begin Result := 0; if HandleAllocated then Result := SendMessageW(Self.FHandle, TTM_GETTIPTEXTCOLOR, 0, 0); end; procedure TWidgetToolTip.SetBackColor(const Value: Cardinal); begin if HandleAllocated then SendMessageW(Self.FHandle, TTM_SETTIPBKCOLOR, Value, 0); end; procedure TWidgetToolTip.SetDelayTime(const Duration: Cardinal; const Delay: Word); begin if HandleAllocated then SendMessageW(Self.FHandle, TTM_SETDELAYTIME, Duration, MakeLong(Delay, 0)); end; procedure TWidgetToolTip.SetTextColor(const Value: Cardinal); begin if HandleAllocated then SendMessageW(Self.FHandle, TTM_SETTIPTEXTCOLOR, Value, 0); end; procedure TWidgetToolTip.WMCustomDraw(var Message: TWidgetMessage); var lpNMCustomDraw: PNMTTCUSTOMDRAW; //R: TRect; begin lpNMCustomDraw := PNMTTCUSTOMDRAW(Message.LParam); with lpNMCustomDraw^.nmcd do case dwDrawStage of CDDS_PREPAINT: begin rc.Right := rc.Right + 40; rc.Bottom := rc.Bottom + 20; { R := rc; DrawText(hdc, 'Selam', 5, R, DT_NOPREFIX or DT_SINGLELINE or DT_VCENTER); } Message.Result := CDRF_SKIPDEFAULT;//CDRF_DODEFAULT;// end; end; end; procedure TWidgetToolTip.WMGetDispInfo(var Message: TWidgetMessage); var pttdi: PNMTTDISPINFOW; Control: TControl; begin pttdi := PNMTTDISPINFOW(Message.LParam); with pttdi^ do if IsWindow(hdr.idFrom) then begin SendMessageW(hdr.hwndFrom, TTM_SETMAXTIPWIDTH, 0, 300); Control := TControl(GetPropW(hdr.idFrom, MakeIntAtomW(WidgetAtom))); if Assigned(Control) and Control.ShowHint and (Control.Hint <> '') then lpszText := PWideChar(Control.Hint); end; end; procedure TWidgetToolTip.WMNotify(var Message: TWidgetMessage); var phdr: PNMHDR; begin with Message do begin phdr := PNMHDR(LParam); case phdr^.code of //NM_CUSTOMDRAW: WMCustomDraw(Message); TTN_NEEDTEXT:; { Bu mesaj uretilmez! } TTN_NEEDTEXTW: WMGetDispInfo(Message); { Dikkat Pencerelerin Unicode! } TTN_SHOW: WMToolTipShow(Message); TTN_POP: WMToolTipPop(Message); end; end; end; procedure TWidgetToolTip.WMToolTipPop(var Message: TWidgetMessage); var phdr: PNMHDR; begin with Message do begin phdr := PNMHDR(LParam); if phdr^.hwndFrom <> 0 then; //UpdateForm(phdr^.hwndFrom); //ToolTipWindow.Hide; end; end; procedure TWidgetToolTip.WMToolTipShow(var Message: TWidgetMessage); var phdr: PNMHDR; //P: TPoint; begin with Message do begin phdr := PNMHDR(LParam); if phdr^.hwndFrom <> 0 then; //UpdateForm(phdr^.hwndFrom); { GetCursorPos(P); ToolTipWindow.Left := P.X + 16; ToolTipWindow.Top := P.Y + 16; //ToolTipWindow.Opacity := 0; ToolTipWindow.Show; ToolTipWindow.Update; } end; end; procedure TWidgetToolTip.WndProc(var Message: TWidgetMessage); begin case Message.Msg of WM_NOTIFY: WMNotify(Message); else inherited WndProc(Message); end; end; { TWidgetControl } constructor TWidgetControl.Create(AOwner: TComponent); begin inherited Create(AOwner); FCanvas := TWidgetCanvas.Create(Width, Height); FOpacity := $FF; end; destructor TWidgetControl.Destroy; begin FCanvas.Free; inherited Destroy; end; procedure TWidgetControl.Paint; begin if HandleAllocated then begin PaintWindow; PaintChildren; PaintCanvas; end; end; procedure TWidgetControl.PaintCanvas; var PCanvas: TWidgetCanvas; begin { Paint to Parent Canvas } if Assigned(Parent) and (Parent is TWidgetControl) then begin PCanvas := (Parent as TWidgetControl).Canvas; if FOpacityChanged then PCanvas.DrawImage(FCanvas.Bitmap, Left, Top, Width, Height, FOpacity) else PCanvas.DrawImage(FCanvas.Bitmap, Left, Top, Width, Height); end; end; procedure TWidgetControl.PaintChildren; var Child: HWND; Control: TWidgetControl; Window: HWND; begin { Paint Child Controls } Child := GetWindow(FHandle, GW_CHILD); if Child <> 0 then begin Window := GetWindow(Child, GW_HWNDLAST); while Window <> 0 do begin Control := TWidgetControl(GetPropW(Window, MakeIntAtomW(WidgetAtom))); if Assigned(Control) and (Control.Visible) then Control.Paint; Window := GetWindow(Window, GW_HWNDPREV); end; end; end; procedure TWidgetControl.PaintWindow; begin FCanvas.Clear; if Assigned(FOnPaint) then FOnPaint(Self, FCanvas); end; procedure TWidgetControl.SetOpacity(const Value: Byte); begin if FOpacity <> Value then begin FOpacity := Value; FOpacityChanged := True; end; end; procedure TWidgetControl.Update; begin if Assigned(Parent) then Parent.Update; end; procedure TWidgetControl.WMShowWindow(var Message: TWidgetMessage); begin inherited WMShowWindow(Message); FCanvas.Reallocate(Width, Height); end; procedure TWidgetControl.WMSize(var Message: TWidgetMessage); begin inherited WMSize(Message); FCanvas.Reallocate(Width, Height); end; { TWinForm } procedure TWinForm.CanvasChange(Sender: TObject); begin //Invalidate; end; constructor TWinForm.Create(AOwner: TComponent); begin inherited Create(AOwner); Width := 320; Height := 240; FOpacity := $FF; FCanvas := TCanvas.Create; FCanvas.OnChange := CanvasChange; Brush.Color := clBtnFace; end; procedure TWinForm.CreateForm; begin if HandleAllocated then SetLayeredWindowAttributes(Self.Handle, 0, FOpacity, LWA_ALPHA); if Assigned(FOnCreate) then FOnCreate(Self); end; procedure TWinForm.CreateParams(var Params: TCreateParamsW); begin inherited CreateParams(Params); with Params do begin Style := WS_OVERLAPPEDWINDOW; if not Enabled then Style := Style or WS_DISABLED; ExStyle := WS_EX_OVERLAPPEDWINDOW; end; end; destructor TWinForm.Destroy; begin FCanvas.Free; inherited Destroy; end; procedure TWinForm.SetOpacity(const Value: Byte); begin if FOpacity <> Value then begin FOpacity := Value; if HandleAllocated then SetLayeredWindowAttributes(Self.Handle, 0, FOpacity, LWA_ALPHA); end; end; procedure TWinForm.WMActivate(var Message: TWidgetMessage); begin if Assigned(FOnActivate) then with Message do FOnActivate(Self, WParamLo); end; procedure TWinForm.WMClose(var Message: TWidgetMessage); var Action: TCloseAction; begin Action := caFree; if Assigned(FOnClose) then FOnClose(Self, Action); case Action of caFree: DestroyWindow(FHandle); caHide: Hide; caMinimize:; end; end; procedure TWinForm.WMCreate(var Message: TWidgetMessage); begin inherited WMCreate(Message); CreateForm; end; procedure TWinForm.WMDestroy(var Message: TWidgetMessage); begin inherited WMDestroy(Message); if Assigned(FOnDestroy) then FOnDestroy(Self); end; procedure TWinForm.WMMouseActivate(var Message: TWidgetMessage); begin with Message do begin Result := MA_ACTIVATE; if Assigned(FOnMouseActivate) then FOnMouseActivate(Self, LParamLo, LParamHi, Result); end; end; procedure TWinForm.WMPaint(var Message: TWidgetMessage); var DC: HDC; PS: TPaintStruct; begin DC := Message.WParam; if DC = 0 then DC := BeginPaint(Handle, PS); try FCanvas.Handle := DC; SetViewportOrgEx(DC, 0, 0, nil); SetViewportExtEx(DC, Width, Height, nil); FCanvas.Brush.Assign(Brush); FCanvas.Pen.Assign(Pen); FCanvas.Font.Assign(Font); Paint; finally if Message.WParam = 0 then EndPaint(Handle, PS); FCanvas.Handle := 0; end; end; procedure TWinForm.WndProc(var Message: TWidgetMessage); begin case Message.Msg of WM_CREATE: WMCreate(Message); WM_CLOSE: WMClose(Message); WM_DESTROY: WMDestroy(Message); WM_ACTIVATE: WMActivate(Message); WM_MOUSEACTIVATE: WMMouseActivate(Message); //WM_PAINT: WMPaint(Message); WM_ERASEBKGND: WMEraseBkGnd(Message); else inherited WndProc(Message); end; end; { TWidgetTray } constructor TWidgetTray.Create(AOwner: TComponent); begin inherited Create(AOwner); FBalloonFlags := bfNone; BalloonTimeout := 3000; FVisibleTray := False; FIsClicked := False; FillChar(FData, SizeOf(FData), 0); FData.cbSize := SizeOf(FData); FData.uTimeout := 3000; FData.uFlags := NIF_ICON or NIF_MESSAGE; FData.uCallbackMessage := WM_TRAY_MESSAGE; end; procedure TWidgetTray.CreateForm; begin inherited CreateForm; if Self.HandleAllocated then begin FData.Wnd := Self.Handle; FData.uID := FData.Wnd; Refresh; end; end; procedure TWidgetTray.CreateParams(var Params: TCreateParamsW); begin inherited CreateParams(Params); CreateSubClass(Params, 'Widget_Tray_Window_Class'); with Params do begin ExStyle := WS_EX_TOOLWINDOW; Style := WS_POPUP; end; end; destructor TWidgetTray.Destroy; begin inherited Destroy; end; function TWidgetTray.GetBalloonTimeout: Integer; begin Result := FData.uTimeout; end; procedure TWidgetTray.Refresh; begin if FVisibleTray then Refresh(NIM_MODIFY); end; function TWidgetTray.Refresh(Message: Integer): Boolean; begin Result := Shell_NotifyIconW(Message, @FData); end; procedure TWidgetTray.SetBalloonHint(const Value: WideString); begin if CompareStr(FBalloonHint, Value) <> 0 then begin FBalloonHint := Value; StrLCopyW(FData.szInfo, PWideChar(FBalloonHint), SizeOf(FData.szInfo) - 1); Refresh(NIM_MODIFY); end; end; procedure TWidgetTray.SetBalloonTimeout(const Value: Integer); begin FData.uTimeout := Value; end; procedure TWidgetTray.SetBalloonTitle(const Value: WideString); begin if CompareStr(FBalloonTitle, Value) <> 0 then begin FBalloonTitle := Value; StrLCopyW(FData.szInfoTitle, PWideChar(FBalloonTitle), SizeOf(FData.szInfoTitle) - 1); Refresh(NIM_MODIFY); end; end; procedure TWidgetTray.SetHintText(const Value: WideString); begin if CompareStr(FHintText, Value) <> 0 then begin FHintText := Value; StrLCopyW(FData.szTip, PWideChar(FHintText), SizeOf(FData.szTip) - 1); if Length(FHintText) > 0 then FData.uFlags := FData.uFlags or NIF_TIP else FData.uFlags := FData.uFlags and not NIF_TIP; Refresh; end; end; procedure TWidgetTray.SetIcon(const Value: HICON); begin if FIcon <> 0 then begin DestroyIcon(FIcon); FIcon := 0; end; FIcon := Value; FData.hIcon := FIcon; Refresh; end; procedure TWidgetTray.SetVisibleTray(const Value: Boolean); begin if FVisibleTray <> Value then begin FVisibleTray := Value; if not (csDesigning in ComponentState) then begin if FVisibleTray then begin if not Refresh(NIM_ADD) then; //raise EOutOfResources.Create(STrayIconCreateError); end else if not (csLoading in ComponentState) then begin if not Refresh(NIM_DELETE) then; //raise EOutOfResources.Create(STrayIconRemoveError); end; end; end; end; procedure TWidgetTray.ShowBalloonHint; begin FData.uFlags := FData.uFlags or NIF_INFO; FData.dwInfoFlags := Integer(FBalloonFlags); Refresh(NIM_MODIFY); end; procedure TWidgetTray.WMDestroy(var Message: TWidgetMessage); begin Refresh(NIM_DELETE); if FIcon <> 0 then DestroyIcon(FIcon); inherited WMDestroy(Message); end; procedure TWidgetTray.WMTrayMessage(var Message: TWidgetMessage); { Return the state of the shift keys. } function ShiftState: Integer; begin Result := 0; if GetKeyState(VK_SHIFT) < 0 then Result := Result or MK_SHIFT; if GetKeyState(VK_CONTROL) < 0 then Result := Result or MK_CONTROL; { if GetKeyState(VK_MENU) < 0 then Include(Result, ssAlt); } end; var Point: TPoint; Shift: Integer; begin case Message.lParam of WM_MOUSEMOVE: begin if Assigned(FOnMouseMove) then begin Shift := ShiftState; GetCursorPos(Point); FOnMouseMove(Self, Shift, Point.X, Point.Y); end; end; WM_LBUTTONDOWN: begin if Assigned(FOnMouseDown) then begin Shift := ShiftState or MK_LBUTTON; GetCursorPos(Point); FOnMouseDown(Self, Shift, Point.X, Point.Y); end; FIsClicked := True; end; WM_LBUTTONUP: begin Shift := ShiftState or MK_LBUTTON; GetCursorPos(Point); if FIsClicked and Assigned(FOnClick) then begin FOnClick(Self); FIsClicked := False; end; if Assigned(FOnMouseUp) then FOnMouseUp(Self, Shift, Point.X, Point.Y); end; WM_RBUTTONDOWN: begin if Assigned(FOnMouseDown) then begin Shift := ShiftState or MK_RBUTTON; GetCursorPos(Point); FOnMouseDown(Self, Shift, Point.X, Point.Y); end; end; WM_RBUTTONUP: begin Shift := ShiftState or MK_RBUTTON; GetCursorPos(Point); if Assigned(FOnMouseUp) then FOnMouseUp(Self, Shift, Point.X, Point.Y); { if Assigned(FPopupMenu) then begin SetForegroundWindow(Application.Handle); Application.ProcessMessages; FPopupMenu.AutoPopup := False; FPopupMenu.PopupComponent := Owner; FPopupMenu.Popup(Point.x, Point.y); end; } end; WM_LBUTTONDBLCLK, WM_MBUTTONDBLCLK, WM_RBUTTONDBLCLK: if Assigned(FOnDblClick) then FOnDblClick(Self); WM_MBUTTONDOWN: begin if Assigned(FOnMouseDown) then begin Shift := ShiftState or MK_MBUTTON; GetCursorPos(Point); FOnMouseDown(Self, Shift, Point.X, Point.Y); end; end; WM_MBUTTONUP: begin if Assigned(FOnMouseUp) then begin Shift := ShiftState or MK_MBUTTON; GetCursorPos(Point); FOnMouseUp(Self, Shift, Point.X, Point.Y); end; end; NIN_BALLOONHIDE, NIN_BALLOONTIMEOUT: begin FData.uFlags := FData.uFlags and not NIF_INFO; end; end; end; procedure TWidgetTray.WndProc(var Message: TWidgetMessage); begin case Message.Msg of WM_QUERYENDSESSION: Message.Result := 1; WM_ENDSESSION: if BOOL(Message.WParam) then Refresh(NIM_DELETE); WM_TRAY_MESSAGE: WMTrayMessage(Message); else inherited WndProc(Message); end; end; { TGraphicObject } procedure TGraphicObject.Assign(Source: TGraphicObject); begin end; procedure TGraphicObject.Changed; begin if Assigned(FOnChange) then FOnChange(Self); end; { TPen } procedure TPen.Allocate; begin FHandle := CreatePen(FStyle, FWidth, ColorToRGB(FColor)); end; destructor TPen.Destroy; begin Release; inherited Destroy; end; procedure TPen.Release; begin if FHandle <> 0 then begin DeleteObject(FHandle); FHandle := 0; end; end; procedure TPen.SetColor(const Value: TColor); begin if FColor <> Value then begin Release; FColor := Value; Allocate; Changed; end; end; procedure TPen.SetHandle(const Value: HPEN); begin if FHandle <> Value then begin Release; FHandle := Value; Changed; end; end; procedure TPen.SetStyle(const Value: Integer); begin if FStyle <> Value then begin Release; FStyle := Value; Allocate; Changed; end; end; procedure TPen.SetWidth(const Value: Integer); begin if FWidth <> Value then begin Release; FWidth := Value; Allocate; Changed; end; end; { TBrush } procedure TBrush.Allocate; begin FHandle := CreateSolidBrush(FColor); end; procedure TBrush.Assign(Source: TGraphicObject); var Brush: TBrush; begin if (Source is TBrush) and (Self <> Source) then begin Brush := Source as TBrush; Release; FColor := Brush.Color; FStyle := Brush.Style; Allocate; Changed; end; end; constructor TBrush.Create; begin inherited Create; FColor := -1; end; destructor TBrush.Destroy; begin Release; inherited Destroy; end; procedure TBrush.Release; begin if FHandle <> 0 then begin DeleteObject(FHandle); FHandle := 0; end; end; procedure TBrush.SetColor(const Value: TColor); begin if FColor <> Value then begin Release; FColor := ColorToRGB(Value); Allocate; Changed; end; end; procedure TBrush.SetHandle(const Value: HBRUSH); begin if FHandle <> Value then begin Release; FHandle := Value; Changed; end; end; procedure TBrush.SetStyle(const Value: Integer); begin if FStyle <> Value then begin Release; FStyle := Value; FHandle := CreateHatchBrush(FStyle, FColor); Changed; end; end; { TFont } procedure TFont.Allocate; var ncm: NONCLIENTMETRICSW; lf: LOGFONTW; dc: HDC; begin dc := GetDC(HWND_DESKTOP); try ncm.cbSize := SizeOf(ncm); SystemParametersInfoW(SPI_GETNONCLIENTMETRICS, 0, @ncm, 0); System.Move(ncm.lfMessageFont, lf, SizeOf(LOGFONTW)); if FStyle and FS_BOLD <> 0 then lf.lfWeight := FW_BOLD; if FStyle and FS_ITALIC <> 0 then lf.lfItalic := Byte(True); if FStyle and FS_UNDERLINE <> 0 then lf.lfUnderline := Byte(True); StrCopyW(lf.lfFaceName, PWideChar(FName)); lf.lfCharSet := TURKISH_CHARSET; lf.lfHeight := -MulDiv(GetDeviceCaps(dc, LOGPIXELSY), FSize, 72); FHandle := CreateFontIndirectW(lf); finally ReleaseDC(HWND_DESKTOP, dc); end; end; procedure TFont.Assign(Source: TGraphicObject); var Font: TFont; begin if (Source is TFont) and (Self <> Source) then begin Font := Source as TFont; Release; FSize := Font.Size; FName := Font.Name; FStyle := Font.Style; FColor := Font.Color; Allocate; Changed; end; end; constructor TFont.Create; begin inherited Create; FSize := 8; FName := 'Tahoma';//'Arial Unicode MS';// FStyle := FS_NORMAL; Allocate; end; destructor TFont.Destroy; begin Release; inherited Destroy; end; procedure TFont.Release; begin if FHandle <> 0 then begin DeleteObject(FHandle); FHandle := 0; end; end; procedure TFont.SetColor(const Value: TColor); begin if FColor <> Value then begin FColor := ColorToRGB(Value); Changed; end; end; procedure TFont.SetHandle(const Value: HFONT); begin if FHandle <> Value then begin Release; FHandle := Value; Changed; end; end; procedure TFont.SetName(const Value: WideString); begin if FName <> Value then begin Release; FName := Value; Allocate; Changed; end; end; procedure TFont.SetSize(const Value: Integer); begin if FSize <> Value then begin Release; FSize := Value; Allocate; Changed; end; end; procedure TFont.SetStyle(const Value: UINT); begin if FStyle <> Value then begin Release; FStyle := Value; Allocate; Changed; end; end; { TWinControl } procedure TWinControl.BrushChange(Sender: TObject); begin Invalidate; end; constructor TWinControl.Create(AOwner: TComponent); begin inherited Create(AOwner); FFont := TFont.Create; FFont.OnChange := FontChanged; FBrush := TBrush.Create; FBrush.OnChange := BrushChange; FPen := TPen.Create; FPen.OnChange := PenChange; end; procedure TWinControl.CreateWnd; begin inherited CreateWnd; Perform(WM_SETFONT, FFont.Handle, 1); end; destructor TWinControl.Destroy; begin FPen.Free; FBrush.Free; FFont.Free; inherited Destroy; end; procedure TWinControl.FontChanged(Sender: TObject); begin Invalidate; end; function TWinControl.GetColor: TColor; begin Result := FBrush.Color; end; procedure TWinControl.Invalidate; begin if Handleallocated then InvalidateRect(FHandle, nil, True); end; procedure TWinControl.PenChange(Sender: TObject); begin Invalidate; end; procedure TWinControl.SetColor(const Value: TColor); begin FBrush.Color := Value; end; procedure TWinControl.WMEraseBkGnd(var Message: TWidgetMessage); begin CallDefaultProc(Message); end; procedure TWinControl.WMNCPaint(var Message: TWidgetMessage); begin CallDefaultProc(Message); end; procedure TWinControl.WMPaint(var Message: TWidgetMessage); begin CallDefaultProc(Message); end; procedure TWinControl.WndProc(var Message: TWidgetMessage); begin case Message.Msg of WM_PAINT: WMPaint(Message); WM_NCPAINT: WMNcPaint(Message); WM_ERASEBKGND: WMEraseBkGnd(Message); else inherited WndProc(Message); end; end; { TCanvas } procedure TCanvas.AngleArc(X, Y: Integer; Radius: DWORD; StartAngle, SweepAngle: Single); begin if HandleAllocated then begin Windows.AngleArc(FHandle, X, Y, Radius, StartAngle, SweepAngle); end; end; procedure TCanvas.BeginPath; begin if HandleAllocated then begin Windows.BeginPath(FHandle); end; end; procedure TCanvas.BrushChange(Sender: TObject); begin if HandleAllocated then begin SelectObject(FHandle, (Sender as TBrush).Handle); Changed; end; end; procedure TCanvas.Changed; begin if Assigned(FOnChange) then FOnChange(Self); end; constructor TCanvas.Create; begin inherited Create; FFont := TFont.Create; FFont.OnChange := FontChange; FBrush := TBrush.Create; FBrush.OnChange := BrushChange; FBrush.Color := clWindow; FPen := TPen.Create; FPen.OnChange := PenChange; FPen.Color := clBlack; end; destructor TCanvas.Destroy; begin FPen.Free; FBrush.Free; FFont.Free; inherited Destroy; end; procedure TCanvas.DrawFrameControl(const Rect: TRect; uType, State: UINT); begin if HandleAllocated then begin Windows.DrawFrameControl(FHandle, Rect, uType, State); end; end; procedure TCanvas.EndPath; begin if HandleAllocated then begin Windows.EndPath(FHandle); end; end; procedure TCanvas.FillRect(const Rect: TRect); begin if HandleAllocated then begin Windows.FillRect(FHandle, Rect, FBrush.Handle); end; end; procedure TCanvas.FontChange(Sender: TObject); begin if HandleAllocated then begin SelectObject(FHandle, (Sender as TFont).Handle); SetTextColor(FHandle, (Sender as TFont).Color); Changed; end; end; function TCanvas.HandleAllocated: Boolean; begin Result := FHandle <> 0; end; procedure TCanvas.LineTo(X, Y: Integer); begin if HandleAllocated then Windows.LineTo(FHandle, X, Y); end; procedure TCanvas.MoveTo(X, Y: Integer); begin if HandleAllocated then Windows.MoveToEx(FHandle, X, Y, nil); end; procedure TCanvas.PenChange(Sender: TObject); begin if HandleAllocated then begin SelectObject(FHandle, (Sender as TPen).Handle); Changed; end; end; procedure TCanvas.Rectangle(X1, Y1, X2, Y2: Integer); begin if HandleAllocated then Windows.Rectangle(FHandle, X1, Y1, X2, Y2); end; procedure TCanvas.SetControl(const Value: TWinControl); begin FControl := Value; end; procedure TCanvas.SetHandle(const Value: HDC); begin if FHandle <> Value then FHandle := Value; end; procedure TCanvas.StrokeAndFillPath; begin if HandleAllocated then begin Windows.StrokeAndFillPath(FHandle); end; end; procedure TCanvas.TextOut(X, Y: Integer; const Text: WideString); begin if HandleAllocated then Windows.TextOutW(FHandle, X, Y, PWideChar(Text), Length(Text)); end; { TStreamAdapter } constructor TStreamAdapter.Create(Stream: TStream; Ownership: TStreamOwnership); begin inherited Create; FStream := Stream; FOwnership := Ownership; end; destructor TStreamAdapter.Destroy; begin if FOwnership = soOwned then begin FStream.Free; FStream := nil; end; inherited Destroy; end; function TStreamAdapter.Read(pv: Pointer; cb: Longint; pcbRead: PLongint): HResult; var NumRead: Longint; begin try if pv = nil then begin Result := STG_E_INVALIDPOINTER; Exit; end; NumRead := FStream.Read(pv^, cb); if pcbRead <> nil then pcbRead^ := NumRead; Result := S_OK; except Result := S_FALSE; end; end; function TStreamAdapter.Write(pv: Pointer; cb: Longint; pcbWritten: PLongint): HResult; var NumWritten: Longint; begin try if pv = nil then begin Result := STG_E_INVALIDPOINTER; Exit; end; NumWritten := FStream.Write(pv^, cb); if pcbWritten <> nil then pcbWritten^ := NumWritten; Result := S_OK; except Result := STG_E_CANTSAVE; end; end; function TStreamAdapter.Seek(dlibMove: Largeint; dwOrigin: Longint; out libNewPosition: Largeint): HResult; var NewPos: LargeInt; begin try if (dwOrigin < STREAM_SEEK_SET) or (dwOrigin > STREAM_SEEK_END) then begin Result := STG_E_INVALIDFUNCTION; Exit; end; NewPos := FStream.Seek(dlibMove, TSeekOrigin(dwOrigin)); if @libNewPosition <> nil then libNewPosition := NewPos; Result := S_OK; except Result := STG_E_INVALIDPOINTER; end; end; function TStreamAdapter.SetSize(libNewSize: Largeint): HResult; begin try FStream.Size := libNewSize; if libNewSize <> FStream.Size then Result := E_FAIL else Result := S_OK; except Result := E_UNEXPECTED; end; end; function TStreamAdapter.CopyTo(stm: IStream; cb: Largeint; out cbRead: Largeint; out cbWritten: Largeint): HResult; const MaxBufSize = 1024 * 1024; // 1mb var Buffer: Pointer; BufSize, N, I, R: Integer; BytesRead, BytesWritten, W: LargeInt; begin Result := S_OK; BytesRead := 0; BytesWritten := 0; try if cb > MaxBufSize then BufSize := MaxBufSize else BufSize := Integer(cb); GetMem(Buffer, BufSize); try while cb > 0 do begin if cb > MaxInt then I := MaxInt else I := cb; while I > 0 do begin if I > BufSize then N := BufSize else N := I; R := FStream.Read(Buffer^, N); if R = 0 then Exit; // The end of the stream was hit. Inc(BytesRead, R); W := 0; Result := stm.Write(Buffer, R, @W); Inc(BytesWritten, W); if (Result = S_OK) and (Integer(W) <> R) then Result := E_FAIL; if Result <> S_OK then Exit; Dec(I, R); Dec(cb, R); end; end; finally FreeMem(Buffer); if (@cbWritten <> nil) then cbWritten := BytesWritten; if (@cbRead <> nil) then cbRead := BytesRead; end; except Result := E_UNEXPECTED; end; end; function TStreamAdapter.Commit(grfCommitFlags: Longint): HResult; begin Result := S_OK; end; function TStreamAdapter.Revert: HResult; begin Result := STG_E_REVERTED; end; function TStreamAdapter.LockRegion(libOffset: Largeint; cb: Largeint; dwLockType: Longint): HResult; begin Result := STG_E_INVALIDFUNCTION; end; function TStreamAdapter.UnlockRegion(libOffset: Largeint; cb: Largeint; dwLockType: Longint): HResult; begin Result := STG_E_INVALIDFUNCTION; end; function TStreamAdapter.Stat(out statstg: TStatStg; grfStatFlag: Longint): HResult; begin Result := S_OK; try if (@statstg <> nil) then begin FillChar(statstg, SizeOf(statstg), 0); { Bug fixed: Must be empty } with statstg do begin dwType := STGTY_STREAM; cbSize := FStream.Size; mTime.dwLowDateTime := 0; mTime.dwHighDateTime := 0; cTime.dwLowDateTime := 0; cTime.dwHighDateTime := 0; aTime.dwLowDateTime := 0; aTime.dwHighDateTime := 0; grfLocksSupported := LOCK_WRITE; end; end; except Result := E_UNEXPECTED; end; end; function TStreamAdapter.Clone(out stm: IStream): HResult; begin Result := E_NOTIMPL; end; initialization InitWidgetSystem; finalization DoneWidgetSystem; end.