home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1990 / 06 / heimwerk / zeigimg.bas < prev    next >
BASIC Source File  |  1990-03-07  |  6KB  |  206 lines
  1. '* ------------------------------------------------------- *
  2. '*                      ZEIGIMG.BAS                        *
  3. '*       lädt eine Image-Datei und gibt sie auf dem        *
  4. '*                     Bildschirm aus                      *
  5. '*              (c) 1990 Kay Glahn & TOOLBOX               *
  6. '* ------------------------------------------------------- *
  7. DEFINT A-Z
  8. DECLARE FUNCTION HercKart% ()
  9. DECLARE FUNCTION FileExist% (Datei$)
  10. DECLARE FUNCTION Lese% (Stand%, Inhalt$)
  11. DECLARE SUB SetXY (Segment%, Offset%, X%, Y%)
  12. DECLARE SUB GetInhalt (Inhalt$, Headlen%, Laenge%)
  13. DECLARE SUB GetHead (Headlen%, Farben%, Musterlen%, Breite%)
  14. DECLARE SUB GetImage (Datei$, Segment%, Offset%)
  15. DIM A(16000) AS INTEGER
  16. Datei$ = COMMAND$
  17. SELECT CASE HercKart
  18.   CASE 1
  19.     ON ERROR GOTO Fehler
  20.     SCREEN 3
  21.     ON ERROR GOTO 0
  22.     SCREEN 0
  23.     MaxX = 720
  24.     MaxY = 348
  25.     Mode = 3
  26.   CASE ELSE
  27.     MaxX = 640
  28.     MaxY = 200
  29.     Mode = 2
  30. END SELECT
  31. CLS
  32. WHILE Datei$ = ""
  33.   INPUT "Name des Imagefiles : ", Datei$
  34. WEND
  35. IF INSTR(1, Datei$, ".") = 0 THEN
  36.   Datei$ = LEFT$(Datei$, 8) + ".IMG"
  37. END IF
  38. Datei$ = UCASE$(Datei$)
  39. IF FileExist(Datei$) = 0 THEN
  40.   PRINT Datei$; " existiert nicht !"
  41.   END
  42. ELSE
  43.   PRINT Datei$; " wird geladen, bitte warten !"
  44. END IF
  45. CALL GetImage(Datei$, VARSEG(A(0)), VARPTR(A(0)))
  46. CLS
  47. SCREEN Mode
  48. PUT (0, 0), A, PRESET
  49. WHILE INKEY$ = "": WEND
  50. SCREEN 0
  51. END
  52. Fehler:
  53. PRINT "QBHERC.COM wurde nicht geladen !"
  54. PRINT "Programm kann nicht fortgeführt werden."
  55. END
  56.  
  57. '* ------------------------------------------------------- *
  58. '*   Überprüfen ob die angegebene Datei vorhanden ist      *
  59. FUNCTION FileExist (Datei$)
  60.   OPEN Datei$ FOR BINARY AS #1
  61.   Vorhanden = LOF(1)
  62.   CLOSE #1
  63.   IF Vorhanden > 0 THEN
  64.     FileExist = 1
  65.   ELSE
  66.     FileExist = 0
  67.     KILL Datei$
  68.   END IF
  69. END FUNCTION
  70.  
  71. '* ------------------------------------------------------- *
  72. '*       Header der Image-Datei einlesen und auswerten     *
  73. SUB GetHead (Headlen, Farben, Musterlen, Breite)
  74.   DIM Highbyte AS STRING * 1
  75.   DIM LowByte AS STRING * 1
  76.   GET #1, 3, Highbyte
  77.   GET #1, 4, LowByte
  78.   Headlen = ASC(Highbyte) * 256 + ASC(LowByte)
  79.   GET #1, 5, Highbyte
  80.   GET #1, 6, LowByte
  81.   Farben = ASC(Highbyte) * 256 + ASC(LowByte)
  82.   GET #1, 7, Highbyte
  83.   GET #1, 8, LowByte
  84.   Musterlen = ASC(Highbyte) * 256 + ASC(LowByte)
  85.   GET #1, 13, Highbyte
  86.   GET #1, 14, LowByte
  87.   Breite = ASC(Highbyte) * 256 + ASC(LowByte)
  88. END SUB
  89.  
  90. '* ------------------------------------------------------- *
  91. '*        Daten entpacken und in ein Array übergeben       *
  92. SUB GetImage (Datei$, Segment, Offset)
  93.   SHARED MaxX, MaxY
  94.   DIM Muster(4096) AS INTEGER
  95.   DIM Pattern(16) AS INTEGER
  96.   DEF SEG = Segment
  97.   OPEN Datei$ FOR BINARY AS #1
  98.   CALL GetHead(Headlen, Farben, Musterlen, Breite)
  99.   CALL GetInhalt(Inhalt$, Headlen, Laenge)
  100.   CALL SetXY(Segment, Offset, MaxX, MaxY)
  101.   Links = INT((MaxX - Breite) / 2)
  102.   WHILE Stand < Laenge AND Y < MaxY
  103.     A = Lese(Stand, Inhalt$)
  104.     B = Lese(Stand, Inhalt$)
  105.     C = Lese(Stand, Inhalt$)
  106.     IF A = 0 AND B = 0 AND C = &HFF THEN
  107.       Vertrep = Lese(Stand, Inhalt$)
  108.     ELSE
  109.       IF A = 0 AND B = 0 THEN
  110.         EXIT SUB
  111.       ELSE
  112.         Stand = Stand - 3
  113.         Vertrep = 1
  114.       END IF
  115.     END IF
  116.     FOR Farbe = 1 TO Farben
  117.       X = Links
  118.       WHILE (X < Breite + Links)
  119.         A = Lese(Stand, Inhalt$)
  120.         SELECT CASE A
  121.           CASE 0
  122.             A = Lese(Stand, Inhalt$)
  123.             FOR j = 1 TO Musterlen
  124.               Pattern(j) = Lese(Stand, Inhalt$)
  125.             NEXT
  126.             FOR j = 1 TO A
  127.               FOR t = 1 TO Musterlen
  128.                 Muster((j - 1) * Musterlen + t) = Pattern(t)
  129.               NEXT
  130.             NEXT
  131.             N = A * Musterlen
  132.           CASE &H80
  133.             A = Lese(Stand, Inhalt$)
  134.             FOR j = 1 TO A
  135.               Muster(j) = Lese(Stand, Inhalt$)
  136.             NEXT
  137.             N = A
  138.           CASE ELSE
  139.             N = A AND &H7F
  140.             IF (A AND &H80) <> 0 THEN
  141.               FOR t = 1 TO N
  142.                 Muster(t) = &HFF
  143.               NEXT
  144.             ELSE
  145.               FOR t = 1 TO N
  146.                 Muster(t) = 0
  147.               NEXT
  148.             END IF
  149.         END SELECT
  150.         FOR i = 1 TO Vertrep
  151.           Adrs = 3 + (Y + i - 1) * (MaxX \ 8) + (X \ 8)
  152.           Adrs = Adrs + Offset
  153.           FOR t = 1 TO N
  154.             POKE Adrs + t, Muster(t)
  155.           NEXT
  156.         NEXT
  157.         X = X + N * 8
  158.       WEND
  159.     NEXT
  160.     Y = Y + Vertrep
  161.   WEND
  162.   CLOSE #1
  163. END SUB
  164.  
  165. '* ------------------------------------------------------- *
  166. '*            Datenblock der Datei einlesen                *
  167. SUB GetInhalt (Inhalt$, Headlen, Laenge)
  168.   SEEK 1, Headlen * 2 + 1
  169.   Laenge = LOF(1) - Headlen * 2
  170.   Inhalt$ = STRING$(Laenge, " ")
  171.   GET #1, , Inhalt$
  172. END SUB
  173.  
  174. '* ------------------------------------------------------- *
  175. '*     überprüfen ob eine Herculeskarte vorhanden ist      *
  176. FUNCTION HercKart
  177.   DEF SEG = &H40
  178.   Karte = PEEK(16) + 256 * PEEK(17)
  179.   Karte = (Karte AND 48) / 16
  180.   SELECT CASE Karte
  181.     CASE IS = 3
  182.       HercKart = 1
  183.     CASE ELSE
  184.       HercKart = 0
  185.   END SELECT
  186. END FUNCTION
  187.  
  188. '* ------------------------------------------------------- *
  189. '* Ein Byte aus String in eine Integer-Variable übertragen *
  190. FUNCTION Lese (Stand, Inhalt$)
  191.   Stand = Stand + 1
  192.   Lese = ASC(MID$(Inhalt$, Stand, 1))
  193. END FUNCTION
  194.  
  195. '* ------------------------------------------------------- *
  196. '*  Ausdehnung des Bildes in X- und Y-Richtung festlegen   *
  197. SUB SetXY (Segment, Offset, X, Y)
  198.   DEF SEG = Segment
  199.   POKE Offset, X MOD 256
  200.   POKE Offset + 1, X \ 256
  201.   POKE Offset + 2, Y MOD 256
  202.   POKE Offset + 3, Y \ 256
  203. END SUB
  204. '* ------------------------------------------------------- *
  205. '*                 Ende von ZEIGIMG.BAS                    *
  206.