Marco Web Center

[an error occurred while processing this directive]

Home: Code Repository: Mastering Delphi 5

Project CLIPBMP

Project Structure

CLIPBMP.DPR

program ClipBmp;

uses
  Forms,
  Viewer in 'VIEWER.PAS' {Form1},
  Preview in 'PREVIEW.PAS' {PreviewForm};

{$R *.RES}

begin
  Application.CreateForm(TForm1, Form1);
  Application.CreateForm(TPreviewForm, PreviewForm);
  Application.Run;
end.

VIEWER.PAS

unit Viewer;

interface

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

type
  TForm1 = class(TForm)
    OpenDialog1: TOpenDialog;
    TabControl1: TTabControl;
    Image1: TImage;
    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;
    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);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

uses
  Clipbrd;

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

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

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

procedure TForm1.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 TForm1.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 TForm1.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 TForm1.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 TForm1.Copy1Click(Sender: TObject);
begin
  Clipboard.Assign (Image1.Picture.Graphic);
end;

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

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

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

end.

PREVIEW.PAS

unit Preview;

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
  Viewer;

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 +
    (Form1.Image1.Picture.Graphic.Width * Scale) div 5;
  Rect.Bottom := 10 +
    (Form1.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,
    Form1.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 +
    (Form1.Image1.Picture.Graphic.Width * Scale);
  Rect.Bottom := 10 +
    (Form1.Image1.Picture.Graphic.Height * Scale);

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

end.

VIEWER.DFM

object Form1: TForm1
  Left = 139
  Top = 111
  Width = 435
  Height = 308
  Caption = 'ClipBmp'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clBlack
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  Menu = MainMenu1
  OldCreateOrder = True
  PixelsPerInch = 96
  TextHeight = 13
  object TabControl1: TTabControl
    Left = 0
    Top = 0
    Width = 427
    Height = 262
    Align = alClient
    TabOrder = 0
    OnChange = TabControl1Change
    object Image1: TImage
      Left = 4
      Top = 6
      Width = 419
      Height = 252
      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

PREVIEW.DFM

object PreviewForm: TPreviewForm
  Left = 157
  Top = 111
  Width = 550
  Height = 375
  Caption = 'Print Preview'
  Font.Color = clWindowText
  Font.Height = -13
  Font.Name = 'System'
  Font.Style = []
  PixelsPerInch = 96
  TextHeight = 16
  object Panel1: TPanel
    Left = 0
    Top = 0
    Width = 542
    Height = 41
    Align = alTop
    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
      Caption = '+'
      OnClick = ScalePlusButtonClick
    end
    object ScaleMinusButton: TSpeedButton
      Left = 40
      Top = 8
      Width = 25
      Height = 25
      Caption = '-'
      OnClick = ScaleMinusButtonClick
    end
    object PrintButton: TSpeedButton
      Left = 200
      Top = 8
      Width = 25
      Height = 25
      Glyph.Data = {
        76010000424D7601000000000000760000002800000020000000100000000100
        04000000000000010000130B0000130B00000000000000000000000000000000
        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
      Glyph.Data = {
        78010000424D7801000000000000760000002800000020000000100000000100
        04000000000000000000120B0000120B00000000000000000000000000000000
        800000800000008080008000000080008000808000007F7F7F00BFBFBF000000
        FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00333000000000
        3333333777777777F3333330F777777033333337F3F3F3F7F3333330F0808070
        33333337F7F7F7F7F3333330F080707033333337F7F7F7F7F3333330F0808070
        33333337F7F7F7F7F3333330F080707033333337F7F7F7F7F3333330F0808070
        333333F7F7F7F7F7F3F33030F080707030333737F7F7F7F7F7333300F0808070
        03333377F7F7F7F773333330F080707033333337F7F7F7F7F333333070707070
        33333337F7F7F7F7FF3333000000000003333377777777777F33330F88877777
        0333337FFFFFFFFF7F3333000000000003333377777777777333333330777033
        3333333337FFF7F33333333330000033333333333777773333330000}
      NumGlyphs = 2
      OnClick = CancelButtonClick
    end
    object Label1: TLabel
      Left = 72
      Top = 8
      Width = 67
      Height = 24
      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
    end
  end
end