Marco's Web Center

Menu for Development

Site Menu
Object Pascal Handbook
Delphi Handbooks Collection
Mastering Borland Delphi 2005
(Old) White Papers
(Old)Tools
(Old) Conferences

My Other Sites
Italian Site (www.marcocantu.it)
the delphi search

Spirit of delphi

Advertising
Home My Blog Books Object Pascal Marco

Home: Code Repository: Mastering Delphi 6

Chapter 07 - Project BmpViewer

Project Structure

BmpViewer.dpr
program BmpViewer;

uses
  Forms,
  BmpViewForm in 'BmpViewForm.pas' {FormBmpViewer},
  BmpPreview in 'BmpPreview.pas' {PreviewForm};

{$R *.RES}

begin
  Application.CreateForm(TFormBmpViewer, FormBmpViewer);
  Application.CreateForm(TPreviewForm, PreviewForm);
  Application.Run;
end.
BmpViewForm.pas
unit BmpViewForm;

interface

uses
  Windows, Classes, SysUtils, Graphics, Forms, Controls, StdCtrls,
  Tabs, Menus, Dialogs, ExtCtrls, Printers, ComCtrls;

type
  TFormBmpViewer = class(TForm)
    OpenDialog1: TOpenDialog;
    MainMenu1: TMainMenu;
    File1: TMenuItem;
    Open1: TMenuItem;
    Print1: TMenuItem;
    N1: TMenuItem;
    Exit1: TMenuItem;
    Edit1: TMenuItem;
    Cut1: TMenuItem;
    Copy1: TMenuItem;
    Paste1: TMenuItem;
    N2: TMenuItem;
    Delete1: TMenuItem;
    Help1: TMenuItem;
    About1: TMenuItem;
    TabControl1: TTabControl;
    Image1: TImage;
    procedure Open1Click(Sender: TObject);
    procedure Exit1Click(Sender: TObject);
    procedure About1Click(Sender: TObject);
    procedure Print1Click(Sender: TObject);
    procedure TabControl1Change(Sender: TObject);
    procedure Edit1Click(Sender: TObject);
    procedure Paste1Click(Sender: TObject);
    procedure Copy1Click(Sender: TObject);
    procedure Cut1Click(Sender: TObject);
    procedure Delete1Click(Sender: TObject);
    procedure File1Click(Sender: TObject);
    procedure TabControl1DrawTab(Control: TCustomTabControl;
      TabIndex: Integer; const Rect: TRect; Active: Boolean);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    TabBmp: TBitmap;
  public
    { Public declarations }
  end;

var
  FormBmpViewer: TFormBmpViewer;

implementation

{$R *.DFM}

uses
  Clipbrd, BmpPreview;

const
  BmpSide = 20;

procedure TFormBmpViewer.Open1Click(Sender: TObject);
begin
  if OpenDialog1.Execute then
  begin
    TabControl1.Tabs.AddStrings (OpenDialog1.Files);
    TabControl1.TabIndex := 0;
    TabControl1Change (TabControl1);
  end;
end;

procedure TFormBmpViewer.Exit1Click(Sender: TObject);
begin
  Close;
end;

procedure TFormBmpViewer.About1Click(Sender: TObject);
begin
  MessageDlg ('Bitmap Viewer with Tabs, from "Mastering Delphi"',
    mtInformation, [mbOk], 0);
end;

procedure TFormBmpViewer.Print1Click(Sender: TObject);
begin
  {double checks if an image is selected}
  if Image1.Picture.Graphic <> nil then
  begin
    {set a default scale, and start the preview}
    PreviewForm.Scale := 2;
    PreviewForm.SetPage;
    PreviewForm.DrawPreview;
    PreviewForm.ShowModal;
  end;
end;

procedure TFormBmpViewer.TabControl1Change(Sender: TObject);
var
  TabText: string;
begin
  Image1.Visible := True;
  TabText := TabControl1.Tabs [TabControl1.TabIndex];
  if TabText <> 'Clipboard' then
    // load the file indicated in the tab
    Image1.Picture.LoadFromFile (TabText)
  else
    {if the tab is 'Clipboard' and a bitmap
    is available in the clipboard}
    if Clipboard.HasFormat (cf_Bitmap) then
      Image1.Picture.Assign (Clipboard)
    else
    begin
      // else remove the clipboard tab
      TabControl1.Tabs.Delete (TabControl1.TabIndex);
      if TabControl1.Tabs.Count = 0 then
        Image1.Visible := False;
    end;
end;

procedure TFormBmpViewer.Edit1Click(Sender: TObject);
begin
  Paste1.Enabled := Clipboard.HasFormat (cf_Bitmap);
  if TabControl1.Tabs.Count > 0 then
  begin
    Cut1.Enabled := True;
    Copy1.Enabled := True;
    Delete1.Enabled := True;
  end
  else
  begin
    Cut1.Enabled := False;
    Copy1.Enabled := False;
    Delete1.Enabled := False;
  end;
end;

procedure TFormBmpViewer.Paste1Click(Sender: TObject);
var
  TabNum: Integer;
begin
  // try to locate the page
  TabNum := TabControl1.Tabs.IndexOf ('Clipboard');
  if TabNum < 0 then
    // create a new page for the clipboard
    TabNum := TabControl1.Tabs.Add ('Clipboard');
  // go to the clipboard page and force repaint
  TabControl1.TabIndex := TabNum;
  TabControl1Change (Self);
end;

procedure TFormBmpViewer.Copy1Click(Sender: TObject);
begin
  Clipboard.Assign (Image1.Picture.Graphic);
end;

procedure TFormBmpViewer.Cut1Click(Sender: TObject);
begin
  Copy1Click (Self);
  Delete1Click (Self);
end;

procedure TFormBmpViewer.Delete1Click(Sender: TObject);
begin
  with TabControl1 do
  begin
    if TabIndex >= 0 then
      Tabs.Delete (TabIndex);
    if Tabs.Count = 0 then
      Image1.Visible := False
    else
      TabControl1Change (Self);
  end;
end;

procedure TFormBmpViewer.File1Click(Sender: TObject);
begin
  Print1.Enabled := TabControl1.Tabs.Count > 0;
end;

procedure TFormBmpViewer.TabControl1DrawTab(Control: TCustomTabControl;
  TabIndex: Integer; const Rect: TRect; Active: Boolean);
var
 TabText: string;
 OutRect: TRect;
begin
  TabText := TabControl1.Tabs [TabIndex];
  OutRect := Rect;
  InflateRect (OutRect, -3, -3);
  OutRect.Left := OutRect.Left + BmpSide + 3;
  DrawText (Control.Canvas.Handle,
    PChar (ExtractFileName (TabText)),
    Length (ExtractFileName (TabText)),
    OutRect, dt_Left or dt_SingleLine or dt_VCenter);
  if TabText = 'Clipboard' then
    if Clipboard.HasFormat (cf_Bitmap) then
      TabBmp.Assign (Clipboard)
    else
      TabBmp.FreeImage
  else
    TabBmp.LoadFromFile (TabText);
  OutRect.Left := OutRect.Left - BmpSide - 3;
  OutRect.Right := OutRect.Left + BmpSide;
  Control.Canvas.StretchDraw (OutRect, TabBmp);
end;

procedure TFormBmpViewer.FormCreate(Sender: TObject);
begin
  TabControl1.TabHeight := BmpSide + 6;
  TabBmp := TBitmap.Create;
end;

procedure TFormBmpViewer.FormDestroy(Sender: TObject);
begin
  TabBmp.Free;
end;

end.
BmpPreview.pas
unit BmpPreview;

interface

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

type
  TPreviewForm = class(TForm)
    Panel1: TPanel;
    ScalePlusButton: TSpeedButton;
    ScaleMinusButton: TSpeedButton;
    PrintButton: TSpeedButton;
    ScrollBox1: TScrollBox;
    Image1: TImage;
    CancelButton: TSpeedButton;
    Label1: TLabel;
    procedure ScalePlusButtonClick(Sender: TObject);
    procedure ScaleMinusButtonClick(Sender: TObject);
    procedure CancelButtonClick(Sender: TObject);
    procedure PrintButtonClick(Sender: TObject);
  public
    Scale: Integer;
    procedure DrawPreview;
    procedure SetPage;
  end;

var
  PreviewForm: TPreviewForm;

implementation

{$R *.DFM}

uses
  BmpViewForm;

procedure TPreviewForm.SetPage;
begin
  {set the image size to be proportional with the page size}
  Image1.Width := Printer.PageWidth div 5;
  Image1.Height := Printer.PageHeight div 5;
  {output the scale to the toolbar}
  Label1.Caption := IntToStr (Scale);
end;

procedure TPreviewForm.ScalePlusButtonClick(Sender: TObject);
begin
  {increse the size of the bitmap}
  Scale := Scale * 2;
  Label1.Caption := IntToStr (Scale);
  DrawPreview;
end;

procedure TPreviewForm.DrawPreview;
var
  Rect: TRect;
begin
  {compute the rectangle for the bitmap preview}
  Rect.Top := 10;
  Rect.Left := 10;
  Rect.Right := 10 +
    (FormBmpViewer.Image1.Picture.Graphic.Width * Scale) div 5;
  Rect.Bottom := 10 +
    (FormBmpViewer.Image1.Picture.Graphic.Height * Scale) div 5;

  {remove the current image}
  Image1.Canvas.Pen.Mode := pmWhite;
  Image1.Canvas.Rectangle (0, 0, Image1.Width, Image1.Height);

  {stretch the bitmap into the rectangle}
  Image1.Canvas.StretchDraw (Rect,
    FormBmpViewer.Image1.Picture.Graphic);
end;

procedure TPreviewForm.ScaleMinusButtonClick(Sender: TObject);
begin
  {decrease the size of the image}
  if Scale > 1 then
  begin
    Scale := Scale div 2;
    Label1.Caption := IntToStr (Scale);
    DrawPreview;
  end;
end;

procedure TPreviewForm.CancelButtonClick(Sender: TObject);
begin
  {close (hide) the preview dialog}
  Close;
end;

procedure TPreviewForm.PrintButtonClick(Sender: TObject);
var
  Rect: TRect;
begin
  {compute the rectangle for the printer}
  Rect.Top := 10;
  Rect.Left := 10;
  Rect.Right := 10 +
    (FormBmpViewer.Image1.Picture.Graphic.Width * Scale);
  Rect.Bottom := 10 +
    (FormBmpViewer.Image1.Picture.Graphic.Height * Scale);

  {print the bitmap}
  Printer.BeginDoc;
  Printer.Canvas.StretchDraw (Rect,
    FormBmpViewer.Image1.Picture.Graphic);
  Printer.EndDoc;
end;

end.
BmpViewForm.dfm
object FormBmpViewer: TFormBmpViewer
  Left = 196
  Top = 155
  Width = 636
  Height = 393
  Caption = 'BmpViewer'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clBlack
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  Menu = MainMenu1
  OldCreateOrder = True
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  PixelsPerInch = 96
  TextHeight = 13
  object TabControl1: TTabControl
    Left = 0
    Top = 0
    Width = 628
    Height = 347
    Align = alClient
    MultiLine = True
    OwnerDraw = True
    TabHeight = 20
    TabOrder = 0
    TabWidth = 120
    OnChange = TabControl1Change
    OnDrawTab = TabControl1DrawTab
    object Image1: TImage
      Left = 4
      Top = 6
      Width = 620
      Height = 337
      HelpType = htKeyword
      Align = alClient
    end
  end
  object OpenDialog1: TOpenDialog
    Filter = 'Bitmpas (*.bmp)|*.bmp'
    FilterIndex = 0
    Options = [ofHideReadOnly, ofAllowMultiSelect, ofFileMustExist]
    Left = 24
    Top = 48
  end
  object MainMenu1: TMainMenu
    Left = 24
    Top = 104
    object File1: TMenuItem
      Caption = '&File'
      OnClick = File1Click
      object Open1: TMenuItem
        Caption = '&Open...'
        OnClick = Open1Click
      end
      object Print1: TMenuItem
        Caption = 'Print...'
        OnClick = Print1Click
      end
      object N1: TMenuItem
        Caption = '-'
      end
      object Exit1: TMenuItem
        Caption = 'E&xit'
        OnClick = Exit1Click
      end
    end
    object Edit1: TMenuItem
      Caption = '&Edit'
      OnClick = Edit1Click
      object Cut1: TMenuItem
        Caption = 'Cu&t'
        ShortCut = 16472
        OnClick = Cut1Click
      end
      object Copy1: TMenuItem
        Caption = '&Copy'
        ShortCut = 16451
        OnClick = Copy1Click
      end
      object Paste1: TMenuItem
        Caption = '&Paste'
        ShortCut = 16470
        OnClick = Paste1Click
      end
      object N2: TMenuItem
        Caption = '-'
      end
      object Delete1: TMenuItem
        Caption = '&Delete'
        OnClick = Delete1Click
      end
    end
    object Help1: TMenuItem
      Caption = '&Help'
      object About1: TMenuItem
        Caption = '&About...'
        OnClick = About1Click
      end
    end
  end
end
BmpPreview.dfm
object PreviewForm: TPreviewForm
  Left = 152
  Top = 111
  Width = 550
  Height = 375
  Caption = 'Print Preview'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -13
  Font.Name = 'System'
  Font.Style = []
  OldCreateOrder = True
  PixelsPerInch = 96
  TextHeight = 16
  object Panel1: TPanel
    Left = 0
    Top = 0
    Width = 542
    Height = 41
    Align = alTop
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clBlack
    Font.Height = -21
    Font.Name = 'Arial'
    Font.Style = [fsBold]
    ParentFont = False
    TabOrder = 0
    object ScalePlusButton: TSpeedButton
      Left = 8
      Top = 8
      Width = 25
      Height = 25
      HelpType = htKeyword
      Caption = '+'
      OnClick = ScalePlusButtonClick
    end
    object ScaleMinusButton: TSpeedButton
      Left = 40
      Top = 8
      Width = 25
      Height = 25
      HelpType = htKeyword
      Caption = '-'
      OnClick = ScaleMinusButtonClick
    end
    object PrintButton: TSpeedButton
      Left = 200
      Top = 8
      Width = 25
      Height = 25
      HelpType = htKeyword
      Glyph.Data = {
        76010000424D7601000000000000760000002800000020000000100000000100
        04000000000000010000130B0000130B00001000000000000000000000000000
        800000800000008080008000000080008000808000007F7F7F00BFBFBF000000
        FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00300000000000
        00033FFFFFFFFFFFFFFF0888888888888880777777777777777F088888888888
        8880777777777777777F0000000000000000FFFFFFFFFFFFFFFF0F8F8F8F8F8F
        8F80777777777777777F08F8F8F8F8F8F9F0777777777777777F0F8F8F8F8F8F
        8F807777777777777F7F0000000000000000777777777777777F3330FFFFFFFF
        03333337F3FFFF3F7F333330F0000F0F03333337F77773737F333330FFFFFFFF
        03333337F3FF3FFF7F333330F00F000003333337F773777773333330FFFF0FF0
        33333337F3FF7F3733333330F08F0F0333333337F7737F7333333330FFFF0033
        33333337FFFF7733333333300000033333333337777773333333}
      NumGlyphs = 2
      OnClick = PrintButtonClick
    end
    object CancelButton: TSpeedButton
      Left = 232
      Top = 8
      Width = 25
      Height = 25
      HelpType = htKeyword
      Glyph.Data = {
        76010000424D7601000000000000760000002800000020000000100000000100
        04000000000000010000120B0000120B00001000000000000000000000000000
        800000800000008080008000000080008000808000007F7F7F00BFBFBF000000
        FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00333000000000
        3333333777777777F3333330F777777033333337F3F3F3F7F3333330F0808070
        33333337F7F7F7F7F3333330F080707033333337F7F7F7F7F3333330F0808070
        33333337F7F7F7F7F3333330F080707033333337F7F7F7F7F3333330F0808070
        333333F7F7F7F7F7F3F33030F080707030333737F7F7F7F7F7333300F0808070
        03333377F7F7F7F773333330F080707033333337F7F7F7F7F333333070707070
        33333337F7F7F7F7FF3333000000000003333377777777777F33330F88877777
        0333337FFFFFFFFF7F3333000000000003333377777777777333333330777033
        3333333337FFF7F3333333333000003333333333377777333333}
      NumGlyphs = 2
      OnClick = CancelButtonClick
    end
    object Label1: TLabel
      Left = 72
      Top = 8
      Width = 67
      Height = 24
      HelpType = htKeyword
      Caption = 'Label1'
    end
  end
  object ScrollBox1: TScrollBox
    Left = 0
    Top = 41
    Width = 542
    Height = 307
    Align = alClient
    TabOrder = 1
    object Image1: TImage
      Left = 20
      Top = 20
      Width = 485
      Height = 330
      HelpType = htKeyword
    end
  end
end