BcadParallel 2画面連動ズーム 2019/01/20
・2019/01/20 グラフィックウィンドウが取得できないことがあるのを手直し
・2019/01/15 イメージ上のマウス移動で、CAD上にクロスカーソルを描画を追加
・2019/01/14 初版作成
・2つの図面の同じ位置をパン、ズームします。が、かなり無理があります。
システム変数 VIEWSIZE(高さ)、VIEWCTR(中心) を監視し、前回と違う時、アクティブ図面を切り替え、表示位置とサイズを同じにします。
編集図面を2つだけにし、「ウィンドウ」 - 「左右にならべて表示」で、同じ大きさにしておく必要があります。
Capture のチェックを外すと、2図面連動の反応が速くなります。
中心、View サイズが変わると、一時的にアクティブ図面が切り替わるので、CAD 上の操作は中断されます。
Command = ':' にチェックを付けると、コマンドラインの文字列が ":"の時のみ、連動するようになり、中断されなくなります。
・2つの図面の色が異なるところを抽出します。
厳密な図面比較ではなく、画面をキャプチャーした画像のピクセル単位での比較です。グリッドの点、線も比較対象になります。
イメージをマウスクリックすると、CAD上の中心がその位置になります。
イメージ上にマウスを移動すると、CAD 上にクロスカーソルが描画されます。(2019/01/15)
イメージの上にある2つの数値は、2つのグラフィックウィンドウのハンドルで、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.