Bricscad V13-V19 (BJ-Electrical) 線番数取得、リレー接点集計ツール
2019/01/03 選択セットの取得を修正（ソースコードのみの変更）
2018/12/21 V19に対応。線番のシート名のソート、重複を除外を追加 (Ver.13)
2017/08/19 リレー接点の集計を追加 (Ver.1.2)
Bricscad で開いているすべての図面から、線番を取得し、作成数を表示するツールです。
※外部から操作している (Delphi - ActiveX) ので、かなり遅いです。
・Canon チューブプリンタツール Mk2500PC 用のCSVファイルが作成できます。
・配線、線番を画面の中央に表示し、△マークで指示します。
・これにより、線番の無い配線、複数の線番がある場合も、見つけやすいです。
※配線上に線番が無いときは、端子記号が線番として採用されます。
・配線、線番を画面の中央に表示し、△マークで指示します。
・リレーの接点数を集計して、属性に書き込みます。（Ver.1.2）
C接点は、ａ接点、ｂ接点の線番によって判断しています。（ピン番号は無視）
■ダウンロード BcadSenban.zip (Ver.1.3 exe本体のみ）
2019/01/03 選択セットの取得を変更
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);
// ２座標を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;
// ２点間の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;
{
// ss := doc.ActiveSelectionSet; が使えるため、コメントアウト。使用しない
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';
// セレクションセットを取得
ss := doc.ActiveSelectionSet;
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;
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';
// セレクションセットを取得
ss := doc.ActiveSelectionSet;
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;
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
// セレクションセットを取得
ss := doc.ActiveSelectionSet;
// 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);
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;
// １つ見つかれば終了
break;
end;
end;
// 新規に取得できなければ終了（念のため）
if n = Length(LineIdAry) then break;
end;
pta := ptb;
end;
ss.Clear;
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
// セレクションセットを取得
ss := doc.ActiveSelectionSet;
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;
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
// セレクションセットを取得
ss := doc.ActiveSelectionSet;
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;
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';
// セレクションセットを取得
ss := doc.ActiveSelectionSet;
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;
// 画層ロックを戻す
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);
// セレクションセットを取得
ss := doc.ActiveSelectionSet;
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;
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] := '１行目';
Cells[5, 0] := '２行目';
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.