{ @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)

License:
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) } TKPreviewChangedEvent = procedure(Sender: TObject) of object; { @abstract(Declares the information structure for the @link(TKCustomControl.MeasurePages) method) } 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) 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) } 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. } 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. } function InchesToValue(Units: TKPrintUnits; Value: Double): Double; { Converts value given in specified units into a value given in inches. } 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.