wwriched.pas

胜天进销存源码,国产优秀的进销存

unit wwriched;
{$R-}
{
//
// Component : TwwDBRichEdit
//
// Copyright (c) 1995-2001 by Woll2Woll Software
//
// 8/13/97 - Support TwwIntl richedit popup captions by updating menu captions
//           in Loaded method.
//
// 9/5/97 - PopupMenuPopup restores original property values so component
//          displays popup correctly when switching back to readonly=false
//
// 10/15/97 - Always set FDataLink.Readonly
//
// 10/29/97 - Call BeginEditing when changing attributes.  This is necessary
//            so that the component will still post even when just the attributes
//            are modified.
// 11/18/97 - Call BeginEditing when changing paragraph attributes
// 1/22/98 - Use TwwIntl setting
// 1/28/98  - Allow Change of text when there is a protected flag in previous richtext.
// 1/29/98 - Add check to see if Datafield is nil to see if this is an unbound case
// 2/6/98 - Default printpagesize changed to 1 from 2
// 4/6/98 - Use International Settings for Alignment
// 4/22/98 - Use richedit's Font charset for any change of font
// 4/28/98 - Support append operation
// 8/24/98 - Support em_findtext even when Delphi FindText is called
// 9/15/98 - Respect Tfield.readonly in change method.
// 9/22/98 - Support patch[1]=True to use RichEdit version 1
// 9/25/98 - Skip change when bringing when using CopyRichEditTo method.
// 9/27/98 - Use Screen.PixelsPerInch instead of 96 in SetEditRect
// 10/6/98 - Prevent richedit from incorrectly going into edit mode
// 10/16/98 - RichEditStrings.Get method no longer returns trailing carriage return
// 10/18/98 - Add support of OLE icons within the richedit text
// 10/30/98 - Restore to default cursor
// 11/4/98 - Workaround Delphi 4 showing bug within tabsheet
// 12/29/98 - Patch[3] Set to True to preserve old behavior of
              allowing ole link to file.  The component does not support this
              so this option is now disabled in the dialog.
// 1/9/99   - Don't allow OLE object to open if readonly
// 2/12/99 - Line spacing of 1.5 or 2 is not recognized.  Workaround by using
//           multiple instead.
// 2/15/99 - Don't use richedit's charset as this prevent's symbol fonts from
//           working
// 2/22/99 - Double-click richedit with OLE disabled on a REadOnly field
//           could cause nil pointer reference.  Problem fixed.
// 3/16/99 - Workaround for bug when assigning streaming a richedit which
//           has exceeded its maxLength.  Previously in this case, the richedit
//           control would lose the richedit formatting.
// 3/30/99 - Support form.print command
// 4/14/99 - Scope should be public so fix for VCL4
// 5/24/99 - RSW - Move before BeginDoc
// 5/29/99 - RSW - Fire OnCloseDialog when the user clicks Save And Exit without
//           making any changes.
// 12/5/99 - Allow grid to display text in more cases such as embedded ole objects
// 2/9/2000 - Make sure mouse is over URL link before opening URL link
// 4/11/00 -  When going into insert mode in a inspector,
//            the richedit was not told it was modified.  Problem fixed.
// 7/16/00 -  Prevent dbl-popup in non Win2000 environments
// 9/29/00 - More robust InsertObjectDialog to support links
// 10/05/00 - Added missing updateaction and executeaction methods. PYW
// 10/11/2000 - PYW - Ensure PopupMenu's PopupComponent property is set.
// 10/18/00 - Respect Autoedit of datasource
// 3/20/01 - Specify control in datalink
// 4/11/2001 - Add Full Justification support.
// 6/01/2001 - Check if nil before setting visibility.
// 8/8/01 - Don't update Lines during streaming if datasource
//          assigned.  Otherwise when using frames and have a
//          datasource, the lines property is overwriting the datasource's
//          value and putting the dataset in edit mode.
// 10/02/2001-PYW-Toggling not working on highlight color because it was exiting.
// 12/18/01 - Fix unbound richedit in inspector problem where it was not being painted
// 1/31/2002 - Pass Button instead of hardcoded mbLeft.
// 4/3/2002-PYW-Seems necessary to call beginediting here, when databound and empty.  Won't insert otherwise.
// 7/9/02 - New property WantNavigationKeys
//          Don't pass grid these navigation keys - VK_UP, VK_DOWN, VK_NEXT, VK_PRIOR:
// 9/10/03  Use Button intead of mbLeft
}

interface

{$i wwIfDef.pas}

{$C PRELOAD}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ComCtrls, RichEdit, menus, dbctrls, db, wwstr, wwcommon, printers,
  dbtables, wwintl, extctrls, wwtrackicon, wwtypes, wwrichole, olectnrs, activex,
  ShellAPI, OleDlg, buttons, oleconst, grids, wwframe, commctrl;

const wwTwipsPerInch = 1440;
      PFA_FULLJUSTIFY = 4;
type
  TwwCustomRichEdit = class;
  TwwRichEditWidth=(rewWindowSize, rewPrinterSize);
  TwwOnRichEditDlgEvent = procedure(Form : TForm) of object;
  TwwURLOpenEvent = procedure(Sender : TwwCustomRichEdit; URLLink: string;
     var UseDefault: boolean) of object;
  TwwMeasurementUnits=(muInches, muCentimeters);
  TwwRichEditParaOption=(rpoAlignment, rpoBullet,
                         rpoLeftIndent, rpoRightIndent, rpoFirstLineIndent, rpoTabs,
                         rpoSpaceBefore, rpoSpaceAfter, rpoLineSpacing);
  TwwRichEditOleOption= (reoAdjustPopupMenu, reoDisableOLE);
  TwwRichEditOleOptions= set of TwwRichEditOleOption;

  TwwRichEditCopyMethod = (recmByMemory, recmByTempFile);

  TwwRichEditParaOptions=Set of TwwRichEditParaOption;
  TwwRichEditPopupOption=(rpoPopupEdit, rpoPopupCut, rpoPopupCopy, rpoPopupPaste,
       rpoPopupBold, rpoPopupItalic, rpoPopupUnderline,
       rpoPopupFont, rpoPopupBullet, rpoPopupParagraph, rpoPopupTabs,
       rpoPopupFind, rpoPopupReplace, rpoPopupInsertObject, rpoPopupMSWordSpellCheck
        );
  TwwRichEditPopupOptions=Set of TwwRichEditPopupOption;

  TwwRichEditOption=(reoShowLoad, reoShowSaveAs, reoShowSaveExit, reoShowPrint, reoShowPrintPreview, reoShowPageSetup,
                     reoShowFormatBar, reoShowToolBar, reoShowStatusBar,
                     reoShowHints, reoShowRuler, reoShowInsertObject, reoCloseOnEscape,
                     reoFlatButtons, reoShowSpellCheck, reoShowMainMenuIcons,
                     reoShowJustifyButton, reoUseBackColor, reoNoConfirmation);
  TwwRichEditOptions=Set of TwwRichEditOption;

//  TwwSpellCheckOption = (reoSpellCheck, reoGrammarCheck, reoGrammarStatistics);
//  TwwSpellCheckOptions = set of TwwSpellCheckOption;

  TwwRichSelection = (wwstText, wwstObject, wwstMultiChar, wwstMultiObject);
  TwwRichSelectionType = set of TwwRichSelection;

  TwwRTFDrawHeaderFooter =
    procedure(Sender : TwwCustomRichEdit;
       DrawRect: TRect;
       PageNumber: integer;
       var LeftText, CenterText, RightText: string;
       var DoDefault: boolean) of object;

  TwwRTFHeaderFooter = class(TPersistent)
  private
     FVertMargin: Double;
//     FLeftMarginOffset, FRightMarginOffset: integer;
     FLeftText: string;
     FCenterText: string;
     FRightText: string;
     FFont: TFont;
     FLineSeparator: boolean;
     procedure SetFont(Value: TFont);
  public
     Procedure Assign(Source: TPersistent); override;
     constructor Create(AOwner: TComponent); virtual;
     destructor Destroy; override;
  published
     property VertMargin : Double read FVertMargin write FVertMargin;
     property LeftText: string read FLeftText write FLeftText;
     property CenterText: string read FCenterText write FCenterText;
     property RightText: string read FRightText write FRightText;
     property Font: TFont read FFont write SetFont;
     property LineSeparator: boolean read FLineSeparator write FLineSeparator default False;
//     property OnDrawText: TwwRTFDrawHeaderFooter read FOnDrawText write FOnDrawText;
  end;

  TwwPrintMargins = class(TPersistent)
  private
     FTop, FBottom, FLeft, FRight: Double;
  public
     Procedure Assign(Source: TPersistent); override;
     constructor Create(AOwner: TComponent); virtual;
  published
     property Top: Double read FTop write FTop;
     property Bottom: Double read FBottom write FBottom;
     property Left : Double read FLeft write FLeft;
     property Right : Double read FRight write FRight;
  end;

  TwwParaFormat2 = record
    cbSize: UINT;
    dwMask: DWORD;
    wNumbering: Word;
    wReserved: Word;
    dxStartIndent: Longint;
    dxRightIndent: Longint;
    dxOffset: Longint;
    wAlignment: Word;
    cTabCount: Smallint;
    rgxTabs: array [0..MAX_TAB_STOPS - 1] of Longint;
    dySpaceBefore: Longint;
    dySpaceAfter: Longint;
    dyLineSpacing: Longint;
    sStyle: SmallInt;
    bLineSpacingRule: Byte;
    bCRC: Byte;
    wShadingWeight: word;
    wShadingStyle: word;
    wNumberingStart: word;
    wNumberingStyle: word;
    wNumberingTab: word;
    wBorderSpace: word;
    wBorderWidth: word;
    wBorders: word;
  end;

  TwwRTFNotifyEvent = procedure (Form: TForm; RichEdit: TwwCustomRichEdit;
                                 var DoDefault: boolean) of object;

  TwwCustomRichEdit = class(TCustomRichEdit)
  private
     FAutoURLDetect: boolean;
     FAutoSelect: boolean;
     FOnURLOpen: TwwURLOpenEvent;
     FLibHandle: THandle;
     FWordWrap: boolean;
     FPrintMargins: TwwPrintMargins;
     FHeader: TwwRTFHeaderFooter;
     FFooter: TwwRTFHeaderFooter;
     FOnPrintHeader : TwwRTFDrawHeaderFooter;
     FOnPrintFooter : TwwRTFDrawHeaderFooter;
     FPrintPageSize: integer;
     FEditWidth: TwwRichEditWidth;
     StartingFindPos: integer;
     InResetToStart: boolean;
     PopupEdit, PopupCut, PopupCopy, PopupPaste,
     PopupBold, PopupItalic, PopupUnderline,
     PopupFont, PopupBullet, PopupParagraph, PopupTabs,
     PopupFind, PopupReplace, PopupInsertObject, PopupSpellCheck,
     PopupSep1, PopupSep2, PopupSep3, PopupSep4, PopupSep5: TMenuItem;
     FPopupOptions: TwwRichEditPopupOptions;
     FEditorOptions: TwwRichEditOptions;
     FEditorCaption: string;
     FEditorPosition: TwwFormPosition;
     LastSearchText: string;
     FUnits: TwwMeasurementUnits;
     FOnInitDialog: TwwOnRichEditDlgEvent;
     FOnCloseDialog: TwwOnRichEditDlgEvent;
     FOnCreateDialog: TwwOnRichEditDlgEvent;
     FOnMenuLoadClick : TwwRTFNotifyEvent;
     FOnMenuPrintClick : TwwRTFNotifyEvent;
     FOnMenuSaveAsClick : TwwRTFNotifyEvent;
     FOnMenuSaveAndExitClick : TwwRTFNotifyEvent;
//     FLastSetRect: TRect;
     OrigHideSelection: boolean;
     FOLEOptions: TwwRichEditOleOptions;
     FOleSelObject: IOleObject;
     FRichEditCopyMethod: TwwRichEditCopyMethod;
     FUserSpeedButton1: TSpeedButton;
     FUserSpeedButton2: TSpeedButton;
     FPrintJobName: string;
//     FTransparent: boolean;
     FHighlightColor: TColor;
//     FSpellCheckOptions: TwwSpellCheckOptions;
     FFrame: TwwEditFrame;
     FWantNavigationKeys: boolean;
     FCanvas: TControlCanvas;
     FPaintControl: TWinControl;

     { OLE support }
     FRichEditOle: IRichEditOLE;
     FRichEditOleCallback: IRichEditOleCallback;
     FObjectVerbs: TStringList;
     OleMenuItemList: TList;
     InParentChanging: boolean;

     ReloadStream: TStream;
     UseReloadStream: boolean;
     NewDataFormat: boolean;

     URLDetectButtonPressed: boolean;
     FVerbMenu: TPopupMenu;

     InitEditRect: boolean;
     FRichEditVersion: integer;
     FLines: TStrings; { Internal FLines list is never really used }
     FTitle: string;

     InMouseUp: boolean;
     SkipChange: boolean;
//     FUseClipboardForSpelling: boolean;
     FGutterWidth: integer;
     OldLineCount, OldCharPos: Integer;
     OrigWin32MajorVersion: integer;
     FMSVersion: integer;
     FHideSelection: Boolean; // inherited requires windows handle to set (too restrictive)

     procedure SetHideSelection(Value: Boolean);
     procedure FindDialog1Close(Sender: TObject);
     procedure FindDialog1Find(Sender: TObject);
     Procedure FindReplaceDlg(
        dialog: TFindDialog; replace: boolean;
        replaceStr: string);
     procedure ReplaceDialog1Replace(Sender: TObject);
     procedure PopupMenuPopup(Sender: TObject);
     procedure PopupEditclick(Sender: TObject);
     procedure PopupCutClick(Sender: TObject);
     procedure PopupCopyClick(Sender: TObject);
     procedure PopupPasteClick(Sender: TObject);
     procedure PopupFontClick(Sender: TObject);
     procedure PopupParagraphClick(Sender: TObject);
     procedure PopupTabsClick(Sender: TObject);
     procedure PopupBulletClick(Sender: TObject);
     procedure PopupBoldClick(Sender: TObject);
     procedure PopupItalicClick(Sender: TObject);
     procedure PopupUnderlineClick(Sender: TObject);
     procedure PopupFindClick(Sender: TObject);
     procedure PopupReplaceClick(Sender: TObject);
     procedure PopupInsertObjectClick(Sender: TObject);
     procedure PopupSpellCheckClick(Sender: TObject);
     procedure SetWordWrap(val: boolean);
     procedure SetPrintPageSize(val: integer);
     function TwipsToPixels(twips: integer): integer;

     procedure WMNCDestroy(var Msg: TMessage); message WM_NCDESTROY;
     procedure SetOleOptions(val: TwwRichEditOleOptions);

     procedure ReadData(Stream: TStream);
     procedure WriteData(Stream: TStream);
     procedure ReadVersion(Reader: TReader);
     procedure WriteVersion(Writer: TWriter);
//     procedure SetTransparent(val: boolean);

     {$ifndef wwDelphi4Up}
     procedure WndProc(var Message: TMessage); override;
     {$endif}
     procedure WMNotify(var Message: TWMNotify); message WM_NOTIFY;
     procedure URLLinkNotification(Link: Pointer);
     procedure SetAutoURLDetect(val: boolean);
//     procedure InheritedCreateParams(var Params: TCreateParams);
     procedure SetUserSpeedButton1(val: TSpeedButton);
     procedure SetUserSpeedButton2(val: TSpeedButton);
     procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBkgnd;
     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
     procedure SetLines(val: TStrings);
     procedure CNKeyDown(var Message: TWMKeyDown); message CN_KEYDOWN;
     procedure WMChar(var Message: TWMChar); message WM_CHAR;
     procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
     procedure WMRButtonUp(var Message: TWMRButtonUp); message WM_RBUTTONUP;
     function GetSelectionType: TwwRichSelectionType;
     procedure CMShowingChanged(var Message: TMessage); message CM_SHOWINGCHANGED;
     procedure SetTitle(const Value: string);
     procedure SetScrollBars(Value: TScrollStyle);
     function GetScrollBars: TScrollStyle;
  protected
     BoundMode: boolean;
     ScreenPixelsPerInch : integer;
     FFocused: Boolean;

     function StoreScrollBars: boolean;
     procedure DblClick; override;
     procedure ClearSelectedBackgroundColor; virtual;
     procedure WriteState(Writer: TWriter); override;
     procedure ReadState(Reader: TReader); override;
     procedure Loaded; override;
     procedure CreateParams(var Params: TCreateParams); override;
     procedure EMFormatRange(var msg:TMessage); message EM_FORMATRANGE;
     procedure SelectionChange; override;
     procedure WMSize(var msg:twmsize); message wm_size;
     function GetReadOnly: Boolean; virtual;
     procedure BeginEditing; virtual;
     procedure UpdateField; virtual;
     procedure CreateWnd; override;
     procedure DestroyWnd; override;
     function GetPopupMenu: TPopupMenu; override;

     procedure DestroyVerbs;
     procedure UpdateVerbs;
     procedure PopupVerbMenuClick(Sender: TObject);
     procedure ObjectPropertiesMenuClick(Sender: TObject);
     Function IsMemoLoaded: boolean; virtual;
     procedure DefineProperties(Filer: TFiler); override;
     function GetField: TField; virtual;
     procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
     procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
     procedure DoURLOpen(URLLink: string; var UseDefault: boolean); virtual;
     {$ifndef wwDelphi4Up} { 4/14/99 - Scope should be public so fix for VCL4}
     function FindText(const SearchStr: string;
        StartPos, Length: Integer; Options: TSearchTypes): Integer; virtual;
     {$endif}
     procedure LoadPacketsFromStream(
       Stream: TStream;
       AppendMode: boolean; NumPackets: integer = 0); virtual;
     {$ifdef wwDelphi4Up}
     procedure WndProc(var Message: TMessage); override;
     {$endif}
     function isTransparentEffective: boolean; virtual;
     procedure LoadMemo; virtual;
     Procedure CreatePopup; virtual;