wwriched.pas

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

    bReserved1: byte;
  end;
{
  Typedef struct _charformat2
    UINT        cbSize;
    DWORD       dwMask;
    DWORD       dwEffects;
    LONG        yHeight;
    LONG        yOffset;
    COLORREF    crTextColor;
    BYTE        bCharSet;
    BYTE        bPitchAndFamily;
    WCHAR       szFaceName[LF_FACESIZE];
    WORD        wWeight;
    SHORT       sSpacing;
    COLORREF    crBackColor;
    LCID        lcid;
    DWORD       dwReserved;
    SHORT       sStyle;
    WORD        wKerning;
    BYTE        bUnderlineType;
    BYTE        bAnimation;
    BYTE        bRevAuthor;
    BYTE        bReserved1;
 CHARFORMAT2;
}
Function wwGetUniqueFileName(var Filename: string): boolean;

type
  EwwRTFError = class(Exception)
  private
    FErrorCode: Integer;
//    FErrorMsg: string;
  public
    constructor Create(Message: string; ErrCode: integer; Dummy: integer);
    property ErrorCode: Integer read FErrorCode;
//    property ErrorMsg: string read FErrorMsg;
  end;

procedure Register;

implementation

uses consts,
  {$ifdef wwDelphi6Up}
  rtlconsts, variants,
  {$endif}
   wwrtfconverter,
   comstrs, wwrich, wwrchdlg, wwrichtb, comobj, clipbrd, wwricholecallback,
     wwrichobjinfo, wwrtfprintpreview;

{1/28/98  - Allow Change of text when there is a protected flag in previous richtext.}
const
      WWEM_SETTYPOGRAPHYOPTIONS = WM_USER + 202;
      WWEM_GETTYPOGRAPHYOPTIONS = WM_USER + 203;
      WWTO_ADVANCEDTYPOGRAPHY	= 1;
      WWTO_SIMPLELINEBREAK = 2;
type
  TRichProtectClass = class(TObject)
     procedure RichProtectChange(Sender: TObject; StartPos,
       EndPos: Integer; var AllowChange: Boolean);
  end;

{ TwwDBRichEdit }

  { The following class is for the sole purpose of avoiding
    the incompatibility of the Delphi TRichEditStrings.insert method
    with RichEdit version 2.
    We have removed the exception raised at the end. }
  TwwRichEditStrings = class(TStrings)
  private
    RichEdit: TwwCustomRichEdit;
    procedure EnableChange(const Value: Boolean);
  protected
    function Get(Index: Integer): string; override;
    function GetCount: Integer; override;
    procedure Put(Index: Integer; const S: string); override;
    procedure SetUpdateState(Updating: Boolean); override;
    procedure SetTextStr(const Value: string); override;
  public
    procedure Clear; override;
    procedure AddStrings(Strings: TStrings); override;
    procedure Delete(Index: Integer); override;
    procedure Insert(Index: Integer; const S: string); override;
    procedure LoadFromFile(const FileName: string); override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToFile(const FileName: string); override;
    procedure SaveToStream(Stream: TStream); override;
  end;

procedure TwwRichEditStrings.LoadFromFile(const FileName: string);
begin
   RichEdit.ILines.LoadFromFile(FileName);
end;

procedure TwwRichEditStrings.LoadFromStream(Stream: TStream);
begin
   RichEdit.ILines.LoadFromStream(Stream);
end;

procedure TwwRichEditStrings.SaveToFile(const FileName: string);
begin
   RichEdit.ILines.SaveToFile(FileName);
end;

procedure TwwRichEditStrings.SaveToStream(Stream: TStream);
begin
   RichEdit.ILines.SaveToStream(Stream);
end;

procedure TwwCustomRichEdit.SetLines(val: TStrings);
begin
   ILines.Assign(val);
end;

procedure TwwRichEditStrings.AddStrings(Strings: TStrings);
var
  SelChange: TNotifyEvent;
begin
  SelChange := RichEdit.OnSelectionChange;
  RichEdit.OnSelectionChange := nil;
  try
    inherited AddStrings(Strings);
  finally
    RichEdit.OnSelectionChange := SelChange;
  end;
end;

function TwwRichEditStrings.GetCount: Integer;
begin
  Result := SendMessage(RichEdit.Handle, EM_GETLINECOUNT, 0, 0);
  if SendMessage(RichEdit.Handle, EM_LINELENGTH, SendMessage(RichEdit.Handle,
    EM_LINEINDEX, Result - 1, 0), 0) = 0 then Dec(Result);
end;

function TwwRichEditStrings.Get(Index: Integer): string;
var
  Text: array[0..4095] of Char;
  L: Integer;
begin
  Word((@Text)^) := SizeOf(Text);
  L := SendMessage(RichEdit.Handle, EM_GETLINE, Index, Longint(@Text));
  if (L>1) and (Text[L - 2] = #13) and (Text[L - 1] = #10) then Dec(L, 2); { 10/16/98 }
  if (L>0) and (Text[L - 1] = #13) then Dec(L, 1); { 10/16/98}
  SetString(Result, Text, L);
end;

procedure TwwRichEditStrings.Put(Index: Integer; const S: string);
var
  Selection: TCharRange;
begin
  if Index >= 0 then
  begin
    Selection.cpMin := SendMessage(RichEdit.Handle, EM_LINEINDEX, Index, 0);
    if Selection.cpMin <> -1 then
    begin
      Selection.cpMax := Selection.cpMin +
        SendMessage(RichEdit.Handle, EM_LINELENGTH, Selection.cpMin, 0);
      SendMessage(RichEdit.Handle, EM_EXSETSEL, 0, Longint(@Selection));
      SendMessage(RichEdit.Handle, EM_REPLACESEL, 0, Longint(PChar(S)));
    end;
  end;
end;

procedure TwwRichEditStrings.Insert(Index: Integer; const S: string);
var
  L: Integer;
  Selection: TCharRange;
  Fmt: PChar;
  Str: string;
begin
  if Index >= 0 then
  begin
    Selection.cpMin := SendMessage(RichEdit.Handle, EM_LINEINDEX, Index, 0);
    if Selection.cpMin >= 0 then Fmt := '%s'#13#10
    else begin
      Selection.cpMin :=
        SendMessage(RichEdit.Handle, EM_LINEINDEX, Index - 1, 0);
      if Selection.cpMin < 0 then Exit;
      L := SendMessage(RichEdit.Handle, EM_LINELENGTH, Selection.cpMin, 0);
      if L = 0 then Exit;
      Inc(Selection.cpMin, L);
      Fmt := #13#10'%s';
    end;
    Selection.cpMax := Selection.cpMin;
    SendMessage(RichEdit.Handle, EM_EXSETSEL, 0, Longint(@Selection));
    Str := Format(Fmt, [S]);
    SendMessage(RichEdit.Handle, EM_REPLACESEL, 0, LongInt(PChar(Str)));

//   if RichEdit.SelStart <> (Selection.cpMax + Length(Str)) then
//      raise EOutOfResources.Create(sRichEditInsertError);
  end;
end;

procedure TwwRichEditStrings.Delete(Index: Integer);
begin
  RichEdit.ILines.Delete(Index);
end;

procedure TwwRichEditStrings.Clear;
begin
  RichEdit.Clear;
end;

procedure TwwRichEditStrings.SetUpdateState(Updating: Boolean);
begin
  if RichEdit.Showing then
    SendMessage(RichEdit.Handle, WM_SETREDRAW, Ord(not Updating), 0);
  if not Updating then begin
    RichEdit.Refresh;
    RichEdit.Perform(CM_TEXTCHANGED, 0, 0);
  end;
end;

procedure TwwRichEditStrings.EnableChange(const Value: Boolean);
var
  EventMask: Longint;
begin
  with RichEdit do
  begin
    if Value then
      EventMask := SendMessage(Handle, EM_GETEVENTMASK, 0, 0) or ENM_CHANGE
    else
      EventMask := SendMessage(Handle, EM_GETEVENTMASK, 0, 0) and not ENM_CHANGE;
    SendMessage(Handle, EM_SETEVENTMASK, 0, EventMask);
  end;
end;

procedure TwwRichEditStrings.SetTextStr(const Value: string);
begin
  EnableChange(False);
  try
    inherited SetTextStr(Value);
  finally
    EnableChange(True);
  end;
end;

{ Advise sink to detect when OLE object is changed }
type
  TwwAdviseSinkChange = (asData, asView, asRename, asSave, asClose);
  TwwRichEditAdviseSink = class(TInterfacedObject, IAdviseSink)
  protected
    // IAdviseSink
    procedure OnDataChange(const formatetc: TFormatEtc;
      const stgmed: TStgMedium); stdcall;
    procedure OnViewChange(dwAspect: Longint; lindex: Longint); stdcall;
    procedure OnRename(const mk: IMoniker); stdcall;
    procedure OnSave; stdcall;
    procedure OnClose; stdcall;

    procedure Change(Change: TwwAdviseSinkChange); virtual;
  public
    Owner: TComponent;
    Connection: integer;
    constructor Create(AOwner: TComponent); virtual;
    destructor Destroy; override;
  end;



{$WARNINGS OFF}
function EditSelectStreamInCallback(dwCookie: Longint; pbBuff: PByte;
  cb: Longint; var pcb: Longint): Longint; Stdcall;
var
  theStream: TStream;
  dataAvail: LongInt;
begin
  theStream := TStream(dwCookie);
  with theStream do begin
    dataAvail := Size - Position;
    Result := 0; {assume everything is ok}
    if dataAvail <= cb then begin
      pcb := Read(pbBuff^, dataAvail);
      if pcb <> dataAvail then {couldn't read req. amount of bytes}
         result := E_FAIL;
    end
    else begin
      pcb := Read(pbBuff^, cb);
      if pcb <> cb then
        result := E_FAIL;
    end;
  end;
end;
{$WARNINGS ON}


Function EditSelectStreamOutCallback(dwCookie: Longint; pbBuff: PByte;
     cb: Longint; var pcb: Longint): Longint; stdcall;
var
  theStream: TStream;
begin
  theStream := TStream(dwCookie);

  with theStream do begin
    If cb > 0 Then
      pcb := Write(pbBuff^, cb);
    Result := 0;
  end;
end;

{ Extracts richedit's current selection into a stream }
Procedure TwwCustomRichEdit.GetRTFSelection (DestStream: TStream);
var editstream: TEditStream;
Begin
  with editStream Do begin
    dwCookie:= Longint(DestStream);
    dwError:= 0;
    pfnCallback:= EditSelectStreamOutCallBack;
  end;
  Perform( EM_STREAMOUT, SF_RTF or SFF_SELECTION, longint(@editstream));
end;

{ Replaces richedit's current seelction with characters from stream }
Procedure TwwCustomRichEdit.PutRTFSelection (sourceStream: TStream);
var
  editstream: TEditStream;
Begin
  sourceStream.Position := 0;
  With editstream Do Begin
    dwCookie:= Longint(sourceStream);
    dwError:= 0;
    pfnCallback:= EditSelectStreamInCallBack;
  end;
  Perform( EM_STREAMIN, SF_RTF or SFF_SELECTION, longint(@editstream));
end;


destructor TwwRichEditAdviseSink.Destroy;
begin
   inherited Destroy;
end;

constructor TwwRichEditAdviseSink.Create(AOwner: TComponent);
begin
   Owner:= AOwner;
//   _AddRef;
end;

procedure TwwRichEditAdviseSink.OnDataChange(const formatetc: TFormatEtc;
  const stgmed: TStgMedium);
begin
  Change(asData);
end;

procedure TwwRichEditAdviseSink.OnViewChange(dwAspect: Longint; lindex: Longint);
begin
  Change(asView);
end;

procedure TwwRichEditAdviseSink.OnRename(const mk: IMoniker);
begin
  Change(asRename);
end;

procedure TwwRichEditAdviseSink.OnSave;
begin
  Change(asSave);
end;

procedure TwwRichEditAdviseSink.OnClose;
begin
  Change(asClose);
end;

procedure TwwRichEditAdviseSink.Change(Change: TwwAdviseSinkChange);
begin
  if Change = asSave then begin
    with (Owner as TwwDBRichEdit) do
    begin
//       FOleSelObject.UnAdvise(Connection);
       BeginEditing;
       Fdatalink.modified;
       Modified:= True;
    end;
  end;
end;

constructor TwwDBRichEdit.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  MSVersion:= 3;
  ControlStyle:= ControlStyle + [csReplicatable];
  FVerbMenu := TPopupMenu.Create(self);