www.pudn.com > yrsCapture.zip > main.pas
{******************************************************************************}
{* *}
{* Adirondack Software & Graphics Main Unit *}
{* (C) Copyright Adirondack Software & Graphics 1996-1998 *}
{* *}
{******************************************************************************}
unit Main;
interface
uses Windows, SysUtils, xProcs, Classes, Graphics, Forms, Controls, Menus, StdCtrls,
Dialogs, IdlgUt, Buttons, Messages, ExtCtrls, ComCtrls, ScrnCap, GlobalUt,
About, Iinfo16, Iinfo256, Clipbrd, CompDlg, IniFiles, Printers, JPeg, ExtDlgs,
URL, mmlabel, ClipIcon, SpeedBar, Placemnt;
type
TMainForm = class( TForm )
MainMenu1: TMainMenu;
File1: TMenuItem;
FileNewItem: TMenuItem;
FileOpenItem: TMenuItem;
FileCloseItem: TMenuItem;
Help1: TMenuItem;
FileExitItem: TMenuItem;
HelpAboutItem: TMenuItem;
FileSaveItem: TMenuItem;
FileSaveAsItem: TMenuItem;
EditMnu1: TMenuItem;
CopyItem: TMenuItem;
ImageMnu: TMenuItem;
Desktop1: TMenuItem;
Area1: TMenuItem;
Print1: TMenuItem;
PrintSetup1: TMenuItem;
N3: TMenuItem;
PrintDialog1: TPrintDialog;
PrinterSetupDialog1: TPrinterSetupDialog;
N4: TMenuItem;
CloseAll1: TMenuItem;
N6: TMenuItem;
ForceClose1: TMenuItem;
ShowConfig1: TMenuItem;
CaptureWindoworControl1: TMenuItem;
Components1: TMenuItem;
Information1: TMenuItem;
CaptureIcon1: TMenuItem;
Lisence1: TMenuItem;
ColorDialog1: TColorDialog;
Undo1: TMenuItem;
ZoomPopupMenu: TPopupMenu;
Stretch1: TMenuItem;
pmActivePage: TPopupMenu;
pmaClosePage: TMenuItem;
pmaCloseAllPages: TMenuItem;
pmaNew: TMenuItem;
pmaOpen: TMenuItem;
pmaSave: TMenuItem;
pmaSaveAs: TMenuItem;
pmaExit: TMenuItem;
SaveAll1: TMenuItem;
StatusBar: TStatusBar;
Crop1: TMenuItem;
Preview1: TMenuItem;
File3: TMenuItem;
Print3: TMenuItem;
Preview2: TMenuItem;
Print4: TMenuItem;
Info1: TMenuItem;
Copy1: TMenuItem;
Crop2: TMenuItem;
Resize2: TMenuItem;
Clipboard2: TMenuItem;
Next1: TMenuItem;
Previous1: TMenuItem;
Capture2: TMenuItem;
Desktop2: TMenuItem;
Area2: TMenuItem;
Object1: TMenuItem;
Icon1: TMenuItem;
FullScreen1: TMenuItem;
PageControl1: TPageControl;
View1: TMenuItem;
StatusBar1: TMenuItem;
ProgressBar2: TMenuItem;
N10: TMenuItem;
Resize1: TMenuItem;
N1: TMenuItem;
N2: TMenuItem;
N8: TMenuItem;
SpeedBar1: TSpeedBar;
SpeedbarSection2: TSpeedbarSection;
ExitButton: TSpeedItem;
NewButton: TSpeedItem;
OpenButton: TSpeedItem;
SaveButton: TSpeedItem;
SaveAsButton: TSpeedItem;
SpeedBar2: TSpeedBar;
SpeedbarSection8: TSpeedbarSection;
CopyButton: TSpeedItem;
CropButton: TSpeedItem;
ResizeButton: TSpeedItem;
ClipboardButton: TSpeedItem;
UndoButton: TSpeedItem;
SpeedbarSection9: TSpeedbarSection;
SpeedItem33: TSpeedItem;
AreaButton: TSpeedItem;
ObjectButton: TSpeedItem;
IconButton: TSpeedItem;
SpeedBar3: TSpeedBar;
SpeedbarSection10: TSpeedbarSection;
StretchButton: TSpeedItem;
SpeedbarSection11: TSpeedbarSection;
CloseButton: TSpeedItem;
PreviousButton: TSpeedItem;
NextButton: TSpeedItem;
FullButton: TSpeedItem;
ProgressBar1: TProgressBar;
OpenPictureDialog1: TOpenPictureDialog;
SavePictureDialog1: TSavePictureDialog;
PrintPreviewButton: TSpeedItem;
PrintButton: TSpeedItem;
InfoButton: TSpeedItem;
FormPlacement1: TFormPlacement;
Contents1: TMenuItem;
procedure FormCreate( Sender: TObject );
procedure FileNewItemClick( Sender: TObject );
procedure FileCloseItemClick( Sender: TObject );
procedure FileOpenItemClick( Sender: TObject );
procedure FileExitItemClick( Sender: TObject );
procedure FileSaveItemClick( Sender: TObject );
procedure FileSaveAsItemClick( Sender: TObject );
procedure CopyItemClick( Sender: TObject );
procedure FormDestroy( Sender: TObject );
procedure Desktop1Click( Sender: TObject );
procedure Area1Click( Sender: TObject );
procedure Print1Click( Sender: TObject );
procedure PrintSetup1Click( Sender: TObject );
procedure HelpAboutItemClick( Sender: TObject );
procedure SpeedButton11Click( Sender: TObject );
procedure CloseAll1Click( Sender: TObject );
procedure WindowNextItemClick( Sender: TObject );
procedure WindowPreviousItemClick( Sender: TObject );
procedure ForceClose1Click( Sender: TObject );
procedure CaptureWindowClick( Sender: TObject );
procedure ShowConfig1Click( Sender: TObject );
procedure Components1Click( Sender: TObject );
procedure Exit2Click( Sender: TObject );
procedure Information1Click( Sender: TObject );
procedure CaptureIcon1Click( Sender: TObject );
procedure FormClose( Sender: TObject; var Action: TCloseAction );
procedure wmHandleMessages( var Msg: TMsg; var Handled: Boolean );
procedure SpeedButton4Click( Sender: TObject );
procedure Contents1Click( Sender: TObject );
procedure Lisence1Click( Sender: TObject );
procedure FormShow( Sender: TObject );
procedure SetJPEGOptions( Sender: TObject );
procedure Resize1Click( Sender: TObject );
procedure Undo( Sender: TObject );
procedure ClipboardButtonClick( Sender: TObject );
procedure Stretch1Click( Sender: TObject );
procedure NewImageDblClick(Sender: TObject);
procedure NewImageMouseDown( Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer );
procedure NewImageMouseMove( Sender: TObject; Shift: TShiftState; X, Y: Integer );
procedure NewImageMouseUp( Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer );
procedure SaveAll1Click( Sender: TObject );
procedure PasteToolbarButton97Click( Sender: TObject );
procedure Crop1Click( Sender: TObject );
procedure PageControl1Changing( Sender: TObject;
var AllowChange: Boolean );
procedure PrintPreviewClick(Sender: TObject);
procedure FullScreen1Click(Sender: TObject);
procedure ProgressUpdate(Sender: TObject; Stage: TProgressStage;
PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);
procedure StatusBar1Click(Sender: TObject);
procedure ProgressBar2Click(Sender: TObject);
procedure PageControl1Change(Sender: TObject);
procedure SaveLayoutItemClick(Sender: TObject);
procedure RestoreLayoutItemClick(Sender: TObject);
procedure SetupClick(Sender: TObject);
procedure SpeedBar1DblClick(Sender: TObject);
procedure SpeedBar2DblClick(Sender: TObject);
procedure SpeedBar3DblClick(Sender: TObject);
procedure FormPlacement1RestorePlacement(Sender: TObject);
procedure FormPlacement1SavePlacement(Sender: TObject);
procedure Contents(Sender: TObject);
private
{ Private declarations }
FSetDefault: Boolean;
FTmpBmp: TBitmap;
procedure AddControls( Sender: TObject );
procedure ResizeTheForm;
function EllipsifyText( AsPath: boolean; const Text: string;
const Canvas: TCanvas; MaxWidth: integer ): string;
function ReadConfigInfo: boolean;
procedure WriteConfigInfo;
procedure ShowHint( Sender: TObject );
procedure CaptureArea;
procedure CaptureIcon;
public
{ Public declarations }
{ See Globalut.pas }
procedure DrawRubberband;
procedure UpdateControls( Sender: TObject );
end;
const
ScreenWidth: LongInt = 800; {I designed my form in 800x600 mode.}
ScreenHeight: LongInt = 600;
var
MainForm: TMainForm;
implementation
{$R *.DFM}
uses
TypInfo, ShowCFG, Capture2, Capture3, Capture4, Splash, Lic, CompressQual,
Resize, imagesize, CVUnit, Preview, Abort, fullscrn, Note;
{==============================================================================}
procedure TMainForm.SetJPEGOptions( Sender: TObject );
{==============================================================================}
var
JPI: TJPEGImage;
begin
if PageControl1.PageCount <> 0 then
begin
Screen.Cursor := crHourglass;
with TImage(PageControl1.ActivePage.Tag) do
begin
// Create jpeg
JPI := TJPEGImage.Create;
// Assign bmp to jpeg
JPI.Assign( Picture.Graphic );
with JPI do
begin
// Get compression quality & save
JPI.CompressionQuality := QualityForm.CompressionQuality1.Value;
try
Compress;
except
begin
MessageDlg( 'Error compressing file,' + FilePathName, mtWarning, [mbOK], 0 );
Screen.Cursor := crDefault;
ErrorSavingJPGFile := True;
exit;
end;
end; {except}
// Assign Image component converted jpeg
Picture.Assign( JPI );
end;
end;
// Free jpg
JPI.Free;
Screen.Cursor := crDefault;
end;
end;
{==============================================================================}
function TMainForm.EllipsifyText( AsPath: boolean; const Text: string;
const
Canvas: TCanvas; MaxWidth: integer ): string;
{==============================================================================}
procedure CutFirstDirectory( var S: string );
var
Root: Boolean;
P: Integer;
begin
if S = '' then exit;
if S = '\' then
S := ''
else
begin
if S[1] = '\' then
begin
Root := True;
Delete( S, 1, 1 );
end else
Root := False;
if S[1] = '.' then
Delete( S, 1, 4 );
P := Pos( '\', S );
if P <> 0 then
begin
Delete( S, 1, P );
S := '...\' + S;
end else
S := '';
if Root then
S := '\' + S;
end;
end;
function MinimizeName( const Filename: string; const Canvas: TCanvas;
MaxLen: Integer ): string;
var
Drive: string;
Dir: string;
Name: string;
begin
Result := FileName;
Dir := ExtractFilePath( Result );
Name := ExtractFileName( Result );
if ( Length( Dir ) >= 2 ) and ( Dir[2] = ':' ) then
begin
Drive := Copy( Dir, 1, 2 );
Delete( Dir, 1, 2 );
end else
Drive := '';
while ( ( Dir <> '' ) or ( Drive <> '' ) ) and ( Canvas.TextWidth( Result ) > MaxLen ) do
begin
if Dir = '\...\' then
begin
Drive := '';
Dir := '...\';
end else if Dir = '' then
Drive := ''
else
CutFirstDirectory( Dir );
Result := Drive + Dir + Name;
end;
end;
{$IFNDEF WIN32}
procedure SetLength( var s: string; NewLen: byte );
begin
S[0] := chr( NewLen );
end;
{$ENDIF}
var
Temp: string;
AvgChar: integer;
TLen : integer;
Index : integer;
Metrics: TTextMetric;
begin
try
if AsPath then
begin
Result := MinimizeName( Text, Canvas, MaxWidth );
end else
begin
Temp := Text;
if ( Temp <> '' ) and ( Canvas.TextWidth( Temp ) > MaxWidth ) then
begin
GetTextMetrics( Canvas.Handle, Metrics );
AvgChar := Metrics.tmAveCharWidth;
if ( AvgChar * 3 ) < MaxWidth then
begin
Index := ( MaxWidth div AvgChar ) - 1;
Temp := Copy( Text, 1, Index );
if Canvas.TextWidth( Temp + '...' ) > MaxWidth then
begin
repeat
dec( Index );
SetLength( Temp, Index );
until ( Canvas.TextWidth( Temp + '...' ) < MaxWidth ) or ( Index < 1 );
{ delete chars }
end else
begin
TLen := Length( Text );
repeat
inc( Index );
Temp := Copy( Text, 1, Index );
until ( Canvas.TextWidth( Temp + '...' ) > MaxWidth ) or ( Index >= TLen );
SetLength( Temp, Index - 1 );
end;
Temp := Temp + '...';
end else
Temp := '.';
end;
Result := Temp;
end;
except
Result := '';
end;
end;
{==============================================================================}
function TMainForm.ReadConfigInfo: Boolean;
{==============================================================================}
var
ApprehendIni: TIniFile;
begin
ApprehendIni := TIniFile.Create( ChangeFileExt( Application.ExeName, '.INI' ) );
FormPlacement1.IniFileName := ChangeFileExt( Application.ExeName, '.INI' );
with ApprehendIni do
begin
InstallPath := ReadString( 'Program Options', 'Program Directory', ExtractFilePath( Application.EXEName ) + 'Images' );
FilePath := ReadString( 'Program Options', 'File Directory', ExtractFilePath( Application.EXEName ) );
DefaultDirectory := FilePath;
OpenPictureDialog1.InitialDir := FilePath;
SavePictureDialog1.InitialDir := FilePath;
DelayTime := ReadInteger( 'Program Options', 'Delay Time', 800 );
DefaultImageType := ReadInteger( 'Program Options', 'Default Image Type', 3 );
end;
ApprehendIni.Free;
end;
{==============================================================================}
procedure TMainForm.WriteConfigInfo;
{==============================================================================}
var
ApprehendIni: TIniFile;
begin
ApprehendIni := TIniFile.Create( ChangeFileExt( Application.ExeName, '.INI' ) );
with ApprehendIni do
begin
WriteString( 'Program Options', 'Program Directory', InstallPath );
WriteString( 'Program Options', 'File Directory', FilePath );
WriteInteger( 'Program Options', 'Delay Time', DelayTime );
WriteInteger( 'Program Options', 'Default Image Type', DefaultImageType );
end;
ApprehendIni.Free;
end;
{==============================================================================}
procedure TMainForm.wmHandleMessages( var Msg: TMsg; var Handled: Boolean );
{==============================================================================}
var
CheckedFlag: Word;
SystemMenu : Hmenu;
begin
if Msg.message = WM_SYSCOMMAND then
begin
if Msg.wParam = smAlwaysOnTop then
begin
// Code to keep the form on top or not
if AlwaysOnTop then
begin
AlwaysOnTop := False;
CheckedFlag := mf_unchecked; {Clear the Always on top checkmark }
SetWindowPos( Handle, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE );
end else
begin
AlwaysOnTop := True;
CheckedFlag := mf_checked; {Set the checkmark}
SetWindowPos( Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE );
end;
SystemMenu := GetSystemMenu( Application.Handle, False );
CheckMenuItem( SystemMenu, smAlwaysOnTop, mf_ByCommand + CheckedFlag );
SystemMenu := GetSystemMenu( Handle, False );
CheckMenuItem( SystemMenu, smAlwaysOnTop, mf_ByCommand + CheckedFlag );
end else
//if Msg.wParam = smCaptureDesktop then
//Desktop1Click( Self );
if Msg.wParam = smCaptureRectangle then
Area1Click( Self );
if Msg.wParam = smCaptureWindow then
CaptureWindowClick( Self );
if Msg.wParam = smCaptureIcon then
CaptureIcon1Click( Self );
end;
end;
{==============================================================================}
procedure TMainForm.ProgressUpdate(Sender: TObject; Stage: TProgressStage;
PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);
{==============================================================================}
var
Progress: string;
begin
if Stage = psRunning then
begin
Caption := Format('%d%%', [PercentDone]);
Progress := Format('%d%', [PercentDone]);
ProgressBar1.Visible := True;
ProgressBar1.Position := StrtoInt(Progress);
end
else
begin
Caption := 'Apprehend98';
ProgressBar1.Visible := False;
ProgressBar1.Position := 0;
end;
end;
{==============================================================================}
procedure TMainForm.ResizeTheForm;
{==============================================================================}
var
i, OldFormWidth, NewFormWidth: integer;
begin
// resize the form for screen resolution
scaled := true;
if ( Screen.width <> ScreenWidth ) then
begin
OldFormWidth := Width;
Height := longint( Height ) * longint( Screen.Height ) div ScreenHeight;
Width := longint( Width ) * longint( Screen.Width ) div ScreenWidth;
ScaleBy( Screen.Width, ScreenWidth );
Font.Size := ( Width div OldFormWidth ) * Font.Size;
NewFormWidth := Width;
// Check font sizes for screen resoltion
for i := ComponentCount - 1 downto 0 do
with Components[i] do
begin
if GetPropInfo( ClassInfo, 'font' ) <> nil then
Font.Size := ( NewFormWidth div OldFormWidth ) * Font.Size;
end;
end;
end;
{==============================================================================}
procedure TMainForm.FormCreate( Sender: TObject );
{==============================================================================}
var
SystemMenu: HMenu;
begin
Application.OnMessage := wmHandleMessages;
// Build a New System Menu for app when it's minimized
SystemMenu := GetSystemMenu( Application.Handle, False );
// And now add in another separator bar
InsertMenu( SystemMenu, 5, MF_ByPosition + MF_SEPARATOR , 901, '' );
// Add in New Menu Items after the separator bar
InsertMenu( SystemMenu, 6, MF_ByPosition + MF_String, smAlwaysOnTop, '&Always On Top' );
// And now add in another separator bar
InsertMenu( SystemMenu, 7, MF_ByPosition + MF_SEPARATOR , 901, '' );
InsertMenu( SystemMenu, 8, MF_ByPosition + MF_String, smCaptureDesktop, 'Capture Desktop' + #9 + 'F3' );
InsertMenu( SystemMenu, 9, MF_ByPosition + MF_String, smCaptureRectangle, 'Capture Rectangle' + #9 + 'F4' );
InsertMenu( SystemMenu, 10, MF_ByPosition + MF_String, smCaptureWindow, 'Capture Object' + #9 + 'F5' );
InsertMenu( SystemMenu, 11, MF_ByPosition + MF_String, smCaptureIcon, 'Capture Icon' + #9 + 'F6' );
// And then build another for when it's NOT minimized
SystemMenu := GetSystemMenu( Handle, False );
// Add in New Menu Items after the existing separator bar
InsertMenu( SystemMenu, 6, MF_ByPosition + MF_String, smAlwaysOnTop, '&Always On Top' );
// And now add in another separator bar
InsertMenu( SystemMenu, 7, MF_ByPosition + MF_SEPARATOR , 901, '' );
InsertMenu( SystemMenu, 8, MF_ByPosition + MF_String, smCaptureDesktop, 'Capture Desktop' + #9 + 'F3' );
InsertMenu( SystemMenu, 9, MF_ByPosition + MF_String, smCaptureRectangle, 'Capture Rectangle' + #9 + 'F4' );
InsertMenu( SystemMenu, 10, MF_ByPosition + MF_String, smCaptureWindow, 'Capture Object' + #9 + 'F5' );
InsertMenu( SystemMenu, 11, MF_ByPosition + MF_String, smCaptureIcon, 'Capture Icon' + #9 + 'F6' );
// And now add in another separator bar
InsertMenu( SystemMenu, 12, MF_ByPosition + MF_SEPARATOR , 901, '' );
Application.OnMessage := wmHandleMessages;
Application.OnHint := ShowHint;
// Set initial defaults
Screen.OnActiveFormChange := UpdateControls;
TmpFolder := '';
FSetDefault := True;
ErrorSavingJPGFile := False;
RubberbandVisible := False;
OpenPictureDialog1.Filename := '';
OpenPictureDialog1.FilterIndex := 1;
// Create a temporary bitmaps for image manipulation
FTmpBmp := TBitmap.Create;
TmpBmp := TBitmap.Create;
Application.ProcessMessages;
// Experimental code to fit the form to the screen resolution
ResizeTheForm;
end;
{==============================================================================}
procedure TMainForm.ShowHint( Sender: TObject );
{==============================================================================}
begin
if Application.Hint <> '' then
StatusBar.Panels[0].Text := Application.Hint;
end;
{==============================================================================}
procedure TMainForm.FileNewItemClick( Sender: TObject );
{==============================================================================}
begin
AddControls(Sender);
// Set the caption of the tabsheet
TabSheet.Caption := Format('Untitled%d', [PageControl1.ActivePage.PageIndex]);
end;
{==============================================================================}
procedure TMainForm.AddControls(Sender: TObject);
{==============================================================================}
begin
with PageControl1 do
// Create a new Tabsheet
TabSheet := TTabSheet.Create(Self);
// Set the Tabsheet.PageControl to PageControl1
TabSheet.PageControl := PageControl1;
// Set the activepage to tabsheet
PageControl1.ActivePage := TabSheet;
with Tabsheet do
begin
// Create a Scrollbox component
ScrollBox := TScrollBox.Create(Self);
ScrollBox.Align := alClient;
ScrollBox.Visible := True;
ScrollBox.Parent := TabSheet;
// Create an image component
Image := TImage.Create(Self);
Image.Align := alClient;
Image.Visible := True;
Image.ShowHint := False;
Image.ParentShowHint := True;
Image.Parent := ScrollBox;
Image.OnProgress := ProgressUpdate;
Image.OnDblClick := NewImageDblClick;
Image.OnMouseDown := NewImageMouseDown;
Image.OnMouseUp := NewImageMouseUp;
Image.OnMouseMove := NewImageMouseMove;
// the folowing two lines are the key to referencing the components later
TabSheet.Tag := Integer(Image);
// Set the caption of the tabsheet
Caption := Format('Image%d', [PageControl1.ActivePage.PageIndex]);
bLeftDown := false;
Pointstart.X := 0;
Pointstart.Y := 0;
Pointend.X := 0;
Pointend.Y := 0;
UpdateControls( Sender );
RubberbandVisible := False;
end;
end;
{==============================================================================}
procedure TMainForm.FileOpenItemClick( Sender: TObject );
{==============================================================================}
var
Temp: boolean;
begin
// Set the initial directory of the OpenPictureDialog
OpenPictureDialog1.InitialDir := FilePath;
if OpenPictureDialog1.Execute then
begin
Screen.Cursor := crHourglass;
// Add ScrollBox and Image Controls to a new tabsheet
AddControls( Sender );
if PageControl1.PageCount <> 0 then
begin
TImage(PageControl1.ActivePage.Tag).Picture.LoadFromFile(OpenPictureDialog1.Filename);
TabSheet.Caption := ExtractFileName(OpenPictureDialog1.Filename);
ScrollBox := TScrollbox(PageControl1.ActivePage.Controls[0]);
with ScrollBox do
begin
HorzScrollBar.Range := TImage(PageControl1.ActivePage.Tag).Picture.Width;
VertScrollBar.Range := TImage(PageControl1.ActivePage.Tag).Picture.Height;
end;
// Is image jpeg image - jpeg has no canvas to draw on
Temp := TImage(PageControl1.ActivePage.Tag).Picture.Graphic is TJPEGImage;
if Temp then begin
Crop1.Enabled := false;
Crop2.Enabled := false;
CropButton.Enabled := false;
Resize1.Enabled := false;
ResizeButton.Enabled := false;
end
else
begin
Crop1.Enabled := true;
Crop2.Enabled := true;
CropButton.Enabled := true;
Resize1.Enabled := true;
ResizeButton.Enabled := true;
end;
end;
TImage(PageControl1.ActivePage.Tag).Refresh;
TImage(PageControl1.ActivePage.Tag).Hint := 'Height: ' + IntToStr( TImage(PageControl1.ActivePage.Tag).Picture.Height ) +
' pixels' + ' Width: ' + IntToStr(TImage(PageControl1.ActivePage.Tag).Picture.Width ) +
' pixels';
Noticeform.Showmodal;
end;
Screen.Cursor := crDefault;
end;
{==============================================================================}
procedure TMainForm.FileCloseItemClick( Sender: TObject );
{==============================================================================}
begin
if PageControl1.PageCount <> 0 then begin
TImage(PageControl1.ActivePage.Tag).Destroy;
TScrollbox(PageControl1.ActivePage.Controls[0]).Destroy;
// Close the active page
PageControl1.ActivePage.Free; // Closes and Frees the ActivePage
PageControl1.SelectNextPage( False );
UpdateControls( Sender );
end;
end;
{==============================================================================}
procedure TMainForm.FileSaveItemClick( Sender: TObject );
{==============================================================================}
begin
if PageControl1.PageCount <> 0 then
begin
// Save current file
if PageControl1.PageCount <> 0 then
begin
Screen.Cursor := crHourglass;
if length( FileExtension ) = 0 then
FileExtension := '.jpg';
if length( FileName ) = 0 then
FileName := 'Untitled' + CaptureStr;
if length( Folder ) = 0 then
Folder := strAddSlash( DefaultDirectory );
FNE := FileName + FileExtension;
FilePathName := Folder + FileName + FileExtension;
// Set JPEG compression quality
if FileExtension = '.jpg' then
begin
with TImage(PageControl1.ActivePage.Tag) do
if Picture.Graphic <> nil then
// Assign jpeg image to quality form picture
QualityForm.Picture.Assign( TJPEGImage(TImage(PageControl1.ActivePage.Tag).Picture.Graphic ) );
// Show quality form
QualityForm.ShowModal;
// Assign jpeg image to tab control picture
TJPEGImage(TImage(PageControl1.ActivePage.Tag).Picture ).Assign( QualityForm.Picture );
SetJPEGOptions( Self );
end;
// If error saving file then exit
if ErrorSavingJPGFile then exit;
// If file exists then delete it
if FileExists( FilePathName ) then
// Prompt user to delete file
if MessageDlg( FilePathName + ' exists, Delete?', mtInformation, [mbYes, mbNo], 0 ) = mrYes then
DeleteFile( FilePathName );
try
TImage(PageControl1.ActivePage.Tag).Picture.SaveToFile( FilePathName );
except
on EInvalidGraphic do
MessageDlg( 'Error saving file,' + FilePathName, mtWarning, [mbOK], 0 );
end;
// Reload the file to show compression
try
TImage(PageControl1.ActivePage.Tag).Picture.LoadFromFile( FilePathName );
except
on EInvalidGraphic do
TImage(PageControl1.ActivePage.Tag).Picture.Graphic := nil;
end;
PageControl1.ActivePage.Caption := ExtractFilename( FilePathName );
Screen.Cursor := crDefault;
end;
end;
end;
{==============================================================================}
procedure TMainForm.FileSaveAsItemClick( Sender: TObject );
{==============================================================================}
begin
if PageControl1.PageCount <> 0 then
begin
// Save current file under new name
if length( TmpFolder ) = 0 then
SavePictureDialog1.InitialDir := DefaultDirectory
else
SavePictureDialog1.InitialDir := TmpFolder;
if length( Folder ) = 0 then
Folder := ExtractFilePath( FilePathName );
if length( Folder ) = 0 then
Folder := DefaultDirectory;
SavePictureDialog1.Filename := '';
SavePictureDialog1.Filename := ExtractName( SavePictureDialog1.Filename );
if length( SavePictureDialog1.Filename ) = 0 then
SavePictureDialog1.Filename := '*';
SavePictureDialog1.Filename := SavePictureDialog1.Filename + '.' +
SavePictureDialog1.DefaultExt;
FNE := FileName + FileExtension;
FilePathName := Folder + FileName + FileExtension;
SavePictureDialog1.InitialDir := Folder;
if SavePictureDialog1.Execute then
begin
FileExtension := ExtractFileExt( SavePictureDialog1.Filename );
if length( FileExtension ) = 0 then
FileExtension := '.jpg';
// Set JPEG compression quality
if FileExtension = '.jpg' then
begin
// Assign jpeg image to quality form picture
if TImage(PageControl1.ActivePage.Tag).Picture.Graphic <> nil then
QualityForm.Picture.Assign( TJPEGImage( TImage(PageControl1.ActivePage.Tag).Picture.Graphic ) );
// Show jpg image quality form
QualityForm.ShowModal;
// Assign jpeg image to tab control picture
TJPEGImage(TImage(PageControl1.ActivePage.Tag).Picture ).Assign( QualityForm.Picture );
// Convert bitmap to jeg & compress
SetJPegOptions( Self );
// If error saving file then exit
if ErrorSavingJPGFile then exit;
end;
// Save image to file
try
TImage(PageControl1.ActivePage.Tag).Picture.SaveToFile( SavePictureDialog1.Filename );
except
on EInvalidGraphic do
MessageDlg( 'Error saving file,' + Filename, mtWarning, [mbOK], 0 );
end;
FilePathName := SavePictureDialog1.Filename;
Folder := ExtractFilePath( SavePictureDialog1.Filename );
Filename := ExtractName( FilePathName );
FileExtension := ExtractFileExt( SavePictureDialog1.Filename );
FNE := FileName + FileExtension;
// If JPEG image then reload the file to show compression
if FileExtension = '.jpg' then
try
TImage(PageControl1.ActivePage.Tag).Picture.LoadFromFile( FilePathName );
except
on EInvalidGraphic do
TImage(PageControl1.ActivePage.Tag).Picture.Graphic := nil;
end;
PageControl1.ActivePage.Caption := ExtractFilename( SavePictureDialog1.Filename );
end;
end;
end;
{==============================================================================}
procedure TMainForm.FileExitItemClick( Sender: TObject );
{==============================================================================}
begin
Close;
end;
{==============================================================================}
procedure TMainForm.CopyItemClick( Sender: TObject );
{==============================================================================}
var
Temp: boolean;
begin
if PageControl1.PageCount <> 0 then begin
Temp := TImage(PageControl1.ActivePage.Tag).Picture.Graphic is TIcon;
if Temp then
begin
Screen.Cursor := crHourglass;
CopyIconToClipboard( TImage(PageControl1.ActivePage.Tag).Picture.Icon, clwhite );
Screen.Cursor := crDefault;
end
else
begin
Screen.Cursor := crHourglass;
Clipboard.Assign(TImage(PageControl1.ActivePage.Tag).Picture );
Screen.Cursor := crDefault;
end;
end;
end;
{==============================================================================}
procedure TMainForm.FormDestroy( Sender: TObject );
{==============================================================================}
begin
Screen.OnActiveFormChange := nil;
WriteConfigInfo;
FTmpBmp.Free;
TmpBmp.Free;
end;
{==============================================================================}
procedure TMainForm.CaptureArea;
{==============================================================================}
begin
with TForm2.Create( Application ) do
try
if ShowModal = mrOK then
with fRect do
begin
// Exit if improper rectangle drawn
if ( Right > Left ) and ( Bottom > Top ) then
begin
// Give system time to refresh
Sleep( DelayTime );
// Capture desktop
ABitmap := TBitmap.Create;
ABitmap.Assign( CaptureScreenRect( fRect ) );
// Copy the image to the Image component
TImage(PageControl1.ActivePage.Tag).Picture.Bitmap := ABitmap;
// Free the bitmap
ABitmap.Free;
end
else
begin
MessageDlg( 'Error selecting rectangle, try again!', mtInformation, [mbOk], 0 );
Area1Click( Self );
Exit;
end; {If}
end; {fRect}
finally {ShowModal}
Free;
end;
end;
{==============================================================================}
procedure TMainForm.CaptureIcon;
{==============================================================================}
begin
with TForm4.Create( Application ) do
try
if ShowModal = mrOK then
with fRect do
begin
// Exit if improper rectangle drawn
if ( Right > Left ) and ( Bottom > Top ) then
begin
// Give system time to refresh
Sleep( DelayTime );
// Capture icon
ABitmap := TBitmap.Create;
ABitmap.Assign( CaptureScreenRect( fRect ) );
// Copy the image to the Image component
TImage(PageControl1.ActivePage.Tag).Picture.Bitmap := ABitmap;
// Free the bitmap
ABitmap.Free;
end
else
begin
MessageDlg( 'Error selecting rectangle, try again!', mtInformation, [mbOk], 0 );
Form4.Free;
Exit;
end; {If}
end; {fRect}
finally {ShowModal}
Free;
end;
end;
{==============================================================================}
procedure TMainForm.NewImageDblClick(Sender: TObject);
{==============================================================================}
begin
FullScreen1Click( Sender );
end;
{==============================================================================}
procedure TMainForm.NewImageMouseDown( Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer );
{==============================================================================}
var
Temp: boolean;
begin
if PageControl1.PageCount <> 0 then
begin
bLeftDown := false;
// Is image jpeg image - jpeg has no canvas to draw on
Temp := TImage(PageControl1.ActivePage.Tag).Picture.Graphic is TJPEGImage;
if not Temp then
// if Rubberband is visible then erase the rubberband
if RubberbandVisible then
begin
DrawRubberband;
RubberbandVisible := False;
end;
if button = mbLeft then
begin
bLeftDown := true;
Pointstart.X := X;
Pointstart.Y := Y;
Pointend.X := X;
Pointend.Y := Y;
end;
if Assigned( TImage(PageControl1.ActivePage.Tag) ) then
begin
Filename := ExpandFilename ( PageControl1.ActivePage.Caption );
Hint := 'Height: ' + IntToStr( TImage(PageControl1.ActivePage.Tag).Picture.Height ) +
' pixels' + ' Width: ' + IntToStr( TImage(PageControl1.ActivePage.Tag).Picture.Width ) +
' pixels';
end;
end;
end;
{==============================================================================}
procedure TMainForm.NewImageMouseMove( Sender: TObject; Shift: TShiftState; X,
Y: Integer );
{==============================================================================}
var
Temp : boolean;
begin
if PageControl1.PageCount <> 0 then
begin
if not bLeftDown then exit;
// Is image jpeg image
Temp := TImage(PageControl1.ActivePage.Tag).Picture.Graphic is TJPEGImage;
if not Temp then
DrawRubberband;
PointEnd.x := X;
PointEnd.y := Y;
// Is image jpeg image
Temp := TImage(PageControl1.ActivePage.Tag).Picture.Graphic is TJPEGImage;
if not Temp then
begin
DrawRubberband;
// Make sure the rubberband is visible for cropping
RubberbandVisible := True;
StatusBar.Panels[1].Text := 'X: ' + IntToStr(X - Pointstart.X) +
' Y: ' + IntToStr(Y - Pointstart.Y);
end;
end;
end;
{==============================================================================}
procedure TMainForm.NewImageMouseUp( Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer );
{==============================================================================}
begin
if PageControl1.PageCount <> 0 then
begin
if not bLeftDown then exit;
bLeftDown := false;
Pointend.X := X;
Pointend.Y := Y;
// Store points in public variables to provide cropping method
// rectangular coordinates
CL := Pointstart.X;
CT := Pointstart.Y;
CB := Pointend.Y;
CR2 := Pointend.X;
NW := Pointend.X - Pointstart.X;
NH := Pointend.Y - Pointstart.Y;
StatusBar.Panels[1].Text := '';
// Is image jpeg image
//Temp := TImage( P ).Picture.Graphic is TJPEGImage;
//if Temp then
//MessageDlg( 'Cropping only suported with bitmaps. Save the jpeg image as a bitmap and try again.', mtWarning, [mbOK], 0 );
end;
end;
{==============================================================================}
procedure TMainForm.Desktop1Click( Sender: TObject );
{==============================================================================}
begin
// Get Apprehend out of the way
Application.Minimize;
// Give screen time to refresh by delay
Sleep( DelayTime );
// Create new image
AddControls(Sender);
if PageControl1.PageCount <> 0 then
begin
// Set file information
TImage(PageControl1.ActivePage.Tag).Picture.Bitmap.Assign( CaptureScreen );
ScrollBox := TScrollbox(PageControl1.ActivePage.Controls[0]);
with ScrollBox do
begin
HorzScrollBar.Range := TImage(PageControl1.ActivePage.Tag).Picture.Width;
VertScrollBar.Range := TImage(PageControl1.ActivePage.Tag).Picture.Height;
end;
InfoDlg.edHeight.Text := IntToStr( TImage(PageControl1.ActivePage.Tag).Height );
InfoDlg.edWidth.Text := IntToStr( TImage(PageControl1.ActivePage.Tag).Width );
TImage(PageControl1.ActivePage.Tag).Hint := 'Height: ' +
IntToStr( TImage(PageControl1.ActivePage.Tag).Picture.Height ) + ' pixels' +
' Width: ' + IntToStr( TImage(PageControl1.ActivePage.Tag).Picture.Width ) + ' pixels';
// Restore Apprehend32 to original state
Application.Restore;
end;
end;
{==============================================================================}
procedure TMainForm.Area1Click( Sender: TObject );
{==============================================================================}
begin
// Get Apprehend out of the way
Application.Minimize;
// Give screen time to refresh by delay
Sleep( DelayTime );
// Create new image
AddControls(Sender);
if PageControl1.PageCount <> 0 then
begin
// Set file information
Filename := 'Untitled';
// Capture area of screen
CaptureArea;
InfoDlg.edHeight.Text := IntToStr( TImage(PageControl1.ActivePage.Tag).Height );
InfoDlg.edWidth.Text := IntToStr( TImage(PageControl1.ActivePage.Tag).Width );
InfoDlg.edHeight.Text := IntToStr( TImage(PageControl1.ActivePage.Tag).Height );
InfoDlg.edWidth.Text := IntToStr( TImage(PageControl1.ActivePage.Tag).Width );
Image.Hint := 'Height: ' +
IntToStr( TImage(PageControl1.ActivePage.Tag).Picture.Height ) + ' pixels' +
' Width: ' + IntToStr( TImage(PageControl1.ActivePage.Tag).Picture.Width ) + ' pixels';
ScrollBox := TScrollbox(PageControl1.ActivePage.Controls[0]);
with ScrollBox do
begin
HorzScrollBar.Range := TImage(PageControl1.ActivePage.Tag).Picture.Width;
VertScrollBar.Range := TImage(PageControl1.ActivePage.Tag).Picture.Height;
end;
end;
// Restore Apprehend to original state
Application.Restore;
end;
{==============================================================================}
procedure TMainForm.Print1Click( Sender: TObject );
{==============================================================================}
var
Rect: TRect;
begin
if PageControl1.PageCount <> 0 then
begin
Screen.Cursor := crHourglass;
with TImage(PageControl1.ActivePage.Tag) do
begin
// Compute the rectangle for the printer
Rect.Top := 10;
Rect.Left := 10;
Rect.Right := 10 + ( Picture.Graphic.Width );
Rect.Bottom := 10 + ( Picture.Graphic.Height );
AbortDlg.Show;
// Print the bitmap
Printer.BeginDoc;
Printer.Canvas.StretchDraw ( Rect, Picture.Graphic );
Printer.EndDoc;
AbortDlg.Hide;
end;
end;
end;
{==============================================================================}
procedure TMainForm.PrintSetup1Click( Sender: TObject );
{==============================================================================}
begin
Screen.Cursor := crHourglass;
PrinterSetupDialog1.Execute;
Screen.Cursor := crDefault;
end;
{==============================================================================}
procedure TMainForm.HelpAboutItemClick( Sender: TObject );
{==============================================================================}
begin
AboutBox1 := TAboutBox1.Create( Application );
AboutBox1.ShowModal;
end;
{==============================================================================}
procedure TMainForm.SpeedButton11Click( Sender: TObject );
{==============================================================================}
begin
PrintSetup1Click( Sender );
end;
{==============================================================================}
procedure TMainForm.CloseAll1Click( Sender: TObject );
{==============================================================================}
var
i: Integer;
begin
//Close All pages
for i := PageControl1.PageCount - 1 downto 0 do
begin
PageControl1.ActivePage := PageControl1.Pages[i];
FileCloseItemClick( Sender );
end;
end;
{==============================================================================}
procedure TMainForm.WindowNextItemClick( Sender: TObject );
{==============================================================================}
begin
if PageControl1.PageCount <> 0 then
begin
PageControl1.SelectNextPage( True );
end;
end;
{==============================================================================}
procedure TMainForm.WindowPreviousItemClick( Sender: TObject );
{==============================================================================}
begin
if PageControl1.PageCount <> 0 then
begin
PageControl1.SelectNextPage( False );
end;
end;
{==============================================================================}
procedure TMainForm.ForceClose1Click( Sender: TObject );
{==============================================================================}
begin
ForceClose1.Checked := not ForceClose1.Checked;
end;
{==============================================================================}
procedure TMainForm.CaptureWindowClick( Sender: TObject );
{==============================================================================}
var
ABitmap : TBitmap;
P1 : TPoint;
Handles : HWnd;
begin
// Get Apprehend out of the way
Application.Minimize;
// Give screen time to refresh by delay
Sleep( DelayTime );
// Create new image
AddControls(Sender);
if PageControl1.PageCount <> 0 then
begin
with TForm3.Create( Application ) do
try
if ShowModal = mrOK then
begin
// Set file information
// Give system time to refresh
Sleep( DelayTime );
// Create a bitmap
ABitmap := TBitmap.Create;
// Get cursor position
GetCursorPos( P1 );
{ If the function succeeds, the return value is the handle of the window }
{ that contains the point. If no window exists at the given point, the }
{ return value is NULL. }
Handles := WindowFromPoint( P1 );
// Add code to capture control as bitmap & copy to bitmap
ABitmap := CaptureWindowImage( Handles );
// Copy the image to the Images component
TImage(PageControl1.ActivePage.Tag).Picture.Bitmap := ABitmap;
Hint := 'Height: ' + IntToStr( TImage(PageControl1.ActivePage.Tag).Picture.Height ) + ' pixels' +
' Width: ' + IntToStr( TImage(PageControl1.ActivePage.Tag).Picture.Width ) + ' pixels';
// Free the bitmap
ABitmap.Free;
end; {If}
finally {ShowModal}
Free;
InfoDlg.edHeight.Text := IntToStr( TImage(PageControl1.ActivePage.Tag).Height );
InfoDlg.edWidth.Text := IntToStr( TImage(PageControl1.ActivePage.Tag).Width );
end;
end;
ScrollBox := TScrollbox(PageControl1.ActivePage.Controls[0]);
with ScrollBox do
begin
HorzScrollBar.Range := TImage(PageControl1.ActivePage.Tag).Picture.Width;
VertScrollBar.Range := TImage(PageControl1.ActivePage.Tag).Picture.Height;
end;
// Restore Apprehend32 to original state
Application.Restore;
end;
{==============================================================================}
procedure TMainForm.ShowConfig1Click( Sender: TObject );
{==============================================================================}
begin
ViewModifyDlg := TViewModifyDlg.Create( Application );
ViewModifyDlg.Execute;
end;
{==============================================================================}
procedure TMainForm.Components1Click( Sender: TObject );
{==============================================================================}
begin
Comp := TComp.Create( Application );
Comp.ShowModal;
end;
{==============================================================================}
procedure TMainForm.Exit2Click( Sender: TObject );
{==============================================================================}
begin
Close;
end;
{==============================================================================}
procedure TMainForm.Information1Click( Sender: TObject );
{==============================================================================}
var
FS : Integer;
Temp: Boolean;
PF: string;
Comp: string;
begin
if PageControl1.PageCount <> 0 then
begin
with InfoDlg do
begin
edName.Text := '';
edBits.Text := '';
edCompression.Text := '';
edHeight.Text := '';
edWidth.Text := '';
edFileSize.Text := '';
end;
Temp := TImage(PageControl1.ActivePage.Tag).Picture.Graphic is TJPEGImage;
if Temp then
with TJPEGImage( TImage(PageControl1.ActivePage.Tag).Picture.Graphic ) do
begin
case TJPEGPixelFormat( PixelFormat ) of
jf24Bit: PF := '24 bit';
jf8Bit: PF := '8 bit';
end;
Comp := IntToStr( TJPEGQualityRange( CompressionQuality ) );
end
else
begin
case TImage(PageControl1.ActivePage.Tag).Picture.Bitmap.PixelFormat of
pfDevice: PF := 'Device';
pf1bit : PF := '1 bit';
pf4bit : PF := '4 bit';
pf8bit : PF := '8 bit';
pf15bit : PF := '15 bit';
pf16bit : PF := '16 bit';
pf24bit : PF := '24 bit';
pf32bit : PF := '32 bit';
pfCustom: PF := 'Custom';
else
PF := 'NA';
end;
Comp := 'NA';
end;
with InfoDlg do
begin
FilePathName := PageControl1.ActivePage.Caption;
edName.Text := FilePathName;
if edName.Text = '' then
edName.Text := 'Image not saved';
edBits.Text := PF;
edCompression.Text := Comp;
edHeight.Text := IntToStr( TImage(PageControl1.ActivePage.Tag).Picture.Height );
edWidth.Text := IntToStr( TImage(PageControl1.ActivePage.Tag).Picture.Width );
FS := FileSize( FilePathName );
if FS > 0 then
edFileSize.Text := FormatFloat( '#," bytes"', FS ) else
edFileSize.Text := 'Image not saved';
end;
end;
if PageControl1.PageCount <> 0 then
InfoDlg.ShowModal;
end;
{==============================================================================}
procedure TMainForm.CaptureIcon1Click( Sender: TObject );
{==============================================================================}
begin
// Get Apprehend out of the way
Application.Minimize;
// Give screen time to refresh by delay
Sleep( DelayTime );
// Create new image
AddControls(Sender);
// Capture icon size ( 32x32 ) area of screen
CaptureIcon;
InfoDlg.edHeight.Text := '32';
InfoDlg.edWidth.Text := '32';
with TImage(PageControl1.ActivePage.Tag) do
Hint := 'Height: ' + IntToStr( Picture.Height ) + ' pixels' +
' Width: ' + IntToStr( Picture.Width ) + ' pixels';
// Restore Apprehend to original state
Application.Restore;
end;
{==============================================================================}
procedure TMainForm.FormClose( Sender: TObject; var Action: TCloseAction );
{==============================================================================}
begin
WriteConfigInfo;
end;
{==============================================================================}
procedure TMainForm.SpeedButton4Click( Sender: TObject );
{==============================================================================}
begin
Application.HelpFile := ExtractFilePath( Application.EXEName ) + 'APPREHEND98.HLP';
Application.HelpCommand( HELP_CONTENTS, 0 );
end;
{==============================================================================}
procedure TMainForm.Contents1Click( Sender: TObject );
{==============================================================================}
begin
Application.HelpFile := ExtractFilePath( Application.EXEName ) + 'APPREHEND98.HLP';
Application.HelpCommand( HELP_CONTENTS, 0 );
end;
{==============================================================================}
procedure TMainForm.Lisence1Click( Sender: TObject );
{==============================================================================}
begin
LicenseForm := TLicenseForm.Create( Application );
LicenseForm.Show;
end;
{==============================================================================}
procedure TMainForm.FormShow( Sender: TObject );
{==============================================================================}
begin
Application.ProcessMessages;
// If no ini file info then display message
if not ReadConfigInfo then
begin
MessageDlg( 'Config Information not Found' + #10#13 +
'Please register this program by' + #10#13 +
'selecting Help-Register from the menu!', mtWarning, [mbOK], 0 );
end;
PageControl1.SetFocus;
//Sleep( DelayTime*2 );
// Create & Show license form
//LicenseForm := TLicenseForm.Create( Application );
//LicenseForm.Show;
end;
{==============================================================================}
procedure TMainForm.Resize1Click( Sender: TObject );
{==============================================================================}
begin
if PageControl1.PageCount <> 0 then
begin
// Save undo
TmpBmp.Assign( TImage(PageControl1.ActivePage.Tag).Picture.Graphic );
ResizeDlg := TResizeDlg.Create( Application );
ResizeDlg.Image1.Picture.Graphic := TImage(PageControl1.ActivePage.Tag).Picture.Graphic;
ResizeDlg.Image2.Picture.Graphic := TImage(PageControl1.ActivePage.Tag).Picture.Graphic;
// Show resize dialog
ResizeDlg.ShowModal;
if ResizeDlg.ModalResult = mrOk then
begin
TmpBmp.Assign( TImage(PageControl1.ActivePage.Tag).Picture.Bitmap );
// If changed then pass new image back to main form
TImage(PageControl1.ActivePage.Tag).Picture.Graphic.Assign( ResizeDlg.Image2.Picture.Bitmap );
ScrollBox.HorzScrollBar.Range := TImage(PageControl1.ActivePage.Tag).Picture.Width;
ScrollBox.VertScrollBar.Range := TImage(PageControl1.ActivePage.Tag).Picture.Height;
TImage(PageControl1.ActivePage.Tag).Hint := 'Height: ' +
IntToStr( TImage(PageControl1.ActivePage.Tag).Picture.Height ) + ' pixels' +
' Width: ' + IntToStr( TImage(PageControl1.ActivePage.Tag).Picture.Width ) + ' pixels';
Invalidate;
Refresh;
end;
end;
end;
{==============================================================================}
procedure TMainForm.Undo( Sender: TObject );
{==============================================================================}
begin
if PageControl1.PageCount <> 0 then
TImage(PageControl1.ActivePage.Tag).Picture.Graphic.Assign( TmpBmp );
end;
{==============================================================================}
procedure TMainForm.ClipboardButtonClick( Sender: TObject );
{==============================================================================}
begin
Screen.Cursor := crHourglass;
CV := TCV.Create( Application );
CV.Show;
Screen.Cursor := crDefault;
end;
{==============================================================================}
procedure TMainForm.DrawRubberband;
{==============================================================================}
var
Temp: boolean;
begin
if PageControl1.PageCount <> 0 then
begin
// Is image jpeg image
Temp := TImage(PageControl1.ActivePage.Tag).Picture.Graphic is TJPEGImage;
if Temp then
exit;
SetROP2( TImage(PageControl1.ActivePage.Tag).Canvas.handle, R2_NOT );
TImage(PageControl1.ActivePage.Tag).Canvas.Moveto( PointStart.x, PointStart.y );
TImage(PageControl1.ActivePage.Tag).Canvas.Lineto( PointStart.x, PointEnd.y );
TImage(PageControl1.ActivePage.Tag).Canvas.Lineto( PointEnd.x, PointEnd.y );
TImage(PageControl1.ActivePage.Tag).Canvas.Lineto( PointEnd.x, PointStart.y );
TImage(PageControl1.ActivePage.Tag).Canvas.Lineto( PointStart.x, PointStart.y );
end;
end;
{==============================================================================}
procedure TMainForm.UpdateControls( Sender: TObject );
{==============================================================================}
begin
//Force memu items and buttons to be disabled if no pagecontrol visible
FileCloseItem.Enabled := PageControl1.PageCount > 0;
FileSaveItem.Enabled := PageControl1.PageCount <> 0;
FileSaveAsItem.Enabled := PageControl1.PageCount <> 0;
CopyItem.Enabled := PageControl1.PageCount <> 0;
FileCloseItem.Enabled := PageControl1.PageCount <> 0;
CloseAll1.Enabled := PageControl1.PageCount <> 0;
ForceClose1.Enabled := PageControl1.PageCount <> 0;
FileSaveItem.Enabled := PageControl1.PageCount <> 0;
FileSaveAsItem.Enabled := PageControl1.PageCount <> 0;
Information1.Enabled := PageControl1.PageCount <> 0;
Crop1.Enabled := PageControl1.PageCount <> 0;
Resize1.Enabled := PageControl1.PageCount <> 0;
Print1.Enabled := PageControl1.PageCount <> 0;
Preview1.Enabled := PageControl1.PageCount <> 0;
SaveButton.Enabled := PageControl1.PageCount <> 0;
SaveasButton.Enabled := PageControl1.PageCount <> 0;
CopyButton.Enabled := PageControl1.PageCount <> 0;
CropButton.Enabled := PageControl1.PageCount <> 0;
PrintPreviewButton.Enabled := PageControl1.PageCount <> 0;
PrintButton.Enabled := PageControl1.PageCount <> 0;
InfoButton.Enabled := PageControl1.PageCount <> 0;
StretchButton.Enabled := PageControl1.PageCount <> 0;
ResizeButton.Enabled := PageControl1.PageCount <> 0;
UndoButton.Enabled := PageControl1.PageCount <> 0;
CloseButton.Enabled := PageControl1.PageCount > 0;
PreviousButton.Enabled := PageControl1.PageCount <> 0;
NextButton.Enabled := PageControl1.PageCount <> 0;
FullButton.Enabled := PageControl1.PageCount <> 0;
end;
{==============================================================================}
procedure TMainForm.Stretch1Click( Sender: TObject );
{==============================================================================}
begin
if PageControl1.PageCount <> 0 then
begin
Stretch1.Checked := not Stretch1.Checked;
TImage(PageControl1.ActivePage.Tag).Stretch := Stretch1.Checked;
end;
end;
{==============================================================================}
procedure TMainForm.SaveAll1Click( Sender: TObject );
{==============================================================================}
var
i: Integer;
begin
//Save All modified images //
for i := PageControl1.PageCount - 1 downto 0 do
begin
PageControl1.ActivePage := PageControl1.Pages[i];
FileSaveItemClick( Sender );
end;
end;
{==============================================================================}
procedure TMainForm.PasteToolbarButton97Click( Sender: TObject );
{==============================================================================}
var
Bitmap: TBitmap;
begin
if PageControl1.PageCount <> 0 then
begin
if Clipboard.HasFormat( CF_BITMAP ) then { is there a bitmap on the Clipboard? }
begin
Bitmap := TBitmap.Create; { create bitmap to hold the contents on the Clipboard }
try
Bitmap.Assign( Clipboard ); { get the bitmap off the Clipboard }
TImage(PageControl1.ActivePage.Tag).Canvas.Draw( 0, 0, Bitmap ); { copy the bitmap to the Image }
finally
Bitmap.Free;
end;
end;
end;
end;
{==============================================================================}
procedure TMainForm.Crop1Click( Sender: TObject );
{==============================================================================}
var
bitmap : TBitmap;
sourcerect : TRect;
destrect : TRect;
StretchFactor_X: Integer;
StretchFactor_Y: Integer;
begin
if PageControl1.PageCount <> 0 then
// Erase the mask
DrawRubberband;
// Save undo
TmpBmp.Assign( TImage(PageControl1.ActivePage.Tag).Picture.Graphic );
// Redraw the mask
DrawRubberband;
begin
// If image present...
if Assigned( TImage(PageControl1.ActivePage.Tag).Picture.Graphic ) then
begin
// Erase the rubberband created with PImage1MouseMove
if RubberbandVisible then
begin
DrawRubberband;
RubberbandVisible := False;
end
else
RubberbandVisible := True;
if TImage(PageControl1.ActivePage.Tag).Stretch then
begin
Bitmap := TBitmap.Create; // change this to scrollbox
StretchFactor_X := Round( TImage(PageControl1.ActivePage.Tag).Picture.Bitmap.Width / TImage(PageControl1.ActivePage.Tag).Picture.Bitmap.Width);
StretchFactor_Y := Round( TImage(PageControl1.ActivePage.Tag).Picture.Bitmap.Height / TImage(PageControl1.ActivePage.Tag).Picture.Bitmap.Height);
Bitmap.Width := ( CR2 * StretchFactor_X ) - ( CL * StretchFactor_X );
Bitmap.Height := ( CB * StretchFactor_Y ) - ( CT * StretchFactor_Y );
SourceRect.Left := CL * StretchFactor_X;
SourceRect.Top := CT * StretchFactor_Y;
SourceRect.Right := CR2 * StretchFactor_X;
SourceRect.Bottom := CB * StretchFactor_Y;
DestRect.Left := 0;
DestRect.Top := 0;
DestRect.Right := ( CR2 * StretchFactor_X ) - ( CL * StretchFactor_X );
DestRect.Bottom := ( CB * StretchFactor_Y ) - ( CT * StretchFactor_Y );
end else
begin
Bitmap := TBitmap.Create;
Bitmap.Width := CR2 - CL;
Bitmap.Height := CB - CT;
SourceRect.Left := CL;
SourceRect.Top := CT;
SourceRect.Right := CR2;
SourceRect.Bottom := CB;
DestRect.Left := 0;
DestRect.Top := 0;
DestRect.Right := CR2 - CL;
DestRect.Bottom := CB - CT;
end;
SetStretchBltmode( Bitmap.Canvas.Handle,
Stretch_deletescans );
Bitmap.Canvas.CopyRect( DestRect,
TImage(PageControl1.ActivePage.Tag).Picture.Bitmap.Canvas,
SourceRect );
Bitmap.Palette := TImage(PageControl1.ActivePage.Tag).Picture.Bitmap.Palette;
StatusBar.Panels[0].Text := 'Height: ' + IntToStr( Bitmap.Height ) +
' pixels Width: ' + IntToStr( Bitmap.Width ) + ' pixels';
TImage(PageControl1.ActivePage.Tag).Picture.Bitmap.Width := Bitmap.Width;
TImage(PageControl1.ActivePage.Tag).Picture.Bitmap.Height := Bitmap.Height;
TImage(PageControl1.ActivePage.Tag).Picture.Bitmap.Assign( Bitmap );
TImage(PageControl1.ActivePage.Tag).Hint := StatusBar.Panels[0].Text;
ScrollBox := TScrollbox(PageControl1.ActivePage.Controls[0]);
with ScrollBox do
begin
HorzScrollBar.Range := TImage(PageControl1.ActivePage.Tag).Picture.Width;
VertScrollBar.Range := TImage(PageControl1.ActivePage.Tag).Picture.Height;
end;
bLeftDown := false;
Pointstart.X := 0;
Pointstart.Y := 0;
Pointend.X := 0;
Pointend.Y := 0;
Hint := StatusBar.Panels[0].Text;
Bitmap.Free;
TImage(PageControl1.ActivePage.Tag).Stretch := False;
Invalidate;
Refresh;
end;
end;
end;
{==============================================================================}
procedure TMainForm.PageControl1Changing( Sender: TObject; var AllowChange: Boolean );
{==============================================================================}
begin
AllowChange := not RubberbandVisible;
end;
{==============================================================================}
procedure TMainForm.PrintPreviewClick( Sender: TObject );
{==============================================================================}
begin
if PageControl1.PageCount <> 0 then
begin
Screen.Cursor := crHourglass;
// Double checks if an image is selected
if TImage(PageControl1.ActivePage.Tag).Picture.Graphic <> nil then
begin
// Set a default scale, and start the preview
PreviewForm.Picture.Assign( TImage(PageControl1.ActivePage.Tag).Picture );
PreviewForm.Scale := 2;
PreviewForm.SetPage;
PreviewForm.DrawPreview;
PreviewForm.ShowModal;
end;
Screen.Cursor := crDefault;
end;
end;
{==============================================================================}
procedure TMainForm.FullScreen1Click( Sender: TObject );
{==============================================================================}
var
Temp: boolean;
TBM: TBitmap;
begin
if PageControl1.PageCount <> 0 then
begin
Screen.Cursor := crDefault;
// Is image jpeg image
Temp := TImage(PageControl1.ActivePage.Tag).Picture.Graphic is TJPEGImage;
if Temp then
begin
// Create a temporary bitmap to hold jpegimage;
TBM := TBitmap.Create;
TBM.Assign(TImage(PageControl1.ActivePage.Tag).Picture.Graphic);
{-------------------------------------------------------------------------}
{Here you assign the new bitmap to the graphic property of the image box. }
{The image box will automatically dispose of the resources used by its }
{prior image. }
{-------------------------------------------------------------------------}
FullScreen.Image1.Picture.Bitmap.Assign( TBM );
// Adjust the Window
FullScreen.ScrollBox1.HorzScrollBar.Range := TBM.Width;
FullScreen.ScrollBox1.VertScrollBar.Range := TBM.Height;
// Free bitmap and jpeg images
TBM.Free;
{show the image fulscreen}
FullScreen.Showmodal;
end
else
begin
{copy image to fullscreen image}
FullScreen.Image1.Picture.Bitmap.Assign(TImage(PageControl1.ActivePage.Tag).Picture.Graphic);
FullScreen.ScrollBox1.HorzScrollBar.Range := TImage(PageControl1.ActivePage.Tag).Picture.Graphic.Width;
FullScreen.ScrollBox1.VertScrollBar.Range := TImage(PageControl1.ActivePage.Tag).Picture.Graphic.Height;
{show the image fulscreen}
FullScreen.Showmodal;
end;
Screen.Cursor := crDefault;
end;
end;
{==============================================================================}
procedure TMainForm.StatusBar1Click( Sender: TObject );
{==============================================================================}
begin
StatusBar1.Checked := not StatusBar1.Checked;
if StatusBar1.Checked then StatusBar.Visible := True else StatusBar.Visible := False;
end;
{==============================================================================}
procedure TMainForm.ProgressBar2Click( Sender: TObject );
{==============================================================================}
begin
ProgressBar2.Checked := not ProgressBar2.Checked;
if ProgressBar2.Checked then ProgressBar1.Visible := True else ProgressBar1.Visible := False;
end;
{==============================================================================}
procedure TMainForm.PageControl1Change(Sender: TObject);
{==============================================================================}
var
Temp: boolean;
begin
// Is image jpeg image - jpeg has no canvas to draw on
Temp := TImage(PageControl1.ActivePage.Tag).Picture.Graphic is TJPEGImage;
if Temp then begin
Crop1.Enabled := false;
Crop2.Enabled := false;
CropButton.Enabled := false;
Resize1.Enabled := false;
ResizeButton.Enabled := false;
end
else
begin
Crop1.Enabled := true;
Crop2.Enabled := true;
CropButton.Enabled := true;
Resize1.Enabled := true;
ResizeButton.Enabled := true;
end;
Noticeform.Showmodal;
end;
{==============================================================================}
procedure TMainForm.SaveLayoutItemClick(Sender: TObject);
{==============================================================================}
var
IniFile: TIniFile;
begin
IniFile := TIniFile.Create(ChangeFileExt( Application.ExeName, '.INI'));
try
Speedbar1.SaveLayout(IniFile);
Speedbar2.SaveLayout(IniFile);
Speedbar3.SaveLayout(IniFile);
finally
IniFile.Free;
end;
end;
{==============================================================================}
procedure TMainForm.RestoreLayoutItemClick(Sender: TObject);
{==============================================================================}
var
IniFile: TIniFile;
begin
IniFile := TIniFile.Create(ChangeFileExt( Application.ExeName, '.INI'));
try
Speedbar1.RestoreLayout(IniFile);
Speedbar2.RestoreLayout(IniFile);
Speedbar3.RestoreLayout(IniFile);
finally
IniFile.Free;
end;
end;
{==============================================================================}
procedure TMainForm.SetupClick(Sender: TObject);
{==============================================================================}
begin
Speedbar1.Customize(0);
Speedbar2.Customize(0);
Speedbar3.Customize(0);
end;
{==============================================================================}
procedure TMainForm.SpeedBar1DblClick(Sender: TObject);
{==============================================================================}
begin
Speedbar1.Customize(0);
end;
{==============================================================================}
procedure TMainForm.SpeedBar2DblClick(Sender: TObject);
{==============================================================================}
begin
Speedbar2.Customize(0);
end;
{==============================================================================}
procedure TMainForm.SpeedBar3DblClick(Sender: TObject);
{==============================================================================}
begin
Speedbar3.Customize(0);
end;
{==============================================================================}
procedure TMainForm.FormPlacement1RestorePlacement(Sender: TObject);
{==============================================================================}
begin
RestoreLayoutItemClick(Sender);
end;
{==============================================================================}
procedure TMainForm.FormPlacement1SavePlacement(Sender: TObject);
{==============================================================================}
begin
SaveLayoutItemClick(Sender);
end;
{==============================================================================}
procedure TMainForm.Contents(Sender: TObject);
{==============================================================================}
begin
Application.HelpFile := ExtractFilePath( Application.EXEName ) + 'APPREHEND98.HLP';
Application.HelpCommand( HELP_CONTENTS, 0 );
end;
end.