📄 rm_e_main.pas

📁 中小企业管理系统------ ERP系统原代码
💻 PAS
字号:
unit RM_e_main;

interface

{$I RM.INC}

uses
  SysUtils, Windows, Messages, Classes, Graphics, Forms, Dialogs, StdCtrls,
  Controls, Comctrls, RM_Class
{$IFDEF RXGIF}, RxGif{$ENDIF}
{$IFDEF JPEG}, JPEG{$ENDIF};

type
  TRMEFImageFormat = (ifGIF, ifJPG, ifBMP);

  TRMEFFrameTyp = (efftNone, efftRight, efftBottom, efftRightBottom,
    efftLeft, efftLeftRight, efftLeftBottom, efftLeftRightBottom,
    efftTop, efftRightTop, efftTopBottom, efftRightTopBottom,
    efftLeftTop, efftLeftRightTop, efftLeftTopBottom, efftAll);

  TRMEFFontInfo = packed record
    Name: TFontName;
    Size: Integer;
    Color: TColor;
    Style: TFontStyles;
    Charset: TFontCharset;
  end;

  TRMEFFrameInfo = packed record
    FrameVisible: Boolean;
    FrameTyp: TRMEFFrameTyp;
    FrameWidth: Single;
    FrameColor: TColor;
    FrameStyle: Word;
    FillColor: TColor;
  end;

  TRMEFTextProperty = (eftpAlignLeft, eftpAlignRight, eftpAlignTop, eftpAlignBottom,
    eftpAlignJustify, eftpAlignCenter, eftpAlignVerticalCenter);

  TRMEFTextRec = packed record
    X, Y: Integer;
    Text: string;
    TextWidth: Integer;
    TextHeight: Integer;
    FontInfo: TRMEFFontInfo;
    DrawRect: TRect;
  end;
  PRMEFTextRec = ^TRMEFTextRec;

  TRMEFDataRec = record
    X, Y, dx, dy: Integer;
    Text: string; // for RTF
    TextWidth: Integer; // for RTF
    TextAlign: set of TRMEFTextProperty;
    FontInfo: TRMEFFontInfo; // for RTF
    FrameInfo: TRMEFFrameInfo;
    LFInfo, TFInfo, RFInfo, BFInfo: TRMEFFrameInfo;
    ViewName: string;
    ViewIndex: Integer;
    ViewClassName: string;
    Bitmap: TBitmap;
		BmpWidth: Integer;
		BmpHeight: Integer;
    VerticalText: Boolean;
    Stretched: Boolean;
    WordWrap: Boolean;
  end;
  PRMEFDataRec = ^TRMEFDataRec;

  TRMMainExportFilter = class;

  TBeforeSaveGraphicEvent = procedure(Sender: TRMMainExportFilter;
    AViewName: string; var UniqueImage: Boolean; var ReuseImageIndex: Integer;
    AAltText: string) of object;

  TAfterSaveGraphicEvent = procedure(Sender: TRMMainExportFilter;
    AViewName: string; ObjectImageIndex: Integer) of object;

 { TRMMainExportFilter }
  TRMMainExportFilter = class(TRMExportFilter)
  private
    FExportFrames, FExportImages: Boolean;
{$IFDEF JPEG}
    FJPEGQuality: TJPEGQualityRange;
{$ENDIF}
    FViewNames: TStringList;
  protected
    FTextList: TList;
    FDataList: TList;
    FPageNo: Integer;
    FPageWidth: Integer;
    FPageHeight: Integer;
    FExportImageFormat: TRMEFImageFormat;
    function GetBitmapAsJpgGifStream(Bmp: TBitmap; ImgFormat: TRMEFImageFormat
{$IFDEF JPEG}; JPEGQuality: TJPEGQualityRange{$ENDIF}): TStream;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure OnBeginDoc; override;
    procedure OnEndDoc; override;
    procedure OnBeginPage; override;
    procedure OnEndPage; override;
    procedure OnData(x, y: Integer; View: TRMView); override;
    procedure OnText(DrawRect: TRect; x, y: Integer; const text: string; FrameTyp: Integer; View: TRMView); override;
    procedure ClearTextList;
    procedure ClearDataList;
  published
    property ExportImages: Boolean read FExportImages write FExportImages default True;
    property ExportFrames: Boolean read FExportFrames write FExportFrames default True;
    property ExportImageFormat: TRMEFImageFormat read FExportImageFormat write FExportImageFormat default ifJPG;
{$IFDEF JPEG}
    property JPEGQuality: TJPEGQualityRange read FJPEGQuality write FJPEGQuality default High(TJPEGQualityRange);
{$ENDIF}
  end;

const
  ImageFormats: array[TRMEFImageFormat] of string = ('GIF', 'JPG', 'BMP');

function RMReplaceString(const S, OldPattern, NewPattern: string): string;

implementation

uses RM_CmpReg, RM_rrect;

function RMReplaceString(const S, OldPattern, NewPattern: string): string;
var
  I: Integer;
  SearchStr, Str, OldPat: string;
begin
  SearchStr := AnsiUpperCase(S);
  OldPat := AnsiUpperCase(OldPattern);
  Str := S;
  Result := '';
  while SearchStr <> '' do
  begin
    I := AnsiPos(OldPat, SearchStr);
    if I = 0 then
    begin
      Result := Result + Str;
      Break;
    end;
    Result := Result + Copy(Str, 1, I - 1) + NewPattern;
    Str := Copy(Str, I + Length(OldPattern), MaxInt);
    SearchStr := Copy(SearchStr, I + Length(OldPat), MaxInt);
  end;
end;

function RMGetTextSize(AFont: TFont; const Text: string): TSize;
var
  DC: HDC;
  SaveFont: HFont;
begin
  DC := GetDC(0);
  SaveFont := SelectObject(DC, AFont.Handle);
  Result.cX := 0;
  Result.cY := 0;
  GetTextExtentPoint32(DC, PChar(Text), Length(Text), Result);
  SelectObject(DC, SaveFont);
  ReleaseDC(0, DC);
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMMainExportFilter}

constructor TRMMainExportFilter.Create(AOwner: TComponent);
begin
  inherited;
  ShowDialog := True;

  FExportImages := True;
  FExportFrames := True;
  FExportImageFormat := ifJPG;
{$IFDEF JPEG}
  FJPEGQuality := 100;
{$ENDIF}
end;

destructor TRMMainExportFilter.Destroy;
begin
  RMUnRegisterExportFilter(Self);
  inherited Destroy;
end;

procedure TRMMainExportFilter.OnBeginDoc;
begin
  FDataList := TList.Create;
  FTextList := TList.Create;
  FViewNames := TStringList.Create;

  FPageNo := 0;
  FPageWidth := CurReport.EMFPages[0].PrnInfo.Pgw;
  FPageHeight := CurReport.EMFPages[0].PrnInfo.Pgh;
end;

procedure TRMMainExportFilter.OnEndDoc;
begin
  ClearDataList;
  ClearTextList;
  FDataList.Free;
  FTextList.Free;
  FViewNames.Free;
end;

procedure TRMMainExportFilter.OnBeginPage;
begin
  ClearDataList;
  ClearTextList;
end;

type
  THackRMView = class(TRMView);

procedure TRMMainExportFilter.OnData(x, y: Integer; View: TRMView);
var
  DataRec: PRMEFDataRec;
  I: Integer;
  liFlag: Boolean;
begin
  if not (View is TRMSubReportView) and not (View is TRMBandView) then
  begin
    New(DataRec);

  // Coordinates
    DataRec^.X := x;
    DataRec^.Y := y;
    DataRec^.dx := View.dx;
    DataRec^.dy := View.dy;

    DataRec^.VerticalText := False;
    if (View is TRMMemoView) and ((TRMMemoView(View).Alignment and $4) <> 0) then
      DataRec^.VerticalText := True;

    DataRec^.Bitmap := nil;
    DataRec^.BmpWidth := -1;
    liFlag := (View.ClassName = TRMMemoView.ClassName) or (View.ClassName = TRMCalcMemoView.ClassName);
    if (not liFlag or DataRec^.VerticalText) or	(View.ClassName = TRMLineView.ClassName) then
		begin
      if ExportImages then
      begin
        DataRec^.Bitmap := TBitmap.Create;
        DataRec^.Bitmap.Width := View.dx + 1;
        DataRec^.Bitmap.Height := View.dy + 1;

        View.SetBounds(0, 0, View.dx, View.dy);
        View.Draw(DataRec^.Bitmap.Canvas);
        View.SetBounds(x, y, View.dx, View.dy);
      end
      else
        DataRec^.BmpWidth := 1;
    end;

  // Font and Text for RTF Filter
    if View is TRMMemoView then
    begin
      with View as TRMMemoView do
      begin
        DataRec^.dx := View.dx + 1;
        DataRec^.Text := RMReplaceString(Memo.Text, #1, '');
        DataRec^.TextWidth := RMGetTextSize(Font, Memo.Text).cx;
        DataRec^.FontInfo.Charset := Font.Charset;
        DataRec^.FontInfo.Color := Font.Color;
        DataRec^.FontInfo.Name := Font.Name;
        DataRec^.FontInfo.Size := Font.Size;
        DataRec^.FontInfo.Style := Font.Style;
        DataRec^.WordWrap := TRMMemoView(View).PWordWrap;
        if THackRMView(View).Parent <> nil then
          DataRec^.Stretched := ((Flags and flStretched) <> 0) and
            THackRMView(View).Parent.Stretched
        else
          DataRec^.Stretched := ((Flags and flStretched) <> 0);

        case Alignment of
          0: DataRec^.TextAlign := [eftpAlignLeft, eftpAlignTop];
          1: DataRec^.TextAlign := [eftpAlignRight, eftpAlignTop];
          2: DataRec^.TextAlign := [eftpAlignCenter, eftpAlignTop];
          3: DataRec^.TextAlign := [eftpAlignJustify, eftpAlignTop];
          8: DataRec^.TextAlign := [eftpAlignLeft, eftpAlignVerticalCenter];
          9: DataRec^.TextAlign := [eftpAlignRight, eftpAlignVerticalCenter];
          10: DataRec^.TextAlign := [eftpAlignCenter, eftpAlignVerticalCenter];
          11: DataRec^.TextAlign := [eftpAlignJustify, eftpAlignVerticalCenter];
          16: DataRec^.TextAlign := [eftpAlignLeft, eftpAlignBottom];
          17: DataRec^.TextAlign := [eftpAlignRight, eftpAlignBottom];
          18: DataRec^.TextAlign := [eftpAlignCenter, eftpAlignBottom];
          19: DataRec^.TextAlign := [eftpAlignJustify, eftpAlignBottom];
        end;
      end;
    end;

  // Frame information
    if ExportFrames then
    begin
      DataRec^.FrameInfo.FillColor := View.FillColor;
      DataRec^.FrameInfo.FrameColor := View.Prop['FrameColor'];
      DataRec^.FrameInfo.FrameStyle := view.Prop['FrameStyle'];
      DataRec^.FrameInfo.FrameTyp := TRMEFFrameTyp(View.Prop['FrameTyp'] mod 16);
      DataRec^.FrameInfo.FrameWidth := View.Prop['FrameWidth'];

      DataRec^.LFInfo.FrameVisible := View.LeftFrame.Visible;
      DataRec^.LFInfo.FrameColor := View.LeftFrame.Color;
      DataRec^.LFInfo.FrameStyle := View.LeftFrame.Style;
      DataRec^.LFInfo.FrameWidth := View.LeftFrame.Width;

      DataRec^.TFInfo.FrameVisible := View.TopFrame.Visible;
      DataRec^.TFInfo.FrameColor := View.TopFrame.Color;
      DataRec^.TFInfo.FrameStyle := View.TopFrame.Style;
      DataRec^.TFInfo.FrameWidth := View.TopFrame.Width;

      DataRec^.RFInfo.FrameVisible := View.RightFrame.Visible;
      DataRec^.RFInfo.FrameColor := View.RightFrame.Color;
      DataRec^.RFInfo.FrameStyle := View.RightFrame.Style;
      DataRec^.RFInfo.FrameWidth := View.RightFrame.Width;

      DataRec^.BFInfo.FrameVisible := View.BottomFrame.Visible;
      DataRec^.BFInfo.FrameColor := View.BottomFrame.Color;
      DataRec^.BFInfo.FrameStyle := View.BottomFrame.Style;
      DataRec^.BFInfo.FrameWidth := View.BottomFrame.Width;
    end;

    I := FViewNames.IndexOf(View.Name);
    if I = -1 then
      I := FViewNames.Add(View.Name);

    DataRec^.ViewIndex := I;
    DataRec^.ViewName := View.Name;
    DataRec^.ViewClassName := View.ClassName;
    FDataList.Add(DataRec);
  end;
end;

procedure TRMMainExportFilter.OnEndPage;
begin
  Inc(FPageNo);
end;

procedure TRMMainExportFilter.OnText(DrawRect: TRect; x, y: Integer;
  const text: string; FrameTyp: Integer; View: TRMView);
var
  TextRec: PRMEFTextRec;
begin
  if (View = nil) or (ExportImages and (View is TRMRoundRectView)) or not (View is TRMMemoView) then
	  Exit;
  if (View is TRMMemoView) and ((TRMMemoView(View).Alignment and $4) <> 0) then
    Exit;

  New(TextRec);
 // Text Coordinates
  TextRec^.X := x;
  TextRec^.Y := y;

  TextRec^.DrawRect := DrawRect;
  TextRec^.Text := text;

 // Font Information
  if View is TRMMemoView then
  begin
    with View as TRMMemoView do
    begin
      TextRec^.TextWidth := RMGetTextSize(Font, text).cx;
      TextRec^.TextHeight := RMGetTextSize(Font, text).cy;
      TextRec^.FontInfo.Charset := Font.Charset;
      TextRec^.FontInfo.Color := Font.Color;
      TextRec^.FontInfo.Name := Font.Name;
      TextRec^.FontInfo.Size := Font.Size;
      TextRec^.FontInfo.Style := Font.Style;
    end;
  end;
  FTextList.Add(TextRec);
end;

procedure TRMMainExportFilter.ClearDataList;
var
  i: Integer;
  p: PRMEFDataRec;
begin
  if FDataList = nil then Exit;
  for i := 0 to FDataList.Count - 1 do
  begin
    Application.ProcessMessages;
    p := PRMEFDataRec(FdataList[i]);
    if p <> nil then
      Dispose(p);
  end;
  FDataList.Clear;
end;

procedure TRMMainExportFilter.ClearTextList;
var
  i: Integer;
  p: PRMEFTextRec;
begin
  if FTextList = nil then Exit;
  for i := 0 to FTextList.Count - 1 do
  begin
    Application.ProcessMessages;
    p := PRMEFTextRec(FTextList[i]);
    if p <> nil then
      Dispose(p);
  end;
  FTextList.Clear;
end;

function TRMMainExportFilter.GetBitmapAsJpgGifStream(Bmp: TBitmap;
  ImgFormat: TRMEFImageFormat{$IFDEF JPEG}; JPEGQuality: TJPEGQualityRange{$ENDIF}): TStream;
var
  Img: TGraphic;
begin
	Result := nil;
{$IFNDEF RXGIF}
{$IFNDEF JPEG}
  Img := nil;
{$ENDIF}
{$ENDIF}
  case ImgFormat of
    ifGIF:
{$IFDEF RXGIF}
      Img := TGIFImage.Create;
{$ELSE}
{$IFDEF JPEG}Img := TJPEGImage.Create;{$ELSE}	Img := nil;{$ENDIF}
{$ENDIF}
    ifJPG:
{$IFDEF JPEG}
      Img := TJPEGImage.Create;
  else
    Img := TJPEGImage.Create;
{$ENDIF}
  end;

	if Img <> nil then
  begin
	  Result := TMemoryStream.Create;
  	try
{$IFDEF JPEG}
    	if Img is TJPEGImage then
	      TJPEGImage(Img).CompressionQuality := JPEGQuality;
{$ENDIF}
  	  Img.Assign(Bmp);
    	Img.SaveToStream(Result);
	  finally
  	  Img.Free;
	  end;
  end;
end;

end.



//此源码由程序太平洋收集整理发布,任何人都可自由转载,但需保留本站信息
//╭⌒╮┅~ ¤　欢迎光临程序太平洋╭⌒╮
//╭⌒╭⌒╮╭⌒╮～╭⌒╮  ︶  ,︶︶
//,︶︶︶︶,''︶~~ ,''~︶︶　 ,''
//╔　╱◥███◣═╬╬╬╬╬╬╬╬╬╗
//╬ ︱田︱田 田 ︱　　　　　　　　　 ╬
//╬　　　　　　　http://www.5ivb.net ╬
//╬　 ╭○╮●　                   　╬
//╬　　/■\/■\　　                  ╬
//╬　　 <|　||　   有希望,就有成功！ ╬
//╬　　　　　　　　　　　　　　　　　╬
//╚╬╬╬╬╬╬╬╬╬╬╗  ╔╬╬╬╬╝
//
//说明：
//专业提供VB、．NET、Delphi、ASP、PB源码下载
//包括:程序源码,控件,商业源码,系统方案，开发工具，书籍教程，技术文档
💿 文件大小 6484 K
👤 上传用户 xufengping716
📂 所属分类 Delphi控件源码
🏷️ 相关标签

#ERP #企业管理 #代码
⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -