unit Main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Menus, StdCtrls, ExtCtrls, Buttons,
libmng;
{****************************************************************************}
{* For conditions of distribution and use, *}
{* see copyright notice in libmng.pas *}
{****************************************************************************}
{* *}
{* project : libmng *}
{* file : main.pas copyright (c) 2000-2002 G.Juyn *}
{* version : 1.0.5 *}
{* *}
{* purpose : Main form for mngview application *}
{* *}
{* author : G.Juyn *}
{* web : http://www.3-t.com *}
{* email : mailto:info@3-t.com *}
{* *}
{* comment : this is the heart of the mngview applciation *}
{* *}
{* changes : 0.5.1 - 05/02/2000 - G.Juyn *}
{* - added this version block *}
{* - made the initialization part more robust *}
{* eg. program aborts on initialization errors *}
{* - B002(105797) - added check for existence of default sRGB *}
{* profile (now included in distribution) *}
{* - added mng_cleanup to program exit *}
{* 0.5.1 - 05/08/2000 - G.Juyn *}
{* - changed to stdcall convention *}
{* 0.5.1 - 05/11/2000 - G.Juyn *}
{* - changed callback function declarations *}
{* *}
{* 0.5.3 - 06/16/2000 - G.Juyn *}
{* - removed processmessages call from refresh callback *}
{* 0.5.3 - 06/17/2000 - G.Juyn *}
{* - switched "storechunks" off *}
{* 0.5.3 - 06/26/2000 - G.Juyn *}
{* - changed definition of userdata to mng_ptr *}
{* 0.5.3 - 06/28/2000 - G.Juyn *}
{* - changed the default icon to something more appropriate *}
{* - changed definition of memory alloc size to mng_size_t *}
{* 0.5.3 - 06/29/2000 - G.Juyn *}
{* - changed order of refresh parameters *}
{* *}
{* 0.9.0 - 06/30/2000 - G.Juyn *}
{* - changed refresh parameters to 'x,y,width,height' *}
{* *}
{* 0.9.1 - 07/08/2000 - G.Juyn *}
{* - fixed to use returncode constants *}
{* - changed to accomodate MNG_NEEDTIMERWAIT returncode *}
{* 0.9.1 - 07/10/2000 - G.Juyn *}
{* - changed to use suspension-mode *}
{* *}
{* 0.9.3 - 09/11/2000 - G.Juyn *}
{* - removed some tesst-stuff *}
{* *}
{* 1.0.1 - 05/02/2000 - G.Juyn *}
{* - removed loading default sRGB profile (auto in libmng) *}
{* *}
{* 1.0.5 - 09/16/2002 - G.Juyn *}
{* - added dynamic MNG features *}
{* 1.0.5 - 11/27/2002 - G.Juyn *}
{* - fixed freeze during read-cycle *}
{* *}
{****************************************************************************}
type
TMainForm = class(TForm)
OFMainMenu: TMainMenu;
OFMenuFile: TMenuItem;
OFMenuFileOpen: TMenuItem;
OFMenuFileProfile: TMenuItem;
OFMenuFileN1: TMenuItem;
OFMenuFileExit: TMenuItem;
OFMenuOptions: TMenuItem;
OFMenuOptionsModemSpeed: TMenuItem;
OFMenuOptionsModem28k8: TMenuItem;
OFMenuOptionsModem33k6: TMenuItem;
OFMenuOptionsModem56k: TMenuItem;
OFMenuOptionsModemISDN64: TMenuItem;
OFMenuOptionsModemISDN128: TMenuItem;
OFMenuOptionsModemCable512: TMenuItem;
OFMenuOptionsModemUnlimited: TMenuItem;
OFTimer: TTimer;
OFOpenDialog: TOpenDialog;
OFOpenDialogProfile: TOpenDialog;
OFImage: TImage;
procedure FormCreate(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure FormShow(Sender: TObject);
procedure FormResize(Sender: TObject);
procedure FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure OFImageMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure OFImageMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure OFImageMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure OFTimerTimer(Sender: TObject);
procedure OFMenuFileOpenClick(Sender: TObject);
procedure OFMenuFileProfileClick(Sender: TObject);
procedure OFMenuFileExitClick(Sender: TObject);
procedure OFMenuOptionsModemSpeedClick(Sender: TObject);
procedure OFMenuOptionsModemXClick(Sender: TObject);
private
{ Private declarations }
SFFileName : string; { filename of the input stream }
OFFile : TFileStream; { input stream }
IFHandle : mng_handle; { the libray handle }
OFBitmap : TBitmap; { drawing canvas }
BFCancelled : boolean; { <esc> or app-exit }
BFHasMouse : boolean; { mouse is/was over image }
IFTicks : cardinal; { used to fake slow connections }
IFBytes : cardinal;
IFBytesPerSec : integer;
procedure MNGerror (SHMsg : string);
public
{ Public declarations }
end;
var
MainForm: TMainForm;
{****************************************************************************}
implementation
{$R *.DFM}
{****************************************************************************}
{$F+}
function Memalloc (iLen : mng_uint32) : mng_ptr; stdcall;
{$F-}
begin
getmem (Result, iLen); { get memory from the heap }
fillchar (Result^, iLen, 0); { and initialize it }
end;
{****************************************************************************}
{$F+}
procedure Memfree (iPtr : mng_ptr;
iLen : mng_size_t); stdcall;
{$F-}
begin
freemem (iPtr, iLen); { free the memory }
end;
{****************************************************************************}
{$F+}
function Openstream (hHandle : mng_handle) : mng_bool; stdcall;
{$F-}
var OHForm : TMainForm;
begin { get a fix on our form }
OHForm := TMainForm (mng_get_userdata (hHandle));
with OHFORM do
begin
if OFFile <> nil then { free previous stream (if any) }
OFFile.Free;
{ open a new stream }
OFFile := TFileStream.Create (SFFileName, fmOpenRead or fmShareDenyWrite);
end;
Result := MNG_TRUE;
end;
{****************************************************************************}
{$F+}
function Closestream (hHandle : mng_handle) : mng_bool; stdcall;
{$F-}
var OHForm : TMainForm;
begin { get a fix on our form }
OHForm := TMainForm (mng_get_userdata (hHandle));
with OHFORM do
begin
OFFile.Free; { cleanup the stream }
OFFile := nil; { don't use it again ! }
end;
Result := MNG_TRUE;
end;
{****************************************************************************}
{$F+}
function Readdata ( hHandle : mng_handle;
pBuf : mng_ptr;
iBuflen : mng_uint32;
var pRead : mng_uint32) : mng_bool; stdcall;
{$F-}
var OHForm : TMainForm;
IHTicks : cardinal;
IHByte1 : cardinal;
IHByte2 : cardinal;
IHBytesPerSec : cardinal;
begin
{ get a fix on our form }
OHForm := TMainForm (mng_get_userdata (hHandle));
with OHForm do
begin { are we at EOF ? }
if OFFile.Position >= OFFile.Size then
begin
pRead := 0; { indicate so }
end
else
begin
IHBytesPerSec := IFBytesPerSec; { fake a slow connection }
if IHBytesPerSec > 0 then
begin
IHTicks := Windows.GetTickCount;
IHByte1 := round (((IHTicks - IFTicks) / 1000) * IHBytesPerSec);
IHByte2 := (IFBytes + iBuflen);
if ((IHByte2 - IHByte1) div IHBytesPerSec) > 10 then
Windows.Sleep ((IHByte2 - IHByte1) div IHBytesPerSec);
end;
{ read the requested data }
pRead := OFFile.Read (pBuf^, iBuflen);
IFBytes := IFBytes + pRead;
end;
end;
Result := MNG_TRUE;
end;
{****************************************************************************}
{$F+}
function ProcessHeader (hHandle : mng_handle;
iWidth : mng_uint32;
iHeight : mng_uint32) : mng_bool; stdcall;
{$F-}
var OHForm : TMainForm;
begin { get a fix on our form }
OHForm := TMainForm (mng_get_userdata (hHandle));
with OHForm do
begin
OFBitmap.Width := iWidth; { store the new dimensions }
OFBitmap.Height := iHeight;
OFImage.Left := 0; { adjust the visible component }
OFImage.Top := 0;
OFImage.Width := iWidth;
OFImage.Height := iHeight;
FormResize (OHForm); { force re-centering the image}
{ clear the canvas & draw an outline }
OFBitmap.Canvas.Brush.Color := clGray;
OFBitmap.Canvas.Brush.Style := bsSolid;
OFBitmap.Canvas.FillRect (OFBitmap.Canvas.ClipRect);
OFBitmap.Canvas.Brush.Color := clRed;
OFBitmap.Canvas.Brush.Style := bsSolid;
OFBitmap.Canvas.Pen.Color := clRed;
OFBitmap.Canvas.Pen.Style := psSolid;
OFBitmap.Canvas.FrameRect (OFBitmap.Canvas.ClipRect);
OFImage.Picture.Assign (OFBitmap); { make sure it gets out there }
{ tell the library we want funny windows-bgr}
if mng_set_canvasstyle (hHandle, MNG_CANVAS_BGRX8) <> 0 then
MNGerror ('libmng reported an error setting the canvas style');
end;
Result := MNG_TRUE;
end;
{****************************************************************************}
{$F+}
function GetCanvasLine (hHandle : mng_handle;
iLinenr : mng_uint32) : mng_ptr; stdcall;
{$F-}
var OHForm : TMainForm;
begin { get a fix on our form }
OHForm := TMainForm (mng_get_userdata (hHandle));
{ easy with these bitmap objects ! }
Result := OHForm.OFBitmap.ScanLine [iLinenr];
end;
{****************************************************************************}
{$F+}
function ImageRefresh (hHandle : mng_handle;
iX : mng_uint32;
iY : mng_uint32;
iWidth : mng_uint32;
iHeight : mng_uint32) : mng_bool; stdcall;
{$F-}
var OHForm : TMainForm;
begin { get a fix on our form }
OHForm := TMainForm (mng_get_userdata (hHandle));
{ force redraw }
OHForm.OFImage.Picture.Assign (OHForm.OFBitmap);
Result := MNG_TRUE;
end;
{****************************************************************************}
{$F+}
function GetTickCount (hHandle : mng_handle) : mng_uint32; stdcall;
{$F-}
begin
Result := Windows.GetTickCount; { windows knows that }
end;
{****************************************************************************}
{$F+}
function SetTimer (hHandle : mng_handle;
iMsecs : mng_uint32) : mng_bool; stdcall;
{$F-}
var OHForm : TMainForm;
begin { get a fix on our form }
OHForm := TMainForm (mng_get_userdata (hHandle));
OHForm.OFTimer.Interval := iMsecs; { and set the timer }
OHForm.OFTimer.Enabled := true;
Result := MNG_TRUE;
end;
{****************************************************************************}
procedure TMainForm.FormCreate(Sender: TObject);
var IHRed, IHGreen, IHBlue : word;
begin { initialize }
OFBitmap := TBitmap.Create;
IFBytesPerSec := 10000000;
BFHasMouse := false;
OFFile := nil;
OFOpenDialog.Initialdir := '';
OFBitmap.HandleType := bmDIB; { make it a 24-bit DIB }
OFBitmap.PixelFormat := pf32bit;
{ now initialize the library }
IFHandle := mng_initialize (mng_ptr(self), Memalloc, Memfree, nil);
if IFHandle = NIL then
begin
MNGerror ('libmng initialization error' + #13#10 +
'Program aborted');
Windows.Postmessage (handle, WM_Close, 0, 0);
Exit;
end;
{ no need to store chunk-info ! }
mng_set_storechunks (IFHandle, MNG_FALSE);
{ do not use suspension-buffer }
mng_set_suspensionmode (IFHandle, MNG_FALSE);
{ set all the callbacks }
if (mng_setcb_openstream (IFHandle, Openstream ) <> MNG_NOERROR) or
(mng_setcb_closestream (IFHandle, Closestream ) <> MNG_NOERROR) or
(mng_setcb_readdata (IFHandle, Readdata ) <> MNG_NOERROR) or
(mng_setcb_processheader (IFHandle, ProcessHeader) <> MNG_NOERROR) or
(mng_setcb_getcanvasline (IFHandle, GetCanvasLine) <> MNG_NOERROR) or
(mng_setcb_refresh (IFHandle, ImageRefresh ) <> MNG_NOERROR) or
(mng_setcb_gettickcount (IFHandle, GetTickCount ) <> MNG_NOERROR) or
(mng_setcb_settimer (IFHandle, SetTimer ) <> MNG_NOERROR) then
begin
MNGerror ('libmng reported an error setting a callback function!' + #13#10 +
'Program aborted');
Windows.Postmessage (handle, WM_Close, 0, 0);
Exit;
end;
IHRed := (Color ) and $FF; { supply our own bg-color }
IHGreen := (Color shr 8) and $FF;
IHBlue := (Color shr 16) and $FF;
IHRed := (IHRed shl 8) + IHRed;
IHGreen := (IHGreen shl 8) + IHGreen;
IHBlue := (IHBlue shl 8) + IHBlue;
if mng_set_bgcolor (IFHandle, IHRed, IHGreen, IHBlue) <> MNG_NOERROR then
MNGerror ('libmng reported an error setting the background color!');
end;
{****************************************************************************}
procedure TMainForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
OFTimer.Enabled := false;
BFCancelled := true;
{ if we're still animating then stop it }
if mng_status_running (IFHandle) and not mng_status_reading (IFHandle) then
if mng_display_freeze (IFHandle) <> MNG_NOERROR then
MNGerror ('libmng reported an error during display_freeze!');
mng_cleanup (IFHandle);
end;
{****************************************************************************}
procedure TMainForm.FormShow(Sender: TObject);
begin
FormResize (self);
end;
{****************************************************************************}
procedure TMainForm.FormResize(Sender: TObject);
begin { center the image in the window }
if ClientWidth < OFImage.Width then
OFImage.Left := 0
else
OFImage.Left := (ClientWidth - OFImage.Width ) div 2;
if ClientHeight < OFImage.Height then
OFImage.Top := 0
else
OFImage.Top := (ClientHeight - OFImage.Height) div 2;
end;
{****************************************************************************}
procedure TMainForm.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if Key = vk_Escape then { pressing <esc> will freeze an animation }
begin
OFTimer.Enabled := false; { don't let that timer go off then ! }
BFCancelled := true;
if mng_status_running (IFHandle) and not mng_status_reading (IFHandle) then
if mng_display_freeze (IFHandle) <> MNG_NOERROR then
MNGerror ('libmng reported an error during display_freeze!');
end;
end;
{****************************************************************************}
procedure TMainForm.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if mng_status_dynamic (IFHandle) then
begin
if BFHasMouse then { if we had the mouse, it's left ! }
begin
if mng_trapevent (IFHandle, 3, 0, 0) <> MNG_NOERROR then
MNGerror ('libmng reported an error during trapevent!');
BFHasMouse := false;
end;
end;
end;
{****************************************************************************}
procedure TMainForm.OFImageMouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
begin
if mng_status_dynamic (IFHandle) then
begin
if BFHasMouse then { did we have the mouse already ? }
begin
if mng_trapevent (IFHandle, 2, X, Y) <> MNG_NOERROR then
MNGerror ('libmng reported an error during trapevent!');
end
else
begin { if not, it has entered ! }
if mng_trapevent (IFHandle, 1, X, Y) <> MNG_NOERROR then
MNGerror ('libmng reported an error during trapevent!');
BFHasMouse := true;
end;
end;
end;
{****************************************************************************}
procedure TMainForm.OFImageMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if mng_status_dynamic (IFHandle) then
if mng_trapevent (IFHandle, 4, X, Y) <> MNG_NOERROR then
MNGerror ('libmng reported an error during trapevent!');
end;
{****************************************************************************}
procedure TMainForm.OFImageMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if mng_status_dynamic (IFHandle) then
if mng_trapevent (IFHandle, 5, X, Y) <> MNG_NOERROR then
MNGerror ('libmng reported an error during trapevent!');
end;
{****************************************************************************}
procedure TMainForm.OFTimerTimer(Sender: TObject);
var IHRslt : mng_retcode;
begin
OFTimer.Enabled := false; { only once ! }
if not BFCancelled then
begin { and inform the library }
IHRslt := mng_display_resume (IFHandle);
if (IHRslt <> MNG_NOERROR) and (IHRslt <> MNG_NEEDTIMERWAIT) then
MNGerror ('libmng reported an error during display_resume!');
end;
end;
{****************************************************************************}
procedure TMainForm.OFMenuFileOpenClick(Sender: TObject);
var IHRslt : mng_retcode;
begin
OFOpenDialog.InitialDir := '';
OFOpenDialog.FileName := SFFileName;
if OFOpenDialog.Execute then { get the filename }
begin
if OFTimer.Enabled then { if the lib was active; stop it }
begin
OFTimer.Enabled := false;
Application.ProcessMessages; { process any timer requests (for safety) }
{ now freeze the animation }
if mng_display_freeze (IFHandle) <> MNG_NOERROR then
MNGerror ('libmng reported an error during display_freeze!');
end;
{ save interesting fields }
SFFileName := OFOpenDialog.FileName;
IFTicks := Windows.GetTickCount;
IFBytes := 0;
BFCancelled := false;
{ always reset (just in case) }
if mng_reset (IFHandle) <> MNG_NOERROR then
MNGerror ('libmng reported an error during reset!')
else
begin { and let the lib do it's job ! }
IHRslt := mng_readdisplay (IFHandle);
if (IHRslt <> MNG_NOERROR) and (IHRSLT <> MNG_NEEDTIMERWAIT) then
MNGerror ('libmng reported an error reading the input file!');
end;
end;
end;
{****************************************************************************}
procedure TMainForm.OFMenuFileProfileClick(Sender: TObject);
var SHProfileDir : array [0 .. MAX_PATH + 20] of char;
begin
GetSystemDirectory (@SHProfileDir, MAX_PATH);
strcat (@SHProfileDir, '\Color');
OFOpenDialogProfile.InitialDir := strpas (@SHProfileDir);
if OFOpenDialogProfile.Execute then
if mng_set_outputprofile (IFHandle, pchar (OFOpenDialogProfile.FileName)) <> 0 then
MNGerror ('libmng reported an error setting the output-profile!');
end;
{****************************************************************************}
procedure TMainForm.OFMenuFileExitClick(Sender: TObject);
begin
if mng_cleanup (IFHandle) <> MNG_NOERROR then
MNGerror ('libmng cleanup error');
Close;
end;
{****************************************************************************}
procedure TMainForm.OFMenuOptionsModemSpeedClick(Sender: TObject);
begin
OFMenuOptionsModem28k8.Checked := false;
OFMenuOptionsModem33k6.Checked := false;
OFMenuOptionsModem56k.Checked := false;
OFMenuOptionsModemISDN64.Checked := false;
OFMenuOptionsModemISDN128.Checked := false;
OFMenuOptionsModemCable512.Checked := false;
OFMenuOptionsModemUnlimited.Checked := false;
if IFBytesPerSec = OFMenuOptionsModem28k8.Tag div 10 then
OFMenuOptionsModem28k8.Checked := true
else
if IFBytesPerSec = OFMenuOptionsModem33k6.Tag div 10 then
OFMenuOptionsModem33k6.Checked := true
else
if IFBytesPerSec = OFMenuOptionsModem56k.Tag div 10 then
OFMenuOptionsModem56k.Checked := true
else
if IFBytesPerSec = OFMenuOptionsModemISDN64.Tag div 10 then
OFMenuOptionsModemISDN64.Checked := true
else
if IFBytesPerSec = OFMenuOptionsModemISDN128.Tag div 10 then
OFMenuOptionsModemISDN128.Checked := true
else
if IFBytesPerSec = OFMenuOptionsModemUnlimited.Tag div 10 then
OFMenuOptionsModemCable512.Checked := true
else
OFMenuOptionsModemUnlimited.Checked := true;
end;
{****************************************************************************}
procedure TMainForm.OFMenuOptionsModemXClick(Sender: TObject);
begin
IFBytesPerSec := TMenuItem (Sender).Tag div 10;
end;
{****************************************************************************}
procedure TMainForm.MNGerror;
var iErrorcode : mng_uint32;
iSeverity : mng_uint8;
iChunkname : mng_chunkid;
iChunkseq : mng_uint32;
iExtra1 : mng_int32;
iExtra2 : mng_int32;
zErrortext : mng_pchar;
begin { get extended info }
iErrorcode := mng_getlasterror (IFHandle, iSeverity, iChunkname, iChunkseq,
iExtra1, iExtra2, zErrortext);
MessageDlg (SHMsg + #13#10#13#10 + strpas (zErrortext) + #13#10#13#10 +
Format ('Error = %d; Severity = %d; Chunknr = %d; Extra1 = %d',
[iErrorcode, iSeverity, iChunkseq, iExtra1]),
mtError, [mbOK], 0);
end;
{****************************************************************************}
end.