{ @abstract(This unit contains the base class for all visible controls.)
@author(Tomas Krysl (tk@tkweb.eu))
@created(18 Sep 2009)
@lastmod(20 Jun 2010)
This unit implements the base class TKCustomControl for all visible controls
from the KControls Development Suite.
Copyright © 2009 Tomas Krysl (tk@@tkweb.eu)<BR><BR>
<B>License:</B><BR>
This code is distributed as a freeware. You are free to use it as part
of your application for any purpose including freeware, commercial and
shareware applications. The origin of this source code must not be
misrepresented; you must not claim your authorship. You may modify this code
solely for your own purpose. Please feel free to contact the author if you
think your changes might be useful for other users. You may distribute only
the original package. The author accepts no liability for any damage
that may result from using this code. }
unit KControls;
{$include kcontrols.inc}
{$WEAKPACKAGEUNIT ON}
interface
uses
{$IFDEF FPC}
LCLType, LCLIntf, LMessages, LCLProc, LResources,
{$ELSE}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Graphics, Controls, Forms, KFunctions
{$IFDEF USE_THEMES}
, Themes
{$IFNDEF FPC}
, UxTheme
{$ENDIF}
{$ENDIF}
;
type
{ This array serves as storage place for all colors. }
TKColorArray = array of TColor;
{ Declares possible indexes e.g. for the @link(TKPreviewColors.Color) property. }
TKPreviewColorIndex = Integer;
{ Declares print options - possible values for the @link(TKPrintPageSetup.Options) property. }
TKPrintOption = (
{ If there are more printed copies these will be collated. }
poCollate,
{ The printed shape will be scaled to fit on page. }
poFitToPage,
{ Every even page will be printed with mirrored (swapped) margins. }
poMirrorMargins,
{ Page numbers will be added to the bottom of each printed page. }
poPageNumbers,
{ Paints the selection in control's specific manner. }
poPaintSelection,
{ Title will be printed to the top of each printed page. }
poTitle,
{ Color page will be printed instead of B/W page. }
poUseColor
);
{ Print options can be arbitrary combined. }
TKPrintOptions = set of TKPrintOption;
{ Declares possible values for the @link(TKPrintPageSetup.Range) property. }
TKPrintRange = (
{ All pages will be printed. }
prAll,
{ Only selected block will be printed. }
prSelectedOnly,
{ Only given range of pages will be printed. }
prRange
);
{ Declares measurement units for KControls printing system. }
TKPrintUnits = (
{ Corresponding value is given in millimeters. }
puMM,
{ Corresponding value is given in centimeters. }
puCM,
{ Corresponding value is given in inches. }
puInch,
{ Corresponding value is given in hundredths of inches. }
puHundredthInch
);
const
{ Default value for the @link(TKCustomControl.BorderStyle) property. }
cBorderStyleDef = bsSingle;
{ Minimum for the @link(TKPrintPageSetup.Copies) property }
cCopiesMin = 1;
{ Maximum for the @link(TKPrintPageSetup.Copies) property }
cCopiesMax = 1000;
{ Default value for the @link(TKPrintPageSetup.Copies) property }
cCopiesDef = 1;
{ Default value for the @link(TKPrintPageSetup.MarginBottom) property }
cMarginBottomDef = 2.0;
{ Default value for the @link(TKPrintPageSetup.MarginLeft) property }
cMarginLeftDef = 1.5;
{ Default value for the @link(TKPrintPageSetup.MarginRight) property }
cMarginRightDef = 1.5;
{ Default value for the @link(TKPrintPageSetup.MarginTop) property }
cMarginTopDef = 1.8;
{ Default value for the @link(TKPrintPageSetup.Options) property. }
cOptionsDef = [poFitToPage, poPageNumbers, poUseColor];
{ Default value for the @link(TKPrintPageSetup.Options) property. }
cRangeDef = prAll;
{ Minimum for the @link(TKPrintPageSetup.Scale) property }
cScaleDef = 100;
{ Maximum for the @link(TKPrintPageSetup.Scale) property }
cScaleMin = 10;
{ Default value for the @link(TKPrintPageSetup.Scale) property }
cScaleMax = 500;
{ Default value for the @link(TKPrintPageSetup.Units) property. }
cUnitsDef = puCM;
{ Default value for the @link(TKPreviewColors.Paper) color property. }
cPaperDef = clWhite;
{ Default value for the @link(TKPreviewColors.BkGnd) color property. }
cBkGndDef = clAppWorkSpace;
{ Default value for the @link(TKPreviewColors.Border) color property. }
cBorderDef = clBlack;
{ Default value for the @link(TKPreviewColors.SelectedBorder) color property. }
cSelectedBorderDef = clNavy;
{ Index for the @link(TKPreviewColors.Paper) property. }
ciPaper = TKPreviewColorIndex(0);
{ Index for the @link(TKPreviewColors.BkGnd) property. }
ciBkGnd = TKPreviewColorIndex(1);
{ Index for the @link(TKPreviewColors.Border) property. }
ciBorder = TKPreviewColorIndex(2);
{ Index for the @link(TKPreviewColors.SelectedBorder) property. }
ciSelectedBorder = TKPreviewColorIndex(3);
{ Maximum color array index }
ciPreviewColorsMax = ciSelectedBorder;
{ Constant for control scrollbars. It means: Leave that scrollbar untouched. }
cScrollNoAction = -1;
{ Constant for control scrollbars. It means: Use given Delta to update scrollbar. }
cScrollDelta = -2;
{ Internal flag for TKPrintPreview. }
cPF_Dragging = $00000001;
{ Internal flag for TKPrintPreview. }
cPF_UpdateRange = $00000002;
type
{ Declares possible values for the @link(ScaleMode) property }
TKPreviewScaleMode = (
{ Apply scale defined by the @link(Scale) property }
smScale,
{ Scale the page so that it horizontally fits to the window client area }
smPageWidth,
{ Scale the page so that it fits to the window client area }
smWholePage);
{ @abstract(Declares @link(TKPrintPreview.OnChanged) event handler)
<UL>
<LH>Parameters:</LH>
<LI><I>Sender</I> - identifies the event caller</LI>
</UL>
}
TKPreviewChangedEvent = procedure(Sender: TObject) of object;
{ @abstract(Declares the information structure for the @link(TKCustomControl.MeasurePages) method)
<UL>
<LH>Members:</LH>
<LI><I>OutlineWidth</I> - printed outline width (maximum of all pages) in desktop pixels</LI>
<LI><I>OutlineHeight</I> - printed outline height (maximum of all pages) in desktop pixels</LI>
<LI><I>HorzPageCount</I> - number of pages to split a wide shape into</LI>
<LI><I>VertPageCount</I> - number of pages to split a tall shape into</LI>
<LI><I>PageCount</I> - total number of pages for 1 copy. Might be HorzPageCount * VertPageCount
but does not necessarilly have to be. </LI>
</UL>
}
TKPrintMeasureInfo = record
OutlineWidth: Integer;
OutlineHeight: Integer;
HorzPageCount: Integer;
VertPageCount: Integer;
PageCount: Integer;
end;
{ Declares possible values for the Status parameter in the @link(TKPrintNotifyEvent) event }
TKPrintStatus = (
{ This event occurs at the beginning of the print job - you may show an Abort dialog here }
epsBegin,
{ This event occurs after each page has been printed - you may update the Page/Copy information
in the Abort dialog }
epsNewPage,
{ This event occurs at the end of the print job - you may hide the Abort dialog here }
epsEnd
);
{ @abstract(Declares @link(TKCustomControl.OnPrintNotify) event handler)
<UL>
<LH>Parameters:</LH>
<LI><I>Sender</I> - identifies the event caller</LI>
<LI><I>Status</I> - specifies the event type</LI>
<LI><I>Abort</I> - set to True to abort the print job</LI>
</UL>
Remark: At certain time slots, the print spooler allows the message queue
to be processed for the thread where the print job is running. This e.g. allows
the user to press a button on the Abort dialog. Because this message loop can be invoked
e.g. during a Printer.Canvas.TextRect function and any painting messages may hover in
the message queue, any functions used both to print a job and to process particular
messages should be reentrant to avoid conflicts. Perhaps should print jobs be run
in seperate threads?
}
TKPrintNotifyEvent = procedure(Sender: TObject; Status: TKPrintStatus;
var Abort: Boolean) of object;
{ @abstract(Declares @link(TKCustomControl.OnPrintPaint) event handler)
<UL>
<LH>Parameters:</LH>
<LI><I>Sender</I> - identifies the event caller</LI>
</UL>
}
TKPrintPaintEvent = procedure(Sender: TObject) of object;
TKPrintPageSetup = class;
TKPrintPreview = class;
{ Base class for all visible controls in KControls. }
TKCustomControl = class(TCustomControl)
private
{$IFNDEF FPC}
FBorderStyle: TBorderStyle;
{$ENDIF}
{$IFNDEF COMPILER10_UP}
FMouseInClient: Boolean;
{$ENDIF}
FMemoryCanvas: TCanvas;
FMemoryCanvasRect: TRect;
FPageSetup: TKPrintPageSetup;
FUpdateLock: Integer;
FOnPrintNotify: TKPrintNotifyEvent;
FOnPrintPaint: TKPrintPaintEvent;
{$IFNDEF FPC}
procedure CMCancelMode(var Msg: TMessage); message CM_CANCELMODE;
procedure CMCtl3DChanged(var Msg: TMessage); message CM_CTL3DCHANGED;
{$ENDIF}
procedure CMMouseLeave(var Msg: TLMessage); message CM_MOUSELEAVE;
function GetCanPrint: Boolean;
function GetPageSetup: TKPrintPageSetup;
function GetPageSetupAllocated: Boolean;
procedure KMLateUpdate(var Msg: TLMessage); message KM_LATEUPDATE;
{$IFNDEF FPC}
procedure SetBorderStyle(Value: TBorderStyle);
{$ENDIF}
procedure SetPageSetup(Value: TKPrintPageSetup);
{$IFNDEF FPC}
procedure WMCancelMode(var Msg: TWMCancelMode); message WM_CANCELMODE;
{$ENDIF}
{$IFNDEF COMPILER10_UP}
procedure WMMouseLeave(var Msg: TLMessage); message KM_MOUSELEAVE;
{$ENDIF}
{$IFNDEF FPC}
procedure WMNCPaint(var Msg: TWMNCPaint); message WM_NCPAINT;
procedure WMSetCursor(var Msg: TWMSetCursor); message WM_SETCURSOR;
{$ENDIF}
procedure WMSize(var Msg: TLMSize); message LM_SIZE;
{$IFNDEF FPC}
{$IFDEF USE_THEMES}
procedure WMThemeChanged(var Msg: TMessage); message WM_THEMECHANGED;
{$ENDIF}
{$ENDIF}
protected
{ Holds the mutually inexclusive state as cXF... flags. }
FFlags: Cardinal;
{ Defines the message queue for late update. }
FMessages: array of TLMessage;
{ Gains access to the list of associated previews. }
FPreviewList: TList;
{ Adds a preview control to the internal list of associated previews. }
procedure AddPreview(APreview: TKPrintPreview);
{ Gives the descendant the possibility to adjust the associated TKPrintPageSetup
instance just before printing. }
procedure AdjustPageSetup; virtual;
{ Cancels any dragging or resizing operations performed by mouse. }
procedure CancelMode; virtual;
{ Defines additional styles. }
procedure CreateParams(var Params: TCreateParams); override;
{$IFDEF FPC}
{ Overriden method. Calls @link(TKCustomControl.UpdateSize). }
procedure CreateWnd; override;
{ Overriden method. Calls @link(TKCustomControl.UpdateSize). }
procedure DoOnChangeBounds; override;
{$ENDIF}
{ If Value is True, includes the flag specified by AFLag to @link(FFlags).
If Value is False, excludes the flag specified by AFLag from @link(FFlags). }
procedure FlagAssign(AFlag: Cardinal; Value: Boolean);
{ Excludes the flag specified by AFLag from @link(FFlags). }
procedure FlagClear(AFlag: Cardinal);
{ Includes the flag specified by AFLag to @link(FFlags). }
procedure FlagSet(AFlag: Cardinal);
{ If the flag specified by AFLag is included in @link(FFlags), FlagToggle
excludes it and vice versa. }
procedure FlagToggle(AFlag: Cardinal);
{ Invalidates the page setup settings. If page setup is required again,
it's UpdateSettings method is called. }
procedure InvalidatePageSetup;
{ Invalidates a rectangular part of the client area if control updating is not locked
by @link(TKCustomControl.LockUpdate). }
procedure InvalidateRectArea(const R: TRect); virtual;
{ Returns True if the control has a selection. }
function InternalGetSelAvail: Boolean; virtual;
{ Called in UnlockUpdate. Allows the changes to be reflected. }
procedure InternalUnlockUpdate; virtual;
{ Determines if control can be painted with OS themes. }
function IsThemed: Boolean; virtual;
{ Called from KM_LATEUPDATE. Performs late update. Override to adapt. }
procedure LateUpdate(var Msg: TLMessage); virtual;
{ Updates information about printed shape. }
procedure MeasurePages(var Info: TKPrintMeasureInfo); virtual;
{ Retrieves a message from message queue if there is one. Used for late update.}
function MessagePeek(out Msg: TLMessage): Boolean;
{ Puts a new message into the message queue. Used for late update.}
procedure MessagePoke(const Msg: TLMessage);
{ Searches the message queue for given message code. }
function MessageSearch(MsgCode: Cardinal): Boolean;
{ Responds to WM_MOUSELEAVE message. }
procedure MouseFormLeave; virtual;
{ Overriden method - see Delphi help. }
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
{ Notifies all associated previews about a change in the associated page setup. }
procedure NotifyPreviews;
{ Overriden method - see Delphi help. Paints the entire control client area. }
procedure Paint; override;
{ Paints a page to a printer/preview canvas. }
procedure PaintPage; virtual;
{ Paints the control to the specified canvas. Must always be overriden. }
procedure PaintToCanvas(ACanvas: TCanvas); virtual; abstract;
{ Adds a message to message queue for late update. Set IfNotExists to True to
add that message only if the specified message code does not exist in the
message queue at this moment. }
procedure PostLateUpdate(const Msg: TLMessage; IfNotExists: Boolean = False);
{ Calls the @link(TKCustomControl.OnPrintNotify) event }
procedure PrintNotify(Status: TKPrintStatus; var Abort: Boolean); virtual;
{ Calls the @link(TKCustomControl.OnPrintPaint) event }
procedure PrintPaint; virtual;
{ Removse a preview control to the internal list of associated previews. }
procedure RemovePreview(APreview: TKPrintPreview);
{ Updates mouse cursor according to the state determined from current mouse
position. Returns True if cursor has been changed. }
function SetMouseCursor(X, Y: Integer): Boolean; virtual;
{ Updates the control size. Responds to WM_SIZE under Delphi and similar
notifications under Lazarus. }
procedure UpdateSize; virtual;
public
{ Creates the instance. Assigns default values to properties, allocates
default column, row and cell data. }
constructor Create(AOwner: TComponent); override;
{ Destroys the instance along with all allocated column, row and cell data.
See TObject.Destroy in Delphi help. }
destructor Destroy; override;
{ Determines whether a flag specified by AFlag is included in @link(FFlags). }
function Flag(AFlag: Cardinal): Boolean;
{ Invalidates the entire control if control updating is not locked
by @link(TKCustomControl.LockUpdate). }
procedure Invalidate; override;
{ Locks control updating so that all possibly slow operations such as all Invalidate...
methods will not be performed. This is useful e.g. when assigning many
properties at one time. Every LockUpdate call must have
a corresponding @link(TKCustomControl.UnlockUpdate) call, please use a
try-finally section. }
procedure LockUpdate;
{ Prints the control. }
procedure PrintOut;
{ Unlocks back to normal control updating and calls InternalUnlockUpdate
to reflect (possible) multiple changes made. Each @link(LockUpdate) call must
be always followed by the UnlockUpdate call. }
procedure UnlockUpdate;
{ Returns True if control updating is not locked, i.e. there is no open
LockUpdate and UnlockUpdate pair. }
function UpdateUnlocked: Boolean;
{ Determines whether a single line border is drawn around the control.
Set BorderStyle to bsSingle to add a single line border around the control.
Set BorderStyle to bsNone to omit the border. }
{$IFDEF FPC}
property BorderStyle default cBorderStyleDef;
{$ELSE}
property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default cBorderStyleDef;
{$ENDIF}
{ Returns True if the control has anything to print and a printer is installed. }
property CanPrint: Boolean read GetCanPrint;
{$IFNDEF COMPILER10_UP}
{ This property has the same meaning as the MouseInClient property introduced
into TWinControl in BDS 2006. }
property MouseInClient: Boolean read FMouseInClient;
{$ENDIF}
{ Setting this property causes the control to be painted to MemoryCanvas in it's
Paint method. This approach replaces PaintTo as it does not work good for all
LCL widget sets. The control is painted normally on it's Canvas and then
copied only once to MemoryCanvas. MemoryCanvas is then set to nil (not freed)
to indicate the copying is complete. }
property MemoryCanvas: TCanvas read FMemoryCanvas write FMemoryCanvas;
{ Specifies what rectangular part of the control should be copied on MemoryCanvas. }
property MemoryCanvasRect: TRect read FMemoryCanvasRect write FMemoryCanvasRect;
{ This event is called at certain phases of the actually running print job. }
property OnPrintNotify: TKPrintNotifyEvent read FOnPrintNotify write FOnPrintNotify;
{ This event is called after the shape was drawn onto the printer canvas. }
property OnPrintPaint: TKPrintPaintEvent read FOnPrintPaint write FOnPrintPaint;
{ Specifies the page setup component used for this control. }
property PageSetup: TKPrintPageSetup read GetPageSetup write SetPageSetup;
{Returns True if page setup component is allocated for this control. }
property PageSetupAllocated: Boolean read GetPageSetupAllocated;
end;
{ @abstract(Class to specify the print job parameters) }
TKPrintPageSetup = class(TPersistent)
private
FActive: Boolean;
FCanvas: TCanvas;
FControl: TKCustomControl;
FCopies: Integer;
FCurrentCopy: Integer;
FCurrentPage: Integer;
FCurrentScale: Double;
FDesktopPixelsPerInchX: Integer;
FDesktopPixelsPerInchY: Integer;
FEndPage: Integer;
FFooterSpace: Double;
FHeaderSpace: Double;
FHorzPageCount: Integer;
FIsValid: Boolean;
FMarginBottom: Double;
FMarginLeft: Double;
FMarginRight: Double;
FMarginTop: Double;
FOptions: TKPrintOptions;
FOutlineHeight: Integer;
FOutlineWidth: Integer;
FPageCount: Integer;
FPageHeight: Integer;
FPageWidth: Integer;
FPaintAreaHeight: Integer;
FPaintAreaWidth: Integer;
FPreviewing: Boolean;
FPrinterFooterSpace: Integer;
FPrinterHeaderSpace: Integer;
FPrinterMarginBottom: Integer;
FPrinterMarginLeft: Integer;
FPrinterMarginLeftMirrored: Integer;
FPrinterMarginRight: Integer;
FPrinterMarginRightMirrored: Integer;
FPrinterMarginTop: Integer;
FPrinterName: string;
FPrinterPixelsPerInchX: Integer;
FPrinterPixelsPerInchY: Integer;
FPrintingMapped: Boolean;
FRange: TKPrintRange;
FStartPage: Integer;
FScale: Integer;
FTitle: string;
FUnits: TKPrintUnits;
FUpdateLock: Integer;
FValidating: Boolean;
FVertPageCount: Integer;
function GetCanPrint: Boolean;
procedure SetCopies(Value: Integer);
procedure SetEndPage(Value: Integer);
procedure SetFooterSpace(Value: Double);
procedure SetHeaderSpace(Value: Double);
procedure SetMarginBottom(Value: Double);
procedure SetMarginLeft(Value: Double);
procedure SetMarginRight(Value: Double);
procedure SetMarginTop(Value: Double);
procedure SetOptions(Value: TKPrintOptions);
procedure SetPrinterName(const Value: string);
procedure SetPrintingMapped(Value: Boolean);
procedure SetRange(Value: TKPrintRange);
procedure SetScale(Value: Integer);
procedure SetStartPage(Value: Integer);
procedure SetUnits(Value: TKPrintUnits);
function GetSelAvail: Boolean;
protected
{ Called before new Units are set. Converts the margins to inches by default. }
procedure AfterUnitsChange; virtual;
{ Called after new Units are set. Converts the margins from inches by default. }
procedure BeforeUnitsChange; virtual;
{ Paints a page to APreview.Canvas. }
procedure PaintPageToPreview(APreview: TKPrintPreview); virtual;
{ Prints the page number at the bottom of the page, horizontally centered. }
procedure PrintPageNumber(Value: Integer); virtual;
{ Prints the title at the top of the page. }
procedure PrintTitle; virtual;
{ Updates entire printing information. }
procedure UpdateSettings; virtual;
public
{ Creates the instance. Assigns default values to properties. }
constructor Create(AControl: TKCustomControl);
{ Copies shareable properties of another TKPrintPageSetup instance
to this instance. }
procedure Assign(Source: TPersistent); override;
{ Returns a value mapped from desktop horizontal units to printer horizontal units. }
function HMap(Value: Integer): Integer;
{ Invalidates the settings. }
procedure Invalidate;
{ Prints the associated control. }
procedure PrintOut;
{ Locks page setup updating. Use this if you assign many properties at the
same time. Every LockUpdate call must have a corresponding
@link(TKPrintPageSetup.UnlockUpdate) call, please use a try-finally section. }
procedure LockUpdate; virtual;
{ Unlocks page setup updating and updates the page settings.
Each @link(TKPrintPageSetup.LockUpdate) call must be always followed
by the UnlockUpdate call. }
procedure UnlockUpdate; virtual;
{ Returns True if updating is not locked, i.e. there is no open
LockUpdate and UnlockUpdate pair. }
function UpdateUnlocked: Boolean; virtual;
{ Validates the settings. }
procedure Validate;
{ Returns a value mapped from desktop vertical units to printer vertical units. }
function VMap(Value: Integer): Integer;
{ Returns True if printing or previewing is active. }
property Active: Boolean read FActive;
{ Returns True if the control is associated and has anything to print. }
property CanPrint: Boolean read GetCanPrint;
{ Returns the Printer.Canvas or TkPrintPreview.Canvas. Do not access outside
print job. }
property Canvas: TCanvas read FCanvas;
{ Returns the control to which this TKPrintPageSetup instance is assigned. }
property Control: TKCustomControl read FControl;
{ Specifies the number of copies to print. }
property Copies: Integer read FCopies write SetCopies;
{ Returns the currently printed copy. }
property CurrentCopy: Integer read FCurrentCopy;
{ Returns the currently printed page. }
property CurrentPage: Integer read FCurrentPage;
{ Returns the horizontal scale for the printed shape, without dimension. }
property CurrentScale: Double read FCurrentScale;
{ Returns the amount of pixels per inch for the desktop device context's horizontal axis }
property DesktopPixelsPerInchX: Integer read FDesktopPixelsPerInchX;
{ Returns the amount of pixels per inch for the desktop device context's vertical axis }
property DesktopPixelsPerInchY: Integer read FDesktopPixelsPerInchY;
{ Specifies last page printed if Range is eprRange. }
property EndPage: Integer read FEndPage write SetEndPage;
{ Specifies the vertical space that should stay free for application
specific footer. Value is given in Units. }
property FooterSpace: Double read FFooterSpace write SetFooterSpace;
{ Specifies the vertical space that should stay free for application
specific header. Value is given in Units. }
property HeaderSpace: Double read FHeaderSpace write SetHeaderSpace;
{ Returns the maximum amount of pages for horizontal axis of the control. }
property HorzPageCount: Integer read FHorzPageCount;
{ Specifies the bottom margin. Value is given in Units. }
property MarginBottom: Double read FMarginBottom write SetMarginBottom;
{ Specifies the left margin. Value is given in Units. }
property MarginLeft: Double read FMarginLeft write SetMarginLeft;
{ Specifies the right margin. Value is given in Units. }
property MarginRight: Double read FMarginRight write SetMarginRight;
{ Specifies the top margin. Value is given in Units. }
property MarginTop: Double read FMarginTop write SetMarginTop;
{ Specifies the printing options. }
property Options: TKPrintOptions read FOptions write SetOptions;
{ Returns the printed shape height (maximum of all pages)
in units depending on PrintingMapped.. }
property OutlineHeight: Integer read FOutlineHeight;
{ Returns the printed shape width (maximum of all pages)
in units depending on PrintingMapped.. }
property OutlineWidth: Integer read FOutlineWidth;
{ Returns the amount of all pages. }
property PageCount: Integer read FPageCount;
{ Returns the page height in printer device context's pixels. }
property PageHeight: Integer read FPageHeight;
{ Returns the page width in printer device context's pixels. }
property PageWidth: Integer read FPageWidth;
{ Returns the top paint area width on canvas in units depending on PrintingMapped. }
property PaintAreaHeight: Integer read FPaintAreaHeight;
{ Returns the top paint area width on canvas in units depending on PrintingMapped. }
property PaintAreaWidth: Integer read FPaintAreaWidth;
{ Returns True if painting to a TKPrintPreview.Canvas is active. }
property Previewing: Boolean read FPreviewing;
{ Returns the footer space in printer device context's units. }
property PrinterFooterSpace: Integer read FPrinterFooterSpace;
{ Returns the header space in printer device context's units. }
property PrinterHeaderSpace: Integer read FPrinterHeaderSpace;
{ Returns the bottom margin in printer device context's units. }
property PrinterMarginBottom: Integer read FPrinterMarginBottom;
{ Returns the left margin in printer device context's units. }
property PrinterMarginLeft: Integer read FPrinterMarginLeft;
{ Returns the left margin in printer device context's units with respect to current page. }
property PrinterMarginLeftMirrored: Integer read FPrinterMarginLeftMirrored;
{ Returns the right margin in printer device context's units. }
property PrinterMarginRight: Integer read FPrinterMarginRight;
{ Returns the left margin in printer device context's units with respect to current page. }
property PrinterMarginRightMirrored: Integer read FPrinterMarginRightMirrored;
{ Returns the top margin in printer device context's units. }
property PrinterMarginTop: Integer read FPrinterMarginTop;
{ Specifies the printer name. }
property PrinterName: string read FPrinterName write SetPrinterName;
{ Returns the amount of pixels per inch for the printer device context's horizontal axis }
property PrinterPixelsPerInchX: Integer read FPrinterPixelsPerInchX;
{ Returns the amount of pixels per inch for the printer device context's vertical axis }
property PrinterPixelsPerInchY: Integer read FPrinterPixelsPerInchY;
{ Specifies the units for printing the control's shape and OutlineX properties.
If True, those extents are given in printer device context's pixels,
otherwise in desktop device context's pixels. It can be adjusted by the descendant
in the AdjustPageSetup method. }
property PrintingMapped: Boolean read FPrintingMapped write SetPrintingMapped;
{ Specifies the printing range. }
property Range: TKPrintRange read FRange write SetRange;
{ Returns True if the associated control has a selection. }
property SelAvail: Boolean read GetSelAvail;
{ Specifies first page printed if Range is eprRange. }
property StartPage: Integer read FStartPage write SetStartPage;
{ Specifies the requested scale for the printed shape, in percent.
If epoFitToPage is specified in Options, this parameter is ignored. }
property Scale: Integer read FScale write SetScale;
{ Specifies the document title as it appears in printer manager. }
property Title: string read FTitle write FTitle;
{ Specifies the units for print margins. }
property Units: TKPrintUnits read FUnits write SetUnits;
{ Returns the maximum amount of pages for vertical axis of the control. }
property VertPageCount: Integer read FVertPageCount;
end;
{ @abstract(Container for all colors used by @link(TKPrintPreview) class)
This container allows to group many colors into one item in object inspector.
Colors are accessible via published properties or several public Color*
properties. }
TKPreviewColors = class(TPersistent)
private
FPreview: TKPrintPreview;
function GetColor(Index: TKPreviewColorIndex): TColor;
function GetColorEx(Index: TKPreviewColorIndex): TColor;
procedure SetColor(Index: TKPreviewColorIndex; Value: TColor);
procedure SetColorEx(Index: TKPreviewColorIndex; Value: TColor);
procedure SetColors(const Value: TKColorArray);
protected
FColors: TKColorArray;
{ Initializes the color array. }
procedure Initialize; virtual;
{ Returns the specific color according to ColorScheme. }
function InternalGetColor(Index: TKPreviewColorIndex): TColor; virtual;
{ Replaces the specific color. }
procedure InternalSetColor(Index: TKPreviewColorIndex; Value: TColor); virtual;
public
{ Creates the instance. You can create a custom instance and pass it
e.g. to a @link(TKPrintPreview.Colors) property. The APreview parameter has no meaning
in this case and you may set it to nil. }
constructor Create(APreview: TKPrintPreview);
{ Copies the properties of another instance that inherits from
TPersistent into this TKPreviewColors instance. }
procedure Assign(Source: TPersistent); override;
{ Returns color for given index. }
property Color[Index: TKPreviewColorIndex]: TColor read GetColorEx write SetColorEx;
{ Returns array of colors. }
property Colors: TKColorArray read FColors write SetColors;
published
{ Specifies the paper background color. }
property Paper: TColor index ciPaper read GetColor write SetColor default cPaperDef;
{ Specifies the color of the background around paper. }
property BkGnd: TColor index ciBkGnd read GetColor write SetColor default cBkGndDef;
{ Specifies the color of the paper border. }
property Border: TColor index ciBorder read GetColor write SetColor default cBorderDef;
{ Specifies the color of the paper border when the control has input focus. }
property SelectedBorder: TColor index ciSelectedBorder read GetColor write SetColor default cSelectedBorderDef;
end;
{ @abstract(Print preview control for the TKCustomControl component) }
TKPrintPreview = class(TKCustomControl)
private
FColors: TKPreviewColors;
FControl: TKCustomControl;
FMouseWheelAccumulator: Integer;
FPage: Integer;
FPageOld: Integer;
FPageSize: TPoint;
FExtent: TPoint;
FPageOffset: TPoint;
FScale: Integer;
FScaleMode: TKPreviewScaleMode;
FScrollExtent: TPoint;
FScrollPos: TPoint;
FScrollPosOld: TPoint;
FX: Integer;
FY: Integer;
FOnChanged: TKPreviewChangedEvent;
function GetCurrentScale: Integer;
function GetEndPage: Integer;
function GetStartPage: Integer;
procedure SetControl(Value: TKCustomControl);
procedure SetPage(Value: Integer);
procedure SetScale(Value: Integer);
procedure SetScaleMode(Value: TKPreviewScaleMode);
procedure WMEraseBkgnd(var Msg: TLMessage); message LM_ERASEBKGND;
procedure WMGetDlgCode(var Msg: TLMNoParams); message LM_GETDLGCODE;
procedure WMHScroll(var Msg: TLMHScroll); message LM_HSCROLL;
procedure WMKillFocus(var Msg: TLMKillFocus); message LM_KILLFOCUS;
procedure WMSetFocus(var Msg: TLMSetFocus); message LM_SETFOCUS;
procedure WMVScroll(var Msg: TLMVScroll); message LM_VSCROLL;
procedure SetColors(const Value: TKPreviewColors);
protected
{ Initializes a scroll message handling. }
procedure BeginScrollWindow;
{ Defines additional styles. }
procedure CreateParams(var Params: TCreateParams); override;
{ Overriden method - handles mouse wheel messages. }
function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
MousePos: TPoint): Boolean; override;
{ Calls the ScrollWindowEx function to complete a scroll message. }
procedure EndScrollWindow;
{ Returns current page rectangle inside of the window client area. }
function GetPageRect: TRect;
{ Processes virtual key strokes. }
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
{ Processes scrollbar messages.
<UL>
<LH>Parameters:</LH>
<LI><I>ScrollBar</I> - scrollbar type from OS</LI>
<LI><I>ScrollCode</I> - scrollbar action from OS</LI>
<LI><I>Delta</I> - scrollbar position change</LI>
</UL> }
procedure ModifyScrollBar(ScrollBar, ScrollCode, Delta: Integer);
{ Initializes drag&scroll functionality. }
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
{ Performs drag&scroll functionality. }
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
{ Finalizes drag&scroll functionality. }
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
{ Notifies about associated TKCustomControl control removal. }
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
{ Paints paper and control shape. }
procedure Paint; override;
{ Calls the @link(OnChanged) event. }
procedure Changed;
{ Grants the input focus to the control when possible and the control has had none before. }
procedure SafeSetFocus;
{ Updates mouse cursor. }
function SetMouseCursor(X, Y: Integer): Boolean; override;
{ Updates page sizes and scrollbar ranges. }
procedure UpdateScrollRange;
{ Updates the control size. }
procedure UpdateSize; override;
public
{ Performs necessary initializations - default values to properties. }
constructor Create(AOwner: TComponent); override;
{ Destroy instance... }
destructor Destroy; override;
{ Shows first page for the given range. }
procedure FirstPage;
{ Shows last page for the given range. }
procedure LastPage;
{ Shows next page. }
procedure NextPage;
{ Shows previous page. }
procedure PreviousPage;
{ Updates the preview. }
procedure UpdatePreview;
{ Returns the page scaling with regard to the @link(ScaleMode) property. }
property CurrentScale: Integer read GetCurrentScale;
{ Returns the current page area rectangle in desktop pixels. }
property PageRect: TRect read GetPageRect;
{ Returns the last page for the given range. }
property EndPage: Integer read GetEndPage;
{ Returns the first page for the given range. }
property StartPage: Integer read GetStartPage;
published
{ Inherited property - see Delphi help. }
property Align;
{ Inherited property - see Delphi help. }
property Anchors;
{ See TKCustomControl.@link(TKCustomControl.BorderStyle) for details. }
property BorderStyle;
{ Inherited property - see Delphi help. }
property BorderWidth;
{ Specifies all colors used by TKPrintPreview's default painting. }
property Colors: TKPreviewColors read FColors write SetColors;
{ Inherited property - see Delphi help. }
property Constraints;
{ Specifies the associated control. }
property Control: TKCustomControl read FControl write SetControl;
{ Inherited property - see Delphi help. }
property DragCursor;
{ Inherited property - see Delphi help. }
property DragKind;
{ Inherited property - see Delphi help. }
property DragMode;
{ Specifies the currently displayed page. }
property Page: Integer read FPage write SetPage default 1;
{ Inherited property - see Delphi help. }
property ParentShowHint;
{ Inherited property - see Delphi help. }
property PopupMenu;
{ Specifies the user defined page scale - i.e. when ScaleMode = smScale. }
property Scale: Integer read FScale write SetScale default 100;
{ Specifies the scale mode to display and scroll previewed pages. }
property ScaleMode: TKPreviewScaleMode read FScaleMode write SetScaleMode default smPageWidth;
{ Inherited property - see Delphi help. }
property ShowHint;
{ Inherited property - see Delphi help. }
property TabStop;
{ Inherited property - see Delphi help. }
property TabOrder;
{ Inherited property - see Delphi help. }
property Visible;
{ Called whenever print preview is updated. }
property OnChanged: TKPreviewChangedEvent read FOnChanged write FOnChanged;
{ Inherited property - see Delphi help. }
property OnClick;
{ Inherited property - see Delphi help. }
property OnContextPopup;
{ Inherited property - see Delphi help. }
property OnDblClick;
{ Inherited property - see Delphi help. }
property OnDockDrop;
{ Inherited property - see Delphi help. }
property OnDockOver;
{ Inherited property - see Delphi help. }
property OnDragDrop;
{ Inherited property - see Delphi help. }
property OnDragOver;
{ Inherited property - see Delphi help. }
property OnEndDock;
{ Inherited property - see Delphi help. }
property OnEndDrag;
{ Inherited property - see Delphi help. }
property OnEnter;
{ Inherited property - see Delphi help. }
property OnExit;
{ Inherited property - see Delphi help. }
property OnGetSiteInfo;
{ Inherited property - see Delphi help. }
property OnKeyDown;
{ Inherited property - see Delphi help. }
property OnKeyPress;
{ Inherited property - see Delphi help. }
property OnKeyUp;
{ Inherited property - see Delphi help. }
property OnMouseDown;
{ Inherited property - see Delphi help. }
property OnMouseMove;
{ Inherited property - see Delphi help. }
property OnMouseUp;
{ Inherited property - see Delphi help. }
property OnMouseWheel;
{ Inherited property - see Delphi help. }
property OnMouseWheelDown;
{ Inherited property - see Delphi help. }
property OnMouseWheelUp;
{ Inherited property - see Delphi help. }
property OnResize;
{ Inherited property - see Delphi help. }
property OnStartDock;
{ Inherited property - see Delphi help. }
property OnStartDrag;
{ Inherited property - see Delphi help. }
property OnUnDock;
end;
{ Converts a value given in inches into a value given in specified units.
<UL>
<LH>Parameters:</LH>
<LI><I>Units</I> - measurement units for the output value</LI>
<LI><I>Value</I> - input value to convert</LI>
</UL> }
function InchesToValue(Units: TKPrintUnits; Value: Double): Double;
{ Converts value given in specified units into a value given in inches.
<UL>
<LH>Parameters:</LH>
<LI><I>Units</I> - measurement units for the input value</LI>
<LI><I>Value</I> - input value to convert</LI>
</UL> }
function ValueToInches(Units: TKPrintUnits; Value: Double): Double;
implementation
uses
Math, Printers, KGraphics;
const
cPreviewHorzBorder = 30;
cPreviewVertBorder = 30;
cPreviewShadowSize = 3;
function InchesToValue(Units: TKPrintUnits; Value: Double): Double;
begin
case Units of
puMM: Result := Value * 25.4;
puCM: Result := Value * 2.54;
puHundredthInch: Result := Value * 100;
else
Result := Value;
end;
end;
function ValueToInches(Units: TKPrintUnits; Value: Double): Double;
begin
case Units of
puMM: Result := Value / 25.4;
puCM: Result := Value / 2.54;
puHundredthInch: Result := Value / 100;
else
Result := Value;
end;
end;
{ TKCustomControl }
constructor TKCustomControl.Create(AOwner: TComponent);
begin
inherited;
BorderStyle := cBorderStyleDef;
FFlags := 0;
FMemoryCanvas := nil;
FMessages := nil;
{$IFNDEF COMPILER10_UP}
FMouseInClient := False;
{$ENDIF}
FPageSetup := nil;
FPreviewList := TList.Create;
FUpdateLock := 0;
FOnPrintNotify := nil;
FOnPrintPaint := nil;
end;
destructor TKCustomControl.Destroy;
begin
inherited;
FMessages := nil;
FreeAndNil(FPreviewList);
FreeAndNil(FPageSetup);
end;
procedure TKCustomControl.AddPreview(APreview: TKPrintPreview);
begin
if Assigned(APreview) then
FPreviewList.Add(APreview);
end;
procedure TKCustomControl.AdjustPageSetup;
begin
end;
procedure TKCustomControl.CancelMode;
begin
end;
{$IFNDEF FPC}
procedure TKCustomControl.CMCancelMode(var Msg: TLMessage);
begin
inherited;
CancelMode;
end;
procedure TKCustomControl.CMCtl3DChanged(var Msg: TLMessage);
begin
inherited;
RecreateWnd;
end;
{$ENDIF}
procedure TKCustomControl.CMMouseLeave(var Msg: TLMessage);
begin
inherited;
try
MouseFormLeave;
except
end;
end;
procedure TKCustomControl.CreateParams(var Params: TCreateParams);
begin
inherited;
{$IFNDEF FPC}
with Params do
begin
WindowClass.style := CS_DBLCLKS;
if BorderStyle = bsSingle then
if NewStyleControls and Ctl3D then
begin
Style := Style and not WS_BORDER;
ExStyle := ExStyle or WS_EX_CLIENTEDGE;
end
else
Style := Style or WS_BORDER;
end;
{$ENDIF}
end;
{$IFDEF FPC}
procedure TKCustomControl.CreateWnd;
begin
inherited;
UpdateSize;
end;
procedure TKCustomControl.DoOnChangeBounds;
begin
inherited;
UpdateSize;
end;
{$ENDIF}
function TKCustomControl.Flag(AFlag: Cardinal): Boolean;
begin
Result := FFlags and AFlag <> 0;
end;
procedure TKCustomControl.FlagAssign(AFlag: Cardinal; Value: Boolean);
begin
if Value then
FlagSet(AFlag)
else
FlagClear(AFlag);
end;
procedure TKCustomControl.FlagClear(AFlag: Cardinal);
begin
FFlags := FFlags and not AFlag;
end;
procedure TKCustomControl.FlagSet(AFlag: Cardinal);
begin
FFlags := FFlags or AFlag;
end;
procedure TKCustomControl.FlagToggle(AFlag: Cardinal);
begin
FFlags := FFlags xor AFlag;
end;
function TKCustomControl.GetCanPrint: Boolean;
begin
Result := PageSetup.CanPrint;
end;
function TKCustomControl.GetPageSetup: TKPrintPageSetup;
begin
if not Assigned(FPageSetup) and not (csDestroying in ComponentState) then
begin
FPageSetup := TKPrintPageSetup.Create(Self);
AdjustPageSetup;
end;
if Assigned(FPageSetup) then
FPageSetup.Validate;
Result := FPageSetup;
end;
function TKCustomControl.GetPageSetupAllocated: Boolean;
begin
Result := Assigned(FPageSetup);
end;
function TKCustomControl.InternalGetSelAvail: Boolean;
begin
Result := False;
end;
procedure TKCustomControl.InternalUnlockUpdate;
begin
end;
procedure TKCustomControl.Invalidate;
begin
if UpdateUnlocked and HandleAllocated then
inherited;
end;
procedure TKCustomControl.InvalidatePageSetup;
begin
if Assigned(FPageSetup) then
FPageSetup.Invalidate;
end;
procedure TKCustomControl.InvalidateRectArea(const R: TRect);
begin
if UpdateUnlocked and HandleAllocated then
InvalidateRect(Handle, @R, False);
end;
function TKCustomControl.IsThemed: Boolean;
begin
Result := True;
end;
procedure TKCustomControl.KMLateUpdate(var Msg: TLMessage);
var
M: TLMessage;
begin
if MessagePeek(M) then
LateUpdate(M);
end;
procedure TKCustomControl.LateUpdate(var Msg: TLMessage);
begin
case Msg.Msg of
LM_SIZE: UpdateSize;
end;
end;
procedure TKCustomControl.LockUpdate;
begin
Inc(FUpdateLock);
end;
procedure TKCustomControl.MeasurePages(var Info: TKPrintMeasureInfo);
begin
end;
function TKCustomControl.MessagePeek(out Msg: TLMessage): Boolean;
var
ALen: Integer;
begin
ALen := Length(FMessages);
if ALen > 0 then
begin
Dec(ALen);
Msg := FMessages[ALen];
SetLength(FMessages, ALen);
Result := True;
end else
Result := False;
end;
procedure TKCustomControl.MessagePoke(const Msg: TLMessage);
var
ALen: Integer;
begin
ALen := Length(FMessages);
SetLength(FMessages, ALen + 1);
FMessages[ALen] := Msg;
end;
function TKCustomControl.MessageSearch(MsgCode: Cardinal): Boolean;
var
I: Integer;
begin
Result := False;
for I := 0 to Length(FMessages) - 1 do
if FMessages[I].Msg = MsgCode then
begin
Result := True;
Exit;
end;
end;
procedure TKCustomControl.MouseFormLeave;
begin
end;
procedure TKCustomControl.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
inherited;
{$IFNDEF COMPILER10_UP}
CallTrackMouseEvent(Self, FMouseInClient);
{$ENDIF}
{$IFDEF FPC}
if not MouseCapture then
SetMouseCursor(X, Y);
{$ENDIF}
end;
procedure TKCustomControl.NotifyPreviews;
var
I: Integer;
begin
for I := 0 to FPreviewList.Count - 1 do
TKPrintPreview(FPreviewList[I]).UpdatePreview;
end;
procedure TKCustomControl.Paint;
begin
PaintToCanvas(Canvas);
if Assigned(FMemoryCanvas) then
begin
{$IFDEF USE_WINAPI}
// this is the best method but does not work both on QT and GTK!
MoveWindowOrg(FMemoryCanvas.Handle, -FMemoryCanvasRect.Left, -FMemoryCanvasRect.Top);
try
PaintToCanvas(FMemoryCanvas);
finally
MoveWindowOrg(FMemoryCanvas.Handle, FMemoryCanvasRect.Left, FMemoryCanvasRect.Top);
end;
{$ELSE}
FMemoryCanvas.CopyRect(Rect(0, 0, FMemoryCanvasRect.Right - FMemoryCanvasRect.Left,
FMemoryCanvasRect.Bottom - FMemoryCanvasRect.Top), Canvas, FMemoryCanvasRect);
{$ENDIF}
FMemoryCanvas := nil;
end;
end;
procedure TKCustomControl.PostLateUpdate(const Msg: TLMessage;
IfNotExists: Boolean);
begin
if HandleAllocated then
begin
if not IfNotExists or not MessageSearch(Msg.Msg) then
MessagePoke(Msg);
PostMessage(Handle, KM_LATEUPDATE, 0, 0);
end;
end;
procedure TKCustomControl.PrintNotify(Status: TKPrintStatus; var Abort: Boolean);
begin
if Assigned(FOnPrintNotify) then
FOnPrintNotify(Self, Status, Abort);
end;
procedure TKCustomControl.PrintPaint;
begin
if Assigned(FOnPrintPaint) then
FOnPrintPaint(Self);
end;
procedure TKCustomControl.PrintOut;
begin
GetPageSetup.PrintOut;
end;
procedure TKCustomControl.PaintPage;
begin
end;
procedure TKCustomControl.RemovePreview(APreview: TKPrintPreview);
begin
if Assigned(FPreviewList) and (FPreviewList.IndexOf(APreview) >= 0) then
FPreviewList.Remove(APreview);
end;
{$IFNDEF FPC}
procedure TKCustomControl.SetBorderStyle(Value: TBorderStyle);
begin
if FBorderStyle <> Value then
begin
FBorderStyle := Value;
RecreateWnd;
end;
end;
{$ENDIF}
function TKCustomControl.SetMouseCursor(X, Y: Integer): Boolean;
begin
Result := False;
end;
procedure TKCustomControl.SetPageSetup(Value: TKPrintPageSetup);
begin
if Value <> FPageSetup then
GetPageSetup.Assign(Value);
end;
procedure TKCustomControl.UnlockUpdate;
begin
if FUpdateLock > 0 then
begin
Dec(FUpdateLock);
if FUpdateLock = 0 then
InternalUnlockUpdate;
end;
end;
procedure TKCustomControl.UpdateSize;
begin
end;
function TKCustomControl.UpdateUnlocked: Boolean;
begin
Result := FUpdateLock = 0;
end;
{$IFNDEF FPC}
procedure TKCustomControl.WMCancelMode(var Msg: TWMCancelMode);
begin
inherited;
CancelMode;
end;
{$ENDIF}
{$IFNDEF COMPILER10_UP}
procedure TKCustomControl.WMMouseLeave(var Msg: TLMessage);
begin
{ this is because of CM_MOUSELEAVE is not sent if mouse has left client area
and entered any of the standard control scrollbars. This behavior has been
fixed via TrackMouseEvent in BDS 2006. }
inherited;
FMouseInClient := False;
Perform(CM_MOUSELEAVE, 0, 0);
end;
{$ENDIF}
{$IFNDEF FPC}
procedure TKCustomControl.WMNCPaint(var Msg: TWMNCPaint);
{$IFDEF USE_THEMES}
var
R: TRect;
ExStyle: Integer;
TempRgn: HRGN;
BorderWidth,
BorderHeight: Integer;
{$ENDIF}
begin
{$IFDEF USE_THEMES}
with ThemeServices do if IsThemed and ThemesEnabled then
begin
// If OS themes are enabled and the client edge border is set for the window then prevent the default window proc
// from painting the old border to avoid flickering.
ExStyle := GetWindowLong(Handle, GWL_EXSTYLE);
if (ExStyle and WS_EX_CLIENTEDGE) <> 0 then
begin
GetWindowRect(Handle, R);
// Determine width of the client edge.
BorderWidth := GetSystemMetrics(SM_CXEDGE);
BorderHeight := GetSystemMetrics(SM_CYEDGE);
InflateRect(R, -BorderWidth, -BorderHeight);
TempRgn := CreateRectRgnIndirect(R);
// Exclude the border from the message region if there is one. Otherwise just use the inflated
// window area region.
if Msg.Rgn <> 1 then
CombineRgn(TempRgn, Msg.Rgn, TempRgn, RGN_AND);
DefWindowProc(Handle, Msg.Msg, Integer(TempRgn), 0);
DeleteObject(TempRgn);
PaintBorder(Self, True);
end else
inherited;
end else
{$ENDIF}
inherited;
end;
procedure TKCustomControl.WMSetCursor(var Msg: TWMSetCursor);
var
MousePt: TPoint;
begin
if (Msg.HitTest = HTCLIENT) and (Msg.CursorWnd = Handle) then
begin
MousePt := ScreenToClient(Mouse.CursorPos);
if SetMouseCursor(MousePt.X, MousePt.Y) then
Msg.Result := 1
else
inherited
end else
inherited;
end;
{$ENDIF}
procedure TKCustomControl.WMSize(var Msg: TLMSize);
begin
inherited;
PostLateUpdate(FillMessage(LM_SIZE, 0, 0), True);
end;
{$IFNDEF FPC}
{$IFDEF USE_THEMES}
procedure TKCustomControl.WMThemeChanged(var Msg: TLMessage);
begin
if IsThemed then
begin
inherited;
ThemeServices.UpdateThemes;
RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_VALIDATE or RDW_FRAME);
end;
end;
{$ENDIF}
{$ENDIF}
{ TKPrintPageSetup }
constructor TKPrintPageSetup.Create(AControl: TKCustomControl);
begin
inherited Create;
FActive := False;
FCanvas := nil;
FControl := AControl;
FCopies := cCopiesDef;
FCurrentCopy := 0;
FCurrentPage := 0;
FCurrentScale := 0;
FDesktopPixelsPerInchX := 0;
FDesktopPixelsPerInchY := 0;
FEndPage := 0;
FFooterSpace := 0;
FHeaderSpace := 0;
FHorzPageCount := 0;
FIsValid := False;
FMarginBottom := cMarginBottomDef;
FMarginLeft := cMarginLeftDef;
FMarginRight := cMarginRightDef;
FMarginTop := cMarginTopDef;
FOptions := cOptionsDef;
FOutlineHeight := 0;
FOutlineWidth := 0;
FPageCount := 0;
FPageHeight := 0;
FPageWidth := 0;
FPaintAreaHeight := 0;
FPaintAreaWidth := 0;
FPreviewing := False;
FPrinterFooterSpace := 0;
FPrinterHeaderSpace := 0;
FPrinterMarginBottom := 0;
FPrinterMarginLeft := 0;
FPrinterMarginLeftMirrored := 0;
FPrinterMarginRight := 0;
FPrinterMarginRightMirrored := 0;
FPrinterMarginTop := 0;
FPrinterName := '';
FPrinterPixelsPerInchX := 0;
FPrinterPixelsPerInchY := 0;
FPrintingMapped := True;
FRange := cRangeDef;
FStartPage := 0;
FScale := cScaleDef;
FTitle := '';
FUnits := cUnitsDef;
FUpdateLock := 0;
FValidating := False;
FVertPageCount := 0;
end;
function TKPrintPageSetup.GetCanPrint: Boolean;
begin
Result := Assigned(FControl) and (FPageCount > 0) and (Printer.Printers.Count > 0);
end;
function TKPrintPageSetup.GetSelAvail: Boolean;
begin
if Assigned(FControl) then
Result := FControl.InternalGetSelAvail
else
Result := False;
end;
procedure TKPrintPageSetup.AfterUnitsChange;
begin
FFooterSpace := InchesToValue(FUnits, FFooterSpace);
FHeaderSpace := InchesToValue(FUnits, FHeaderSpace);
FMarginBottom := InchesToValue(FUnits, FMarginBottom);
FMarginLeft := InchesToValue(FUnits, FMarginLeft);
FMarginRight := InchesToValue(FUnits, FMarginRight);
FMarginTop := InchesToValue(FUnits, FMarginTop);
end;
procedure TKPrintPageSetup.Assign(Source: TPersistent);
begin
if Source is TKPrintPageSetup then
begin
LockUpdate;
try
Copies := TKPrintPageSetup(Source).Copies;
EndPage := TKPrintPageSetup(Source).EndPage;
FooterSpace := TKPrintPageSetup(Source).FooterSpace;
HeaderSpace := TKPrintPageSetup(Source).HeaderSpace;
MarginBottom := TKPrintPageSetup(Source).MarginBottom;
MarginLeft := TKPrintPageSetup(Source).MarginLeft;
MarginRight := TKPrintPageSetup(Source).MarginRight;
MarginTop := TKPrintPageSetup(Source).MarginTop;
Options := TKPrintPageSetup(Source).Options;
PrinterName := TKPrintPageSetup(Source).PrinterName;
Range := TKPrintPageSetup(Source).Range;
StartPage := TKPrintPageSetup(Source).StartPage;
Scale := TKPrintPageSetup(Source).Scale;
Title := TKPrintPageSetup(Source).Title;
Units := TKPrintPageSetup(Source).Units;
finally
UnlockUpdate;
end;
end;
end;
procedure TKPrintPageSetup.BeforeUnitsChange;
begin
FFooterSpace := ValueToInches(FUnits, FFooterSpace);
FHeaderSpace := ValueToInches(FUnits, FHeaderSpace);
FMarginBottom := ValueToInches(FUnits, FMarginBottom);
FMarginLeft := ValueToInches(FUnits, FMarginLeft);
FMarginRight := ValueToInches(FUnits, FMarginRight);
FMarginTop := ValueToInches(FUnits, FMarginTop);
end;
function TKPrintPageSetup.HMap(Value: Integer): Integer;
begin
Result := MulDiv(Value, FPrinterPixelsPerInchX, FDesktopPixelsPerInchX);
end;
procedure TKPrintPageSetup.Invalidate;
begin
FIsValid := False;
end;
procedure TKPrintPageSetup.LockUpdate;
begin
Inc(FUpdateLock);
end;
procedure TKPrintPageSetup.PaintPageToPreview;
var
PaperWidth, PaperHeight, SaveIndex: Integer;
R, PageRect: TRect;
begin
if UpdateUnlocked and Assigned(FControl) then
begin
FCanvas := APreview.Canvas;
FActive := True;
FPreviewing := True;
try
FCurrentCopy := 1;
FCurrentPage := APreview.Page;
if (poMirrorMargins in FOptions) and (FCurrentPage and 1 <> 0) then
begin
FPrinterMarginLeftMirrored := FPrinterMarginRight;
FPrinterMarginRightMirrored := FPrinterMarginLeft;
end else
begin
FPrinterMarginLeftMirrored := FPrinterMarginLeft;
FPrinterMarginRightMirrored := FPrinterMarginRight;
end;
R := APreview.PageRect;
PaperWidth := R.Right - R.Left;
PaperHeight := R.Bottom - R.Top;
SaveIndex := SaveDC(FCanvas.Handle);
try
// change the canvas mapping mode to scale the page outline
CanvasSetOffset(FCanvas,
R.Left + MulDiv(FPrinterMarginLeftMirrored, PaperWidth, FPageWidth),
R.Top + MulDiv(FPrinterMarginTop + FPrinterHeaderSpace, PaperHeight, FPageHeight));
if FPrintingMapped then
CanvasSetScale(FCanvas, Round(PaperWidth * FCurrentScale), Round(PaperHeight * FCurrentScale),
MulDiv(FPageWidth, FDesktopPixelsPerInchX, FPrinterPixelsPerInchX),
MulDiv(FPageHeight, FDesktopPixelsPerInchY, FPrinterPixelsPerInchY))
else
CanvasSetScale(FCanvas, PaperWidth, PaperHeight, FPageWidth, FPageHeight);
FControl.PaintPage;
finally
RestoreDC(FCanvas.Handle, SaveIndex);
end;
SaveIndex := SaveDC(FCanvas.Handle);
try
CanvasSetOffset(FCanvas, R.Left, R.Top);
CanvasSetScale(FCanvas, PaperWidth, PaperHeight, FPageWidth, FPageHeight);
PageRect := Rect(0, 0, FPageWidth, FPageHeight);
TranslateRectToDevice(FCanvas.Handle, PageRect);
SelectClipRect(FCanvas.Handle, PageRect);
FControl.PrintPaint;
finally
RestoreDC(FCanvas.Handle, SaveIndex);
end;
SaveIndex := SaveDC(FCanvas.Handle);
try
CanvasSetOffset(FCanvas, R.Left, R.Top);
CanvasSetScale(FCanvas, PaperWidth, PaperHeight, FPageWidth, FPageHeight);
PageRect := Rect(0, 0, FPageWidth, FPageHeight);
TranslateRectToDevice(FCanvas.Handle, PageRect);
SelectClipRect(FCanvas.Handle, PageRect);
PrintTitle;
PrintPageNumber(FCurrentPage);
finally
RestoreDC(FCanvas.Handle, SaveIndex);
end;
finally
FActive := False;
FPreviewing := False;
FCanvas := nil;
end;
end;
end;
procedure TKPrintPageSetup.PrintPageNumber(Value: Integer);
var
S: string;
begin
if poPageNumbers in FOptions then
begin
FCanvas.Brush.Style := bsClear;
FCanvas.Font.Color := clBlack;
FCanvas.Font.Height := 1;
FCanvas.Font.Height := VMap(16);
FCanvas.Font.Name := 'Arial';
FCanvas.Font.Pitch := fpDefault;
FCanvas.Font.Style := [fsBold];
S := Format('- %d -', [Value]);
FCanvas.TextOut(FPrinterMarginLeftMirrored + (FPageWidth - FPrinterMarginLeft - FPrinterMarginRight - FCanvas.TextWidth(S)) div 2,
FPageHeight - FPrinterMarginBottom + VMap(5), S);
end;
end;
procedure TKPrintPageSetup.PrintTitle;
begin
if poTitle in FOptions then
begin
FCanvas.Brush.Style := bsClear;
FCanvas.Font.Color := clBlack;
FCanvas.Font.Height := 1;
FCanvas.Font.Height := VMap(16);
FCanvas.Font.Name := 'Arial';
FCanvas.Font.Pitch := fpDefault;
FCanvas.Font.Style := [fsBold];
FCanvas.TextOut(FPrinterMarginLeftMirrored, FPrinterMarginTop - VMap(36), Title);
FCanvas.Brush.Style := bsSolid;
FCanvas.Brush.Color := clBlack;
FCanvas.FillRect(Rect(FPrinterMarginLeftMirrored, FPrinterMarginTop - VMap(14), FPageWidth - FPrinterMarginRight, FPrinterMarginTop - VMap(12)));
end;
end;
procedure TKPrintPageSetup.PrintOut;
function DoPrint: Boolean;
var
SaveIndex: Integer;
PageRect: TRect;
begin
Result := False;
if (poMirrorMargins in FOptions) and (FCurrentPage and 1 <> 0) then
begin
FPrinterMarginLeftMirrored := FPrinterMarginRight;
FPrinterMarginRightMirrored := FPrinterMarginLeft;
end else
begin
FPrinterMarginLeftMirrored := FPrinterMarginLeft;
FPrinterMarginRightMirrored := FPrinterMarginRight;
end;
SaveIndex := SaveDC(FCanvas.Handle);
try
CanvasSetOffset(FCanvas, FPrinterMarginLeftMirrored, FPrinterMarginTop + FPrinterHeaderSpace);
if FPrintingMapped then
begin
// change the canvas mapping mode to scale the page outline
CanvasSetScale(FCanvas, Round(FPageWidth * FCurrentScale), Round(FPageHeight * FCurrentScale),
MulDiv(FPageWidth, FDesktopPixelsPerInchX, FPrinterPixelsPerInchX),
MulDiv(FPageHeight, FDesktopPixelsPerInchY, FPrinterPixelsPerInchY));
end else
CanvasResetScale(FCanvas);
FControl.PaintPage;
finally
RestoreDC(FCanvas.Handle, SaveIndex);
end;
SaveIndex := SaveDC(FCanvas.Handle);
try
CanvasResetScale(FCanvas);
PageRect := Rect(0, 0, FPageWidth, FPageHeight);
TranslateRectToDevice(FCanvas.Handle, PageRect);
SelectClipRect(FCanvas.Handle, PageRect);
FControl.PrintPaint;
finally
RestoreDC(FCanvas.Handle, SaveIndex);
end;
SaveIndex := SaveDC(FCanvas.Handle);
try
CanvasResetScale(FCanvas);
PageRect := Rect(0, 0, FPageWidth, FPageHeight);
TranslateRectToDevice(FCanvas.Handle, PageRect);
SelectClipRect(FCanvas.Handle, PageRect);
PrintTitle;
PrintPageNumber(FCurrentPage);
finally
RestoreDC(FCanvas.Handle, SaveIndex);
end;
FControl.PrintNotify(epsNewPage, Result);
if ((FCurrentPage < FEndPage) or (FCurrentCopy < FCopies)) and not Result then
Printer.NewPage;
end;
var
I, J: Integer;
AbortPrint: Boolean;
{ Orientation: TPrinterOrientation;
PaperSize: TPaperSize;
APageWidth, ApageHeight, APaperWidth, APaperHeight: Integer;
PrinterType: TPrinterType;
APaperRect: TPaperRect;}
begin
if UpdateUnlocked and Assigned(FControl) then
begin
UpdateSettings;
if FPageCount > 0 then
begin
AbortPrint := False;
FCanvas := Printer.Canvas;
Printer.Title := FTitle;
Printer.Copies := 1;
{ PrinterType := Printer.PrinterType;
APageWidth := Printer.PageWidth;
APageHeight := Printer.PageHeight;
APaperRect := Printer.PaperSize.PaperRect;
Orientation := Printer.Orientation;}
Printer.BeginDoc;
FActive := True;
try
FControl.PrintNotify(epsBegin, AbortPrint);
{ Printer.Canvas.Font.Name := 'Arial';
Printer.Canvas.Font.color := clBlack;
Printer.Canvas.Font.height := 100;
Printer.Canvas.TextOut(200, 200, 'hello!');}
if not AbortPrint then
begin
if poCollate in FOptions then
for I := 1 to FCopies do
begin
FCurrentCopy := I;
for J := FStartPage to FEndPage do
begin
FCurrentPage := J;
AbortPrint := DoPrint;
if AbortPrint then Break;
end;
if AbortPrint then Break;
end
else
for J := FStartPage to FEndPage do
begin
FCurrentPage := J;
for I := 1 to FCopies do
begin
FCurrentCopy := I;
AbortPrint := DoPrint;
if AbortPrint then Break;
end;
if AbortPrint then Break;
end
end;
FCurrentPage := 0;
FCurrentCopy := 0;
FControl.PrintNotify(epsEnd, AbortPrint);
finally
FActive := False;
Printer.EndDoc;
FCanvas := nil;
end;
end;
end;
end;
procedure TKPrintPageSetup.SetCopies(Value: Integer);
begin
if FActive then Exit;
if Value <> FCopies then
begin
FCopies := Value;
UpdateSettings;
end;
end;
procedure TKPrintPageSetup.SetEndPage(Value: Integer);
begin
if FActive then Exit;
if Value <> FEndPage then
begin
FEndPage := Value;
UpdateSettings;
end;
end;
procedure TKPrintPageSetup.SetFooterSpace(Value: Double);
begin
if FActive then Exit;
if Value <> FFooterSpace then
begin
FFooterSpace := Value;
UpdateSettings;
end;
end;
procedure TKPrintPageSetup.SetHeaderSpace(Value: Double);
begin
if FActive then Exit;
if Value <> FHeaderSpace then
begin
FHeaderSpace := Value;
UpdateSettings;
end;
end;
procedure TKPrintPageSetup.SetMarginBottom(Value: Double);
begin
if FActive then Exit;
if Value <> FMarginBottom then
begin
FMarginBottom := Value;
UpdateSettings;
end;
end;
procedure TKPrintPageSetup.SetMarginLeft(Value: Double);
begin
if FActive then Exit;
if Value <> FMarginLeft then
begin
FMarginLeft := Value;
UpdateSettings;
end;
end;
procedure TKPrintPageSetup.SetMarginRight(Value: Double);
begin
if FActive then Exit;
if Value <> FMarginRight then
begin
FMarginRight := Value;
UpdateSettings;
end;
end;
procedure TKPrintPageSetup.SetMarginTop(Value: Double);
begin
if FActive then Exit;
if Value <> FMarginTop then
begin
FMarginTop := Value;
UpdateSettings;
end;
end;
procedure TKPrintPageSetup.SetOptions(Value: TKPrintOptions);
begin
if FActive then Exit;
if Value <> FOptions then
begin
FOptions := Value;
UpdateSettings;
end;
end;
procedure TKPrintPageSetup.SetPrinterName(const Value: string);
begin
if FActive then Exit;
if Value <> FPrinterName then
begin
FPrinterName := Value;
UpdateSettings;
end;
end;
procedure TKPrintPageSetup.SetPrintingMapped(Value: Boolean);
begin
if FActive then Exit;
if Value <> FPrintingMapped then
begin
FPrintingMapped := Value;
UpdateSettings;
end;
end;
procedure TKPrintPageSetup.SetRange(Value: TKPrintRange);
begin
if FActive then Exit;
if Value <> FRange then
begin
FRange := Value;
UpdateSettings;
end;
end;
procedure TKPrintPageSetup.SetScale(Value: Integer);
begin
if FActive then Exit;
if Value <> FScale then
begin
FScale := Value;
UpdateSettings;
end;
end;
procedure TKPrintPageSetup.SetStartPage(Value: Integer);
begin
if FActive then Exit;
if Value <> FStartPage then
begin
FStartPage := Value;
UpdateSettings;
end;
end;
procedure TKPrintPageSetup.SetUnits(Value: TKPrintUnits);
begin
if FActive then Exit;
if Value <> FUnits then
begin
BeforeUnitsChange;
FUnits := Value;
AfterUnitsChange;
end;
end;
procedure TKPrintPageSetup.UnlockUpdate;
begin
if FUpdateLock > 0 then
begin
Dec(FUpdateLock);
UpdateSettings;
end;
end;
procedure TKPrintPageSetup.UpdateSettings;
var
I, PixelsPerInchX, PixelsPerInchY: Integer;
D: Double;
DC: HDC;
Info: TKPrintMeasureInfo;
begin
if UpdateUnlocked and not FActive and not FValidating then
begin
FValidating := True;
try
Printer.Refresh;
I := Printer.Printers.IndexOf(FPrinterName);
if I >= 0 then
Printer.PrinterIndex := I;
// limit copies and Scale
FCopies := MinMax(FCopies, cCopiesMin, cCopiesMax);
FScale := MinMax(FScale, cScaleMin, cScaleMax);
// get metrics for the desktop
DC := GetDC(0);
try
FDesktopPixelsPerInchX := GetDeviceCaps(DC, LOGPIXELSX);
FDesktopPixelsPerInchY := GetDeviceCaps(DC, LOGPIXELSY);
finally
ReleaseDC(0, DC);
end;
// get metrics for the printer
if Printer.Printers.Count > 0 then
begin
FPageWidth := Printer.PageWidth;
FPageHeight := Printer.PageHeight;
{$IFDEF FPC}
FPrinterPixelsPerInchX := Printer.XDPI;
FPrinterPixelsPerInchY := Printer.YDPI;
{$ELSE}
FPrinterPixelsPerInchX := GetDeviceCaps(Printer.Handle, LOGPIXELSX);
FPrinterPixelsPerInchY := GetDeviceCaps(Printer.Handle, LOGPIXELSY);
{$ENDIF}
end else
begin
// fake printer metrics if no printer is installed
FPageWidth := 2360;
FPageHeight := 3400;
FPrinterPixelsPerInchX := 300;
FPrinterPixelsPerInchY := 300;
end;
// decide how to outline extent
if FPrintingMapped then
begin
PixelsPerInchX := FDesktopPixelsPerInchX;
PixelsPerInchY := FDesktopPixelsPerInchY;
end else
begin
PixelsPerInchX := FPrinterPixelsPerInchX;
PixelsPerInchY := FPrinterPixelsPerInchY;
end;
// limit and convert margins
D := FPageWidth * 0.4; // 40% of the page
FPrinterMarginLeft := Round(MinMax(ValueToInches(FUnits, FMarginLeft) * FPrinterPixelsPerInchX, 0, D));
FPrinterMarginLeftMirrored := FPrinterMarginLeft;
FMarginLeft := InchesToValue(FUnits, FPrinterMarginLeft / FPrinterPixelsPerInchX);
FPrinterMarginRight := Round(MinMax(ValueToInches(FUnits, FMarginRight) * FPrinterPixelsPerInchX, 0, D));
FPrinterMarginRightMirrored := FPrinterMarginRight;
FMarginRight := InchesToValue(FUnits, FPrinterMarginRight / FPrinterPixelsPerInchX);
D := FPageHeight * 0.4; // 40% of the page
FPrinterMarginTop := Round(MinMax(ValueToInches(FUnits, FMarginTop) * FPrinterPixelsPerInchY, 0, D));
FMarginTop := InchesToValue(FUnits, FPrinterMarginTop / FPrinterPixelsPerInchY);
FPrinterMarginBottom := Round(MinMax(ValueToInches(FUnits, FMarginBottom) * FPrinterPixelsPerInchY, 0, D));
FMarginBottom := InchesToValue(FUnits, FPrinterMarginBottom / FPrinterPixelsPerInchY);
// limit and convert header and footer space
FPrinterHeaderSpace := Round(MinMax(ValueToInches(FUnits, Max(FHeaderSpace, 0)) * FPrinterPixelsPerInchY, 0, D - FPrinterMarginTop));
FHeaderSpace := InchesToValue(FUnits, FPrinterHeaderSpace / FPrinterPixelsPerInchY);
FPrinterFooterSpace := Round(MinMax(ValueToInches(FUnits, Max(FFooterSpace, 0)) * FPrinterPixelsPerInchY, 0, D - FPrinterMarginBottom));
FFooterSpace := InchesToValue(FUnits, FPrinterFooterSpace / FPrinterPixelsPerInchY);
// paint area extent
FPaintAreaHeight := MulDiv(FPageHeight - FPrinterMarginTop - FPrinterMarginBottom - FPrinterHeaderSpace - FPrinterFooterSpace, PixelsPerInchY, FPrinterPixelsPerInchY);
FPaintAreaWidth := MulDiv(FPageWidth - FPrinterMarginLeft - FPrinterMarginRight, PixelsPerInchX, FPrinterPixelsPerInchX);
// default horizontal scaling
FCurrentScale := FScale / 100;
// default page/copy info
FCurrentCopy := 0;
FCurrentPage := 0;
// measured data
if Assigned(FControl) then
begin
FillChar(Info, SizeOf(TKPrintMeasureInfo), 0);
FControl.MeasurePages(Info);
FOutlineWidth := Info.OutlineWidth;
FOutlineHeight := Info.OutlineHeight;
FHorzPageCount := Info.HorzPageCount;
FVertPageCount := Info.VertPageCount;
FPageCount := Info.PageCount;
if FPageCount > 0 then
begin
// update horizontal scaling
if (poFitToPage in FOptions) and (FOutlineWidth > 0) then
FCurrentScale := FPaintAreaWidth / FOutlineWidth;
// limit start and end page
case FRange of
prAll, prSelectedOnly:
begin
FStartPage := 1;
FEndPage := FPageCount;
end;
prRange:
begin
FEndPage := MinMax(FEndPage, 1, FPageCount);
FStartPage := MinMax(FStartPage, 1, FEndPage);
end;
end;
end;
// notify all previews/ force their repainting
FControl.NotifyPreviews;
end else
begin
FOutlineWidth := 0;
FOutlineHeight := 0;
FHorzPageCount := 0;
FVertPageCount := 0;
FPageCount := 0;
FEndPage := 0;
FStartPage := 0;
end;
FIsValid := True;
finally
FValidating := False;
end;
end;
end;
function TKPrintPageSetup.UpdateUnlocked: Boolean;
begin
Result := FUpdateLock = 0;
end;
procedure TKPrintPageSetup.Validate;
begin
if not FIsValid and not FValidating then
UpdateSettings;
end;
function TKPrintPageSetup.VMap(Value: Integer): Integer;
begin
Result := MulDiv(Value, FPrinterPixelsPerInchY, FDesktopPixelsPerInchY);
end;
{ TKPreviewColors }
constructor TKPreviewColors.Create(APreview: TKPrintPreview);
begin
inherited Create;
FPreview := APreview;
Initialize;
end;
procedure TKPreviewColors.Assign(Source: TPersistent);
begin
inherited;
if Source is TKPreviewColors then
begin
Colors := TKPreviewColors(Source).Colors;
FPreview.Invalidate;
end
end;
function TKPreviewColors.GetColor(Index: TKPreviewColorIndex): TColor;
begin
Result := InternalGetColor(Index);
end;
function TKPreviewColors.GetColorEx(Index: TKPreviewColorIndex): TColor;
begin
Result := FColors[Index];
end;
procedure TKPreviewColors.Initialize;
begin
SetLength(FColors, ciPreviewColorsMax + 1);
FColors[ciPaper] := cPaperDef;
FColors[ciBkGnd] := cBkGndDef;
FColors[ciBorder] := cBorderDef;
FColors[ciSelectedBorder] := cSelectedBorderDef;
end;
function TKPreviewColors.InternalGetColor(Index: TKPreviewColorIndex): TColor;
begin
Result := FColors[Index];
end;
procedure TKPreviewColors.InternalSetColor(Index: TKPreviewColorIndex; Value: TColor);
begin
if FColors[Index] <> Value then
begin
FColors[Index] := Value;
if not (csLoading in FPreview.ComponentState) then
FPreview.Invalidate;
end;
end;
procedure TKPreviewColors.SetColor(Index: TKPreviewColorIndex; Value: TColor);
begin
InternalSetColor(Index, Value);
end;
procedure TKPreviewColors.SetColorEx(Index: TKPreviewColorIndex; Value: TColor);
begin
FColors[Index] := Value;
end;
procedure TKPreviewColors.SetColors(const Value: TKColorArray);
var
I: Integer;
begin
for I := 0 to Min(Length(FColors), Length(Value)) - 1 do
FColors[I] := Value[I];
end;
{ TKPrintPreview }
constructor TKPrintPreview.Create(AOwner: TComponent);
begin
inherited;
FColors := TKPreviewColors.Create(Self);
FControl := nil;
FMouseWheelAccumulator := 0;
FPage := 1;
FPageSize := Point(0, 0);
FScale := 100;
FScaleMode := smPageWidth;
FOnChanged := nil;
LoadCustomCursor(crDragHandFree, 'KPREVIEW_CURSOR_HAND_FREE');
LoadCustomCursor(crDragHandGrip, 'KPREVIEW_CURSOR_HAND_GRIP');
Width := 300;
Height := 200;
end;
destructor TKPrintPreview.Destroy;
begin
if Assigned(FControl) then
FControl.RemovePreview(Self);
inherited;
FColors.Free;
end;
procedure TKPrintPreview.BeginScrollWindow;
begin
FPageOld := FPage;
FScrollPosOld := FScrollPos;
end;
procedure TKPrintPreview.CreateParams(var Params: TCreateParams);
begin
inherited;
with Params do
Style := Style or WS_HSCROLL or WS_VSCROLL;
end;
function TKPrintPreview.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
MousePos: TPoint): Boolean;
const
cWheelDivisor = 120;
var
Delta, WheelClicks: Integer;
begin
Result := inherited DoMouseWheel(Shift, WheelDelta, MousePos);
if not Result then
begin
if ssCtrl in Shift then
begin
if FScaleMode = smWholePage then Delta := 10 else Delta := ClientHeight;
end else
if FScaleMode = smWholePage then Delta := 1 else Delta := ClientHeight div 10;
Inc(FMouseWheelAccumulator, WheelDelta);
WheelClicks := FMouseWheelAccumulator div cWheelDivisor;
FMouseWheelAccumulator := FMouseWheelAccumulator mod cWheelDivisor;
BeginScrollWindow;
ModifyScrollBar(SB_VERT, -1, -WheelClicks * Delta);
EndScrollWindow;
Result := True;
end;
end;
procedure TKPrintPreview.EndScrollWindow;
begin
if (FPage <> FPageOld) then
Invalidate
else if (FScrollPos.X <> FScrollPosOld.X) or (FScrollPos.Y <> FScrollPosOld.Y) then
begin
ScrollWindowEx(Handle, FScrollPosOld.X - FScrollPos.X, FScrollPosOld.Y - FScrollPos.Y,
nil, nil, 0, nil, SW_INVALIDATE);
end;
end;
procedure TKPrintPreview.FirstPage;
begin
Page := StartPage;
end;
function TKPrintPreview.GetCurrentScale: Integer;
begin
if Assigned(FControl) then
Result := MulDiv(FPageSize.X, 100, MulDiv(FControl.PageSetup.PageWidth, 300, FControl.PageSetup.PrinterPixelsPerInchX))
else
Result := FScale;
end;
function TKPrintPreview.GetEndPage: Integer;
begin
if Assigned(FControl) then
begin
Result := FControl.PageSetup.EndPage;
if Result = 0 then
begin
FControl.PageSetup.UpdateSettings;
Result := FControl.PageSetup.EndPage
end;
end else
Result := 0;
end;
function TKPrintPreview.GetPageRect: TRect;
begin
with Result do
begin
Left := FPageOffset.X - FScrollPos.X;
if FScaleMode = smWholePage then
Top := FPageOffset.Y
else
Top := FPageOffset.Y - FScrollPos.Y;
Right := Left + FPageSize.X;
Bottom := Top + FPageSize.Y;
end;
end;
function TKPrintPreview.GetStartPage: Integer;
begin
if Assigned(FControl) then
begin
Result := FControl.PageSetup.StartPage;
if Result = 0 then
begin
FControl.PageSetup.UpdateSettings;
Result := FControl.PageSetup.StartPage
end;
end else
Result := 0;
end;
procedure TKPrintPreview.KeyDown(var Key: Word; Shift: TShiftState);
var
DeltaX, DeltaY, LineX, PageY: Integer;
NoAlt, NoAltCtrl: Boolean;
begin
NoAlt := Shift * [ssAlt] = [];
NoAltCtrl := Shift * [ssAlt, ssCtrl] = [];
DeltaX := 0;
DeltaY := 0;
LineX := ClientWidth div 10;
PageY := ClientHeight;
case Key of
VK_UP:
if NoAltCtrl then
begin
if FScaleMode = smWholePage then
PreviousPage
else
DeltaY := -PageY div 10;
end;
VK_DOWN:
if NoAltCtrl then
begin
if FScaleMode = smWholePage then
NextPage
else
DeltaY := PageY div 10;
end;
VK_PRIOR:
if NoAltCtrl then
begin
if FScaleMode = smWholePage then
PreviousPage
else
DeltaY := -PageY;
end;
VK_NEXT:
if NoAltCtrl then
begin
if FScaleMode = smWholePage then
NextPage
else
DeltaY := PageY;
end;
VK_LEFT: if NoAltCtrl then DeltaX := -LineX;
VK_RIGHT: if NoAltCtrl then DeltaX := LineX;
VK_HOME:
if NoAlt then
begin
if ssCtrl in Shift then
FirstPage
else
DeltaX := -FScrollPos.X;
end;
VK_END:
if NoAlt then
begin
if ssCtrl in Shift then
LastPage
else
DeltaX := FScrollExtent.X - FScrollPos.X;
end;
end;
if (DeltaX <> 0) or (DeltaY <> 0) then
begin
BeginScrollWindow;
if DeltaX <> 0 then
ModifyScrollBar(SB_HORZ, -1, DeltaX);
if DeltaY <> 0 then
ModifyScrollBar(SB_VERT, -1, DeltaY);
EndScrollWindow;
end;
end;
procedure TKPrintPreview.LastPage;
begin
Page := EndPage;
end;
procedure TKPrintPreview.ModifyScrollBar(ScrollBar, ScrollCode, Delta: Integer);
var
I, AEndPage: Integer;
Divisor: Cardinal;
PPos, PExtent: PInteger;
SI: TScrollInfo;
begin
Divisor := 10;
if ScrollBar = SB_HORZ then
begin
PPos := @FScrollPos.X;
PExtent := @FScrollExtent.X;
end else
begin
if FScaleMode = smWholePage then
begin
PPos := @FPage;
AEndPage := EndPage;
PExtent := @AEndPage;
Divisor := 1;
end else
begin
PPos := @FScrollPos.Y;
PExtent := @FScrollExtent.Y;
end;
end;
if PExtent^ > 0 then
begin
SI.cbSize := SizeOf(TScrollInfo);
SI.fMask := SIF_RANGE or SIF_PAGE or SIF_TRACKPOS;
GetScrollInfo(Handle, ScrollBar, SI);
{$IF DEFINED(LCLGTK2)}
{.$WARNING "scrollbar arrows still not working properly on GTK2 in some cases!"}
SI.nTrackPos := Delta;
{$IFEND}
I := PPos^;
case ScrollCode of
SB_TOP: I := SI.nMin;
SB_BOTTOM: I := SI.nMax; // will be trimmed below
SB_LINEUP: Dec(I, SI.nPage div Divisor);
SB_LINEDOWN: Inc(I, SI.nPage div Divisor);
SB_PAGEUP: Dec(I, SI.nPage);
SB_PAGEDOWN: Inc(I, SI.nPage);
SB_THUMBTRACK, SB_THUMBPOSITION: I := SI.nTrackPos;
else
Inc(I, Delta)
end;
if FScaleMode = smWholePage then
I := MinMax(I, 1, PExtent^)
else
I := MinMax(I, 0, PExtent^);
PPos^ := I;
SI.nPos := I;
SI.fMask := SIF_POS;
SetScrollInfo(Handle, ScrollBar, SI, True);
end;
end;
procedure TKPrintPreview.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
inherited;
if ssLeft in Shift then
begin
SafeSetFocus;
if (FScaleMode <> smWholePage) and PtInRect(GetPageRect, Point(X, Y)) then
begin
FlagSet(cPF_Dragging);
FX := X;
FY := Y;
SetMouseCursor(X, Y);
end;
end;
end;
procedure TKPrintPreview.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
inherited;
if Flag(cPF_Dragging) and MouseCapture then
begin
BeginScrollWindow;
if (X > FX) and (FScrollPos.X > 0) or (X < FX) and (FScrollPos.X < FScrollExtent.X) then
begin
ModifyScrollBar(SB_HORZ, -1, FX - X);
FX := X;
end;
if (Y > FY) and (FScrollPos.Y > 0) or (Y < FY) and (FScrollPos.Y < FScrollExtent.Y) then
begin
ModifyScrollBar(SB_VERT, -1, FY - Y);
FY := Y;
end;
EndScrollWindow;
end;
end;
procedure TKPrintPreview.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
inherited;
FlagClear(cPF_Dragging);
SetMouseCursor(X, Y);
end;
procedure TKPrintPreview.NextPage;
begin
Page := Page + 1;
end;
procedure TKPrintPreview.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited;
if (Operation = opRemove) and (AComponent = FControl) then
begin
FControl := nil;
UpdatePreview;
end;
end;
procedure TKPrintPreview.Paint;
procedure DoPaint(IsBuffer: Boolean);
var
C: TColor;
R, RPaper, RPage: TRect;
RgnPaper: HRGN;
begin
Canvas.Brush.Style := bsSolid;
Canvas.Pen.Mode := pmCopy;
Canvas.Pen.Style := psSolid;
Canvas.Pen.Width := 1;
RPage := GetPageRect;
RPaper := RPage;
with RPaper do
begin
Inc(Right, cPreviewShadowSize);
Inc(Bottom, cPreviewShadowSize);
end;
if not IsBuffer then
RgnPaper := CreateRectRgnIndirect(RPaper)
else
RgnPaper := 0;
try
// paint background around paper, we don't want at least this to flicker
if IsBuffer or (ExtSelectClipRgn(Canvas.Handle, RgnPaper, RGN_DIFF) <> NULLREGION) then
begin
Canvas.Brush.Color := FColors.BkGnd;
Canvas.FillRect(ClientRect);
end;
if not IsBuffer then
SelectClipRgn(Canvas.Handle, RgnPaper);
finally
if not IsBuffer then
DeleteObject(rgnPaper);
end;
// paint paper outline
if Focused then
C := FColors.SelectedBorder
else
C := FColors.Border;
Canvas.Pen.Color := C;
Canvas.Brush.Color := FColors.Paper;
Canvas.Rectangle(RPage);
Canvas.Brush.Color := FColors.BkGnd;
R := Rect(RPage.Left, RPage.Bottom, RPage.Left + cPreviewShadowSize, RPage.Bottom + cPreviewShadowSize);
Canvas.FillRect(R);
R := Rect(RPage.Right, RPage.Top, RPage.Right + cPreviewShadowSize, RPage.Top + cPreviewShadowSize);
Canvas.FillRect(R);
Canvas.Brush.Color := C;
R := Rect(RPage.Left + cPreviewShadowSize, RPage.Bottom, RPaper.Right, RPaper.Bottom);
Canvas.FillRect(R);
R := Rect(RPage.Right, RPage.Top + cPreviewShadowSize, RPaper.Right, RPaper.Bottom);
Canvas.FillRect(R);
// paint page outline
InflateRect(RPage, -1, -1);
FControl.PageSetup.PaintPageToPreview(Self);
end;
var
SaveIndex: Integer;
RClient: TRect;
{$IFDEF USE_WINAPI}
Org: TPoint;
MemBitmap, OldBitmap: HBITMAP;
DC: HDC;
{$ENDIF}
begin
RClient := ClientRect;
if Assigned(FControl) then
begin
SaveIndex := SaveDC(Canvas.Handle);
try
{$IFDEF USE_WINAPI}
if DoubleBuffered then
begin
// we must paint always the entire client because of canvas scaling
MemBitmap := CreateCompatibleBitmap(Canvas.Handle, RClient.Right - RClient.Left, RClient.Bottom - RClient.Top);
try
OldBitmap := SelectObject(Canvas.Handle, MemBitmap);
try
SetWindowOrgEx(Canvas.Handle, 0, 0, @Org);
SelectClipRect(Canvas.Handle, Rect(0, 0, RClient.Right - RClient.Left, RClient.Bottom - RClient.Top));
DoPaint(True);
finally
SelectObject(Canvas.Handle, OldBitmap);
SetWindowOrgEx(Canvas.Handle, Org.X, Org.Y, nil);
end;
// copy MemBitmap to original canvas
DC := CreateCompatibleDC(Canvas.Handle);
try
OldBitmap := SelectObject(DC, MemBitmap);
try
CopyBitmap(Canvas.Handle, RClient, DC, 0, 0);
finally
SelectObject(DC, OldBitmap);
end;
finally
DeleteDC(DC);
end;
finally
DeleteObject(MemBitmap);
end;
end else
{$ENDIF}
DoPaint(False);
finally
RestoreDC(Canvas.Handle, SaveIndex);
end;
end else
begin
Canvas.Brush.Color := FColors.BkGnd;
Canvas.FillRect(RClient);
end;
end;
procedure TKPrintPreview.Changed;
begin
if Assigned(FOnChanged) then
FOnChanged(Self);
end;
procedure TKPrintPreview.PreviousPage;
begin
Page := Page - 1;
end;
procedure TKPrintPreview.SafeSetFocus;
var
Form: TCustomForm;
begin
Form := GetParentForm(Self);
if (Form <> nil) and Form.Visible and Form.Enabled and Visible and Enabled then
Form.ActiveControl := Self;
end;
procedure TKPrintPreview.SetColors(const Value: TKPreviewColors);
begin
FColors.Assign(Value);
end;
procedure TKPrintPreview.SetControl(Value: TKCustomControl);
begin
if (Value <> FControl) and (Value <> Self) and not (Value is TKPrintPreview) then
begin
if Assigned(FControl) then
FControl.RemovePreview(Self);
FControl := Value;
if Assigned(FControl) then
FControl.AddPreview(Self);
UpdatePreview;
end;
end;
procedure TKPrintPreview.SetPage(Value: Integer);
begin
Value := MinMax(Value, StartPage, EndPage);
if Value <> FPage then
begin
BeginScrollWindow;
if FScaleMode = smWholePage then
ModifyScrollBar(SB_VERT, -1, Value - FPage)
else
FPage := Value;
EndScrollWindow;
Changed;
end;
end;
procedure TKPrintPreview.SetScale(Value: Integer);
begin
Value := MinMax(Value, cScaleMin, cScaleMax);
if Value <> FScale then
begin
FScale := Value;
UpdatePreview;
end;
end;
procedure TKPrintPreview.SetScaleMode(Value: TKPreviewScaleMode);
begin
if Value <> FScaleMode then
begin
FScaleMode := Value;
UpdatePreview;
end;
end;
function TKPrintPreview.SetMouseCursor(X, Y: Integer): Boolean;
var
ACursor: TCursor;
begin
if PtInRect(GetPageRect, Point(X, Y)) and (FScaleMode <> smWholePage) then
begin
if MouseCapture then
ACursor := crDragHandGrip
else
ACursor := crDragHandFree;
end else
ACursor := crDefault;
{$IFDEF FPC}
FCursor := ACursor;
SetTempCursor(ACursor);
{$ELSE}
Windows.SetCursor(Screen.Cursors[ACursor]);
{$ENDIF}
Result := True;
end;
procedure TKPrintPreview.UpdatePreview;
begin
Page := FPage;
UpdateScrollRange;
Changed;
end;
procedure TKPrintPreview.UpdateScrollRange;
var
I: Integer;
PageWidth100Percent, PageHeight100Percent: Integer;
SI: TScrollInfo;
begin
if HandleAllocated and not Flag(cPF_UpdateRange) then
begin
FlagSet(cPF_UpdateRange);
try
if Assigned(FControl) then
begin
// get isotropic page size in 300 dpi
PageWidth100Percent := MulDiv(FControl.PageSetup.PageWidth, 300, FControl.PageSetup.PrinterPixelsPerInchX);
PageHeight100Percent := MulDiv(FControl.PageSetup.PageHeight, 300, FControl.PageSetup.PrinterPixelsPerInchY);
case FScaleMode of
smScale:
begin
FPageSize.X := MulDiv(PageWidth100Percent, FScale, 100);
FPageSize.Y := MulDiv(PageHeight100Percent, FScale, 100);
end;
smPageWidth:
begin
FPageSize.X := Max(ClientWidth - 2 * cPreviewHorzBorder - cPreviewShadowSize, 40);
FPageSize.Y := MulDiv(FPageSize.X, PageHeight100Percent, PageWidth100Percent);
end;
smWholePage:
begin
FPageSize.X := Max(ClientWidth - 2 * cPreviewHorzBorder - cPreviewShadowSize, 40);
FPageSize.Y := Max(ClientHeight - 2 * cPreviewVertBorder - cPreviewShadowSize, 40);
I := MulDiv(FPageSize.Y, PageWidth100Percent, PageHeight100Percent);
if I < FPageSize.X then
FPageSize.X := I
else
FPageSize.Y := MulDiv(FPageSize.X, PageHeight100Percent, PageWidth100Percent);
end;
end;
FExtent.X := FPageSize.X + 2 * cPreviewHorzBorder + cPreviewShadowSize;
FExtent.Y := FPageSize.Y + 2 * cPreviewVertBorder + cPreviewShadowSize;
FPageOffset.X := cPreviewHorzBorder;
if (FExtent.X < ClientWidth) then
Inc(FPageOffset.X, (ClientWidth - FExtent.X) div 2);
FPageOffset.Y := cPreviewVertBorder;
if (FExtent.Y < ClientHeight) then
Inc(FPageOffset.Y, (ClientHeight - FExtent.Y) div 2);
// adjust horizontal scroll position
I := FScrollPos.X + ClientWidth - FExtent.X - 1;
if I > 0 then
Dec(FScrollPos.X, I);
FScrollPos.X := Max(FScrollPos.X, 0);
// adjust vertical scroll position
I := FScrollPos.Y + ClientHeight - FExtent.Y - 1;
if I > 0 then
Dec(FScrollPos.Y, I);
FScrollPos.Y := Max(FScrollPos.Y, 0);
// update scroll range
FScrollExtent.X := 0;
FScrollExtent.Y := 0;
FillChar(SI, SizeOf(TScrollInfo), 0);
SI.cbSize := SizeOf(TScrollInfo);
SI.fMask := SIF_RANGE or SIF_PAGE or SIF_POS or SIF_DISABLENOSCROLL {$IFDEF UNIX}or SIF_UPDATEPOLICY{$ENDIF};
SI.nMin := 0;
{$IFDEF UNIX}
SI.ntrackPos := SB_POLICY_CONTINUOUS;
{$ENDIF}
case FScaleMode of
smScale:
begin
ShowScrollbar(Handle, SB_HORZ, True);
ShowScrollbar(Handle, SB_VERT, True);
SI.nMax := FExtent.X{$IFDEF FPC}+ 1{$ENDIF};
SI.nPage := ClientWidth;
SI.nPos := FScrollPos.X;
FScrollExtent.X := SI.nMax - Integer(SI.nPage);
SetScrollInfo(Handle, SB_HORZ, SI, True);
SI.nMax := FExtent.Y{$IFDEF FPC}+ 1{$ENDIF};
SI.nPage := ClientHeight;
SI.nPos := FScrollPos.Y;
FScrollExtent.Y := SI.nMax - Integer(SI.nPage);
SetScrollInfo(Handle, SB_VERT, SI, True);
end;
smPageWidth:
begin
ShowScrollbar(Handle, SB_HORZ, False);
ShowScrollbar(Handle, SB_VERT, True);
SI.nMax := FExtent.Y{$IFDEF FPC}+ 1{$ENDIF};
SI.nPage := ClientHeight;
SI.nPos := FScrollPos.Y;
FScrollExtent.Y := SI.nMax - Integer(SI.nPage);
SetScrollInfo(Handle, SB_VERT, SI, True);
end;
smWholePage:
begin
// another mode for vertical scrollbar - page selection
ShowScrollbar(Handle, SB_HORZ, False);
ShowScrollbar(Handle, SB_VERT, True);
SI.nMin := StartPage;
SI.nMax := EndPage{$IFDEF FPC}+ 1{$ENDIF};
SI.nPage := 1;
SI.nPos := FPage;
SetScrollInfo(Handle, SB_VERT, SI, True);
end;
end;
end else
begin
ShowScrollbar(Handle, SB_HORZ, False);
ShowScrollbar(Handle, SB_VERT, False);
end;
Invalidate;
finally
FlagClear(cPF_UpdateRange);
end;
end;
end;
procedure TKPrintPreview.UpdateSize;
begin
inherited;
UpdatePreview;
end;
procedure TKPrintPreview.WMEraseBkgnd(var Msg: TLMessage);
begin
Msg.Result := 1;
end;
procedure TKPrintPreview.WMGetDlgCode(var Msg: TLMNoParams);
begin
Msg.Result := DLGC_WANTARROWS;
end;
procedure TKPrintPreview.WMHScroll(var Msg: TLMHScroll);
begin
SafeSetFocus;
BeginScrollWindow;
ModifyScrollBar(SB_HORZ, Msg.ScrollCode, Msg.Pos);
EndScrollWindow;
end;
procedure TKPrintPreview.WMKillFocus(var Msg: TLMKillFocus);
begin
inherited;
Invalidate;
end;
procedure TKPrintPreview.WMSetFocus(var Msg: TLMSetFocus);
begin
inherited;
Invalidate;
end;
procedure TKPrintPreview.WMVScroll(var Msg: TLMVScroll);
begin
SafeSetFocus;
BeginScrollWindow;
ModifyScrollBar(SB_VERT, Msg.ScrollCode, Msg.Pos);
EndScrollWindow;
end;
{$IFDEF FPC}
initialization
{$i kcontrols.lrs}
{$ELSE}
{$R kcontrols.res}
{$ENDIF}
end.