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.