Bricscad V13-V17 (BJ-Electrical) 線番数取得、リレー接点集計ツール

2017/08/19 リレー接点の集計を追加 (Ver.1.2)

Bricscad で開いているすべての図面から、線番を取得し、作成数を表示するツールです。
※外部から操作している (Delphi - ActiveX) ので、かなり遅いです。

 ・Canon チューブプリンタツール Mk2500PC 用のCSVファイルが作成できます。
 ・配線、線番を画面の中央に表示し、△マークで指示します。
 ・これにより、線番の無い配線、複数の線番がある場合も、見つけやすいです。
 ※配線上に線番が無いときは、端子記号が線番として採用されます。

・配線、線番を画面の中央に表示し、△マークで指示します。


・リレーの接点数を集計して、属性に書き込みます。(Ver.1.2)
 C接点は、a接点、b接点の線番によって判断しています。(ピン番号は無視)



■ダウンロード BcadSenban.zip (Ver.1.2 exe本体のみ)


unit BcadSenbanUnit;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, BricscadApp_TLB, BricscadDb_TLB, ComObj,
  Vcl.StdCtrls, Vcl.Grids, Vcl.ComCtrls, Vcl.Menus, Vcl.ExtDlgs, System.UITypes,
  Vcl.Buttons;

type
  LineCheck = record
    LineId : integer;
    Checked : boolean;
  end;
  SenbanId = record
    ObjectId : integer;
    DocumentId : integer;
  end;

type
  TForm3 = class(TForm)
    Button1: TButton;
    StringGrid1: TStringGrid;
    ProgressBar1: TProgressBar;
    Label1: TLabel;
    Label2: TLabel;
    MainMenu1: TMainMenu;
    N1: TMenuItem;
    CSV1: TMenuItem;
    SaveTextFileDialog1: TSaveTextFileDialog;
    SpeedButton1: TSpeedButton;
    Edit1: TEdit;
    UpDown1: TUpDown;
    UpDown2: TUpDown;
    SpeedButton2: TSpeedButton;
    Edit2: TEdit;
    SpeedButton3: TSpeedButton;
    SpeedButton4: TSpeedButton;
    SpeedButton5: TSpeedButton;
    SpeedButton6: TSpeedButton;
    Button2: TButton;
    N2: TMenuItem;
    N3: TMenuItem;
    N4: TMenuItem;
    N5: TMenuItem;
    N6: TMenuItem;
    N7: TMenuItem;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure CSV1Click(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    procedure StringGrid1Click(Sender: TObject);
    procedure UpDown1Click(Sender: TObject; Button: TUDBtnType);
    procedure SpeedButton2Click(Sender: TObject);
    procedure UpDown2Click(Sender: TObject; Button: TUDBtnType);
    procedure SpeedButton3Click(Sender: TObject);
    procedure SpeedButton4Click(Sender: TObject);
    procedure SpeedButton5Click(Sender: TObject);
    procedure SpeedButton6Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure N3Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
    RunFlag : boolean;
    //
    procedure DrawLineMarker(LineFlag: boolean);
  end;

var
  Form3: TForm3;

  // 線分の端点同士がつながる線分を一時的に保持
  LineIdAry : array of LineCheck;//integer;
  // 線分上の交点を一時的に保持
  KoutenIdAry : array of integer;
  SenbanStrAry : array of string;
  SenbanIdAry : array of SenbanId;

  // 線分上の線番を一時的に保持
  // 線分チェック済を保持
  LineCheckAry : array of LineCheck;

  function GetLineLineStart(doc : AcadDocument ; line : AcadLine) : integer;

implementation

{$R *.dfm}
procedure SgSortByCol2(sg : TStringGrid; col1, col2 :integer; NumFlag:boolean);
// StringGrid ソート
var
  i, j : integer;
  sl, sltemp : TStringList;
  s1, s0 : string;
begin
  // ソート
  sl := TStringList.Create;
  try
    sltemp := TStringList.Create;
    try
      with sg do begin
        for i := 1 to RowCount -2 do begin
          s0 := '';
          if col1 >= 0 then s0 := s0 + Cells[col1, i];
          if col2 >= 0 then s0 := s0 + Cells[col2, i];
          for j := i + 1 to RowCount -1 do begin
            s1 := '';
            if col1 >= 0 then s1 := s1 + Cells[col1, j];
            if col2 >= 0 then s1 := s1 + Cells[col2, j];

            if (not NumFlag and (s0 > s1)) or
               (NumFlag and (StrToIntDef(s0, 0) > StrToIntDef(s1, 0))) then begin
              slTemp.Assign(Rows[i]);
              Rows[i] := Rows[j];
              Rows[j] := slTemp;
              s0 := s1;
            end;
          end;
        end;
      end;
    finally
      slTemp.Free;
    end;
  finally
    sl.Free;
  end;
end;

procedure PointToPolygon(vpt : OleVariant; faz: double; var vpts: OleVariant);
// Point vpt を囲う四角形を返す
begin
  vpts[0] := vpt[0] - faz;
  vpts[1] := vpt[1] + faz;
  vpts[2] := 0;

  vpts[3] := vpt[0] + faz;
  vpts[4] := vpt[1] + faz;
  vpts[5] := 0;

  vpts[6] := vpt[0] + faz;
  vpts[7] := vpt[1] - faz;
  vpts[8] := 0;

  vpts[9] := vpt[0] - faz;
  vpts[10] := vpt[1] - faz;
  vpts[11] := 0;
end;

procedure StEdToFence(stpt, edpt :OleVariant; var vpts: OleVariant);
// 2座標をFence座標に
var
  i : integer;
begin
  // 線分の始点-終点をポイントリストに
  for i := 0 to 2 do vpts[i] := stpt[i];
  for i := 0 to 2 do vpts[i + 3] := edpt[i];
end;

function AddLineIdAry(objId : integer): integer;
var
  i, n: integer;
  flag : boolean;
begin
  n := Length(LineIdAry);
  if n = 0 then begin
    SetLength(LineIdAry, n + 1);
    with LineIdAry[n] do begin
      LineId := objId;
      Checked := False;
    end;
  end
  else begin
    flag := false;
    for i := 0 to n -1 do begin
      // すでに存在
      if LineIdAry[i].LineId = objId then begin
        flag := True;
        break;
      end;
    end;
    if not flag then begin
      SetLength(LineIdAry, n + 1);
      with LineIdAry[n] do begin
        LineId := objId;
        Checked := False;
      end;
    end;
  end;
  result := Length(LineIdAry);
end;

function AddKoutenIdAry(objId : integer): integer;
var
  i, n: integer;
  flag : boolean;
begin
  n := Length(KoutenIdAry);
  if n = 0 then begin
    SetLength(KoutenIdAry, n + 1);
    KoutenIdAry[n] := objId;
  end
  else begin
    flag := false;
    for i := 0 to n -1 do begin
      // すでに存在
      if KoutenIdAry[i] = objId then begin
        flag := True;
        break;
      end;
    end;
    if not flag then begin
      SetLength(KoutenIdAry, n + 1);
      KoutenIdAry[n] := objId;
    end;
  end;
  result := Length(KoutenIdAry);
end;

function Distance(vpt1, vpt2 : OleVariant): double;
// 2点間の2D距離
begin
  result := sqrt((vpt1[0] - vpt2[0]) * (vpt1[0] - vpt2[0])
               + (vpt1[1] - vpt2[1]) * (vpt1[1] - vpt2[1]));
end;

function GetLineLine(doc : AcadDocument) : integer;
// LineIdAry の線分の端点に接続する線分を取得
var
  line : AcadLine;
  i : integer;
  pts : OleVariant;
begin
  if Length(LineIdAry) > 0 then begin
    pts := VarArrayCreate([0, 11], varDouble);
    for i := 0 to Length(LineIdAry) - 1 do begin
      // 最初に検出した線分は除外する
      if not LineIdAry[i].Checked then begin
        line := doc.ObjectIdToObject(LineIdAry[i].LineId) as AcadLine;
        GetLineLineStart(doc, line);
      end;
    end;
  end;
  result := Length(LineIdAry);
end;

procedure MakeSelectionSet(doc : AcadDocument; const ssName : string; var ss : AcadSelectionSet);
// 選択セットを作成
var
  i : integer;
  ssets : AcadSelectionSets;
  flag : boolean;
begin
  flag := False;
  ssets :=doc.SelectionSets;
  if ssets.Count > 0 then begin
    for i := 0 to ssets.Count - 1 do begin
      if ssets.Item(i).Name = ssName then begin
        ss := ssets.Item(i);
        ss.Clear;
        flag := True;
      end;
    end;
  end;
  if not flag then
    ss := ssets.Add(ssName);
end;

function GetKoutenLine(doc : AcadDocument): integer;
// KoutenIdAryの交点マークに交差する線分を取得
var
  i, j : integer;
  filterType, filterData: OleVariant;
  pts : OleVariant;
  ss : AcadSelectionSet;
  blkref : AcadBlockReference;
begin
  pts := VarArrayCreate([0, 11], varDouble);

  // フィルターを作成
  filterType := VarArrayCreate([0, 2], varSmallInt);
  filterData := VarArrayCreate([0, 2], varVariant);

  filterType[0] := 8; // 画層
  filterData[0] := 'WIRE';
  filterType[1] := 0; // 図形
  filterData[1] := 'LINE';
  filterType[2] := 62; // 色
  filterData[2] := '256';

  // セレクションセットを作成
  MakeSelectionSet(doc, 'SSKOUTENLINE', ss);

  try
    if Length(KoutenIdAry) > 0 then begin
      for i := 0 to Length(KoutenIdAry) - 1 do begin
        blkref := doc.ObjectIdToObject(KoutenIdAry[i]) as AcadBlockReference;
        PointToPolygon(blkref.InsertionPoint, 0.1 , pts);
        ss.SelectByPolygon(acSelectionSetCrossingPolygon, pts, filterType, filterData);
        if ss.Count > 0 then begin
          for j := 0 to ss.Count - 1 do
            AddLineIdAry(ss.Item(j).ObjectID);
        end;
      end;
    end;
  finally
    ss.Delete;
  end;
  result := Length(LineIdAry);
end;

function GetLineKouten(doc : AcadDocument): integer;
// LineIdAry の線分上の交点を取得
var
  line : AcadLine;
  i, j, n : integer;
  filterType, filterData: OleVariant;
  pts : OleVariant;
  ss : AcadSelectionSet;
begin
  pts := VarArrayCreate([0, 5], varDouble);

  // フィルターを作成
  filterType := VarArrayCreate([0, 2], varSmallInt);
  filterData := VarArrayCreate([0, 2], varVariant);

  filterType[0] := 8; // 画層
  filterData[0] := 'WIRE';
  filterType[1] := 0; // 図形
  filterData[1] := 'INSERT';
  filterType[2] := 2; // 名前
  filterData[2] := 'CMARK';

  // セレクションセットを作成
  MakeSelectionSet(doc, 'SSLINEKOUTEN', ss);

  try
    n := Length(LineIdAry);
    if n > 0 then begin
      for i := 0 to n - 1 do begin
        line := doc.ObjectIdToObject(LineIdAry[i].LineId) as AcadLine;
        StEdToFence(line.StartPoint, line.EndPoint, pts);
        ss.SelectByPolygon(acSelectionSetFence, pts, filterType, filterData);
        if ss.Count > 0 then begin
          for j := 0 to ss.Count - 1 do
            AddKoutenIdAry(ss.Item(j).ObjectID);
        end;
      end;
    end;
  finally
    ss.Delete;
  end;
  result := Length(KoutenIdAry);
end;

function GetLineLineStart(doc : AcadDocument; line : AcadLine) : integer;
// 線分の端点につながる線分を取得
// 線分数を返す
var
  ss : AcadSelectionSet;
  j, k : integer;
  pta, ptb : OleVariant;
  pts : OleVariant;
  stpt, edpt : OleVariant;
  n : integer;
  d1,d2 : double;
  lineId : integer;
  filterType, filterData: OleVariant;
begin
  // セレクションセットを作成
  MakeSelectionSet(doc, 'SSLINELINE', ss);

  // 4点の3D座標リスト(配列数=4×3,添え字の上限 = 11)
  pts := VarArrayCreate([0, 11], varDouble);

  // フィルターを作成
  filterType := VarArrayCreate([0, 2], varSmallInt);
  filterData := VarArrayCreate([0, 2], varVariant);
  filterType[0] := 8; // 画層
  filterData[0] := 'WIRE';
  filterType[1] := 0; // 図形
  filterData[1] := 'LINE';
  filterType[2] := 62; // 色
  filterData[2] := '256'; // BYLAYER

  pta := line.StartPoint;
  ptb := line.EndPoint;
  lineId := line.ObjectID;

  AddLineIdAry(lineId);

  try
    for k := 0 to 1 do begin
      while True do begin

        PointToPolygon(pta, 0.1, pts);
        ss.Clear;
        ss.SelectByPolygon(acSelectionSetCrossingPolygon, pts, filterType, filterData);

        // 自分自身だけであれば終了
        if ss.Count < 2 then break;
        n := Length(LineIdAry);
        for j := 0 to ss.Count - 1 do begin
          if ss.Item(j).ObjectID <> lineId then begin
            line := ss.Item(j) as AcadLine;
            stpt := line.StartPoint;
            edpt := line.EndPoint;
            d1 := Distance(pta, stpt);
            d2 := Distance(pta, edpt);

            // 端点同士がつながる線分のみ
            if (d1 <= 0.1) or (d2 <= 0.1) then begin
              AddLineIdAry(ss.Item(j).ObjectID);
              // 次の端点を見つける
              if d1 <= 0.1 then pta := edpt
              else pta := stpt;
              // 基準線分を更新
              lineId := line.ObjectID;
            end;
            // 1つ見つかれば終了
            break;
          end;
        end;
        // 新規に取得できなければ終了(念のため)
        if n = Length(LineIdAry) then break;
      end;
      pta := ptb;
    end;
    ss.Clear;
  finally
    ss.Delete;
  end;
  result := Length(LineIdAry);
end;

procedure AddSenbanStr(const senban :string);
// 線番を一時的に保持
var
  i, n : integer;
  flag : boolean;
begin
  flag := false;
  n := Length(SenbanStrAry);
  // すでに存在するか
  if n > 0 then begin
    for i := 0 to n - 1 do begin
      if senban = SenbanStrAry[i] then begin
        flag := True;
        break;
      end;
    end;
  end;
  // 追加
  if not flag then begin
    SetLength(SenbanStrAry, n + 1);
    SenbanStrAry[n] := senban;
  end;
end;

function GetSenbanTextString(blkref : AcadBlockReference): string;
// ブロックから線番文字列を得る
// 属性名=SENBAN
var
  atts : OleVariant;
  att    : AcadAttributeReference;
  i : integer;
  idisp : IDispatch;
begin
  result := '';
  if blkref.HasAttributes then begin
    atts := blkref.GetAttributes;
    for i := 0 to VarArrayHighBound(atts, 1) do begin
      idisp  := atts[i];
      att := idisp as AcadAttributeReference;
      if att.TagString = 'SENBAN' then begin
        result := att.TextString;
        break;
      end;
    end;
  end;
end;

function GetSenban(doc : AcadDocument; docId :integer): string;
// 線上の線番を取得
var
  i, n, m : integer;
  line : AcadLine;
  stpt, edpt, pts : OleVariant;
  ss : AcadSelectionSet;
  filterType, filterData : OleVariant;
  blkref : AcadBlockReference;
  j : Integer;
  d1 , d2 : double;
  s : string;
begin
  result := '';

  // フェンス選択のための3D座標リスト
  pts := VarArrayCreate([0, 5], varDouble);

  // フィルターを作成
  filterType := VarArrayCreate([0, 2], varSmallInt);
  filterData := VarArrayCreate([0, 2], varVariant);
  filterType[0] := 8; // 画層
  filterData[0] := '*SENBAN*';
  filterType[1] := 0; // 図形
  filterData[1] := 'INSERT';
  filterType[2] := 2; // 図形
  filterData[2] := '*SENBAN*';

  n := Length(LineIdAry);
  if n > 0 then begin
    // 選択セットを作成
    MakeSelectionSet(doc, 'SSSENBAN', ss);
    try
      for i := 0 to n - 1 do begin
        line := doc.ObjectIdToObject(LineIdAry[i].LineId) as AcadLine;
        stpt := line.StartPoint;
        edpt := line.EndPoint;
        // 横線
        if abs(stpt[0] - edpt[0]) > abs(stpt[1] - edpt[1]) then begin
          // 線分の上側
          stpt[1] := stpt[1] + 2.0;
          edpt[1] := edpt[1] + 2.0;
        end
        else begin
          // 線分の左側
          stpt[0] := stpt[0] - 2.0;
          edpt[0] := edpt[0] - 2.0;
        end;
        StEdToFence(stpt, edpt, pts);
        ss.SelectByPolygon(acSelectionSetFence, pts, filterType, filterData);
        if ss.Count > 0 then begin
          for j := 0 to ss.Count - 1 do begin
            blkref := ss.Item(j) as AcadBlockReference;
            d1 := Distance(blkref.InsertionPoint, line.StartPoint);
            d2 := Distance(blkref.InsertionPoint, line.EndPoint);
            // 挿入起点が、ほぼ線上点
            if abs((d1 + d2) - Distance(line.StartPoint, line.EndPoint)) < 0.1 then begin
              // 線番の文字列を取得
              s := GetSenbanTextString(blkref);
              // 線番を保持
              if s <> '' then begin
                m := Length(SenbanIdAry);
                SetLength(SenbanIdAry, m + 1);
                with SenbanIdAry[m] do begin
                  ObjectId := blkref.ObjectID;
                  DocumentId := docId;
                end;
                AddSenbanStr(s);
              end;
            end;
          end;
        end;
      end;
    finally
      ss.Delete;
    end;
  end;
  n := Length(SenbanStrAry);
  if n > 0 then begin
    for i := 0 to n - 1 do begin
      if i = 0 then result := SenbanStrAry[i]
      else result := result + ',' + SenbanStrAry[i];
    end;
  end;
end;
function GetTbTextString(blkref : AcadBlockReference): string;
// ブロックから端子番号を得る
// 属性名=NAME + NAME1
var
  atts : OleVariant;
  att    : AcadAttributeReference;
  i : integer;
  idisp : IDispatch;
begin
  result := '';
  if blkref.HasAttributes then begin
    atts := blkref.GetAttributes;
    for i := 0 to VarArrayHighBound(atts, 1) do begin
      idisp  := atts[i];
      att := idisp as AcadAttributeReference;
      with att do begin
        if TagString = 'NAME' then
          result := TextString
        else
        if TagString = 'NAME1' then begin
          result := result + TextString;
          break;
        end;
      end;
    end;
  end;
end;

function GetTbNo(doc : AcadDocument; docId: integer): string;
// 線分の端点につながる端子番号を取得
var
  i, n, m : integer;
  line : AcadLine;
  stpt, edpt, pts : OleVariant;
  ss : AcadSelectionSet;
  filterType, filterData : OleVariant;
  blkref : AcadBlockReference;
  j, k : Integer;
  s : string;
begin
  result := '';

  // フェンス選択のためのポイントリスト
  pts := VarArrayCreate([0, 11], varDouble);

  // フィルターを作成
  filterType := VarArrayCreate([0, 2], varSmallInt);
  filterData := VarArrayCreate([0, 2], varVariant);
  filterType[0] := 8; // 画層
  filterData[0] := '*WIRE*';
  filterType[1] := 0; // 図形
  filterData[1] := 'INSERT';
  filterType[2] := 2; // 図形
  filterData[2] := 'INCIR*,OUTCIR*';

  n := Length(LineIdAry);
  if n > 0 then begin
    // 選択セットを作成
    MakeSelectionSet(doc, 'SSTBNO', ss);
    try
      for i := 0 to n - 1 do begin
        line := doc.ObjectIdToObject(LineIdAry[i].LineId) as AcadLine;
        stpt := line.StartPoint;
        edpt := line.EndPoint;
        for k := 0 to 1 do begin
          PointToPolygon(stpt, 0.1, pts);
          ss.SelectByPolygon(acSelectionSetCrossingPolygon, pts, filterType, filterData);
          if ss.Count > 0 then begin
            for j := 0 to ss.Count - 1 do begin
              blkref := ss.Item(j) as AcadBlockReference;
              // 端子番号の文字列を取得
              s := GetTbTextString(blkref);
              // 線番として保持
              if s <> '' then begin
                m := Length(SenbanIdAry);
                SetLength(SenbanIdAry, m + 1);
                with SenbanIdAry[m] do begin
                  ObjectId := blkref.ObjectID;
                  DocumentId := docId;
                end;
                AddSenbanStr(s);
              end;
            end;
          end;
          stpt := edpt;
          ss.Clear;
        end;
      end;
    finally
      ss.Delete;
    end;
  end;
  n := Length(SenbanStrAry);
  if n > 0 then begin
    for i := 0 to n - 1 do begin
      if i = 0 then result := SenbanStrAry[i]
      else result := result + ',' + SenbanStrAry[i];
    end;
  end;
end;

procedure LineCheckMark;
// 線分処理済みをチエック
var
  i, j : integer;
  n, m : integer;
begin
  n := Length(LineIdAry);
  m := Length(LineCheckAry);
  if (n > 0) and (m > 0) then begin
    for i := 0 to n - 1 do begin
      for j := 0 to m - 1 do begin
        if LineIdAry[i].LineId = LineCheckAry[j].LineId then begin
          LineCheckAry[j].Checked := True;
          break;
        end;
      end;
    end;
  end;
end;

function GetSheetNo(doc : AcadDocument): string;
// 図枠ブロック TITLE からシート番号を得る
// 属性名=ZSHEET
var
  i, k, n, m : integer;
  ss : AcadSelectionSet;
  filterType, filterData : OleVariant;
  blkref : AcadBlockReference;
  attr   : OleVariant;
  att    : AcadAttributeReference;
  idisp  : IDispatch;
  lays : AcadLayers;
  lay : AcadLayer;
  flag : boolean;
begin
  result := '';
  flag := false;
  // 画層ロック中は選択できないため、ロックを解除
  lays := doc.Layers;
  for i := 0 to lays.Count - 1 do begin
    if lays.Item(i).Name = 'TITLE' then begin
      lay := lays.Item(i);
      lay.Lock := false;
      flag := True;
      break;
    end;
  end;

  // フィルターを作成
  filterType := VarArrayCreate([0, 2], varSmallInt);
  filterData := VarArrayCreate([0, 2], varVariant);
  filterType[0] := 8; // 画層
  filterData[0] := 'TITLE';
  filterType[1] := 0; // 図形
  filterData[1] := 'INSERT';
  filterType[2] := 2; // 図形
  filterData[2] := 'TITLE';

  // 選択セットを作成
  MakeSelectionSet(doc, 'SSSHEET', ss);
  try
    ss.Select(acSelectionSetAll, EmptyParam, EmptyParam, filterType, filterData);
    if ss.Count > 0 then begin
      blkref := ss.Item(0) as AcadBlockReference;
      if (blkref.Name = 'TITLE') and blkref.HasAttributes then begin
        attr := blkref.GetAttributes;
        n := VarArrayLowBound(attr, 1);
        m := VarArrayHighBound(attr, 1);
        for k := n to m do begin
          // 個々の属性を取得
          idisp :=   attr[k];
          att := idisp as AcadAttributeReference;
          if 'ZSHEET' = att.TagString then begin
            Result := att.TextString;
            Break;
          end;
        end;
      end;
    end;
  finally
    ss.Delete;
  end;
  // 画層ロックを戻す
  if flag then lay.Lock := True
end;

procedure SenbanSeiri(sg : TStringGrid);
// 同じ線番で整理する
var
  i, j, n : integer;
begin
  with sg do begin
    if RowCount > 2 then begin
      n := RowCount;
      for i := n - 1 downto 2 do begin
        if (Cells[2, i] <> '') and (Cells[2, i] = Cells[2, i - 1]) then begin
          Cells[0, i - 1] := Cells[0, i - 1] + ',' + Cells[0, i];
          // シート名
          Cells[1, i - 1] := Cells[1, i - 1] + ',' + Cells[1, i];
          // 作成数
          Cells[3, i - 1] := IntToStr(
            StrToIntDef(Cells[3, i - 1], 0) + StrToIntDef(Cells[3, i], 0) - 2);
          // DocID
          Cells[6, i - 1] := Cells[6, i - 1] + ',' + Cells[6, i];
          // ObjectID
          Cells[7, i - 1] := Cells[7, i - 1] + ',' + Cells[7, i];
          // DocID
          Cells[8, i - 1] := Cells[8, i - 1] + ',' + Cells[8, i];
          // SenbanID
          Cells[9, i - 1] := Cells[9, i - 1] + ',' + Cells[9, i];

          for j := i to RowCount - 2 do Rows[j] := Rows[j + 1];
          RowCount := RowCount - 1;
        end;
      end;
    end;
  end;
end;

procedure TForm3.Button1Click(Sender: TObject);
var
  app  : AcadApplication;
  docs : AcadDocuments;
  doc : AcadDocument;
  ss : AcadSelectionSet;
  filterType, filterData: OleVariant;
  i, j, k : integer;
  line : AcadLine;
  linecnt : integer;
  cmarkcnt : integer;
  cnt : integer;
  s : string;
  limmax, limmin : OleVariant;
  sgcnt : integer;
  sht : string;
  Ticks : Cardinal;
  s1, s2 : string;
  ret : boolean;
begin
  try
    if not Supports(GetActiveOleObject('BricscadApp.AcadApplication'), AcadApplication, app) then begin
      ShowMessage('サポートされていない');
      exit;
    end;
  except
    ShowMessage('有効な BricsCAD が見つかりません.');
    exit;
  end;

  ret := MessageDlg('CADから線番情報を取得しますか?', mtInformation , [mbYes, mbNo], 0) = mrYes;
  if not ret then exit;

  Ticks := GetTickCount;

  Button1.Enabled := False;
  Button2.Enabled := True;

  RunFlag := True;

  // フィルターを作成
  filterType := VarArrayCreate([0, 2], varSmallInt);
  filterData := VarArrayCreate([0, 2], varVariant);
  filterType[0] := 8; // 画層
  filterData[0] := 'WIRE';
  filterType[1] := 0; // 図形
  filterData[1] := 'LINE';
  filterType[2] := 62; // 色
  filterData[2] := '256'; // BYLAYER

  sgcnt := 0;
  docs := app.Documents;
  // BeginUpdate
  SendMessage(StringGrid1.Handle, WM_SETREDRAW, 0, 0);
  try
    // SG 初期化
    with StringGrid1 do begin
      RowCount := 2;
      Row := 1;
      for k := 0 to ColCount - 1 do Cells[k, 1] := '';
    end;

    for k := 0 to docs.Count - 1 do begin
      Application.ProcessMessages;
      if not RunFlag then break;

      doc := docs.Item(k);
      with doc do begin
        // 念のためREGEN
        Regen(acActiveViewport);
        // 選択範囲(図枠の外は除外するため)
        limmin := GetVariable('LIMMIN');
        limmax := GetVariable('LIMMAX');

        Label1.Caption :=
           '[ ' + IntToStr(k + 1) + ' / ' + IntToStr(docs.Count)+ ' ] '+ Name;
      end;
      // シート番号
      sht := GetSheetNo(doc);
      // 選択セットを作成
      MakeSelectionSet(doc, 'SSWIRE', ss);

      try
        ss.Select(acSelectionSetWindow, limmin, limmax, filterType, filterData);
        if ss.Count > 0 then begin
          ProgressBar1.Max := ss.Count;

          // 線分チェックを用意
          SetLength(LineCheckAry, ss.Count);
          for i := 0 to ss.Count - 1 do begin
            with LineCheckAry[i] do begin
              LineId := ss.Item(i).ObjectID;
              Checked := false;
            end;
          end;

          // テンポラリを初期化
          SetLength(LineIdAry, 0);
          SetLength(KoutenIdAry, 0);
          SetLength(SenbanStrAry, 0);
          SetLength(SenbanIdAry, 0);

          for i := 0 to ss.Count - 1 do begin
            Application.ProcessMessages;
            if not RunFlag then break;

            Label2.Caption := IntToStr(i + 1) + ' / ' + IntToStr(ss.Count);
            ProgressBar1.StepIt;
            if not LineCheckAry[i].Checked then begin

              line := ss.Item(i) as AcadLine;

              // 端点同士つながる線分を取得
              GetLineLineStart(doc, line);
              // チェック済にする
              if Length(LineIdAry) > 0 then begin
                for j := 0 to Length(LineIdAry) - 1 do
                  LineIdAry[j].Checked := True;
              end;

              cnt := 0;

              while True do begin
                Application.ProcessMessages;
                if not RunFlag then break;

                linecnt := Length(LineIdAry);
                // その線分上の交点マークを取得
                GetLineKouten(doc);
                cmarkcnt := Length(KoutenIdAry);
                // 交点マークに掛かる線分を取得
                GetKoutenLine(doc);
                // その線分上の交点マークを取得
                GetLineKouten(doc);
                // 交点マークに掛かる線分を取得
                GetKoutenLine(doc);

                // その端点につながる線分を取得
                // 検出済みの線分は除外
                GetLineLine(doc);

                // チェック済にする
                if Length(LineIdAry) > 0 then begin
                  for j := 0 to Length(LineIdAry) - 1 do
                    LineIdAry[j].Checked := True;
                end;

                // 追加分がなければ終了
                if (linecnt = Length(LineIdAry)) and (cmarkcnt = Length(KoutenIdAry)) then
                  break;
                // 念のため、10回程度で終了(無限ループよけ)
                Inc(cnt);
                if cnt > 10 then break;
              end;

              // 処理済みにチェックマークを付ける
              LineCheckMark;

              // 線分上の線番を取得(','があれば、異なる線番がある)
              s := GetSenban(doc, k);
              // 線番が無ければ、端子番号を取得
              if s = '' then s := GetTbNo(doc, k);

              Inc(sgcnt);
              with StringGrid1 do begin
                if RowCount < sgcnt + 1 then
                  RowCount := sgcnt + 1;
                Cells[0, sgcnt] := IntToStr(sgcnt);
                // シート番号
                Cells[1, sgcnt] := sht;
                // 線番
                Cells[2, sgcnt] := s;
                // 作成数
                Cells[3, sgcnt] := IntToStr((Length(KoutenIdAry) + 1) * 2);

                // DocID
                Cells[6, sgcnt] := IntToStr(k);
                // ObjectID (線分の代表)
                Cells[7, sgcnt] := IntToHex(line.ObjectID, 8);

                if Length(SenbanIdAry) > 0 then begin
                  for j := 0 to Length(SenbanIdAry) - 1 do begin
                    s1 := IntToStr(SenbanIdAry[j].DocumentId);
                    s2 := IntToHex(SenbanIdAry[j].ObjectId, 8);
                    if j = 0 then begin
                      // 線番DocID
                      Cells[8, sgcnt] := s1;
                      // 線番ObjectID
                      Cells[9, sgcnt] := s2;
                    end
                    else begin
                      Cells[8, sgcnt] := Cells[8, sgcnt] + ',' + s1;
                      Cells[9, sgcnt] := Cells[9, sgcnt] + ',' + s2;
                    end;
                  end;
                end;
              end;
              // テンポラリを初期化
              SetLength(LineIdAry, 0);
              SetLength(KoutenIdAry, 0);
              SetLength(SenbanStrAry, 0);
              SetLength(SenbanIdAry, 0);

            end;
          end;
          SetLength(LineCheckAry, 0);
          ss.Clear;
        end;
      finally
        ss.Delete;
      end;
    end;
    // ソート
    SgSortByCol2(StringGrid1, 2, -1, false);
    // 同じ線番を整理
    SenbanSeiri(StringGrid1);
  finally
    // EndUpdate
    SendMessage(StringGrid1.Handle, WM_SETREDRAW, 1, 0);
    StringGrid1.Refresh;
  end;

  ProgressBar1.Position := 0;
  Label1.Caption := '';
  Label2.Caption := '';

  ShowMessage('終了しました.(' + Format('%.1f', [(GetTickCount - Ticks) / 1000]) + ' sec)');

  Button2.Enabled := False;
  Button1.Enabled := True;
end;

procedure TForm3.Button2Click(Sender: TObject);
begin
  RunFlag := False;
  Application.ProcessMessages;
end;

procedure TForm3.CSV1Click(Sender: TObject);
// CSV 保存
var
  sl : TStringList;
  i : integer;
  fname : TFIleName;
  ret : boolean;
begin
  if StringGrid1.RowCount <= 2 then exit;
  if SaveTextFileDialog1.Execute then begin
    fname := SaveTextFileDialog1.FileName;
    if Uppercase(ExtractFileExt(fname)) <> '.CSV' then
      fname := fname + '.csv';
    ret := True;
    if FileExists(fname) then
      ret := MessageDlg('すでに存在します.上書きしますか?',
         mtInformation , [mbYes, mbNo], 0) = mrYes;
    if ret then begin
      with StringGrid1 do begin
        //if RowCount > 2 then begin
          sl := TStringList.Create;
          try
            for i := 1 to RowCount - 1 do
              sl.Add(Cells[2, i] + ',,,' + Cells[3, i]);
            sl.SaveToFile(fname);
          finally
            sl.Free;
          end;
        //end;
      end;
    end;
  end;
end;

procedure TForm3.FormCreate(Sender: TObject);
begin
  Button2.Enabled := False;
  Label1.Caption := '';
  Label2.Caption := '';
  with StringGrid1 do begin
    ColCount := 10;
    Cells[0, 0] := 'No.';
    Cells[1, 0] := 'シート';
    Cells[2, 0] := '線番';
    Cells[3, 0] := '作成数';
    Cells[4, 0] := '1行目';
    Cells[5, 0] := '2行目';
    Cells[6, 0] := 'DocID';
    Cells[7, 0] := 'ObjectID';
    Cells[8, 0] := 'DocId';
    Cells[9, 0] := 'SenbanID';

    ColWidths[0] := 120;
    ColWidths[1] := 200;
    ColWidths[2] := 60;
    ColWidths[3] := 60;
    // 非表示
    ColWidths[4] := -1;
    ColWidths[5] := -1;
    ColWidths[6] := -1;
    ColWidths[7] := -1;
    ColWidths[8] := -1;
    ColWidths[9] := -1;

    RowCount := 2;
    Row := 1;
  end;
end;
procedure TForm3.N3Click(Sender: TObject);
begin
  Close;
end;

procedure TForm3.DrawLineMarker(LineFlag : boolean);
// 線番マーク
var
  app : AcadApplication;
  doc : AcadDocument;
  h, hnd : THandle;
  ARect : TRect;
  cx, cy : integer;
  dc : HDC;
  screensize : OleVariant;

  winsc : double;
  docId : integer;
  objId : integer;
  ret : boolean;
  line : AcadLine;
  blkref : AcadBlockReference;
  pt : OleVariant;
  i : integer;
  cel1, cel2 : integer;
  idx : integer;
  sl : TStringList;
  sbnon : boolean;
begin
  try
    if not Supports(GetActiveOleObject('BricscadApp.AcadApplication'),
      AcadApplication, app) then begin
        ShowMessage('サポートされていない');
        exit;
    end;
  except
    ShowMessage('有効な BricsCAD が見つかりません.');
    exit;
  end;

  // 線番がない
  with StringGrid1 do sbnon := Cells[8, Row] = '';
  // 線分マーク
  if LineFlag or sbnon then begin
    cel1 := 6;
    cel2 := 7;
    idx := UpDown1.Position - 1;
  end
  else begin
    // 線番マーク
    cel1 := 8;
    cel2 := 9;
    idx := UpDown2.Position - 1;
  end;
  sl := TStringList.Create;
  try
    with StringGrid1 do begin
      sl.CommaText := Cells[cel1, Row];
      if (sl.Count > 0) and (sl.Count> idx) then
        docId := StrToIntDef(sl[idx] , -1)
      else docId := -1;
      sl.CommaText := Cells[cel2, Row];
      if (sl.Count > 0) and (sl.Count> idx) then
        objId := StrToIntDef('$' + sl[idx], -1)
      else objId := -1;
        ret := (docId >= 0) and (objId > 0);
    end;
  finally
    sl.Free;
  end;

  if ret then begin
    doc := app.Documents.Item(docId);
    if app.ActiveDocument <> doc then begin
      doc.Activate;
      Sleep(100);
    end;
    pt := VarArrayCreate([0, 1], VarDouble);
    try
      if LineFlag or sbnon then begin
        line := doc.ObjectIdToObject(objId) as AcadLine;
        // 中点
        for i := 0 to 1 do
          pt[i] := (line.StartPoint[i] + line.EndPoint[i]) / 2.0;
      end
      else begin
        blkref := doc.ObjectIdToObject(objId) as AcadBlockReference;
        // 挿入起点
        for i := 0 to 1 do pt[i] := blkref.InsertionPoint[i];
      end;
      // ズーム
      app.ZoomCenter(pt, 220.0);

      // システム変数を取得
      screensize := doc.GetVariable('SCREENSIZE');
      h := GetWindow(app.HWND, GW_CHILD);
      h := GetWindow(h, GW_CHILD);
      // グラフィックウィンドウのハンドル
      // クラス名は、バージョンにより異なる(V13 の場合は、下記)
      hnd := FindWindowEx(h, 0, 'AfxFrameOrView100u', nil);
      if not IsWindow(hnd) then
        hnd := FindWindowEx(h, 0, 'AfxFrameOrView110u', nil);
      if not IsWindow(hnd) then
        hnd := FindWindowEx(h, 0, 'AfxFrameOrView120u', nil);
      if IsWindow(hnd) then begin
        // グラフィックウィンドウの矩形座標
        GetWindowRect(hnd, ARect);
        winsc := screensize[0] / (ARect.Right - ARect.Left);
        // グラフィック画面の中心座標
        cx := (ARect.Right - ARect.Left) div 2;
        cy := (Arect.Bottom - ARect.Top) div 2;
        cx := Trunc(cx * winsc);
        cy := Trunc(cy * winsc);
        // ウィンドウのデバイスコンテキストを取得
        dc := GetDC(hnd);
        // デバイスコンテキストの前景モードを反転色にする
        if GetROP2(dc) <> R2_NOT then SetROP2(dc, R2_NOT);
        // 三角形を描く
        MoveToEx(dc, cx, cy, nil);
        LineTo(dc, cx - 30, cy + 15);
        LineTo(dc, cx - 15, cy + 30);
        LineTo(dc, cx, cy);
        // デバイスコンテキストを解放
        ReleaseDC(hnd, dc);
      end
      else
        ShowMessage('グラフィックウィンドウ取得失敗');
    except
      ;
    end;
  end;
end;

procedure TForm3.SpeedButton1Click(Sender: TObject);
// 線番マーク >
begin
  with StringGrid1 do begin
    if Row < RowCount - 1 then Row := Row + 1
    else Row := 1;
  end;
  DrawLineMarker(True);
end;

procedure TForm3.SpeedButton2Click(Sender: TObject);
begin
  with StringGrid1 do begin
    if Row > 1 then Row := Row - 1
    else Row := RowCount - 1;
  end;
  DrawLineMarker(True);
end;

procedure TForm3.SpeedButton3Click(Sender: TObject);
begin
  with StringGrid1 do begin
    if Row < RowCount - 1 then Row := Row + 1
    else Row := 1;
  end;
  DrawLineMarker(False);
end;

procedure TForm3.SpeedButton4Click(Sender: TObject);
begin
  with StringGrid1 do begin
    if Row > 1 then Row := Row - 1
    else Row := RowCount - 1;
  end;
  DrawLineMarker(False);
end;

procedure TForm3.SpeedButton5Click(Sender: TObject);
begin
  DrawLineMarker(True);
end;

procedure TForm3.SpeedButton6Click(Sender: TObject);
begin
  DrawLineMarker(False);
end;

procedure TForm3.StringGrid1Click(Sender: TObject);
var
  sl : TStringList;
begin
  sl := TStringList.Create;
  try
    with StringGrid1 do
      sl.CommaText := Cells[7, Row];
    with UpDown1 do begin
      Max := sl.Count;
      Position := Max;
    end;
    with StringGrid1 do
      sl.CommaText := Cells[9, Row];
    with UpDown2 do begin
      Max := sl.Count;
      Position := Max;
    end;
  finally
    sl.Free;
  end;
end;

procedure TForm3.UpDown1Click(Sender: TObject; Button: TUDBtnType);
begin
  // 複数線分群
  DrawLineMarker(True);
end;

procedure TForm3.UpDown2Click(Sender: TObject; Button: TUDBtnType);
begin
  // 線番
  DrawLineMarker(false);
end;

end.