R12 形式の DXF ファイルを作る (2016/ 8/19)

■R12 形式の DXF ファイルは、ハンドル番号、ハンドル数、クラス名が不要なので、作りやすいです。
 ただし、R12 時代に無い図形は作成できません。例えば、LWPOLYLINE は、POLYLINE で作成します。

※ファイルを挿入するとき、ファイル名の前に "*" を付けると、分解挿入されます。
 分解挿入の時、尺度指定の S オプションが、使えなくなり、X, Y の尺度を指定する必要があります。


unit AcadR12Dxf;

interface
uses
  Windows,        //for TPoint
  System.UITypes,
  SysUtils,
  Graphics,
  Classes;        //for TStrings

type
  TAcadPoint = Record
    x, y, z :Extended;
  end;

var
  procedure MakeR12DxfHead(sl: TStrings);
  procedure AddR12DxfEntHead(sl: TStringList);
  procedure AddR12DxfLineEnt(sl: TStrings; p1, p2: TAcadPoint; const Layer: string; const LType: string; LColor: integer);
  procedure AddR12DxfTextEnt(sl: TStrings;
      const Text: String; pt10, pt11: TAcadPoint; Takasa, Haba, Kakudo: double;
      code72, code73: integer; const Kiten: string; const Lay: string; color: integer);
  procedure AddR12DxfCircleEnt(sl: TStrings; Center: TAcadPoint; hankei: double; const Layer: string; const LType: string; LColor: integer);
  procedure AddR12DxfArcEnt(sl: TStrings; Center: TAcadPoint; hankei, StDeg, EdDeg: double; const Layer: string; const LType: string; LColor: integer);
  procedure AddR12DxfTerm(sl: TStrings);
  procedure AddR12DxfLtypeHidden2(sl: TStrings);
  procedure AddR12DxfLtypeDummy(sl: TStrings);

implementation

procedure MakeR12DxfHead(sl: TStrings);
begin
    sl.Clear;
    sl.Add('  0' + #13#10 + 'SECTION' + #13#10 + '  2' + #13#10 + 'HEADER' + #13#10 +
      '  9' + #13#10 + '$ACADVER' + #13#10 + '  1' + #13#10 + 'AC1009' + #13#10 +
      '  9' + #13#10 + '$CELTYPE' + #13#10 + '  6' + #13#10 + 'BYLAYER' + #13#10 +
      '  9' + #13#10 + '$CECOLOR' + #13#10 + ' 62' + #13#10 + '256' + #13#10 +
      '  0' + #13#10 + 'ENDSEC');
    sl.Add('  0' + #13#10 + 'SECTION' + #13#10 + '  2' + #13#10 + 'TABLES');
end;
procedure AddR12DxfTerm(sl: TStrings);
begin
    sl.Add('  0' + #13#10 + 'ENDSEC');
    sl.Add('  0' + #13#10 + 'EOF');
end;

procedure AddR12DxfLtypeDummy(sl: TStrings);
begin
  with sl do
  begin
    // TABLESセクションのうちLTYPEだけを追加
    Add('  0' + #13#10 + 'TABLE');
    Add('  2' + #13#10 + 'LTYPE');
    Add(' 70' + #13#10 + '     2' + #13#10 + '  0' + #13#10 + 'LTYPE');
    Add('  2' + #13#10 + 'CONTINUOUS' + #13#10 + ' 70' + #13#10 + '     0' + #13#10 + '  3' + #13#10 + 'Solid line');
    Add(' 72' + #13#10 + '    65' + #13#10 + ' 73' + #13#10 + '     0' + #13#10 + ' 40' + #13#10 + '0.0');
    Add('  0' + #13#10 + 'ENDTAB');
  end
end;

procedure AddR12DxfLtypeHidden2(sl: TStrings);
begin
  with sl do
  begin
    // TABLESセクションのうちLTYPEだけを追加
    Add('  2' + #13#10 + 'LTYPE');
    Add('  0' + #13#10 + 'LTYPE' + #13#10 + '  2' + #13#10 + 'HIDDEN2' +
        #13#10 + ' 70' + #13#10 + '     0');
    Add('  3' + #13#10 + 'Hidden (.5x) _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _');
    Add(' 72' + #13#10 + '    65' + #13#10 + ' 73' + #13#10 + '     2');
    Add(' 40' + #13#10 + '4.7625' + #13#10 + ' 49' + #13#10 + '3.175' +
        #13#10 + ' 49' + #13#10 + '-1.5875');
    Add('  0' + #13#10 + 'ENDTAB');
  end
end;

procedure AddR12DxfEntHead(sl: TStringList);
begin
  with sl do begin
    Add('  0' + #13#10 + 'ENDSEC');
    Add('  0' + #13#10 + 'SECTION' + #13#10 + '  2' + #13#10 + 'ENTITIES');
  end;
end;

// R12形式なので、TTFは設定できない
// すでに存在するSTYLEの場合は、フォント名は適当で良い
procedure AddR12DxfTextStyle(sl: TStrings; const style, font1, font2: string);
begin
  with sl do begin
    Add('  0' + #13#10 + 'TABLE' + #13#10 + '  2' + #13#10 + 'STYLE' + #13#10 + ' 70' + #13#10 + '     1');
    Add('  0' + #13#10 + 'STYLE' + #13#10 + '  2' + #13#10 + style + #13#10 + ' 70' + #13#10 +'     0');
    Add(' 40' + #13#10 + '0.0' + #13#10 + ' 41' + #13#10 + '1.0' + #13#10 + ' 50' + #13#10 + '0.0');
    Add(' 71' + #13#10 + '     0' + #13#10 + ' 42' + #13#10 + '2.5' + #13#10 + '  3' + #13#10 + font1);
    Add('  4' + #13#10 + font2 + #13#10 + '  0' + #13#10 + 'ENDTAB');
  end;
end;

procedure AddR12DxfLineEnt(sl: TStrings; p1, p2: TAcadPoint; const Layer: string; const LType: string; LColor: integer);
begin
  with sl do begin
    Add('  0' + #13#10 + 'LINE');
    Add('  8' + #13#10 + Layer + #13#10 + '  6' + #13#10 + LType + #13#10 +
        ' 62' + #13#10 + IntToStr(LColor) + #13#10 + ' 48' + #13#10 + '1.0');
    Add(' 10' + #13#10 + FloatToStr(p1.x) + #13#10 + ' 20' + #13#10 + FloatToStr(p1.y) + #13#10 +
        ' 30' + #13#10 + FloatToStr(p1.z));
    Add(' 11' + #13#10 + FloatToStr(p2.x) + #13#10 + ' 21' + #13#10 + FloatToStr(p2.y) + #13#10 +
        ' 31' + #13#10 + FloatToStr(p2.z));
  end;
end;

procedure AddR12DxfCircleEnt(sl: TStrings; Center: TAcadPoint; hankei: double; const Layer: string; const LType: string; LColor: integer);
begin
  with sl do begin
    Add('  0' + #13#10 + 'CIRCLE');
    Add('  8' + #13#10 + Layer + #13#10 + '  6' + #13#10 + LType + #13#10 +
        ' 62' + #13#10 + IntToStr(LColor) + #13#10 + ' 48' + #13#10 + '1.0');
    Add(' 10' + #13#10 + FloatToStr(Center.x) + #13#10 + ' 20' + #13#10 + FloatToStr(Center.y) + #13#10 +
        ' 30' + #13#10 + FloatToStr(Center.z));
    Add(' 40' + #13#10 + FloatToStr(Hankei));
  end;
end;

procedure AddR12DxfArcEnt(sl: TStrings; Center: TAcadPoint; hankei, StDeg, EdDeg: double; const Layer: string; const LType: string; LColor: integer);
begin
  with sl do begin
    Add('  0' + #13#10 + 'ARC');
    Add('  8' + #13#10 + Layer + #13#10 + '  6' + #13#10 + LType + #13#10 +
        ' 62' + #13#10 + IntToStr(LColor) + #13#10 + ' 48' + #13#10 + '1.0');
    Add(' 10' + #13#10 + FloatToStr(Center.x) + #13#10 + ' 20' + #13#10 + FloatToStr(Center.y) + #13#10 +
        ' 30' + #13#10 + FloatToStr(Center.z));
    Add(' 40' + #13#10 + FloatToStr(Hankei) + #13#10 +
        ' 50' + #13#10 + FloatToStr(StDeg) + #13#10 + ' 51' + #13#10 + FloatToStr(EdDeg));
  end;
end;

procedure AddR12DxfTextEnt(sl: TStrings;
    const Text: String; pt10, pt11: TAcadPoint; Takasa, Haba, Kakudo: double;
    code72, code73: integer; const Kiten: string; const Lay: string; color :Integer);
var
  n: integer;
  s: string;
begin
  if kiten <> '' then begin
    s := Kiten;
    n := Length(s);
    if (n = 2) then begin
      if (s[1] = 'M') then code73 := 2
      else if (s[1] = 'T') then code73 := 3
      else if (s[1] = 'B') then code73 := 1;
      if (s[2] = 'L') then code72 := 0
      else if (s[2] = 'C') then code72 := 1
      else if (s[2] = 'R') then code72 := 2;
    end
    else if n = 1 then begin
      if (s[1] = 'L') then code72 := 0
      else if (s[1] = 'C') then code72 := 1
      else if (s[1] = 'R') then code72 := 2
      else if (s[1] = 'A') then code72 := 3
      else if (s[1] = 'M') then code72 := 4
      else if (s[1] = 'F') then code72 := 5;
    end;
  end;
  with sl do begin
    Add('  0' + #13#10 + 'TEXT');
    Add('  8' + #13#10 + Lay + #13#10 + '  6' + #13#10 + 'BYLAYER' + #13#10 +
        ' 62' + #13#10 + IntToStr(color) + #13#10 + ' 48' + #13#10 + '1.0');
    Add(' 10' + #13#10 + FloatToStr(pt10.x) + #13#10 + ' 20' + #13#10 + FloatToStr(pt10.y));
    Add(' 11' + #13#10 + FloatToStr(pt11.x) + #13#10 + ' 21' + #13#10 + FloatToStr(pt11.y));
    Add('  1' + #13#10 + Text);
    Add(' 40' + #13#10 + FloatToStr(takasa));
    Add(' 41' + #13#10 + FloatToStr(Haba));
    Add(' 50' + #13#10 + FloatToStr(Kakudo));
    Add(' 72' + #13#10 + IntToStr(code72) + #13#10 +' 73' + #13#10 + IntToStr(code73));
  end;
end;

//-----------------------------------------------------
// 使い方
procedure TForm1.Button1Click(Sender: TObject);
var
  sl : TStringList;
  p1, p2 : TAcadPoint;
  DxfName : TFileName;
begin
  p1.x := 100;
  p1.y := 200;
  p1.z := 0;
  p2.x := 200;
  p2.y := 100;
  p2.z := 0;
  
  sl := TStringList.Create;
  try
    // ヘッダー
    MakeR12DxfHead(sl);
    // TABLESセクションのうちLTYPEだけを追加
    AddR12DxfLtypeDummy(sl);
    // ENTITIES 開始
    AddR12DxfEntHead(sl);
    // 線分を追加
    AddR12DxfLineEnt(sl, p1, p2, '0', 'BYLAYER', 256);
    // ENDSEC
    AddR12DxfTerm(sl);
    // DXFファイルを追加
    DxfName := ChangeFileExt(ParamStr(0), '.dxf');
    // ファイルに保存
    sl.SaveToFile(DxfName);
    
  finally
    sl.Free;
  end;
end;