home *** CD-ROM | disk | FTP | other *** search
/ Computer Club Elmshorn Atari PD / CCE_PD.iso / pc / 0400 / CCE_0447.ZIP / CCE_0447.PD / SNAPHELP / SNAPHELP.PAS < prev    next >
Pascal/Delphi Source File  |  1986-02-06  |  5KB  |  198 lines
  1. {$S30}
  2. PROGRAM snaphelp ;
  3.  
  4. {-----------------------------------------------------------------------------}
  5. { Dieses Programm erlaubt das Einlesen aller bekannten Bildfileformate und    }
  6. { ermöglicht das Arbeiten mit Snapshot ! Außerdem kann das Bild im DEGAS-     }
  7. { Format abgespeichert werden !!                                              }
  8. {                                                                             }
  9. { (c) Thomas Proffen , RHEINBACH                                              }
  10. {-----------------------------------------------------------------------------}
  11.  
  12. CONST
  13.  {$I C:\GEM\GEMCONST.PAS }
  14.  {$I C:\SNAP\SNAPHELP.I  }
  15.  
  16. TYPE
  17.  {$I C:\GEM\GEMTYPE.PAS  }
  18.  
  19.  screen                  = ARRAY [1..16000] OF integer ;
  20.  file_type               = FILE  OF integer ;
  21.  string_type             = PACKED ARRAY [1..30] OF char ;
  22.  bild_zeiger             = ^screen ;
  23.  
  24. VAR
  25.  menu_zei                : Menu_Ptr ;
  26.  nachricht               : Message_Buffer ;
  27.  dummy, button, event    : integer ;
  28.  bild                    : bild_zeiger ;
  29.  feld                    : screen ;
  30.  datei                   : file_type ;
  31.  maske, datei_name       : string ;
  32.  
  33.  {$I C:\GEM\GEMSUBS.PAS  }
  34.  
  35. {----------------------    Betriebssystemaufrufe    --------------------------}
  36.  
  37. FUNCTION  bild_adresse : bild_zeiger ; XBIOS (3) ;
  38.  
  39. FUNCTION  Fread  (kanal : integer ; size : long_integer ; VAR buff : screen)
  40.                  : long_integer ; GEMDOS ($3F) ;
  41.  
  42. FUNCTION  Fwrite (kanal : integer ; size : long_integer ; VAR buff : screen)
  43.                  : long_integer ; GEMDOS ($40) ;
  44.  
  45. FUNCTION  Fopen  (VAR dat_name : string_type ; mode : integer)
  46.                  : integer ; GEMDOS ($3D) ;
  47.  
  48. PROCEDURE Fclose (nr : integer) ; GEMDOS ($3E) ;
  49.  
  50.  
  51. {-------- Do_Abbruch : Beendet das Programm nach Rückfrage -------------------}
  52.  
  53. PROCEDURE Do_Abbruch ;
  54.  
  55.  BEGIN
  56.   button := Do_Alert ('[2][Wirklich abbrechen ?][ Ja | Nein ]', 1) ;
  57.   IF button = 1 THEN
  58.    BEGIN
  59.     Free_Resource ;
  60.     Exit_Gem ;
  61.     Halt ;
  62.    END ;
  63.  END ;
  64.  
  65.  
  66. {-------- Draw_Bild : Bringt Bild auf den Bildschirm -------------------------}
  67.  
  68. PROCEDURE Draw_Bild ;
  69.  
  70.  VAR
  71.   index             : integer ;
  72.  
  73.  BEGIN
  74.   Hide_Mouse ;
  75.   {$P-}
  76.   bild^ := feld ;
  77.   {$P+}
  78.   Draw_Menu (menu_zei) ;
  79.   Show_Mouse ;
  80.  END ;
  81.  
  82.  
  83. {-------- Do_Save : Speichert das Bild im DEGAS-Format -----------------------}
  84.  
  85. PROCEDURE Do_Save ;
  86.  
  87.  VAR
  88.   index, nr            : integer ;
  89.   count                : long_integer ;
  90.  
  91.  BEGIN
  92.   maske := 'A:\*.PI3' ;
  93.   IF Get_In_File (maske, datei_name) THEN
  94.    BEGIN
  95.     Draw_Bild ;
  96.     Set_Mouse (M_Bee) ;
  97.     rewrite (datei, datei_name) ;
  98.     nr := handle (datei) ;
  99.     datei^  := 2 ;                        { DEGAS, daß hohe Auflösung !     }
  100.     put (datei) ;
  101.     datei^ := 0 ;                         { keine Farbwerte, da monochrom ! }
  102.     FOR index := 1 TO 16 DO
  103.      put (datei) ;
  104.     count := Fwrite (nr, 32000, feld) ;
  105.     IF count <> 32000 THEN
  106.      button := Do_Alert ('[3][Fehler beim Schreiben !][Abbruch]', 1) ;
  107.     Fclose (nr) ;
  108.     Set_Mouse (M_Arrow) ;
  109.    END
  110.   ELSE
  111.    Draw_Bild ;
  112.  END ;
  113.  
  114.  
  115. {-------- Do_Load : Lädt Bilder aller Formate --------------------------------}
  116.  
  117. PROCEDURE Do_Load (size : long_integer ; art : string) ;
  118.  
  119.  VAR
  120.   index, offset, nr     : integer ;
  121.   count                 : long_integer ;
  122.   dat_name              : string_type ;
  123.  
  124.  BEGIN
  125.   maske := art ;
  126.   IF Get_In_File (maske, datei_name) THEN
  127.    BEGIN
  128.     Draw_Bild ;
  129.     Set_Mouse (M_Bee) ;
  130.     offset := INT (size - 16000) ;
  131.     IF offset <> 0 THEN
  132.      BEGIN
  133.       reset (datei, datei_name) ;
  134.       nr := handle (datei) ;
  135.       FOR index := 1 TO offset-1 DO
  136.        get (datei) ;
  137.      END
  138.     ELSE
  139.      BEGIN
  140.       FOR index := 1 TO LENGTH (datei_name) DO
  141.        dat_name[index] := datei_name[index] ;
  142.       nr := Fopen (dat_name, 0) ;
  143.      END ;
  144.     count := Fread (nr, 32000, feld) ;
  145.     IF count <> 32000 THEN
  146.      button := Do_Alert ('[3][Fehler beim Lesen !][Abbruch]', 1) ;
  147.     Fclose (nr) ;
  148.     Set_Mouse (M_Arrow) ;
  149.    END ;
  150.   Draw_Bild ;
  151.  END ;
  152.  
  153.  
  154. {-------- Event_Loop : Überwacht das Menü ------------------------------------}
  155.  
  156. PROCEDURE Event_Loop ;
  157.  
  158.  BEGIN
  159.   Draw_Bild ;
  160.   WHILE true DO
  161.    BEGIN
  162.     event := Get_Event (E_Message , 0, 0, 0, 0, false, 0, 0, 0, 0,
  163.                         false, 0, 0, 0, 0, nachricht, dummy, dummy,
  164.                         dummy, dummy, dummy, dummy) ;
  165.     IF nachricht[0] = MN_Selected THEN
  166.      BEGIN
  167.       Menu_Normal (menu_zei, nachricht[3]) ;
  168.       CASE nachricht[4] OF
  169.        degas   : Do_Load (16017, 'A:\*.PI3') ;
  170.        doodle  : Do_Load (16000, 'A:\*.ART') ;
  171.        mandel  : Do_Load (16012, 'A:\*.MAN') ;
  172.        save    : Do_Save ;
  173.        ende    : Do_Abbruch ;
  174.       END ;
  175.      END ;
  176.    END ;
  177.  END ;
  178.  
  179.  
  180. {----------------------        Hauptprogramm       ---------------------------}
  181.  
  182. BEGIN
  183.  bild := bild_adresse ;
  184.  IF Init_Gem >= 0 THEN
  185.   BEGIN
  186.    IF NOT Load_Resource ('SNAPHELP.RSC') THEN
  187.     BEGIN
  188.      button := Do_Alert ('[3][RSC-File defekt][Abbruch]', 0) ;
  189.      Exit_Gem ;
  190.      Halt ;
  191.     END ;
  192.    Find_Menu (menu, menu_zei) ;
  193.    Draw_Menu (menu_zei) ;
  194.    Init_Mouse ;
  195.    Event_Loop ;
  196.   END ;
  197. END.
  198.