BcadParallel ２画面連動ズーム 2019/01/20
・2019/01/20 グラフィックウィンドウが取得できないことがあるのを手直し
・2019/01/15 イメージ上のマウス移動で、CAD上にクロスカーソルを描画を追加
・2019/01/14 初版作成
・２つの図面の同じ位置をパン、ズームします。が、かなり無理があります。
システム変数 VIEWSIZE（高さ）、VIEWCTR（中心） を監視し、前回と違う時、アクティブ図面を切り替え、表示位置とサイズを同じにします。
編集図面を２つだけにし、「ウィンドウ」 - 「左右にならべて表示」で、同じ大きさにしておく必要があります。
Capture のチェックを外すと、２図面連動の反応が速くなります。
中心、View サイズが変わると、一時的にアクティブ図面が切り替わるので、CAD 上の操作は中断されます。
Command = ':' にチェックを付けると、コマンドラインの文字列が ":"の時のみ、連動するようになり、中断されなくなります。
・２つの図面の色が異なるところを抽出します。
厳密な図面比較ではなく、画面をキャプチャーした画像のピクセル単位での比較です。グリッドの点、線も比較対象になります。
イメージをマウスクリックすると、CAD上の中心がその位置になります。
イメージ上にマウスを移動すると、CAD 上にクロスカーソルが描画されます。(2019/01/15)
イメージの上にある２つの数値は、２つのグラフィックウィンドウのハンドルで、00000000 でない時、比較が行われます。
■ダウンロード
・ダウンロード （EXE本体のみ。アイコンは、Delphi デフォルトのままです。）
// 2019/01/15 CAD 上にクロスカーソルを表示を追加
// 2019/01/20 グラフィックウィンドウのハンドルが取れないことがあるのを手直し
unit BcadZooerUnit4;
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.ExtCtrls;
type
TForm4 = class(TForm)
Button1: TButton;
Timer1: TTimer;
Edit1: TEdit;
Image1: TImage;
Edit2: TEdit;
CheckBox1: TCheckBox;
CheckBox2: TCheckBox;
procedure Button1Click(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{ Private 宣言 }
public
{ Public 宣言 }
end;
var
Form4: TForm4;
// CAD 座標
ViewH, ViewX, ViewY : double;
ViewW, ViewLeft, ViewTop : double;
// キャプチャーの尺度
captScale : double;
// 2つのWindow の左上座標
scrLeft, scrTop : array [0..1] of integer;
scrHwnd : array [0..1] of HWND;
scrXold, scrYold : array [0..1] of Integer;
// CAD の画面範囲 / Window サイズ
outScale : double;
// Image 上の前回のカーソル位置
curXold, curYold : Integer;
// Bricscad アプリケーションを保持
BcadApp : IAcadApplication;
implementation
{$R *.dfm}
// 画面の指定位置をBitmapに変換
procedure CaptureToBmp(Lf, Tp, W, H: Integer; bmp: TBitmap);
const
CAPTUREBLT = $40000000;
var
hdcScreen : HDC;
begin
bmp.Width := W;
bmp.Height := H;
hdcScreen := CreateDC('DISPLAY', nil, nil, nil);
try
BitBlt( bmp.Canvas.Handle, 0, 0, W, H, hdcScreen, Lf, Tp, SRCCOPY or CAPTUREBLT);
finally
DeleteDC(hdcScreen);
end;
end;
// 他のプロセス内のコントロールの文字列を得る
function GetWindowString(h: HWND): string;
var
buf : array [0..MAX_PATH - 1] of Char;
begin
result := '';
if IsWindow(h) then begin
FillChar(buf, Sizeof(buf), #0);
SendMessage(h, WM_GETTEXT, Length(buf), LPARAM(@buf));
result := string(buf);
end;
end;
// BricsCAD コマンドラインの文字列を得る
function GetBcadCmdLine: string;
var
h, hMain, h2 : HWND;
hCmdBar : HWND;
hCmdLine : HWND;
i : integer;
begin
result := '';
hMain := FindWindow('BricscadMainWindow', nil);
hCmdLine := 0;
if hMain <> 0 then begin
hCmdBar := FindWindowEx(hMain, 0, nil, 'コマンドライン');
if hCmdBar <> 0 then begin
h := hCmdBar;
for i := 1 to 4 do begin
h2 := GetWindow(h, GW_CHILD);
if h2 = 0 then break
else h := h2;
end;
hCmdLine := GetWindow(h, GW_HWNDNEXT);
end;
if hCmdLine = 0 then begin
hCmdBar := FindWindow(nil, 'コマンドライン');
if hCmdBar <> 0 then begin
h := hCmdBar;
for i := 1 to 5 do begin
h2 := GetWindow(h, GW_CHILD);
if h2 = 0 then break
else h := h2;
end;
hCmdLine := GetWindow(h, GW_HWNDNEXT);
end;
end;
if hCmdLine <> 0 then begin
result := GetWindowString(hCmdLine);
end;
end;
end;
// 起動中のBricsCAD を取得
function GetBcadApplication(var app: IAcadApplication; msgFlag: boolean): boolean;
const
BcadClassName = 'BricscadApp.AcadApplication';
begin
result := True;
try
if not Supports(GetActiveOleObject(BcadClassName), IAcadApplication, app) then begin
if msgFlag then ShowMessage('サポートされていません.');
result := False;
end;
except
if msgFlag then ShowMessage('有効な Bricscad が見つかりません．');
result := False;
end;
end;
// キャプチャー、比較
procedure CaptBmpCompare(h1, h2 : HWND; var outbmp : TBitmap);
type
TRGBStr = packed record
B, G, R : Byte;
end;
TRGBArray = array [0..65535] of TRGBStr;
PRGBArray = ^TRGBArray;
var
ARect : TRect;
Bmp1, Bmp2: TBitMap;
i, j : integer;
p1, p2 : PRGBArray;
outp : PRGBArray;
xsc, ysc : double;
x, y :integer;
begin
// ウィンドウの位置と大きさを取得
GetWindowRect(h1, ARect);
// 左上位置を保持
scrLeft[0] := ARect.Left;
scrTop[0] := ARect.Top;
// CAD 上の座標 （グローバル変数）
ViewW := (ViewH / ARect.Height) * ARect.Width;
ViewTop := ViewY + ViewH / 2;
ViewLeft := ViewX - ViewW / 2;
captScale := ARect.Height / ViewH;
xsc := outBmp.Width / ARect.Width;
ysc := outBmp.Height / ARect.Height;
if xsc < ysc then outScale := xsc
else outScale := ysc;
with outbmp do begin
Width := Trunc(ARect.Width * outScale);
Height:= Trunc(ARect.Height * outScale);
Canvas.Brush.Color := clBlack;
Canvas.Brush.Style := bsSolid;
Canvas.FillRect(Rect(0, 0, Width -1, Height -1));
end;
// グラフィックウィンドウの左上座標
Bmp1 := TBitMap.Create;
try
Bmp1.PixelFormat := pf24bit;
Bmp1.Width := ARect.Width;
Bmp1.Height := ARect.Height;
CaptureToBmp(ARect.Left, ARect.Top, Bmp1.Width, Bmp1.Height, Bmp1);
// ウィンドウの位置と大きさを取得
GetWindowRect(h2, ARect);
// 左上位置を保持
scrTop[1] := ARect.Top;
scrLeft[1] := ARect.Left;
// グラフィックウィンドウの左上座標
Bmp2 := TBitMap.Create;
try
Bmp2.PixelFormat := pf24bit;
Bmp2.Width := Bmp1.Width;
Bmp2.Height := Bmp1.Height;
CaptureToBmp(ARect.Left, ARect.Top, Bmp1.Width, Bmp1.Height, Bmp2);
for i := 0 to Bmp1.Height - 1 do begin
p1 := Bmp1.ScanLine[i];
p2 := Bmp2.ScanLine[i];
y := Trunc(i * outScale);
if y < outBmp.Height then begin
outp := outBmp.ScanLine[y];
for j := 0 to Bmp1.Width -1 do begin
if (p1[j].R <> p2[j].R ) or (p1[j].G <> p2[j].G) or (p1[j].B <> p2[j].B) then begin
x := Trunc(j * outScale);
if x < outbmp.Width then
if outp[x].G <> $ff then outp[x].G := $ff;
end;
end;
end;
end;
finally
Bmp2.Free;
end;
finally
Bmp1.Free;
end;
end;
procedure TForm4.Button1Click(Sender: TObject);
// 開始、停止ボタン
begin
Timer1.Enabled := not Timer1.Enabled;
if Timer1.Enabled then Button1.Caption := 'Stop'
else Button1.Caption := 'Start';
end;
procedure TForm4.FormCreate(Sender: TObject);
begin
Edit1.Text := '';
Edit2.Text := '';
// スクリーンの右下に表示
Left := Screen.Width - Width - 10;
Top := Screen.Height - Height - 130;
end;
// イメージ上マウスダウン
// CAD の中心座標を変える
procedure TForm4.Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
cadX, cadY : double;
vctr : OleVariant;
begin
if outScale > 0 then begin
cadY := ViewTop - (Y / outScale) / captScale;
cadX := ViewLeft + (X / outScale) / captScale;
if (FindWindow('BricscadMainWindow', nil) > 0) then begin
try
if Assigned(BcadApp) then begin
vctr := VarArrayCreate([0, 1], VarDouble);
vctr[0] := cadX;
vctr[1] := cadY;
SetForegroundWindow(BcadApp.HWND_);
BcadApp.ZoomCenter(vctr, ViewH);
end;
except
end;
end;
end;
end;
// イメージ上マウス移動
// CADのグラフィック画面のクロスカーソルを描く
procedure TForm4.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
var
cadX, cadY : double;
scrX, scrY : integer;
dc : HDC;
i : integer;
ARect : TRect;
begin
if (outScale > 0) and (captScale > 0) then begin
cadY := ViewTop - (Y / outScale) / captScale;
cadX := ViewLeft + (X / outScale) / captScale;
// CAD 上の座標を表示
Caption := Format('■ %.0f, %.0f',[cadX, cadY]);
for i := 0 to 1 do begin
if IsWindow(scrHwnd[i]) then begin
GetWindowRect(scrHwnd[i], ARect);
scrX := Trunc(X / outScale);
scrY := Trunc(Y / outScale);
// ウィンドウのデバイスコンテキストを取得
dc := GetDC(scrHwnd[i]);
try
// デバイスコンテキストの前景モードを反転色にする
if GetROP2(dc) <> R2_NOT then SetROP2(dc, R2_NOT);
// 前回の線を消す
if (scrXold[i] >= 0) and (scrYold[i] >= 0) then begin
MoveToEx(dc, scrXold[i], 0, nil);
LineTo(dc, scrXold[i], ARect.Height);
MoveToEx(dc, 0, scrYold[i], nil);
LineTo(dc, ARect.Width, scrYold[i]);
end;
MoveToEx(dc, scrX, 0, nil);
LineTo(dc, scrX, ARect.Height);
MoveToEx(dc, 0, scrY, nil);
LineTo(dc, Arect.Width, scrY);
scrXold[i] := scrX;
scrYold[i] := scrY;
finally
// デバイスコンテキストを解放
ReleaseDC(scrHwnd[i], dc);
end;
end;
end;
end;
end;
// システム変数監視
procedure TForm4.Timer1Timer(Sender: TObject);
var
docorg, doc : IAcadDocument;
docs : IAcadDocuments;
vsize : Double;
vctr : OleVariant;
i, j : Integer;
h1, h2 : HWND;
outbmp : TBitmap;
PT : TPoint;
curX, curY : integer;
cmdstr : string;
begin
Timer1.Enabled := False;
if (FindWindow('BricscadMainWindow', nil) > 0) then begin
try
if not Assigned(BcadApp) then
GetBcadApplication(BcadApp, False)
else begin
if CheckBox1.Checked then begin
// Image1 にカーソルを表示
GetCursorPos(PT);
curX := 0; curY := 0;
if (scrLeft[0] < scrLeft[1]) then begin
if (PT.X > scrLeft[1]) then begin
curX := PT.X - scrLeft[1];
curY := PT.Y - scrTop[1];
end
else begin
curX := PT.X - scrLeft[0];
curY := PT.Y - scrTop[0];
end;
end
else if (scrLeft[0] > scrLeft[1]) then begin
if (PT.X > scrLeft[0]) then begin
curX := PT.X - scrLeft[0];
curY := PT.Y - scrTop[0];
end
else begin
curX := PT.X - scrLeft[1];
curY := PT.Y - scrTop[1];
end;
end;
curX := Trunc(curX * outScale);
curY := Trunc(curY * outScale);
with Image1 do begin
if Assigned(Picture.Bitmap) then begin
//Canvas.Pen.Color := clWhite; // pmNot なので色は何色でも良い
Canvas.Pen.Mode := pmNot;
if (curYold >= 0) and (curXold >= 0) then begin
Canvas.MoveTo(0, curYold);
Canvas.LineTo(Width, curYold);
Canvas.MoveTo(curXold, 0);
Canvas.LineTo(curXold, Height);
end;
Canvas.MoveTo(0, curY);
Canvas.LineTo(Width, curY);
Canvas.MoveTo(curX, 0);
Canvas.LineTo(curX, Height);
curXold := curX;
curYold := curY;
end;
end;
end;
// システム変数を取得
docorg := BcadApp.ActiveDocument;
vsize := docorg.GetVariable('VIEWSIZE');
vctr := docorg.GetVariable('VIEWCTR');
if CheckBox2.Checked then
// コマンドラインの文字列
cmdstr := Trim(GetBcadCmdLine)
else
cmdstr := ':';
// グラフィックウィンドウのハンドル
h1 := docorg.HWND_;
for i := 0 to 1 do h1 := GetWindow(h1, GW_CHILD);
if h1 = 0 then begin
h1 := docorg.HWND_;
h1 := GetWindow(h1, GW_CHILD);
for i := 0 to 3 do h1 := GetWindow(h1, GW_HWNDNEXT);
h1 := GetWindow(h1, GW_CHILD);
end;
Edit1.Text := IntToHex(h1, 8);
scrHwnd[0] := h1;
// システム変数の値が違う
if (cmdstr = ':') and
((vsize <> ViewH) or (vctr[0] <> ViewX) or (vctr[1]<> ViewY)) then begin
outbmp := TBitmap.Create;
try
outbmp.PixelFormat := pf24bit;
outbmp.Width := Image1.Width-1;
outbmp.Height := Image1.Height-1;
ViewH := vsize;
ViewX := vctr[0];
ViewY := vctr[1];
docs := BcadApp.Documents;
for i := 0 to docs.Count -1 do begin
doc := docs.Item(i);
if doc <> docorg then begin
// 連動ズーム
BcadApp.ActiveDocument := doc;
BcadApp.ZoomCenter(vctr, vsize);
h2 := doc.HWND_;
for j := 0 to 1 do h2 := GetWindow(h2, GW_CHILD);
if h2 = 0 then begin
h2 := doc.HWND_;
h2 := GetWindow(h2, GW_CHILD);
for j := 0 to 3 do h2 := GetWindow(h2, GW_HWNDNEXT);
h2 := GetWindow(h2, GW_CHILD);
end;
Edit2.Text := IntToHex(h2, 8);
scrHwnd[1] := h2;
// キャプチャと比較
if CheckBox1.Checked then begin
if (h1 <> 0) and (h2 <> 0) and (h1 <> h2) then begin
CaptBmpCompare(h1, h2, outbmp);
// イメージに異差を表示
Image1.Picture.Assign(outbmp);
curYold := -1;
curXold := -1;
for j := 0 to 1 do begin
scrXold[j]:= -1;
scrYold[j]:= -1;
end;
end;
end;
end;
end;
finally
outbmp.Free;
end;
// 元のドキュメントに戻す
BcadApp.ActiveDocument := docorg;
end;
end;
except
end;
end;
Timer1.Enabled := True;
end;
end.