Delphi控件源码

开发平台：
C++ Builder

IMAGEWIN.PAS：源码内容
							unit ImageWin;
interface
uses Windows, Classes, Graphics, Forms, Controls,
  FileCtrl, StdCtrls, ExtCtrls, Buttons, ComCtrls, Dialogs, Printers;
type
  TImageForm = class(TForm)
    PrinterSetupDialog1: TPrinterSetupDialog;
    PrintDialog1: TPrintDialog;
    m_butClose: TButton;
    m_butPrinterSetup: TButton;
    m_butPrint: TButton;
    GroupBox1: TGroupBox;
    LoadButton: TButton;
    m_butFore: TBitBtn;
    m_butStart: TBitBtn;
    m_labelFileName: TLabel;
    m_ComboBoxZoom: TComboBox;
    Label1: TLabel;
    Button1: TButton;
    GroupBox2: TGroupBox;
    m_butRew: TBitBtn;
    procedure m_butPrinterSetupClick(Sender: TObject);
    procedure m_butPrintClick(Sender: TObject);
    procedure m_butCloseClick(Sender: TObject);
    procedure LoadButtonClick(Sender: TObject);
    procedure ViewPic(strPicFile : string);
    procedure FormShow(Sender: TObject);
    procedure m_butStartClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure m_butForeClick(Sender: TObject);
    procedure m_butRewClick(Sender: TObject);
    procedure InitFileCounter(n : integer);
    procedure m_ComboBoxZoomClick(Sender: TObject);
    procedure m_ComboBoxZoomKeyPress(Sender: TObject; var Key: Char);
    procedure Zoom;
    procedure Button1Click(Sender: TObject);
  public
    strTempDir : string;
    lpszTempDir : PChar;
    strTempFirstFileName : string;
    nMetaWidth, nMetaHeight : integer;
  private
    FormCaption: string;
    nFileCounter : integer;
    strFileCounter : string;
  end;
var
  ImageForm: TImageForm;
implementation
uses ViewWin, SysUtils, LoadWin, about;
{$R *.DFM}
procedure TImageForm.m_butPrinterSetupClick(Sender: TObject);
begin
  PrinterSetupDialog1.Execute;
end;
procedure TImageForm.m_butPrintClick(Sender: TObject);
var
  rRec : TRect;
  strTmpFile : string;
  SearchRes : TSearchRec; // search structure
  i, nMax, nTemp, nFound : integer;
  hmf : HMETAFILE;
begin
  rRec.Left := 0;
  rRec.Top := 0;
  rRec.Bottom := Printer.PageHeight;
  rRec.Right := Printer.PageWidth;
  // search min and max values for printing (0..1.EMF .. 0..n.EMF)
  PrintDialog1.MinPage := 1;
  nMax := 1;
  nFound := FindFirst(strTempDir + '*.EMF', faAnyFile, SearchRes);
  while nFound = 0 do begin
    nTemp := StrToInt(Copy(ExtractFileName(SearchRes.Name),1,Pos('.',ExtractFileName(SearchRes.Name))-1));
    if (nMax<nTemp) then nMax := nTemp;
    nFound := FindNext(SearchRes);
  end;
  FindClose(SearchRes);
  PrintDialog1.MaxPage := nMax;
  if (PrintDialog1.Execute) then begin
    try
      if (PrintDialog1.PrintRange = prAllPages) then begin
        PrintDialog1.FromPage := 0;
        PrintDialog1.ToPage := nMax;
      end;
      for i:=PrintDialog1.FromPage to PrintDialog1.ToPage do begin
        strTmpFile := IntToStr(i);
        while (Length(strTmpFile)<8) do
          insert('0', strTmpFile, 1);
        // load pic
        strTmpFile := strTempDir + '' + strTmpFile + '.EMF';
        if (FileExists(strTmpFile)) then begin
          hmf := GetEnhMetaFile(PChar(strTmpFile));
          // print pic
          Printer.BeginDoc;
          PlayEnhMetaFile(Printer.Handle, hmf, rRec);
          Printer.EndDoc;
          DeleteEnhMetaFile(hmf);
        end;
      end;
    except
      on Exception do begin { just in case an error happens... }
        Printer.Abort;
        Printer.EndDoc;
        Raise;
      end;
    end;
  end;
end;
procedure TImageForm.m_butCloseClick(Sender: TObject);
begin
  Close;
end;
procedure TImageForm.LoadButtonClick(Sender: TObject);
begin
  LoadForm.Show;
end;
procedure TImageForm.ViewPic(strPicFile : string);
begin
  if (FileExists(strPicFile)) then begin  // this is the name of a file that exists
    m_labelFileName.Caption := Copy(ExtractFileName(strPicFile), 1, Pos('.', ExtractFileName(strPicFile))-1);
    m_labelFileName.Refresh;
    ViewForm.Image1.Picture.LoadFromFile(strPicFile);
    ViewForm.Caption := FormCaption + ExtractFilename(strPicFile);
    ViewForm.HorzScrollBar.Range := ViewForm.Image1.Picture.Width;
    ViewForm.VertScrollBar.Range := ViewForm.Image1.Picture.Height;
    ViewForm.ClientHeight := ViewForm.Image1.Picture.Height;
    ViewForm.ClientWidth := ViewForm.Image1.Picture.Width;
    nMetaWidth := ViewForm.Image1.Picture.Metafile.Width;
    nMetaHeight := ViewForm.Image1.Picture.Metafile.Height;
    ViewForm.Show;
  end;
end;
procedure TImageForm.FormShow(Sender: TObject);
var strParam : string;
begin
  GetMem(lpszTempDir, 255);
  GetEnvironmentVariable('temp', lpszTempDir, 255);
  strTempDir := string(lpszTempDir);
  LoadForm.strTempDir := strTempDir;
  FreeMem(lpszTempDir, 255);
  strTempFirstFileName := strTempDir + '' + strFileCounter + '.EMF';
  if (ParamCount <> 0) then begin
    strParam := ParamStr(1);
    if (FileExists(ParamStr(1))) then begin
      // parameter is a valid filename
      strTempFirstFileName := strParam;
      strFileCounter := Copy(ExtractFileName(strParam), 1, Pos('.', ExtractFileName(strParam))-1);
      nFileCounter := StrToInt(strFileCounter);
    end else if (DirectoryExists(strParam)) then begin
      // parameter is a valid directory name -> load 1st file of it
      strTempDir := strParam;
      LoadForm.strTempDir := strTempDir;
      strTempFirstFileName := strTempDir + '0000001.EMF';
    end;
  end;
  if (FileExists(strTempFirstFileName)) then ViewPic(strTempFirstFileName);
end;
procedure TImageForm.m_butStartClick(Sender: TObject);
begin
  nFileCounter := 0;
  InitFileCounter(nFileCounter);
  ViewPic(strTempFirstFileName);
  if (m_ComboBoxZoom.Text <> '100') then Zoom;
end;
procedure TImageForm.InitFileCounter(n : integer);
begin
  nFileCounter := n;
  strFileCounter := IntToStr(nFileCounter);
  while (Length(strFileCounter)<8) do
    insert('0', strFileCounter, 1);
end;
procedure TImageForm.FormCreate(Sender: TObject);
begin
  InitFileCounter(1);
end;
procedure TImageForm.m_butForeClick(Sender: TObject);
var
  strTmpFile,
  strTmpFilCnt : string;
begin
  strTmpFilCnt := strFileCounter;
  Inc(nFileCounter);
  InitFileCounter(nFileCounter);
  strTmpFile := strTempDir + '' + strFileCounter + '.EMF';
  if (FileExists(strTmpFile)) then begin
    ViewPic(strTmpFile);
    if (m_ComboBoxZoom.Text <> '100') then Zoom;
  end else begin
    Dec(nFileCounter);
    strFileCounter := strTmpFilCnt;
  end;
end;
procedure TImageForm.m_butRewClick(Sender: TObject);
var
  strTmpFile,
  strTmpFilCnt : string;
begin
  strTmpFilCnt := strFileCounter;
  if (nFileCounter-1) >= 0 then begin
    Dec(nFileCounter);
    InitFileCounter(nFileCounter);
    strTmpFile := strTempDir + '' + strFileCounter + '.EMF';
    if (FileExists(strTmpFile)) then begin
      ViewPic(strTmpFile);
      if (m_ComboBoxZoom.Text <> '100') then Zoom;
    end else begin
      Inc(nFileCounter);
      strFileCounter := strTmpFilCnt;
    end;
  end;
end;
procedure TImageForm.Zoom;
begin
  ViewForm.Image1.Picture.Metafile.Height := (nMetaHeight div 100) * StrToInt(m_ComboBoxZoom.Text);
  ViewForm.Image1.Picture.Metafile.Width := (nMetaWidth div 100) * StrToint(m_ComboBoxZoom.Text);
  ViewForm.HorzScrollBar.Range := ViewForm.Image1.Picture.Width;
  ViewForm.VertScrollBar.Range := ViewForm.Image1.Picture.Height;
  ViewForm.ClientHeight := ViewForm.Image1.Picture.Height;
  ViewForm.ClientWidth := ViewForm.Image1.Picture.Width;
  ViewForm.Repaint;
end;
procedure TImageForm.m_ComboBoxZoomClick(Sender: TObject);
begin
  Zoom;
end;
procedure TImageForm.m_ComboBoxZoomKeyPress(Sender: TObject;
  var Key: Char);
begin
  if Key = #13 then Zoom;
end;
procedure TImageForm.Button1Click(Sender: TObject);
begin
  AboutBox.ShowModal;
end;
end.

						