home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / delite / ver1 / dxfview / acaddxf.pas next >
Encoding:
Pascal/Delphi Source File  |  1991-03-01  |  24.3 KB  |  773 lines
  1. {$N+ }            { 8087 Math Coprocessor on }
  2. {$E+ }            { include 8087 emulation   }
  3.  
  4. UNIT AcadDXF;     { Der Autocad DXF-Interpreter    Version 1.1  15.2.1990  }
  5.  
  6. INTERFACE
  7.  
  8.  TYPE   DXFErr  = (ok, filenotfound, syntax, eof_reached);
  9.  
  10.  function  InterpretDXF(name : string):DXFErr;
  11.  Procedure InitDXF;
  12.  
  13. { Der DXF-Interpreter bedient sich der graphischen Primitive des Kernels.
  14.   Vor der ersten Benutzung muß einmal InitDXF aufgerufen werden, um alle
  15.   Systemvariablen zu initialisieren und die Tabellen zu löschen.
  16.   Die Funktion InterpretDXF zeichnet eine DXF-Grafik in den aktuell ge-
  17.   setzten Viewport. Als name ist der volle Suchpfad ohne die Dateiexten-
  18.   sion DXF.
  19.   Zurückgeliefert wird ein Fehlercode:
  20.  
  21.      ok            :    Die Grafik wurde erfolgreich erstellt.
  22.      filenotfound  :    Unter dem angegebenen Namen existiert keine Datei.
  23.      syntax        :    Die Zeichnung wurde abgebrochen, weil ein
  24.                         fataler syntaktischer Fehler erkannt wurde.
  25.      eof_reached   :    Die DXF-Datei enthält nicht die EOF-Markierung.
  26.  
  27. }
  28.  
  29. IMPLEMENTATION
  30.  
  31. USES Kernel;
  32.  
  33. CONST  NLayer  = 32;    { Anzahl der von uns verwalteten Lagen  }
  34.        NLtypes = 16;    { Anzahl der Linientypen  }
  35.        MaxEle  =  8;    { Anzahl der Strichelemente pro Linie   }
  36.  
  37. TYPE   NameStr    = String[15];
  38.  
  39.        Layer      = record
  40.                       name  : NameStr;       { Name des Layers    }
  41.                       flags : integer;
  42.                       color : integer;       { Farbe ordinal      }
  43.                       ltype : NameStr;       { Linienstil         }
  44.                     end;
  45.  
  46.        Ltype      = record
  47.                       name  : NameStr;      { Name des Linientyps }
  48.                       desc  : NameStr;      { Beschreibung        }
  49.                       flags : integer;      { Flags               }
  50.                       just  : integer;      { Justierungscode     }
  51.                       nE    : integer;      { Anzahl Elemente     }
  52.                       Totlen: double;       { Gesamtlänge Linie   }
  53.                       Eles  : array[1..MaxEle] of double;{ Elemente }
  54.                     end;
  55.  
  56. VAR    f: text;
  57.  
  58.        Layers : array[1..NLayer]  of Layer;   { Die Layer-Liste }
  59.        Ltypes : array[1..NLtypes] of Ltype;   { Die Linientypen }
  60.  
  61.        PolyLayer : string;   { Daten für Polylinien :   }
  62.        PolyMode  : integer;  { -1 = aus,  0 = nicht init. , 1 = init }
  63.        PolyFirstX: double;
  64.        PolyFirstY: double;
  65.        PolyLastX : double;
  66.        PolyLastY : double;
  67.  
  68.        Aspect    : double;
  69.  
  70.        { Autocad-Systemvariablen  }
  71.  
  72.        LIMMIN_X  : double;         { Zeichnungsgrenzen links unten   }
  73.        LIMMIN_Y  : double;
  74.        LIMMAX_X  : double;         { Zeichnungsgrenzen rechts oben   }
  75.        LIMMAX_Y  : double;
  76.        EXTMIN_X  : double;         { tatsächliche Grenze links unten }
  77.        EXTMIN_Y  : double;
  78.        EXTMAX_X  : double;         { tatsächliche Grenze rechts oben }
  79.        EXTMAX_Y  : double;
  80.        VIEWCTR_X : double;         { Zentrum des Ausschnitts         }
  81.        VIEWCTR_Y : double;
  82.        TDCREATE  : double;         { Datum der Erstellung            }
  83.        TDUPDATE  : double;         { Datum der letzten Modifikation  }
  84.        PDMODE    : integer;
  85.        PDSIZE    : double;
  86.  
  87.  
  88. CONST  NVars = 9;                  { Schlüsselworte aus Headerblock  }
  89.        SysWords : array[1..NVars] of NameStr =
  90.          ('$LIMMIN'   , '$LIMMAX'   , '$EXTMIN'  ,  '$EXTMAX',
  91.           '$VIEWCTR'  , '$TDCREATE' , '$TDUPDATE',  '$PDMODE',
  92.           '$PDSIZE');
  93.  
  94.        NEnt  = 10;                 { Schlüsselworte aus Entityblock  }
  95.        EntityWords : array[1..NEnt] of NameStr =
  96.          ('ENDSEC', 'LINE'   , 'ARC'     ,  'POINT',
  97.           'CIRCLE', 'TEXT'   , 'POLYLINE',  'VERTEX',
  98.           'SEQEND', 'SOLID');
  99.  
  100.        NTab  = 4;                  { Schlüsselworte aus Tabellenblock}
  101.        TabWords    : array[1..NTab] of NameStr =
  102.          ('LTYPE' ,  'LAYER'  ,  'STYLE',  'VIEW');
  103.  
  104.  
  105. procedure InitSysVars;            { Initialisierung aller Systemvariablen }
  106. Var i,j : integer;
  107. begin
  108.   Aspect    := 3*PortMaxX / (4*PortMaxY);   { Höhen/Breitenverhältnis }
  109.   PolyLayer := '';                          { PolyLinemodus aus }
  110.   PolyMode  := -1;
  111.   PolyFirstX:=  0;
  112.   PolyLastX :=  0;
  113.   PolyLastX :=  0;
  114.   PolyLastY :=  0;
  115.   LIMMIN_X  :=  0;
  116.   LIMMIN_Y  :=  0;
  117.   LIMMAX_X  := 15;
  118.   LIMMAX_Y  :=  11.25;
  119.   EXTMIN_X  :=  0;
  120.   EXTMIN_Y  :=  0;
  121.   EXTMAX_X  := 12;
  122.   EXTMAX_Y  :=  9;
  123.   VIEWCTR_X :=  5;
  124.   VIEWCTR_Y :=  5;
  125.   TDCREATE  :=  0;
  126.   TDUPDATE  :=  0;
  127.   PDMODE    :=  0;
  128.   PDSIZE    :=  0.1;
  129.  
  130.   for i := 1 to NLtypes do
  131.     With Ltypes[i] do
  132.       begin
  133.         name   := '';
  134.         desc   := '';
  135.         just   :=  0;
  136.         totlen :=  0;
  137.         nE     :=  0;
  138.         for j := 1 to MaxEle do
  139.           Eles[j] := 0;          { Strichelemente löschen }
  140.       end;
  141. end;
  142.  
  143.  
  144. procedure AddLType(lt: LType);   { Linientyp hinzufügen   }
  145. Var  i : integer;
  146. begin
  147.   i := 1;
  148.   while (ltypes[i].name <> '') and (i < NLtypes) do
  149.     i := succ(i);
  150.   if Ltypes[i].name = '' then
  151.     begin
  152.       ltypes[i] := lt;
  153.     end;
  154. end;
  155.  
  156.  
  157. procedure AddLayer(Lname: NameStr; Lflags,Lcolor : integer; Lltype : NameStr);
  158. Var  i : integer;
  159. begin
  160.   i := 1;
  161.   while (Layers[i].name <> '') and (i < NLayer) do
  162.     i := succ(i);                          { suche einen freien Eintrag }
  163.   if Layers[i].name = '' then
  164.     With Layers[i] do
  165.       begin
  166.         name  := LName;
  167.         flags := Lflags;
  168.         color := Lcolor;
  169.         ltype := LLtype;
  170.       end;
  171. end;
  172.  
  173.  
  174. procedure RemoveLayer(Lname: NameStr);
  175. Var i : integer;
  176. begin
  177.   i := 1;
  178.   while (Layers[i].name <> Lname) and (i < NLayer) do
  179.     i := succ(i);
  180.   if Layers[i].name = LName then
  181.     With Layers[i] do
  182.       begin
  183.         name  := '';
  184.         flags :=  0;
  185.         color :=  0;
  186.         ltype := '';
  187.       end;
  188. end;
  189.  
  190.  
  191. function GetLayerColor(Var LName : NameStr):integer;
  192. Var i : integer;
  193. begin
  194.   i := 1;
  195.   while (Layers[i].name <> Lname) and (i < NLayer) do
  196.     i := succ(i);
  197.   if Layers[i].name = LName then
  198.     GetLayerColor := Layers[i].color
  199.   else
  200.     GetLayerColor := 1;
  201. end;
  202.  
  203.  
  204. Procedure InitDXF;
  205. Var AktLine       : String;
  206.     Name,LineType : String;
  207.     Color         : LongInt;
  208.     i             : integer;
  209. Begin
  210.   for i := 1 to NLayer do
  211.     With Layers[i] do              { Alle Layer löschen }
  212.       begin
  213.         name  := '';
  214.         flags :=  0;
  215.         color :=  0;
  216.         ltype := '';
  217.       end;
  218.   If GetInitFileListFirst('AutoCad','Layer',AktLine) Then
  219.     Repeat
  220.       If GetParaName(AktLine,Name) and GetParaInteger(AktLine,Color) Then
  221.         Begin
  222.           if Not GetParaName(AktLine,LineType) Then
  223.             LineType := 'CONTINUOUS';
  224.           AddLayer(Name,0,Color,LineType);
  225.         End;
  226.     Until Not GetInitFileListNext('Layer',AktLine)
  227.   Else AddLayer('0',0,15,'CONTINUOUS');
  228. End;
  229.  
  230.  
  231. { Scale und XScale nehmen die Transformation der Autocad-Koordinaten in das
  232.   einfache Kernel-Koordinatensystem vor. Die Verzerrung durch das Seiten/
  233.   Höhenverhältnis des Bildschirms wird nicht berücksichtigt.   }
  234.  
  235. procedure Scale(Var x1,y1 : double);
  236. begin
  237.   x1 := (PortMaxX * (x1-LIMMIN_X)) / (LIMMAX_X-LIMMIN_X);
  238.   y1 := PortMaxY - ((PortMaxY * (y1-LIMMIN_Y)) / (LIMMAX_Y-LIMMIN_Y));
  239. end;
  240.  
  241.  
  242. procedure XScale(Var r: double);
  243. begin
  244.   r := (PortMaxX * r) / (LIMMAX_X-LIMMIN_X);
  245. end;
  246.  
  247. procedure YScale(Var r: double);
  248. begin
  249.   r := (PortMaxY * r) / (LIMMAX_Y-LIMMIN_Y);
  250. end;
  251.  
  252.  
  253. { Die Elementar-Prozeduren von Autocad arbeiten im Autocad-Koordinatensystem
  254.   und bedienen sich der Skalierungsprozeduren }
  255.  
  256. procedure DXFLine(x1,y1,x2,y2: double; layer: NameStr);            { Linie }
  257. begin
  258.   Scale(x1,y1);
  259.   Scale(x2,y2);
  260.   Line(Integer(Round(x1)),Integer(Round(y1)),
  261.        Integer(Round(x2)),Integer(Round(y2)),GetLayerColor(layer));
  262. end;
  263.  
  264.  
  265. procedure DXFArc(x,y,aa,ae,r : double; layer: NameStr);      { Kreissegment }
  266. begin
  267.   Scale(x,y);
  268.   YScale(r);
  269.   Arc(Integer(Round(x)),Integer(Round(y)),
  270.       Integer(Round(aa)),Integer(Round(ae)),
  271.       Integer(Round(r)),GetLayerColor(layer));
  272. end;
  273.  
  274.  
  275. procedure DXFPoint(x,y : double; layer: NameStr);                  { Punkt }
  276. Var len : double;
  277. begin
  278.   len := PDSIZE / 2;
  279.   Case PDMODE of
  280.     0,1  :  begin
  281.               Scale(x,y);
  282.               SetPoint(Integer(Round(x)),Integer(Round(y)),GetLayerColor(layer));
  283.             end;
  284.     2    :  begin
  285.               DXFLine(x-len,y    ,x+len,y,layer);
  286.               DXFLine(x    ,y-len,x    ,y+len,layer);
  287.             end;
  288.     3    :  begin
  289.               DXFLine(x-len,y-len,x+len,y+len,layer);
  290.               DXFLine(x+len,y-len,x-len,y+len,layer);
  291.             end;
  292.     end;
  293. end;
  294.  
  295.  
  296. procedure DXFCircle(x,y,r : double; layer: NameStr);           { Vollkreis }
  297. begin
  298.   Scale(x,y);
  299.   XScale(r);
  300.   Circle(Integer(Round(x)),Integer(Round(y)),
  301.          Integer(Round(r)),GetLayerColor(layer));
  302. end;
  303.  
  304.  
  305. procedure DXFText(x,y,h : double; str: string; layer: NameStr);     { Text }
  306. Var X0, Y0, FakX, FakY : Integer;
  307. begin
  308.   y := y + h/4;
  309.   Scale(x,y);
  310.   YScale(h);
  311.   X0   := Integer(Round(x));
  312.   Y0   := Integer(Round(y));
  313.   FakX := Integer(Round(h));
  314.   FakY := Integer(Round(h));
  315.   DrawText(X0,Y0,FakX,FakY,Str,GetLayerColor(layer));
  316. End;
  317.  
  318.  
  319. { GetNextGroup liest aus der DXF-Datei die nächste Gruppe und liefert als
  320.   direktes Ergebnis den Gruppencode zurück. Je nach Art der Gruppe (Text,
  321.   integer oder real ) wird einer der VAR-Parameter belegt. Bei Fehlern
  322.   wird 99 zurückgeliefert.   }
  323.  
  324. Function GetNextGroup(Var str: string; Var re: double; Var int: integer):integer;
  325. Var line: string;
  326.     code: integer;
  327.     err : integer;
  328.     i   : integer;
  329. begin
  330.   if eof(f) then GetNextGroup := 99  { Fehlercode }
  331.   else
  332.     begin
  333.       readln(f,line);                { Gruppencode lesen }
  334.       val(line, code, err);
  335.       GetNextGroup := code;
  336.       if err = 0 then
  337.         begin
  338.           readln(f,line);
  339.           Case code of
  340.             0.. 9  : str := line;
  341.            10..59  : val(line,  re, err);
  342.            60..79  : val(line, int, err);
  343.             end;
  344.           if err <> 0 then GetNextGroup := 99;
  345.         end
  346.       else GetNextGroup := 99;
  347.     end;
  348. end;
  349.  
  350. { Die Autocad DXF-Datei besteht aus vier Teilen, die grösstenteils fakultativ
  351.   sind. Für jeden Teil der Datei existiert eine eigene Prozedur zur Bear-
  352.   beitung.  }
  353.  
  354. procedure ProcHeader;        { Verarbeitet den Abschnitt "Header" }
  355. Var code : integer;
  356.     str  : string;
  357.     re   : double;
  358.     re1  : double;
  359.     re2  : double;
  360.     int  : integer;
  361.     code2: integer;
  362.     index: integer;
  363. begin
  364.   repeat
  365.     Code := GetNextGroup(str, re, int);
  366.     if code = 9 then                           { Autocad-Systemvariable   }
  367.       begin
  368.         index := 1;
  369.         while (SysWords[index] <> str) and (index < NVars) do
  370.           index := succ(index);
  371.         if SysWords[index] = str then
  372.           Case index of
  373.  
  374.             1 : begin
  375.                   code  := GetNextGroup(str, re1, int);
  376.                   code2 := GetNextGroup(str, re2, int);
  377.                   if (code = 10) and (code2 = 20) then
  378.                     begin
  379.                       LIMMIN_X := re1;
  380.                       LIMMIN_Y := re2;
  381.                     end;
  382.                 end;
  383.  
  384.             2 : begin
  385.                   code  := GetNextGroup(str, re1, int);
  386.                   code2 := GetNextGroup(str, re2, int);
  387.                   if (code = 10) and (code2 = 20) then
  388.                     begin
  389.                       LIMMAX_X := re1 ;
  390.                       LIMMAX_Y := re2 ;
  391.                     end;
  392.                 end;
  393.  
  394.             3 : begin
  395.                   code  := GetNextGroup(str, re1, int);
  396.                   code2 := GetNextGroup(str, re2, int);
  397.                   if (code = 10) and (code2 = 20) then
  398.                     begin
  399.                       EXTMIN_X := re1;
  400.                       EXTMIN_Y := re2;
  401.                     end;
  402.                 end;
  403.  
  404.             4 : begin
  405.                   code  := GetNextGroup(str, re1, int);
  406.                   code2 := GetNextGroup(str, re2, int);
  407.                   if (code = 10) and (code2 = 20) then
  408.                     begin
  409.                       EXTMAX_X := re1;
  410.                       EXTMAX_Y := re2;
  411.                     end;
  412.                 end;
  413.  
  414.             5 : begin
  415.                   code  := GetNextGroup(str, re1, int);
  416.                   code2 := GetNextGroup(str, re2, int);
  417.                   if (code = 10) and (code2 = 20) then
  418.                     begin
  419.                       VIEWCTR_X := re1;
  420.                       VIEWCTR_Y := re2;
  421.                     end;
  422.                  end;
  423.  
  424.              6 : begin
  425.                    code  := GetNextGroup(str, re1, int);
  426.                    if (code = 10) then TDCREATE := re1;
  427.                  end;
  428.  
  429.              7 : begin
  430.                    code  := GetNextGroup(str, re1, int);
  431.                    if (code = 10) then TDUPDATE := re1;
  432.                  end;
  433.  
  434.              8 : begin
  435.                    code := GetNextGroup(str, re1, int);
  436.                    if code = 70 then PDMODE := int;
  437.                  end;
  438.  
  439.              9 : begin
  440.                    code := GetNextGroup(str, re1, int);
  441.                    if code = 40 then PDSIZE := re1;
  442.                  end;
  443.  
  444.              end; { Case }
  445.       end;
  446.   until (code = 0) or (code = 99);             { Ende bei Code 0 oder Err }
  447. end;
  448.  
  449.  
  450. procedure ProcTables;        { Verarbeitet den Abschnitt "Tables" }
  451. Var   Code  : integer;
  452.       str   : string;
  453.       re    : double;
  454.       int   : integer;
  455.       index : integer;
  456.  
  457.   procedure ProcLtype;       { Subblock A "LTYPE" }
  458.   Var code : integer;
  459.       str  : string;
  460.       re   : double;
  461.       int  : integer;
  462.       i    : integer;
  463.       lt   : LType;
  464.   begin
  465.     code := GetNextGroup(str,re,int);       { Anzahl Einträge überlesen }
  466.  
  467.     repeat
  468.       code := GetNextGroup(str,re,int);
  469.       if (code = 0) and (str = 'LTYPE') then
  470.         begin
  471.           code := GetNextGroup(lt.name,re,int);
  472.           code := GetNextGroup(str,re,lt.flags);
  473.           code := GetNextGroup(lt.desc,re,int);
  474.           code := GetNextGroup(str,re,lt.just);
  475.           code := GetNextGroup(str,re,lt.nE);
  476.           code := GetNextGroup(str,lt.totlen,int);
  477.           if lt.nE > MaxEle then lt.nE := MaxEle;
  478.           for i := 1 to lt.nE do
  479.             code := GetNextGroup(str,lt.Eles[i],int);
  480.  
  481.           if code = 40 then
  482.             AddLtype(lt);
  483.         end;
  484.     until (code = 0) and ((str = 'ENDTAB') or (str = 'EOF'));
  485.   end;
  486.  
  487.   procedure ProcLayer;       { Subblock B "LAYER" }
  488.   Var code : integer;
  489.       str  : string;
  490.       re   : double;
  491.       int  : integer;
  492.       name : NameStr;
  493.       ltyp : NameStr;
  494.       color: integer;
  495.       flags: integer;
  496.   begin
  497.     code := GetNextGroup(str,re,int);       { Anzahl Einträge überlesen }
  498.  
  499.     repeat
  500.       code := GetNextGroup(str,re,int);
  501.       if (code = 0) and (str = 'LAYER') then
  502.         begin
  503.           code := GetNextGroup(name,re,int);
  504.           code := GetNextGroup(str,re,flags);
  505.           code := GetNextGroup(str,re,color);
  506.           code := GetNextGroup(ltyp,re,int);
  507.           if code = 6 then
  508.             AddLayer(name,flags,color,ltyp);
  509.         end;
  510.     until (code = 0) and ((str = 'ENDTAB') or (str = 'EOF'));
  511.   end;
  512.  
  513.   procedure ProcStyle;       { Subblock C "STYLE" }
  514.   begin
  515.     { für zukünftige Erweiterungen }
  516.   end;
  517.  
  518.   procedure ProcView;        { Subblock D "View"  }
  519.   begin
  520.     { für zukünftige Erweiterungen }
  521.   end;
  522.  
  523.  
  524.  
  525. begin
  526.   repeat
  527.     repeat                                  { Suche die nächste Tabelle   }
  528.       Code := GetNextGroup(str, re, int);
  529.     until (code = 99) or ((code = 0) and ((str='TABLE') or (str = 'ENDSEC')));
  530.     if (code = 0) and (str = 'TABLE') then
  531.       begin                                 { eine von 4 Tabellen gefunden }
  532.         Code := GetNextGroup(str,re,int);
  533.         if Code = 2 then
  534.           begin
  535.             index := 1;
  536.             while (TabWords[index] <> str) and (index < NTab) do
  537.               index := succ(index);
  538.             if TabWords[index] = str then
  539.               Case index of
  540.                  1  : ProcLtype;   { Tabelle "LTYPE" für Linientypen  }
  541.                  2  : ProcLayer;   { Tabelle "LAYER" für Layertypen   }
  542.                  3  : ProcStyle;   { Tabelle "STYLE" für Schriftstile }
  543.                  4  : ProcView;    { Tabelle "View"  für Ausschnitte  }
  544.               end; { Case }
  545.           end;
  546.       end;
  547.   until (Code = 99) or ((code = 0) and (str = 'ENDSEC'));
  548. end;
  549.  
  550. procedure ProcBlocks;        { Verarbeitet den Abschnitt "Blocks" }
  551. begin
  552.   { für zukünftige Erweiterungen }
  553. end;
  554.  
  555. procedure ProcEntities;      { Verarbeitet den Abschnitt "Entities" }
  556. Var code : integer;
  557.     str  : string;
  558.     re   : double;
  559.     re1  : double;
  560.     re2  : double;
  561.     re3  : double;
  562.     re4  : double;
  563.     re5  : double;
  564.     int  : integer;
  565.     code2: integer;
  566.     index: integer;
  567.     ready: boolean;
  568.     lay  : NameStr;
  569.     i    : integer;
  570.     FirstX : double;
  571.     FirstY : double;
  572. begin
  573.   ready := false;
  574.   repeat
  575.     Code := GetNextGroup(str, re, int);
  576.     if code = 0 then
  577.       begin
  578.         index := 1;
  579.         for i := 1 to length(str) do str[i] := Upcase(str[i]);
  580.         while (EntityWords[index] <> str) and (index < NEnt) do
  581.           index := succ(index);
  582.         if EntityWords[index] = str then
  583.           Case index of
  584.             1 : ready := true;              { ENDSEC erreicht }
  585.  
  586.             2 : begin                       { Line   }
  587.                   code  := GetNextGroup(lay, re5, int);
  588.                   code  := GetNextGroup(str, re1, int);
  589.                   if code = 62 then
  590.                       { Farbe nicht von Layer }
  591.                     code := GetNextGroup(str, re1, int);
  592.  
  593.                   code  := GetNextGroup(str, re2, int);
  594.                   code  := GetNextGroup(str, re3, int);
  595.                   code2 := GetNextGroup(str, re4, int);
  596.                   if (code = 11) and (code2 = 21) then
  597.                       DXFLine(re1,re2,re3,re4,lay)
  598.                    else
  599.                      write(#7);
  600.                 end;
  601.  
  602.             3 : begin                       { Arc   }
  603.                   code  := GetNextGroup(lay, re5, int);
  604.                   code  := GetNextGroup(str, re1, int);
  605.                   code  := GetNextGroup(str, re2, int);
  606.                   code  := GetNextGroup(str, re3, int);
  607.                   code  := GetNextGroup(str, re4, int);
  608.                   code2 := GetNextGroup(str, re5, int);
  609.                   if (code = 50) and (code2 = 51) then
  610.                       DXFArc(re1,re2,re4,re5,re3,lay);
  611.                 end;
  612.  
  613.             4 : begin                       { Point }
  614.                   code := GetNextGroup(lay,re1,int);
  615.                   code := GetNextGroup(str,re1,int);
  616.                   if code = 62 then
  617.                     code := GetNextGroup(str, re1, int);
  618.                   code2:= GetNextGroup(str,re2,int);
  619.                   if (code = 10) and (code2 = 20) then
  620.                      DXFpoint(re1,re2,lay);
  621.                 end;
  622.  
  623.             5 : begin                       { Circle }
  624.                   code := GetNextGroup(lay,re1,int);
  625.                   code := GetNextGroup(str,re1,int);
  626.                   code := GetNextGroup(str,re2,int);
  627.                   code2:= GetNextGroup(str,re3,int);
  628.                   if (code = 20) and (code2 = 40) then
  629.                      DXFCircle(re1,re2,re3,lay);
  630.                 end;
  631.  
  632.             6 : begin                        { Text }
  633.                   code := GetNextGroup(lay,re1,int);
  634.                   code := GetNextGroup(str,re1,int);
  635.                   code := GetNextGroup(str,re2,int);
  636.                   code := GetNextGroup(str,re3,int);
  637.                   code2:= GetNextGroup(str,re4,int);
  638.                   if (code = 40) and (code2 = 1) then
  639.                      DXFText(re1,re2,re3,str,lay);
  640.                 end;
  641.  
  642.             7 : begin                        { Polyline }
  643.                   code := GetNextGroup(lay,re1,int);
  644.     {             code2:= GetNextGroup(str,re1,int);  }
  645.     {             if code = 8 then                    }
  646.                     begin
  647.                       PolyLayer := lay;
  648.                       PolyMode  :=   0;
  649.                     end;
  650.                 end;
  651.  
  652.             8 : begin                        { Vertex  }
  653.                   code := GetNextGroup(lay,re1,int);
  654.                   code := GetNextGroup(str,re1,int);
  655.                   if code = 62 then
  656.                     code := GetNextGroup(str, re1, int);
  657.                   code2:= GetNextGroup(str,re2,int);
  658.                   if (code = 10) and (code2=20) then
  659.                     Case PolyMode of
  660.                       0 :  begin  { erster Punkt }
  661.                              PolyLastX := re1;
  662.                              PolyLastY := re2;
  663.                              PolyFirstX:= re1;
  664.                              PolyFirstY:= re2;
  665.                              PolyMode := 1;
  666.                            end;
  667.  
  668.                       1 : begin  { weiterer Punkt }
  669.                              DXFLine(PolyLastX,PolyLasty,re1,re2,PolyLayer);
  670.                              PolyLastX := re1;
  671.                              PolyLastY := re2;
  672.                            end;
  673.                      end;
  674.                 end;
  675.  
  676.             9 : begin
  677.                   { code := GetNextGroup(lay,re1,int); }
  678.                   PolyLayer := '';
  679.                   PolyMode  := -1; { abschalten }
  680. {                  DXFLine(PolyFirstX,PolyFirstY,PolyLastX,PolyLastY,PolyLayer);}
  681.                 end;
  682.  
  683.            10 : begin                      { Solid }
  684.                   code := GetNextGroup(lay,re1,int);  { layer }
  685.                   code2:= GetNextGroup(str,re1,int);
  686.                   code2:= GetNextGroup(str,re2,int);  { P1 }
  687.                   FirstX    := re1;
  688.                   FirstY    := re2;
  689.                   PolyLastX := re1;
  690.                   PolyLastY := re2;
  691.                   code := GetNextGroup(str,re1,int);  { P2 }
  692.                   code := GetNextGroup(str,re2,int);
  693.                   DXFLine(PolyLastX,PolyLasty,re1,re2,lay);
  694.                   PolyLastX := re1;
  695.                   PolyLastY := re2;
  696.                   code := GetNextGroup(str,re1,int);  { P3 }
  697.                   code := GetNextGroup(str,re2,int);
  698.                   DXFLine(PolyLastX,PolyLasty,re1,re2,lay);
  699.                   PolyLastX := re1;
  700.                   PolyLastY := re2;
  701.                   code := GetNextGroup(str,re1,int);
  702.                   code := GetNextGroup(str,re2,int);  { P4 }
  703.                   if (re1 = PolyLastX) and (re2 = PolyLastY)
  704.                     then
  705.                      begin
  706.                       re1 := FirstX;
  707.                       re2 := FirstY;
  708.                      end;
  709.                   DXFLine(PolyLastX,PolyLasty,re1,re2,lay);
  710.                 end;
  711.              else write(#7);
  712.             end; { Case }
  713.       end;
  714.   until (code = 99) OR ready;             { Ende bei Code 0 oder Err }
  715. end;
  716.  
  717.  
  718. function InterpretDXF(name : string):DXFErr;
  719. Var ready : boolean;
  720.     re    : double;
  721.     int   : integer;
  722.     str   : string;
  723.     code  : integer;
  724.  
  725. begin
  726.   HideMouse;
  727.   ready := false;
  728.   InitSysVars;
  729.   assign(f,name+'.dxf');
  730.   {$i- }
  731.   reset(f);
  732.   {$i+ }
  733.   if ioresult <> 0 then InterpretDXF := filenotfound
  734.   else
  735.    begin
  736.      InterpretDXF := ok;
  737.      repeat
  738.       repeat
  739.         Code := GetNextGroup(str, re, int);
  740.       until (code = 0) or (code = 99);             { aufsynchronisieren }
  741.       if code = 99 then InterpretDXF := syntax
  742.       else
  743.         begin
  744.          if str = 'EOF' then ready := true;
  745.          if str = 'SECTION' then
  746.            begin
  747.              Code := GetNextGroup(str,re,int);
  748.              if Code = 2 then
  749.                begin
  750.                  if str = 'HEADER'  then ProcHeader;
  751.                  if str = 'TABLES'  then ProcTables;
  752.                  if str = 'BLOCKS'  then ProcBlocks;
  753.                  If str = 'ENTITIES'then ProcEntities;
  754.                end;
  755.            end;
  756.         end;
  757.      until (Code = 99) or ready;
  758.      if not ready then InterpretDXF := syntax;
  759.      close(f);
  760.    end;
  761.   ShowMouse;
  762. end;
  763.  
  764.  
  765. end.
  766.  
  767.  
  768. { Revisionen :
  769.  
  770. 1.0     7.12.1990
  771. 1.1    15.12.1990    Polylinien sind jetzt robuster (Corel Draw Import)
  772.  
  773. }