Delphi控件源码

开发平台：
C++ Builder

IMAGEWIN.PAS：源码内容
							unit ImageWin;
// emf file viewer with some features
interface
uses Windows, Classes, Graphics, Forms, Controls,
  FileCtrl, StdCtrls, ExtCtrls, Buttons, ComCtrls, Dialogs, Printers,
  Grids, Outline, DirOutln;
type
  TImageForm = class(TForm)
    PrinterSetupDialog1: TPrinterSetupDialog;
    PrintDialog1: TPrintDialog;
    m_butClose: TButton;
    m_butPrinterSetup: TButton;
    m_butPrint: TButton;
    GroupBox1: TGroupBox;
    LoadButton: TButton;
    m_butFore: TBitBtn;
    GroupBox2: TGroupBox;
    m_butRew: TBitBtn;
    m_butStart: TBitBtn;
    m_ComboBoxZoom: TComboBox;
    Button1: TButton;
    Label2: TLabel;
    Label1: TLabel;
    m_StatusBar: TStatusBar;
    m_DriveComboBox: TDriveComboBox;
    m_DirectoryListBox: TDirectoryListBox;
    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);
    procedure FormResize(Sender: TObject);
    procedure FormCanResize(Sender: TObject; var NewWidth,
      NewHeight: Integer; var Resize: Boolean);
    procedure m_DriveComboBoxChange(Sender: TObject);
    procedure m_DirectoryListBoxChange(Sender: TObject);
  public
    strTempDir : string;
    strSelectedDir : string;
    lpszTempDir : PChar;
    strTempFirstFileName : string;
    nMetaWidth, nMetaHeight : integer;
  private
    FormCaption: string;
    nFileCounter : integer;
    strFileCounter : string;
  end;
const
  PMON_KEY = 'SYSTEMCurrentControlSetControlPrintEnvironmentsWindows NT x86Print Processors';
var
  ImageForm: TImageForm;
implementation
uses ViewWin, SysUtils, LoadWin, about, WinReg;
{$R *.DFM}
procedure TImageForm.m_butPrinterSetupClick(Sender: TObject);
// brings up windows standard printer setup dialog
begin
  PrinterSetupDialog1.Execute;
end;
procedure TImageForm.m_butPrintClick(Sender: TObject);
// prints the printer job actually seen
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);
// brings up load/browse window
begin
  strSelectedDir := m_DirectoryListBox.Directory;
  LoadForm.strSelectedDir := strSelectedDir;
  LoadForm.Show;
end;
procedure TImageForm.ViewPic(strPicFile : string);
// show picture in separate window
begin
  if (FileExists(strPicFile)) then begin  // this is the name of a file that exists
    m_StatusBar.Panels[0].Text := 'Page: ' + Copy(ExtractFileName(strPicFile), 1, Pos('.', ExtractFileName(strPicFile))-1);
    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, m_strTempVar : string;
    reg : TWinRegistry;
begin
  // inits
  GetMem(lpszTempDir, 255);
  GetEnvironmentVariable('temp', lpszTempDir, 255);
  strTempDir := string(lpszTempDir);
  LoadForm.strTempDir := strTempDir;
  FreeMem(lpszTempDir, 255);
  // try to get registry settings for destdir
  reg := TWinRegistry.CreateWithKey(HKEY_LOCAL_MACHINE, PMON_KEY);
  m_strTempVar := reg.ReadString('vprproc', 'DestDir', '');
  if (m_strTempVar = '') then
    ShowMessage('vprproc registry settings not yet set!' + #13 + 'Please select destination directory for print jobs' + #13 +
                'using the Installer Tool!' + #13 + 'I will use your temp directory at' + #13 + strTempDir)
  else
    strTempDir := m_strTempVar;
  reg.free;
  m_DirectoryListBox.Directory := strTempDir;
end;
procedure TImageForm.m_butStartClick(Sender: TObject);
// jumps to file 00000000.emf
begin
  strSelectedDir := m_DirectoryListBox.Directory;
  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);
// jumps 1 picture forward
var
  strTmpFile,
  strTmpFilCnt : string;
begin
  strSelectedDir := m_DirectoryListBox.Directory;
  strTmpFilCnt := strFileCounter;
  Inc(nFileCounter);
  InitFileCounter(nFileCounter);
  strTmpFile := strSelectedDir + '' + 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);
// jumps 1 picture backward
var
  strTmpFile,
  strTmpFilCnt : string;
begin
  strSelectedDir := m_DirectoryListBox.Directory;
  strTmpFilCnt := strFileCounter;
  if (nFileCounter-1) >= 0 then begin
    Dec(nFileCounter);
    InitFileCounter(nFileCounter);
    strTmpFile := strSelectedDir + '' + 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;
// zoom factor for picture in viewwindow
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);
// for manual setting of zoom factor
begin
  if Key = #13 then Zoom;
end;
procedure TImageForm.Button1Click(Sender: TObject);
begin
  MessageDlg('EMF Viewer for Virtual Printer' + #13 + '(C) 2002 mabuse.de', mtInformation, [mbOK], 0);
end;
procedure TImageForm.FormResize(Sender: TObject);
begin
  ImageForm.Repaint;
end;
procedure TImageForm.FormCanResize(Sender: TObject; var NewWidth,
  NewHeight: Integer; var Resize: Boolean);
begin
  m_DirectoryListBox.Width := NewWidth - 20;
  m_DirectoryListBox.Height := NewHeight - 210;
end;
procedure TImageForm.m_DriveComboBoxChange(Sender: TObject);
begin
  m_DirectoryListBox.Drive := m_DriveComboBox.Drive;
end;
procedure TImageForm.m_DirectoryListBoxChange(Sender: TObject);
begin
  strSelectedDir := m_DirectoryListBox.Directory;
  strTempFirstFileName := strSelectedDir + '' + strFileCounter + '.EMF';
  if (FileExists(strTempFirstFileName)) then ViewPic(strTempFirstFileName);
end;
end.

						