Power-Programmierung/CD1.mdf/pascal/library/dos/grafik/gif/tpgif/example2.pas

Pascal/Delphi Source File | 1992-03-09 | 14.5 KB | 412 lines

Program Example;
  {Sample program for Turbo Pascal version 5.0 showing the use of SCR2GIFU.PAS
  unit for screen compression to GIF graphics file which includes the LZW
  routines in CMPRSS.INC.  To use the unit, simply include SCR2GIFU in
  your USES statement, then call 'ScreenToGif(FileName:String):Integer' when you
  are ready to send the screen to a GIF file.  The following is an elaborate
  program allowing the selection of any of the numerous graphics modes
  supported by TP 5.0, automatic selection of a file name 'SCR0000.GIF'
  through 'SCR9999.GIF', display of a test screen, and saving to a GIF file.
  For the graphics mode selection procedure to work properly, all the BGI
  drivers, as either .BGI or .OBJ files, will have to be in the same directory
  as this source code.  To compile this to an .EXE, all the .OBJ files will
  have to be around (use TP's BINOBJ.EXE utility).   For details of the
  SCR2GIFU unit usage, see the header of the SCR2GIFU.PAS file.

  Written by Rob Crockett [76167,1561] April 1992.  The include file
  CMPRSS.INC written by Bob Berry [76555,167] 1988. }

 Uses CRT,
      DOS,
      GRAPH,
      SCR2GIFU,
      DRIVERS;  {DRIVERS.PAS,
          uses EGAVGA.OBJ, CGA.OBJ, HERC.OBJ, ATT.OBJ,PC3270.OBJ, IBM8514.OBJ}

 Var
   Debugger: Boolean;                 {used in detectgraph}
   ForceMode: Integer;                {used in detectgraph}

 Function FileExists(FileName: String):Boolean;
     Var
       BinFile : File;
     Begin
       Assign(BinFile,FileName);
       {$I-} Reset(BinFile); {$I+}
       If IOResult=0
         Then
           Begin
             Close(BinFile);
             FileExists:=True;
           End
         Else FileExists:=False;
     End; {of FileExists}

 Function GetGifFileName: String;
   {Generates numbered GIF file names until a name is found that is
    not in the current directory.  Named 'SCR0000.GIF' to 'SCR9999.GIF'.
    Utilizes the 'FileExists' procedure.}

   Const
     Preface = 'SCR';
     Suffix = '.GIF';
   Var
     GifFileName,
     FileNumberString: String;
     FileNumber      : Integer;
   Begin
     FileNumber:=-1;
     Repeat
       FileNumber:=Succ(FileNumber);
       Str(FileNumber,FileNumberString);
       If (Length(FileNumberString)<4) then
         Repeat
           FileNumberString:='0'+FileNumberString;
         Until (Length(FileNumberString)=4);
       GifFileName:=Preface+FileNumberString+Suffix;
     Until ((Not FileExists(GifFileName)) OR (FileNumber=9999));
     GetGifFileName:=GifFileName;
   End;


Procedure DrawFigures;
  {Draws a test graphics screen}

  Var
    I,J,
    XCenter,YCenter,
    Width,Height      : Integer;
    Radius            : Word;
    XString,YString,
    CString           : String[3];
    InChar            : Char;
  Begin
    XCenter:=GetMaxX DIV 2;
    YCenter:=GetMaxY DIV 2;
    Radius:=GetMaxX DIV 6;
    Height:=TextHeight('T');
    Width:=TextWidth('000');

    PutPixel(XCenter,YCenter,LightMagenta);


    If GetMaxColor<=15
      Then
         For I:=0 to GetMaxColor do
           Begin
             SetColor(I);
             Str(I,CString);
             OutTextXY(10,10+I*Height,CString);
           End
       Else
         For I:=0 to 22 do       {25}
           For J:=0 to 11 do
             Begin
               SetColor(I+J*23);
               Str(I+J*23,CString);
               OutTextXY(10+J*Width,10+I*Height,CString);
            End;

    SetColor(Blue);
    Circle(XCenter,YCenter,Radius);

    SetColor(Blue);
    Rectangle(0,0,GetMaxX,GetMaxY);
    Rectangle(100,100,115,115);

    For I:=1 to 1000 do
      Begin
        PutPixel((GetMaxX div 2)+Random((GetMaxX div 2)-1),
              Random(GetMaxY-1),1+Random(GetMaxColor));
      End;

    For I:=1 to 500 do
      Begin
        SetColor(Random(GetMaxColor));
        Line((GetMaxX div 6)*4,(GetMaxY div 4),
          Random(GetMaxX div 2)+(GetMaxX div 2),
          Random(GetMaxY div 3)+1);
      End;
  End;

Procedure FillSpace(X1,Y1,X2,Y2:Integer;Ch:Char);
  Var
    FillString: String[80];
    I: Integer;
  Begin
    FillString:='';
    For I:=X1 to X2 do FillString:=FillString+Ch;
    For I:=Y1 to Y2 do
      Begin
        GotoXY(X1,I);
        Write(FillString);
      End;
   End;


Procedure GetScreenType(Var ScreenDriver,ScreenMode:Integer);

Const
   Cursor = '=>';
   DriverNames: Array[1..10] of String[8] =
     ('CGA     ','MCGA    ','EGA     ','EGA64   ',
      'EGAMono ','IBM8514 ','Hercules','ATT400  ',
      'VGA     ','PC3270  ');
   ModeNames  : Array[1..10,0..5] of String[12]=
    {CGA}     ((' 320x200   4',' 320x200   4',' 320x200   4',' 320x200   4',' 640x200   2','            '),
    {MCGA}     (' 320x200   4',' 320x200   4',' 320x200   4',' 320x200   4',' 640x200   2',' 640x480   2'),
    {EGA}      (' 640x200  16',' 640x350  16','            ','            ','            ','            '),
    {EGA64}    (' 640x200  16',' 640x350   4','            ','            ','            ','            '),
    {EGAMono}  ('            ','            ','            ',' 640x350   2','            ','            '),
    {IBM8514}  (' 640x480 256','1024x480 256','            ','            ','            ','            '),
    {Hercules} (' 720x348   2','            ','            ','            ','            ','            '),
    {ATT400}   (' 320x200   4',' 320x200   4',' 320x200   4',' 320x200   4',' 640x200   2',' 640x400   2'),
    {VGA}      (' 640x200  16',' 640x350  16',' 640x480  16','            ','            ','            '),
    {PC3270}   (' 720x350   2','            ','            ','            ','            ','            '));
Var             {procedure GetScreenType}

   GrDriver,GrMode,
   Driver,Mode,
   X1,Y1,X2,Y2,X3,Y3,X4,Y4,X5,Y5,
   LoMode,HiMode,Error           :Integer;
   InChar                        :Char;
   Dum                           :String;

  Procedure WriteCursors(Color:Integer);   {within Procedure GetScreenType}
    Begin
      TextColor(Color);                {erase cursor}
      GotoXY(X1-3,Y1+GrDriver);
      Write(Cursor);
      GotoXY(X2-3,Y2+GrMode+1);
      Write(Cursor);
    End;
  Procedure WriteModes;                    {within Procedure GetScreenType}
    Var
      Mode: Integer;
    Begin
      FillSpace(X2,Y2,X2+Length(ModeNames[1,0])+4,Y2+6,' ');
      TextColor(LightGray);
      GetModeRange(GrDriver,LoMode,HiMode);
      For Mode:=LoMode to HiMode do
        Begin
          GotoXY(X2,Mode+Y2+1);
          Write(Mode:2,'. ',ModeNames[GrDriver,Mode]);
        End;
    End;

Begin                                 {Procedure GetScreenType}
  ClrScr;
  TextColor(Yellow);
  GotoXY(30,2);
  Write('Graphics Mode Menu');
  TextColor(LightGray);
  GotoXY(1,5);
  Writeln('    Use up or down cursor keys to browse the graphics modes.  Press <ENTER>');
  Writeln('to make a selection, or press <ESCAPE> to retain the default mode. ');
  Writeln('The graphics mode first displayed is the default mode selected by TURBO.  ');
  DetectGraph(GrDriver,GrMode);       {Turbo's best choice}

  X1:=15; Y1:=9;                      {initial list positions}
  X2:=45; Y2:=9;                      {X1,Y1=Drivers; X2,Y2=Modes}
  X3:=12; Y3:=23;                     {current selection}
  X4:=12; Y4:=25;                     {forcemode}
  X5:=12; Y5:=21;                     {black and white}

  TextColor(LightGray);
  For Driver:=1 to 10 do
    Begin
      GotoXY(X1,Driver+Y1);
      Write(Driver:2,'. ',DriverNames[Driver]);
    End;

  TextColor(Yellow);
  GetModeRange(GrDriver,LoMode,HiMode);
  WriteModes;
  WriteCursors(Yellow);
  TextColor(Yellow);
  GotoXY(X3,Y3);    Write('Graph Driver:');
  GotoXY(X3,Y3+1);  Write('Graph Mode  :');
  TextColor(White);
  GotoXY(X3+15,Y3);  Write(DriverNames[GrDriver]);
  GotoXY(X3+14,Y3+1);Write(ModeNames[GrDriver,GrMode],' colors');

  InChar:='.';
  Repeat
    If KeyPressed Then
      Begin
        InChar:=ReadKey;
        If InChar = Chr(0) then
          Begin
            Case ReadKey of
              'G': Begin End;                              {Home}
              'I': Begin End;                              {Pg Up}
              'H': Begin                                   {Up Arrow}
                     WriteCursors(Black);
                     If GrMode>LoMode                   {decrease mode}
                       Then GrMode:=GrMode-1
                       Else                           {decrease driver}
                         Begin
                           If GrDriver>1
                             Then GrDriver:=GrDriver-1
                             Else GrDriver:=10;
                           GetModeRange(GrDriver,LoMode,HiMode);
                           WriteModes;                {show new modes}
                           GrMode:=HiMode;            {update gr/hi/lomode}
                         End;
                     WriteCursors(Yellow);
                   End;
              'K': Begin                                      {Left Arrow}
                   End;
              'M': Begin                                      {Right Arrow}
                   End;
              'O': Begin                                      {End}
                   End;
              'P': Begin                                      {Down Arrow}
                     WriteCursors(Black);
                     If GrMode<HiMode                 {increase mode}
                       Then GrMode:=GrMode+1
                       Else                           {increase driver}
                         Begin
                           If GrDriver<10
                             Then GrDriver:=GrDriver+1
                             Else GrDriver:=1;
                           GetModeRange(GrDriver,LoMode,HiMode);
                           WriteModes;                {show new modes}
                           GrMode:=LoMode;            {update gr/hi/lomode}
                         End;
                     WriteCursors(Yellow);
                   End;
              'Q': Begin                                      {Pg Down}
                   End;
            End;   {of Case}
            Sound(1000);Delay(3);Nosound;
            TextColor(White);
            GotoXY(X3+15,Y3);  Write(DriverNames[GrDriver]);
            GotoXY(X3+14,Y3+1);Write(ModeNames[GrDriver,GrMode],' colors');
          End  {of if InChar=chr(0)}
        Else   {of if InChar=chr(0)}
          Begin
            Case InChar of
              {'a'..'z': InChar:=UpCase(InChar); }
               'Q','q': InChar:=Chr(27);          {escape}
            End;   {of case upcase(InChar)}
          End;    {of if inchar=chr(0) else}
      End;    {of if keypressed}
  Until (InChar=Chr(13)) or (InChar=Chr(27));      {return or escape}
  If InChar=Chr(13) then                                {return}
    Begin
      ScreenDriver:=GrDriver;
      ScreenMode:=GrMode;
    End;         {of inchar=return}
  If Debugger Then
    Begin
      TextColor(LightGreen);
      GotoXY(X4,Y4);
      Write('ForceMode(0): ');
      Readln(Dum);
      If (Length(Dum)<>0)
        Then
          Begin
            Val(Dum,ForceMode,Error);
            If (Error<>0) then ForceMode:=0;
          End
        Else ForceMode:=0;
    End;
End;             {of Procedure GetScreenType}


Procedure SetMode(Mode : Byte);
     {Uses EGA/VGA BIOS interupt service to directly access EGA/VGA
      graphics modes not supported by virgin Turbo Pascal.  Then,
      dispite being in the requested graphics mode, Turbo considers
      you to be still in text mode}
     Var
       Regs: Registers;
     Begin
       With Regs do
         Begin
           AH := 0;
           AL :=Mode;
         End;
       Intr($10, Regs);
      { If Mode=0 then DirectVideo:=True Else DirectVideo:=False;}
                {allow writes to function correctly}
     End;

Function InitializeGraphics: Integer;
  {initializes all the graphics BGI drivers in one shot, as external
   procedures in object files.  See 'Uses ... Drivers' at beginning of
   program.  Returns accumulated error.}
  Var
    GraphError              : Integer;
    Xaspect,Yaspect         :Word;
  Begin
    GraphError:=RegisterBGIdriver(@CGADriverProc)
               +RegisterBGIdriver(@EGAVGADriverProc)
               +RegisterBGIdriver(@HercDriverProc)
               +RegisterBGIdriver(@ATTDriverProc)
               +RegisterBGIdriver(@PC3270DriverProc)
               +RegisterBGIdriver(@IBM8514DriverProc)
             { +RegisterBGIfont(@GothicFontProc)   }
             { +RegisterBGIfont(@SansSerifFontProc)}
             { +RegisterBGIfont(@SmallFontProc)    }
             { +RegisterBGIfont(@TriplexFontProc)  } ;
    InitializeGraphics:=GraphError;
  End;        {of InitializeGraphics}

Procedure StartTone;
  Begin
    Sound(1000);
    Delay(50);
    NoSound;
  End;

Procedure OkTone;
  Begin
    Sound(900);
    Delay(100);
    Sound(1000);
    Delay(100);
    NoSound;
  End;

Procedure NotOkTone;
  Begin
    Sound(50);
    Delay(500);
    NoSound;
  End;


{**********MAIN PROGRAM**************************************************}

Var
  GifFileName: String;
  GraphDriver,GraphMode,BGILoadError,
  GifCompressError: Integer;
Begin
  Debugger:=False;                           {used by GetScreenType...}
                                             {...set true to use forcemode}
  ForceMode:=0;                              {used by getScreenType}
  BGILoadError:=InitializeGraphics;          {identify graphics drivers}
  GetScreenType(GraphDriver,GraphMode);      {select graphics mode}
  If ForceMode<>0
    Then SetMode(ForceMode)                  {set a graphics mode outside turbo}
    Else InitGraph(GraphDriver,GraphMode,'');{turbo mode}

  {  GraphDriver:=Detect;                }   {All of the above can be skipped}
  {  InitGraph(GraphDriver,GraphMode,'');}   {..by using these two lines.}

  DrawFigures;                               {draw some graphics}
  GifFileName:=GetGifFileName;               {find name not already used}
  SetColor(1);                               {set color for graphics write}
  OutTextXY(2,2,GifFileName);                {write file name in corner}
  StartTone;                                 {tone at start of save}
  GifCompressError:=ScreenToGif(GifFileName);{save screen to GIF file}
  CloseGraph;                                {close graphics and exit}
  If GifCompressError=0                      {status tones}
    Then OkTone
    Else NotOkTone;
End.