home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / grafik / tiff / aus_tiff.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1990-06-15  |  10.1 KB  |  365 lines
  1. unit Aus_TIFF;
  2. (* Gibt die PCL-Grafikdaten als TIFF-Datei aus *)
  3.  
  4. interface
  5.  
  6. const MaxBuff  = 16000;
  7. type BufferTyp = array[1..MaxBuff] of byte;
  8. var GrafikModus : boolean;
  9.  
  10. function B_to_Str(B_Param : boolean) : string;
  11. (* Hilfsfunktion für Fehlermeldungen etc. *)
  12.  
  13. function R_to_Str(R_Param : real) : string;
  14. (* Hilfsfunktion für Fehlermeldungen etc. *)
  15.  
  16. procedure Fehler(Meldung,Kennung: string);
  17. (* Gibt Fehlermeldungen aus *)
  18.  
  19. procedure AusgabeInit(Breite,Hoehe : integer;  (* In Pixeln *)
  20.                       DateiName    : string;
  21.                       Aufloesung   : integer;  (* 1 für 300 DPI *)
  22.                       Verkleinern  : integer); (* 1,2,4,8 *)
  23. (* Schreibt den Tiff_Header etc. *)
  24.  
  25. procedure AusgabeExit;
  26. (* Schaltet wieder auf Text um *)
  27.  
  28. procedure AusgabeDaten(Daten  : BufferTyp;
  29.                        Anzahl : integer;
  30.                        X_Pos  : integer;
  31.                        Y_Pos  : integer);
  32. (* Gibt eine Pixelzeile aus *)
  33.  
  34.  
  35. implementation
  36.  
  37. uses Dos, Crt;
  38.  
  39. const MaxByte  = 1000;
  40.       MS_Dos   = $21;
  41. type TIFF_Feld = array[0..MaxByte] of byte;
  42.  
  43. var TIFF_Handle : word;
  44.     TIFF_Buff   : TIFF_Feld;
  45.     Kehrwert    : real;
  46.     Len_Header  : LongInt;
  47.     Len_Zeile   : word;
  48.     Max_Breite  : word;
  49.     Max_Hoehe   : word;
  50.     Mass_Faktor : byte;
  51.     Scr_Y       : byte;
  52.  
  53. function B_to_Str(B_Param : boolean) : string;
  54. begin
  55.   if B_Param then B_to_Str := 'TRUE'
  56.   else B_to_Str := 'FALSE';
  57. end;
  58.  
  59. function R_to_Str(R_Param : real) : string;
  60. var R_Str : string;
  61. begin
  62.   if R_Param = int(R_Param) then str(R_Param:1:0,R_Str)
  63.   else str(R_Param:1:3,R_Str);
  64.   R_to_Str := R_Str;
  65. end;
  66.  
  67. procedure Fehler(Meldung,Kennung: string);
  68. begin
  69.   writeln;
  70.   writeln('Fehler ',Meldung,': <',Kennung,'> [CR]');
  71.   readln;
  72. end;
  73.  
  74. procedure CreateHandle(var Handle : word;
  75.                            DatNam : string);
  76. var FileNam : Dos.PathStr;
  77.     Reg_I   : Dos.Registers;
  78. begin
  79.   FileNam := DatNam + #0;
  80.   Reg_I.AH := $3C;
  81.   Reg_I.CX := 0;
  82.   Reg_I.DS := Seg(FileNam[1]);;
  83.   Reg_I.DX := Ofs(FileNam[1]);
  84.   Dos.Intr(MS_Dos,Reg_I); (* Create Handle *)
  85.   Handle := 255;
  86.   if odd(Reg_I.Flags) then Fehler('Create ',R_to_Str(Reg_I.AX))
  87.   else Handle := Reg_I.AX;
  88. end;
  89.  
  90. procedure CloseHandle(Handle : word);
  91. var Reg_I   : Dos.Registers;
  92. begin
  93.   Reg_I.AH := $3E;
  94.   Reg_I.BX := Handle;
  95.   Dos.Intr(MS_Dos,Reg_I); (* close Handle *)
  96.   if odd(Reg_I.Flags) then Fehler('Close ',R_to_Str(Reg_I.AX));
  97. end;
  98.  
  99. procedure ReadBytes(Handle : word;
  100.                 var Puffer;
  101.                 var Anzahl : word);
  102. var Reg_I : Dos.Registers;
  103. begin
  104.   Reg_I.AH := $3F;
  105.   Reg_I.BX := Handle;
  106.   Reg_I.CX := Anzahl;
  107.   Reg_I.DS := Seg(Puffer);
  108.   Reg_I.DX := Ofs(Puffer);
  109.   Dos.Intr(MS_Dos,Reg_I); (* Vom Handle in den Buffer lesen *)
  110.   if odd(Reg_I.Flags) then
  111.   begin
  112.     Anzahl := 0;
  113.     Fehler('ReadBytes ',R_to_Str(Reg_I.AX));
  114.   end
  115.   else Anzahl := Reg_I.AX;
  116. end;
  117.  
  118. procedure WriteBytes(Handle : word;
  119.                  var Puffer;
  120.                      Anzahl : word);
  121. var Reg_I : Dos.Registers;
  122. begin
  123.   Reg_I.AH := $40;
  124.   Reg_I.BX := Handle;
  125.   Reg_I.CX := Anzahl;
  126.   Reg_I.DS := Seg(Puffer);
  127.   Reg_I.DX := Ofs(Puffer);
  128.   Dos.Intr(MS_Dos,Reg_I); (* Buffer in Handle schreiben *)
  129.   if odd(Reg_I.Flags) then Fehler('Write ',R_to_Str(Reg_I.AX));
  130. end;
  131.  
  132. procedure SeekLine(Handle  : word;
  133.                    Zeile_I : integer);
  134. var Reg_I : Dos.Registers;
  135.     F_Pos : LongInt;
  136. begin
  137.   F_Pos := Len_Header + (Len_Zeile * Zeile_I);
  138.   Reg_I.AH := $42;
  139.   Reg_I.AL := 0;
  140.   Reg_I.BX := Handle;
  141.   Reg_I.CX := F_Pos div 65536;
  142.   Reg_I.DX := F_Pos mod 65536;;
  143.   Dos.Intr(MS_Dos,Reg_I); (* Setzt Pointer auf Anfang + F_Pos *)
  144. end;
  145.  
  146. procedure AusgabeInit(Breite,Hoehe : integer;
  147.                       DateiName    : string;
  148.                       Aufloesung   : integer;
  149.                       Verkleinern  : integer);
  150. var Lauf      : integer;
  151.     B_Breite  : integer;
  152.     B_Hoehe   : integer;
  153.  
  154.  procedure WriteHeader(Breite,Hoehe,DPI : integer);
  155.  (* Gibt den Dateiheader der TIFF-Datei aus und füllt die Datei *)
  156.  const Short_Format : word = 3;
  157.        Long_Format  : word = 4;
  158.        Bruch_Format : word = 5;
  159.        Einheit_Zoll : word = 2;
  160.        Breite_TAG   : word = $0100;
  161.        Laenge_TAG   : word = $0101;
  162.        Muster_TAG   : word = $0102;
  163.        Kompress_TAG : word = $0103;
  164.        Inverse_TAG  : word = $0106;
  165.        Streifen_TAG : word = $0111;
  166.        Zeilen_TAG   : word = $0116;
  167.        X_Res_TAG    : word = $011A;
  168.        Y_Res_TAG    : word = $011B;
  169.        Einheit_TAG  : word = $0128;
  170.  
  171.  var Header  : array [0..255] of byte;
  172.      HeadPos : word;
  173.      B_Wert  : byte;
  174.      Lauf_I  : integer;
  175.      Lauf_J  : integer;
  176.  
  177.   procedure SetzeInt(I : integer);
  178.   begin
  179.     Header[HeadPos] := lo(I);
  180.     inc(HeadPos);
  181.     Header[HeadPos] := hi(I);
  182.     inc(HeadPos);
  183.   end;
  184.  
  185.   procedure SetzeLong(L : LongInt);
  186.   var WFeld : array[1..2] of word absolute L;
  187.   begin
  188.     Header[HeadPos] := lo(WFeld[1]);
  189.     inc(HeadPos);
  190.     Header[HeadPos] := hi(WFeld[1]);
  191.     inc(HeadPos);
  192.     Header[HeadPos] := lo(WFeld[2]);
  193.     inc(HeadPos);
  194.     Header[HeadPos] := hi(WFeld[2]);
  195.     inc(HeadPos);
  196.   end;
  197.  
  198.  begin (* WriteHeader *)
  199.    HeadPos := 0;
  200.    FillChar(Header,SizeOf(Header),0);
  201.    SetzeInt($4949);           (* HEADER Intel Format *)
  202.    SetzeInt($002a);           (* Version *)
  203.    SetzeLong($00000008);      (* Pointer to first IFD *)
  204.    SetzeInt(9);               (* Anzahl der entry count IFD *)
  205.  
  206.    SetzeInt(Breite_TAG);      (* 1 - Bildbreite in Pixeln *)
  207.    SetzeInt(Short_Format);
  208.    SetzeLong(1);
  209.    SetzeInt(Breite);
  210.    SetzeInt(0);
  211.  
  212.    SetzeInt(Laenge_TAG);      (* 2 - Bildlänge in Pixeln*)
  213.    SetzeInt(Short_Format);
  214.    SetzeLong(1);
  215.    SetzeInt(Hoehe);
  216.    SetzeInt(0);
  217.  
  218.    SetzeInt(Muster_TAG);      (* Bits pro Muster*)
  219.    SetzeInt(Short_Format);
  220.    SetzeLong(1);
  221.    SetzeInt(1);
  222.    SetzeInt(0);
  223.  
  224.    SetzeInt(Inverse_TAG);     (* Invertieren ? *)
  225.    SetzeInt(Short_Format);
  226.    SetzeLong(1);
  227.    SetzeInt(0);
  228.    SetzeInt(0);
  229.  
  230.    SetzeInt(Streifen_TAG);    (* 5 - Anzahl Streifen *)
  231.    SetzeInt(Long_Format);
  232.    SetzeLong(1);
  233.    SetzeLong($0000008A);      (* Zeiger auf folgenden Daten *)
  234.  
  235.    SetzeInt(Zeilen_TAG);      (* 6 Zeilen pro Streifen *)
  236.    SetzeInt(Short_Format);
  237.    SetzeLong(1);
  238.    SetzeInt(Hoehe);
  239.    SetzeInt(0);
  240.  
  241.    SetzeInt(X_Res_TAG);       (* 7 - X-Auflösung *)
  242.    SetzeInt(Bruch_Format);
  243.    SetzeLong(1);
  244.    SetzeLong($0000007A);      (* Zeiger auf X-Bruch *)
  245.  
  246.    SetzeInt(Y_Res_TAG);       (* 8 - Y-Auflösung*)
  247.    SetzeInt(Bruch_Format);
  248.    SetzeLong(1);
  249.    SetzeLong($00000082);      (* Zeiger auf Y-Bruch *)
  250.  
  251.    SetzeInt(Einheit_TAG);     (* 9 - Maßeinheit setzen *)
  252.    SetzeInt(Short_Format);
  253.    SetzeLong(1);
  254.    SetzeInt(Einheit_Zoll);    (* Maße in Zoll *)
  255.    SetzeInt(0);
  256.  
  257.    SetzeLong(0);              (* Verweis auf nächsten IFD *)
  258.    SetzeLong(1);              (* Bruch X_Resolution, Zähler *)
  259.    SetzeLong(DPI);            (*                     Nenner *)
  260.    SetzeLong(1);              (* Bruch Y-Resolution, Zähler *)
  261.    SetzeLong(DPI);            (*                     Nenner *)
  262.    dec(HeadPos);
  263.    Len_Header := HeadPos;
  264.    WriteBytes(TIFF_Handle,Header,HeadPos);
  265.    (* Jetzt folgen die Graphik-Daten ... *)
  266.    FillChar(TIFF_Buff,SizeOf(Tiff_Buff),0);
  267.    for Lauf_I := 1 to Hoehe do
  268.    begin
  269.      WriteBytes(TIFF_Handle,TIFF_Buff,Len_Zeile);
  270.      GotoXY(1,Scr_Y); write(100.0 * Lauf_I /Hoehe :6:1);
  271.    end;
  272.  end;
  273.  
  274. begin (* AusgabeInit *)
  275.   for Lauf := 1 to length(DateiName)
  276.   do DateiName[Lauf] := upcase(DateiName[Lauf]);
  277.   if pos('.',DateiName) > 0
  278.   then DateiName := copy(DateiName,1,pred(pos('.',DateiName)));
  279.   DateiName := DateiName + '.TIF';
  280.   writeln('TIFF-Datei "',DateiName,'" wird angelegt ... ');
  281.   Kehrwert := 1.0 / (1.0 * Aufloesung);
  282.   case Verkleinern of
  283.    2 : Mass_Faktor := 2;
  284.    4 : Mass_Faktor := 4;
  285.    8 : Mass_Faktor := 8;
  286.    else Mass_Faktor := 1;
  287.   end;
  288.   KehrWert := KehrWert / (1.0 * Mass_Faktor);
  289.   B_Breite := round(Kehrwert * Breite);
  290.   B_Hoehe := round(Kehrwert * Hoehe);
  291.   Len_Zeile := B_Breite div 8;
  292.   if B_Breite mod 8 > 0 then inc(Len_Zeile);
  293.   writeln('benötigt etwa ',(Len_Zeile * B_Hoehe) div 1024,
  294.            ' Kilobyte Platz.');
  295.   writeln(0.0 :6:1,' % Initialisierung');
  296.   Scr_Y := pred(WhereY);
  297.   Max_Breite := B_Breite;
  298.   Max_Hoehe := B_Hoehe;
  299.   CreateHandle(TIFF_Handle,DateiName);
  300.   WriteHeader(B_Breite,B_Hoehe,300 div Aufloesung);
  301.   GotoXY(1,Scr_Y);
  302.   writeln('Initialisierung beendet, Umwandlung beginnt ...');
  303.   writeln('etwa ',0.0 :6:1,' % Umwandlung');
  304.   Scr_Y := pred(WhereY);
  305. end;
  306.  
  307. procedure AusgabeDaten(Daten  : BufferTyp;
  308.                        Anzahl : integer;
  309.                        X_Pos  : integer;
  310.                        Y_Pos  : integer);
  311. var Pixel_X : integer;
  312.     Pixel_Y : integer;
  313.     DatenB  : byte;
  314.     Weiter  : byte;
  315.     Lauf    : integer;
  316.  
  317.   procedure SetzeByte(B : byte; X : integer);
  318.   (* Überlagert die Pixelzeile mit dem Byte-Muster B *)
  319.   var Index : integer;
  320.       Rest  : integer;
  321.       Wert  : integer;
  322.   begin
  323.     Index := X div 8;
  324.     Rest := X mod 8;
  325.     if Rest = 0
  326.     then TIFF_Buff[Index] := TIFF_Buff[Index] or B
  327.     else
  328.     begin
  329.       Wert := B shr (8 - Rest);
  330.       TIFF_Buff[Index] := TIFF_Buff[Index] or lo(Wert);
  331.       inc(Index);
  332.       Wert := B shl Rest;
  333.       TIFF_Buff[Index] := TIFF_Buff[Index] or lo(Wert);
  334.     end;
  335.   end;
  336.  
  337. begin
  338.   Pixel_X := round(Kehrwert * X_Pos);
  339.   Pixel_Y := round(Kehrwert * Y_Pos);
  340.   GotoXY(6,Scr_Y); write(100.0 * Pixel_Y / Max_Hoehe :6:1);
  341.   Weiter := 8 div Mass_Faktor;
  342.   SeekLine(TIFF_Handle,Pixel_Y);
  343.   ReadBytes(TIFF_Handle,TIFF_Buff,Len_Zeile);
  344.   for Lauf := 1 to Anzahl do
  345.   begin
  346.     DatenB := Daten[Lauf];
  347.     if DatenB <> 0 then SetzeByte(DatenB,Pixel_X);
  348.     inc(Pixel_X,Weiter);
  349.   end;
  350.   SeekLine(TIFF_Handle,Pixel_Y);
  351.   WriteBytes(TIFF_Handle,TIFF_Buff,Len_Zeile);
  352. end;
  353.  
  354. procedure AusgabeExit;
  355. begin
  356.   CloseHandle(TIFF_Handle);
  357.   GotoXY(1,Scr_Y);
  358.   writeln('Umwandlung beendet, TIFF-Datei erzeugt.');
  359.   writeln;
  360. end;
  361.  
  362. end.
  363.  
  364. @bu = In dieser Unit wird die TIFF-Datei erzeugt
  365.