rm_view.pas

进销存管理 编译环境Delphi7+Win2000 用到的控件 ReportMachine2.6 InfoPower4000Pro_vcl7 RxLib2.7 SkinEngine 3

{*****************************************}
{                                         }
{             Report Machine v2.0         }
{             Report preview              }
{                                         }
{*****************************************}

unit RM_view;

interface

{$I RM.inc}
{$R RMachine.res}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, Buttons, Printers, RM_Const;

type
  TRMPreviewZoom = (pzDefault, pzPageWidth, pzOnePage, pzTwoPages);
  TRMPreviewButton = (pbZoom, pbLoad, pbSave, pbPrint, pbFind, pbPageSetup, pbExit, pbDesign,
    pbSaveToXLS);
  TRMPreviewButtons = set of TRMPreviewButton;
  TRMScaleMode = (mdNone, mdPageWidth, mdOnePage, mdTwoPages);

  TRMPreview = class;

  { TRMDrawPanel }
  TRMDrawPanel = class(TPanel)
  private
    FDown, FDFlag: Boolean;
    FLastClick: Integer;
    FLastX, FLastY: Integer;
    FPreview: TRMPreview;
    FOldMousePos: TPoint;
    FLastLeft, FLastRight: Integer;

    procedure WMEraseBackground(var Message: TMessage); message WM_ERASEBKGND;
  protected
    procedure Paint; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
  public
    constructor Create(AOwner: TComponent); override;
    procedure DblClick; override;
  end;

  { TRMPreview }
  TRMPreview = class(TPanel)
  private
    FDoc: Pointer;
    FEMFPages: Pointer;
    FCurPage: Integer;
    Fofx, Fofy, FOldV, FOldH: Integer;
    Fper: Double;
    FMode: TRMScaleMode;
    FPaintAllowed: Boolean;
    FLastScale: Double;
    FLastScaleMode: TRMScaleMode;
    FAutoScale: Boolean;

    FStrFound: Boolean;
    FStrBounds: TRect;
    FFindStr: string;
    FCaseSensitive: Boolean;
    FWholewords: Boolean;
    FLastFoundPage, FLastFoundObject: Integer;

    FScrollBox: TScrollBox;
    FRPanel: TPanel;
    FBPanel: TPanel;
    FBevel: TBevel;
    FLabel: TLabel;
    FVScrollBar: TScrollBar;
    FHScrollBar: TScrollBar;
    FPgUp: TSpeedButton;
    FPgDown: TSpeedButton;
    FPBox: TRMDrawPanel;
    FScrollBars: TScrollStyle;
    FKWheel: Integer;
    FParentForm: TForm;
    FInitialDir: string;

    FOnStatusChange: TNotifyEvent;
    FOnPageChanged: TNotifyEvent;
    FOnAfterPageSetup: TNotifyEvent;

    procedure DoStatusChange;
    procedure SetPage(Value: Integer);
    function GetZoom: Double;
    procedure SetZoom(Value: Double);
    function GetAllPages: Integer;
    procedure SetScrollBars(Value: TScrollStyle);

    procedure ShowPageNum;
    procedure SetToCurPage;
    procedure FindInEMF(emf: TMetafile);
    procedure OnResizeEvent(Sender: TObject);
    procedure OnVScrollBarChange(Sender: TObject);
    procedure OnHScrollBarChange(Sender: TObject);
    procedure OnPgUpClick(Sender: TObject);
    procedure OnPgDnClick(Sender: TObject);
    procedure SetAutoScale(Value: Boolean);
{$IFDEF Delphi4}
    procedure OnMouseWheelUpEvent(Sender: TObject; Shift: TShiftState;
      MousePos: TPoint; var Handled: Boolean);
    procedure OnMouseWheelDownEvent(Sender: TObject; Shift: TShiftState;
      MousePos: TPoint; var Handled: Boolean);
{$ENDIF}
  protected
    FCanModify: Boolean;
    property OnAfterPageSetup: TNotifyEvent read FOnAfterPageSetup write FOnAfterPageSetup;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    function CanModify: Boolean;
    procedure Connect(aDoc: TObject);
    procedure Connect_1(aDoc: TObject);
    procedure ConnectBack;
    procedure Disconnect;

    procedure ClearScreen;
    procedure RedrawAll(ResetPage: Boolean);
    procedure OnePage;
    procedure TwoPages;
    procedure PageWidth;
    procedure First;
    procedure Next;
    procedure Prev;
    procedure Last;
    procedure LoadFromFile(aFileName: string);
    procedure LoadFromFiles(aFileNames: TStrings);
    procedure SaveToFile(aFileName: string; aIndex: Integer);
    procedure ExportToFile(aExport: TComponent; aFileName: string);
    procedure Print;
    procedure PrintCurrentPage;
    procedure DlgPageSetup;
    procedure Find;
    procedure FindNext;
    procedure InsertPageBefore;
    procedure InsertPageAfter;
    procedure AddPage;
    procedure DeletePage(PageNo: Integer);
    function EditPage(PageNo: Integer): Boolean;
    procedure DesignReport;

    property ParentForm: TForm read FParentForm write FParentForm;
    property EMFPages: Pointer read FEMFPages;
    property Doc: Pointer read FDoc;
    property AllPages: Integer read GetAllPages;
    property Zoom: Double read GetZoom write SetZoom;
    property VScrollBar: TScrollbar read FVScrollBar write FVScrollBar;
    property HScrollBar: TScrollbar read FHScrollBar write FHScrollBar;
    property ZoomMode: TRMScaleMode read FMode write FMode;
    property LastScale: Double read FLastScale write FLastScale;
    property ScrollBox: TScrollBox read FScrollBox;
    property FindStr: string read FFindStr write FFindstr;
    property CaseSensitive: Boolean read FCaseSensitive write FCaseSensitive;
    property Wholewords: Boolean read FWholewords write FWholewords;
    property LastFoundPage: Integer read FLastFoundPage write FLastFoundPage;
    property LastFoundObject: Integer read FLastFoundObject write FLastFoundObject;
    property CurPage: Integer read FCurPage write SetPage;
    property StrFound: Boolean read FStrFound write FStrFound;
    property StrBounds: TRect read FStrBounds write FStrBounds;
    property AutoScale: Boolean read FAutoScale write SetAutoScale;
  published
    property InitialDir: string read FInitialDir write FInitialDir;
    property ScrollBars: TScrollStyle read FScrollBars write SetScrollBars;
    property OnPageChanged: TNotifyEvent read FOnPageChanged write FOnPageChanged;
    property OnStatusChange: TNotifyEvent read FOnStatusChange write FOnStatusChange;
  end;

implementation

uses RM_Class, RM_pgopt, RM_CmpReg, RM_Prntr, RM_PrDlg, RM_Utils, RM_Srch;

var
  crMagnifier: Integer = 0;
  CurPreview: TRMPreview;
  RecordNum: Integer;

function EnumEMFRecordsProc(DC: HDC; HandleTable: PHandleTable;
  EMFRecord: PEnhMetaRecord; nObj: Integer; OptData: Pointer): Bool; stdcall;
var
  Typ: Byte;
  s: string;
  t: TEMRExtTextOut;
  s1: PChar;

  function _FindText(const aStr: string): Boolean;
  var
    liPos, liLen: Integer;
  begin
    Result := False;
    liPos := Pos(aStr, s);
    liLen := Length(aStr);
    while (liPos > 0) and (not Result) do
    begin
      if liPos < Length(s) then
      begin
        if (s[liPos + liLen] in RMBreakChars) or (s[liPos + liLen] in LeadBytes) then
          Result := True;
      end
      else
        Result := True;

      if not Result then
      begin
        System.Delete(s, 1, liPos - 1 + liLen);
        liPos := Pos(aStr, s);
      end;
    end;
  end;

begin
  Result := True;
  Typ := EMFRecord^.iType;
  if Typ in [83, 84] then
  begin
    t := PEMRExtTextOut(EMFRecord)^;
    if RMGetWindowsVersion <> 'NT' then
    begin
      s1 := StrAlloc(t.EMRText.nChars + 1);
      StrLCopy(s1, PChar(PChar(EMFRecord) + t.EMRText.offString), t.EMRText.nChars);
      s := StrPas(s1);
      StrDispose(s1);
    end
    else
      s := WideCharLenToString(PWideChar(PChar(EMFRecord) + t.EMRText.offString),
        t.EMRText.nChars);

    if not CurPreview.CaseSensitive then
      s := AnsiUpperCase(s);

    if CurPreview.Wholewords then
    begin
      CurPreview.StrFound := _FindText(CurPreview.FindStr);
    end
    else
      CurPreview.StrFound := Pos(CurPreview.FindStr, s) <> 0;

    if CurPreview.StrFound and (RecordNum >= CurPreview.LastFoundObject) then
    begin
      CurPreview.StrBounds := t.rclBounds;
      Result := False;
    end;
  end;
  Inc(RecordNum);
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{ TRMDrawPanel }

constructor TRMDrawPanel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
end;

procedure TRMDrawPanel.WMEraseBackground(var Message: TMessage);
begin
end;

procedure TRMDrawPanel.Paint;
var
  i: Integer;
  r, r1: TRect;
  Pages: TRMEMFPages;
  h: HRGN;
  liScale: Double;

  procedure DrawMargins(i: Integer);
  begin
    with Pages[i].PrnInfo, Pages[i].pgMargins do
    begin
      if Left = 0 then
        r1.Left := Round(Ofx * liScale)
      else
        r1.Left := Round(Left * liScale);
      if Top = 0 then
        r1.Top := Round(Ofy * liScale)
      else
        r1.Top := Round(Top * liScale);
      if Right = 0 then
        r1.Right := Round((Ofx + Pw) * liScale)
      else
        r1.Right := Round((Pgw - Right) * liScale);
      if Bottom = 0 then
        r1.Bottom := Round((Ofy + Ph) * liScale)
      else
        r1.Bottom := Round((Pgh - Bottom) * liScale);
      OffsetRect(r1, r.Left, r.Top);
    end;
    with Canvas do
    begin
      Pen.Color := clGray;
      MoveTo(r1.Left, r1.Top); LineTo(r1.Left, r1.Top - Round(20 * liScale)); //左上
      MoveTo(r1.Left, r1.Top); LineTo(r1.Left - Round(20 * liScale), r1.Top);
      MoveTo(r1.Right, r1.Top); LineTo(r1.Right, r1.Top - Round(20 * liScale)); //右上
      MoveTo(r1.Right, r1.Top); LineTo(r1.Right + Round(20 * liScale), r1.Top);
      MoveTo(r1.Left, r1.Bottom); LineTo(r1.Left, r1.Bottom + Round(20 * liScale)); //左下
      MoveTo(r1.Left, r1.Bottom); LineTo(r1.Left - Round(20 * liScale), r1.Bottom);
      MoveTo(r1.Right, r1.Bottom); LineTo(r1.Right, r1.Bottom + Round(20 * liScale)); //右下
      MoveTo(r1.Right, r1.Bottom); LineTo(r1.Right + Round(20 * liScale), r1.Bottom);
    end;
  end;

  procedure DrawbkPicture;
  var
    lbkPic: TRMbkPicture;
    lPic: TPicture;
    lPicWidth, lPicHeight: Integer;
  begin
    lbkPic := Pages.bkPictures[Pages[i].bkPictureIndex];
    if lbkPic = nil then
      Exit;
    lPic := lbkPic.Picture;
    if lPic.Graphic <> nil then
    begin
//      lPicWidth := lPic.Width; lPicHeight := lPic.Height;
      lPicWidth := lbkPic.Width;
      lPicHeight := lbkPic.Height;

      r1 := Rect(0, 0, Round(lPicWidth * liScale), Round(lPicHeight * liScale));
      OffsetRect(r1, Round(lbkPic.Left * liScale), Round(lbkPic.Top * liScale));
      OffsetRect(r1, r.Left, r.Top);
      try
        IntersectClipRect(Canvas.Handle, r.Left + 1, r.Top + 1, r.Right - 1, r.Bottom - 1);
        RMPrintGraphic(Canvas, r1, lPic.Graphic, False);
      finally
        SelectClipRgn(Canvas.Handle, h);
      end;
    end;
  end;

begin
  if not FPreview.FPaintAllowed then
  begin
    inherited;
    Exit;
  end;

  if FPreview.FEMFPages = nil then
  begin
    Canvas.Brush.Color := clBtnFace;
    Canvas.FillRect(ClientRect);
    Exit;
  end;

  Pages := TRMEMFPages(FPreview.FEMFPages);
  h := CreateRectRgn(0, 0, Width, Height);
  GetClipRgn(Canvas.Handle, h);

  for i := 0 to Pages.Count - 1 do // drawing window background
  begin
    r := Pages[i].R;
    OffsetRect(r, FPreview.Fofx, FPreview.Fofy);
    if (r.Top > 2000) or (r.Bottom < 0) then
      Pages[i].Visible := False
    else
      Pages[i].Visible := RectVisible(Canvas.Handle, r);

    if Pages[i].Visible then
      ExcludeClipRect(Canvas.Handle, r.Left + 1, r.Top + 1, r.Right - 1, r.Bottom - 1);
  end;

  with Canvas do
  begin
    Brush.Color := clGray;
    FillRect(Rect(0, 0, Width, Height));
    Pen.Color := clBlack;
    Pen.Width := 1;
    Pen.Mode := pmCopy;
    Pen.Style := psSolid;
    Brush.Color := clWhite;
  end;

  SelectClipRgn(Canvas.Handle, h);
  for i := 0 to Pages.Count - 1 do // drawing page background
  begin
    if Pages[i].Visible then
    begin
      r := Pages[i].r;
      OffsetRect(r, FPreview.FOfx, FPreview.FOfy);
      Canvas.Rectangle(r.Left, r.Top, r.Right, r.Bottom);
      Canvas.Polyline([Point(r.Left + 1, r.Bottom), Point(r.Right, r.Bottom),
        Point(r.Right, r.Top + 1)]);

      FLastLeft := r.Left; FLastRight := r.Right;
      liScale := FPreview.FPer;
      DrawMargins(i);
      DrawbkPicture;
    end;
  end;

  for i := 0 to Pages.Count - 1 do // drawing page content
  begin
    if Pages[i].Visible then
    begin
      r := Pages[i].r;
      OffsetRect(r, FPreview.FOfx, FPreview.FOfy);
      Pages.Draw(i, Canvas, r);
    end
    else
      Pages.Draw(i, Canvas, Rect(0, 0, 0, 0)); // remove it from cache
  end;
  DeleteObject(h);
end;

procedure TRMDrawPanel.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
  i: Integer;
  pt: TPoint;
  r: TRect;
  C: TCursor;
begin
  FOldMousePos := Point(X, Y);
  if FPreview.FEMFPages = nil then
    Exit;
  if FDFlag then
  begin
    FDFlag := False;
    Exit;
  end;

  with FPreview do
  begin
    if Button = mbLeft then
    begin
      FLastClick := 0;
      pt := Point(x - Fofx, y - Fofy);
      for i := 0 to TRMEMFPages(FEMFPages).Count - 1 do
      begin
        r := TRMEMFPages(FEMFPages)[i].r;
        if PtInRect(r, pt) then
        begin
          FLastClick := i + 1;
          pt := Point(Round((pt.X - r.Left) / Fper), Round((pt.Y - r.Top) / Fper));
          if TRMEMFPages(FEMFPages).DoClick(i, pt, TRUE, C) then
            Exit;
        end;
      end;
      FDown := True;
      FLastX := X; FLastY := Y;
      if FLastClick > 0 then
        FCurPage := FLastClick;
      ShowPageNum;
    end
    else if Button = mbRight then
    begin
      pt := Self.ClientToScreen(Point(X, Y));
      if RMDesigner <> nil then
      begin
      end;
    end;
  end;
end;

procedure TRMDrawPanel.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  i: Integer;
  pt: TPoint;
  r: TRect;
  C: TCursor;
begin
  pt := Self.ClientToScreen(Point(X, Y));
  if FPreview.AutoScale and (pt.X >= FLastLeft) and (pt.X <= FLastRight) then
    Cursor := crMagnifier
  else
    Cursor := crDefault;

  if FDown then
  begin
    FPreview.HScrollBar.Position := FPreview.HScrollBar.Position - (X - FLastX);
    FPreview.VScrollBar.Position := FPreview.VScrollBar.Position - (Y - FLastY);
    FLastX := X; FLastY := Y;
  end
  else
  begin
    with FPreview do
    begin
      if (Doc <> nil) and Assigned(TRMReport(Doc).OnMouseOverObject) then
      begin
        pt := Point(x - FOfx, y - FOfy);
        for i := 0 to TRMEMFPages(FEMFPages).Count - 1 do
        begin
          r := TRMEMFPages(FEMFPages)[i].r;
          if PtInRect(r, pt) then
          begin
            C := crDefault;
            pt := Point(Round((pt.X - r.Left) / FPer), Round((pt.Y - r.Top) / FPer));
            if TRMEMFPages(FEMFPages).DoClick(i, pt, False, C) then
              Self.Cursor := C
            else
              Self.Cursor := crDefault;
            Break;
          end;
        end;
      end;
    end; {with}
  end; {else}
end;

procedure TRMDrawPanel.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if Cursor = crMagnifier then
  begin
    if FPreview.FLastScaleMode = mdOnePage then
      FPreview.Zoom := 100
    else
      FPreview.OnePage;
    FPreview.FVScrollBar.Position := FPreview.FVScrollBar.Position + FOldMousePos.y;
    FPreview.FHScrollBar.Position := FPreview.FHScrollBar.Position + FOldMousePos.x;
  end;

  FDown := False;
end;

procedure TRMDrawPanel.DblClick;
begin