cxrichedit.pas

来自「胜天进销存源码,国产优秀的进销存」· PAS 代码 · 共 1,877 行 · 第 1/5 页

    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure RequestAlign; override;
    procedure RequestSize(const Rect: TRect); override;
    procedure RichCreateParams(var Params: TCreateParams;
      out ARichVersion: Integer); virtual;
    procedure SelectionChange; override;
    procedure URLClick(const AURLText: string; AButton: TMouseButton); dynamic;
    procedure URLMove(const AURLText: string); dynamic;
    procedure WndProc(var Message: TMessage); override;
    function CanPaste: Boolean;
    function GetSelection: TCharRange; virtual;

    property AllowObjects: Boolean read FAllowObjects write SetAllowObjects default True;
    property AutoSelect: Boolean read FAutoSelect write FAutoSelect default False;
    property AutoURLDetect: Boolean read GetAutoURLDetect write SetAutoURLDetect default True;
    property Container: TcxCustomRichEdit read GetContainer;
    property Helper: TcxRichInnerEditHelper read FHelper;
    property MemoMode: Boolean read FMemoMode write SetMemoMode default False;
    property RichVersion: Integer read FRichVersion write FRichVersion;
    property RichEditOle: IcxRichEditOle read GetRichEditOle;
    property RichEditOleCallBack: TcxRichEditOleCallback read GetRichEditOleCallBack;
    property SelectionBar: Boolean read FSelectionBar write SetSelectionBar
      default False;
    property StreamModes: TcxRichEditStreamModes read FStreamModes
      write FStreamModes default [];
    property OnQueryInsertObject: TcxRichEditQueryInsertObjectEvent
      read FOnQueryInsertObject write FOnQueryInsertObject;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    procedure DefaultHandler(var Message); override;
    procedure DragDrop(Source: TObject; X, Y: Integer); override;
    function ExecuteAction(Action: TBasicAction): Boolean; override;
    function FindTexT(const ASearchStr: string;
      AStartPos, ALength: Longint; AOptions: TSearchTypes): Integer;
    function InsertObject: Boolean;
    function ShowObjectProperties: Boolean;
    function PasteSpecial: Boolean;
    procedure Print(const Caption: string); override;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
    function UpdateAction(Action: TBasicAction): Boolean; override;
    function CanFocus: Boolean; override;
    function CanRedo: Boolean; virtual;
    procedure Redo; virtual;
    procedure Undo; virtual;
    property RichLines: TcxRichEditStrings
      read GetRichLines write SetRichLines;
  end;

function AdjustRichLineBreaks(ADest, ASource: PChar; AShortBreak: Boolean = False): Integer;
function AdjustRichLineBreaksW(ADest, ASource: PWideChar; AShortBreak: Boolean = False): Integer;
procedure SetRichEditText(ARichEdit: TRichEdit;
  const AEditValue: TcxEditValue);

implementation

uses
  CommDlg, Printers, cxEditPaintUtils, cxEditUtils, cxExtEditConsts, cxVariants,
  cxDWMAPI, dxUxTheme, dxThemeConsts, dxThemeManager, ComObj, CommCtrl,
  Math, Types, cxGeometry;

type
  TcxRichEditNames = array of string;
  TStringsAccess = class(TStrings);
  PcxENLink = ^TENLink;

const
  RTFConversionFormat: TConversionFormat = (
    ConversionClass: TConversion;
    Extension: 'rtf';
    Next: nil
  );
  TextConversionFormat: TConversionFormat = (
    ConversionClass: TConversion;
    Extension: 'txt';
    Next: @RTFConversionFormat
  );
  cxRichReadError = $0001;
  cxRichWriteError = $0002;
  cxRichNoError = $0000;

const
  cxRichEditVersions: array[0..4] of Integer =
    (100, 200, 300, 410, 500);

const
  // Flags to specify which interfaces should be returned in the structure above
  REO_GETOBJ_NO_INTERFACES  = $00000000;
  REO_GETOBJ_POLEOBJ        = $00000001;
  REO_GETOBJ_PSTG           = $00000002;
  REO_GETOBJ_POLESITE       = $00000004;
  REO_GETOBJ_ALL_INTERFACES = $00000007;

  // Place object at selection
  REO_CP_SELECTION = $FFFFFFFF;

  // Use character position to specify object instead of index
  REO_IOB_SELECTION = $FFFFFFFF;
  REO_IOB_USE_CP    = $FFFFFFFE;

  // Object flags
  REO_NULL            = $00000000;	// No flags
  REO_READWRITEMASK   = $0000003F;	// Mask out RO bits
  REO_DONTNEEDPALETTE = $00000020;	// Object doesn't need palette
  REO_BLANK           = $00000010;	// Object is blank
  REO_DYNAMICSIZE     = $00000008;	// Object defines size always
  REO_INVERTEDSELECT  = $00000004;	// Object drawn all inverted if sel
  REO_BELOWBASELINE   = $00000002;	// Object sits below the baseline
  REO_RESIZABLE       = $00000001;	// Object may be resized
  REO_LINK            = $80000000;	// Object is a link (RO)
  REO_STATIC          = $40000000;	// Object is static (RO)
  REO_SELECTED        = $08000000;	// Object selected (RO)
  REO_OPEN            = $04000000;	// Object open in its server (RO)
  REO_INPLACEACTIVE   = $02000000;	// Object in place active (RO)
  REO_HILITED         = $01000000;	// Object is to be hilited (RO)
  REO_LINKAVAILABLE   = $00800000;	// Link believed available (RO)
  REO_GETMETAFILE     = $00400000;	// Object requires metafile (RO)

  RECO_PASTE          = $00000000;	// paste from clipboard
  RECO_DROP           = $00000001;	// drop
  RECO_COPY           = $00000002;	// copy to the clipboard
  RECO_CUT            = $00000003;	// cut to the clipboard
  RECO_DRAG           = $00000004;	// drag

  cxDataFormatCount = 6;
  cxPasteFormatCount = 6;

var
  FRichEditLibrary: HMODULE = 0;
  FRichRenderer, FRichConverter: TcxRichInnerEdit;
  FConversionFormatList: PConversionFormat = @TextConversionFormat;

  FRichEditDLLNames: TcxRichEditNames;
  FRichEditClassNames: TcxRichEditNames;

  CFObjectDescriptor: Integer;
  CFEmbeddedObject: Integer;
  CFLinkSource: Integer;
  CFRtf: Integer;
  CFRETextObj: Integer;

procedure ReleaseObject(var AObj);
begin
  if IUnknown(AObj) <> nil then
    IUnknown(AObj)._Release;
  IUnknown(AObj) := nil;
end;

function cxIsFormMDIChild(AForm: TCustomForm): Boolean;
begin
  Result := (AForm is TForm) and (TForm(AForm).FormStyle = fsMDIChild);
end;

function cxSetDrawAspect(AOleObject: IOleObject; AIconic: Boolean;
  AIconMetaPict: HGlobal; var ADrawAspect: Cardinal): HResult;
var
  AOleCache: IOleCache;
  AEnumStatData: IEnumStatData;
  AOldAspect: Cardinal;
  AAdviseFlags, AConnection: Longint;
  ATempMetaPict: HGlobal;
  AFormatEtc: TFormatEtc;
  AMedium: TStgMedium;
  AClassID: TCLSID;
  AStatData: TStatData;
  AViewObject: IViewObject;
begin
  AOldAspect := ADrawAspect;
  if AIconic then
  begin
    ADrawAspect := DVASPECT_ICON;
    AAdviseFlags := ADVF_NODATA;
  end else
  begin
    ADrawAspect := DVASPECT_CONTENT;
    AAdviseFlags := ADVF_PRIMEFIRST;
  end;
  if (ADrawAspect <> AOldAspect) or (ADrawAspect = DVASPECT_ICON) then
  begin
    AOleCache := AOleObject as IOleCache;
    if ADrawAspect <> AOldAspect then
    begin
      OleCheck(AOleCache.EnumCache(AEnumStatData));
      if AEnumStatData <> nil then
        while AEnumStatData.Next(1, AStatData, nil) = 0 do
          if AStatData.formatetc.dwAspect = Integer(AOldAspect) then
            AOleCache.Uncache(AStatData.dwConnection);
      FillChar(AFormatEtc, SizeOf(FormatEtc), 0);
      AFormatEtc.dwAspect := ADrawAspect;
      AFormatEtc.lIndex := -1;
      OleCheck(AOleCache.Cache(AFormatEtc, AAdviseFlags, AConnection));
      if AOleObject.QueryInterface(IViewObject, AViewObject) = 0 then
        AViewObject.SetAdvise(ADrawAspect, 0, nil);
    end;
    if ADrawAspect = DVASPECT_ICON then
    begin
      ATempMetaPict := 0;
      if AIconMetaPict = 0 then
      begin
        OleCheck(AOleObject.GetUserClassID(AClassID));
        ATempMetaPict := OleGetIconOfClass(AClassID, nil, True);
        AIconMetaPict := ATempMetaPict;
      end;
      try
        with AFormatEtc do
        begin
          cfFormat := CF_METAFILEPICT;
          ptd := nil;
          dwAspect := DVASPECT_ICON;
          lindex := -1;
          tymed := TYMED_MFPICT;
        end;
        with AMedium do
        begin
          tymed := TYMED_MFPICT;
          hMetaFilePict := AIconMetaPict;
          unkForRelease := nil;
        end;
        OleCheck(AOleCache.SetData(AFormatEtc, AMedium, False));
      finally
        DestroyMetaPict(ATempMetaPict);
      end;
    end;
    if ADrawAspect <> DVASPECT_ICON then
      AOleObject.Update;
  end;
  Result := S_OK;
end;

procedure cxCreateStorage(var AStorage: IStorage);
var
  ALockBytes: ILockBytes;
begin
  OleCheck(CreateILockBytesOnHGlobal(0, True, ALockBytes));
  OleCheck(StgCreateDocfileOnILockBytes(ALockBytes, STGM_READWRITE
    or STGM_SHARE_EXCLUSIVE or STGM_CREATE, 0, AStorage));
  ReleaseObject(ALockBytes);
end;

function cxWStrLen(AStr: PWideChar): Integer;
begin
  Result := 0;
  while AStr[Result] <> #0 do Inc(Result);
end;

procedure cxCenterWindow(Wnd: HWnd);
var
  Rect: TRect;
begin
  GetWindowRect(Wnd, Rect);
  SetWindowPos(Wnd, 0,
    (GetSystemMetrics(SM_CXSCREEN) - Rect.Right + Rect.Left) div 2,
    (GetSystemMetrics(SM_CYSCREEN) - Rect.Bottom + Rect.Top) div 3,
    0, 0, SWP_NOACTIVATE or SWP_NOSIZE or SWP_NOZORDER);
end;

function cxOleDialogHook(Wnd: HWnd; Msg, WParam, LParam: Longint): Longint; stdcall;
begin
  Result := 0;
  if Msg = WM_INITDIALOG then
  begin
    if GetWindowLong(Wnd, GWL_STYLE) and WS_CHILD <> 0 then
      Wnd := GetWindowLong(Wnd, GWL_HWNDPARENT);
    cxCenterWindow(Wnd);
    Result := 1;
  end;
end;

function cxOleStdGetFirstMoniker(const AMoniker: IMoniker): IMoniker;
var
  AMksys: Longint;
  AEnumMoniker: IEnumMoniker;
begin
  Result := nil;
  if AMoniker <> nil then
  begin
    if (AMoniker.IsSystemMoniker(AMksys) = 0) and
      (AMksys = MKSYS_GENERICCOMPOSITE) then
    begin
      if AMoniker.Enum(True, AEnumMoniker) <> 0 then Exit;
      AEnumMoniker.Next(1, Result, nil);
    end
    else
      Result := AMoniker;
  end;
end;

function cxOleStdGetLenFilePrefixOfMoniker(const AMoniker: IMoniker): Integer;
var
  AMkFirst: IMoniker;
  ABindCtx: IBindCtx;
  AMksys: Longint;
  P: PWideChar;
begin
  Result := 0;
  if AMoniker <> nil then
  begin
    AMkFirst := cxOleStdGetFirstMoniker(AMoniker);
    if (AMkFirst <> nil) and
      (AMkFirst.IsSystemMoniker(AMksys) = 0) and
      (AMksys = MKSYS_FILEMONIKER) and
      (CreateBindCtx(0, ABindCtx) = 0) and
      (AMkFirst.GetDisplayName(ABindCtx, nil, P) = 0) and (P <> nil) then
    begin
      Result := cxWStrLen(P);
      CoTaskMemFree(P);
    end;
  end;
end;

function cxCoAllocCStr(const S: string): PChar;
begin
  Result := StrCopy(CoTaskMemAlloc(Length(S) + 1), PChar(S));
end;

function cxGetOleLinkDisplayName(const AOleLink: IOleLink): PChar;
var
  P: PWideChar;
begin
  AOleLink.GetSourceDisplayName(P);
  Result := cxCoAllocCStr(WideCharToString(P));
end;

function cxGetOleObjectFullName(const AOleObject: IOleObject): PChar;
var
  P: PWideChar;
begin
  AOleObject.GetUserType(USERCLASSTYPE_FULL, P);
  Result := cxCoAllocCStr(WideCharToString(P));
  CoTaskMemFree(P);
end;

function cxGetOleObjectShortName(const AOleObject: IOleObject): PChar;
var
  P: PWideChar;
begin
  AOleObject.GetUserType(USERCLASSTYPE_SHORT, P);
  Result := cxCoAllocCStr(WideCharToString(P));
  CoTaskMemFree(P);
end;

function cxGetIconMetaPict(AOleObject: IOleObject; ADrawAspect: Longint): HGlobal;
var
  ADataObject: IDataObject;
  AFormatEtc: TFormatEtc;
  AMedium: TStgMedium;
  AClassID: TCLSID;
begin
  Result := 0;
  if ADrawAspect = DVASPECT_ICON then
  begin
    AOleObject.QueryInterface(IDataObject, ADataObject);
    if ADataObject <> nil then
    begin
      with AFormatEtc do
      begin
        cfFormat := CF_METAFILEPICT;
        ptd := nil;
        dwAspect := DVASPECT_ICON;
        lIndex := -1;
        tymed := TYMED_MFPICT;
      end;
      if Succeeded(ADataObject.GetData(AFormatEtc, AMedium)) then
        Result := AMedium.hMetaFilePict;
      ReleaseObject(ADataObject);
    end;
  end;
  if Result = 0 then
  begin
    OleCheck(AOleObject.GetUserClassID(AClassID));
    Result := OleGetIconOfClass(AClassID, nil, True);
  end;
end;