ページを更新する

BcadCapture.exe for Bricscad V13

■概要
編集中のすべての図面を切り替え、画面をキャプチャーします。※
キャプチャーした画像は、シート番号（またはページ番号）順にソートされ、画像をダブルクリックすると、編集中の図面が切り替わります。
また、キャプチャーとは関係なく、連続実行する LISP コマンドを１個登録できます。
※シート番号（またはページ番号）を取得すると、結構時間がかかります。

プロパティーバーの下に置いた時


プロパティーバーを隠すくらいの大きさにした時


すべてを表示させた時


■設定画面


■ご注意
・Bricscadのバージョン、OS環境(32bit/64bit）が違うと動かないと思います。
・キャプチャ時点の情報しか保持していませんので、Bricscadの図面構成が変わると、正しく動きません。
・キャプチャ位置が合わないときは、「高DPI設定では、画面のスケーリングを無効にする」をチェックしてみて下さい。



■ダウンロード
　　BcadCapture.zip

■ソースコード

unit BcadCaptureUnit;
　
interface

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

type
  TDwgDoc = record
    Index : integer;
    Name : string;
    Comment : string;
  end;
type
  TForm2 = class(TForm)
    DrawGrid1: TDrawGrid;
    Panel1: TPanel;
    ComboBox1: TComboBox;
    SpeedButton1: TSpeedButton;
    PopupMenu1: TPopupMenu;
    N3: TMenuItem;
    N1: TMenuItem;
    N2: TMenuItem;
    SpeedButton2: TSpeedButton;
    SpeedButton3: TSpeedButton;
    procedure FormDestroy(Sender: TObject);
    procedure DrawGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
      Rect: TRect; State: TGridDrawState);
    procedure FormResize(Sender: TObject);
    procedure DrawGrid1DblClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure ComboBox1Change(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    procedure N3Click(Sender: TObject);
    procedure N2Click(Sender: TObject);
    procedure SpeedButton2Click(Sender: TObject);
    procedure SpeedButton3Click(Sender: TObject);
    procedure DrawGrid1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }

    // 取得するブロック名と属性名
    BlkName, BlkName1, BlkName2, AttName, AttName1, AttName2 : string;
    AttFlag1, AttFlag2 : boolean;

    // 連続実行するLISP
    LspFileName : TFileName;
    LspCmdName  : string;
    LspCommand  : string;
  end;

var
  Form2: TForm2;

  // キャプチャしたビットマップを保持
  BmpAry : array of TBitMap;
  // 図面名とその位置を保持
  DwgDocAry : array of TDwgDoc;
  // ビットマップの大きさ
  BmpW, BmpH : integer;
  // タイトル表示の高さ
  TitleH1, TitleH2 : integer;
  // シート名、ページ番号を表示する
  CmtDispFlag : boolean;
  // キャプチャ時、属性を取得
  CmtGetFlag  : boolean;
  BcadActiveFlag : boolean;

implementation


{$R *.dfm}

uses BcadCaptureCfgUnit;

//****************************************
// 画面の指定位置を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 GetAttString(doc : AcadDocument; const BlkName : string; const TagName : string): string;
var
  mspc   : AcadModelSpace;
  ent    : AcadEntity;
  blkref : AcadBlockReference;
  attr   : OleVariant;
  att    : AcadAttributeReference;
  idisp  : IDispatch;
  j , n, m, k : integer;
begin
  Result := '';
  mspc := doc.ModelSpace;

  if mspc.Count > 0 then begin
    for j := 0 to mspc.Count - 1 do begin
      ent := mspc.Item(j);
      if 'AcDbBlockReference' = ent.EntityName then begin
        blkref := ent as AcadBlockReference;
        if blkref.HasAttributes then begin
          if blkname = blkref.Name 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 TagName = att.TagString then begin
                Result := att.TextString;
                Break;
              end;
            end;
            break;
          end;
        end;
      end;
    end;
  end;
end;

// *******************************
// DwgDocAryをソート
// *******************************
procedure SortDwgDocAry;
var
  len, n, m : integer;
  i, j: integer;
  DwgDocTmp : TDwgDoc;
  s, s1 : string;
begin
  n := Length(DwgDocAry);
  if n > 1 then begin

    // コメント文字列の最大文字数
    len := 0;
    for i := 0 to n -1 do begin
      m := DwgDocAry[i].Comment.Length;
      if len < m then len := m;
    end;
    // 文字列比較のため同じ長さにする
    for i := 0 to n -1 do begin
      with DwgDocAry[i] do begin
        m := Comment.Length;
        if m < len then begin
          for j := 1 to len - m do begin
            Comment:= ' ' + Comment;
          end;
        end;
      end;
    end;
    // ソート
    for i := 0 to n - 2 do begin
      s := DwgDocAry[i].Comment + ':' + DwgDocAry[i].Name;
      for j := i + 1 to n - 1 do begin
        s1 := DwgDocAry[j].Comment + ':' + DwgDocAry[j].Name;
        if s1 < s then begin
          DwgDocTmp := DwgDocAry[i];
          DwgDocAry[i] := DwgDocAry[j];
          DwgDocAry[j] := DwgDocTmp;
          s := s1;
        end;
      end;
    end;
  end;
end;

procedure TForm2.ComboBox1Change(Sender: TObject);
var
  idx : integer;
  i : integer;
begin
  with ComboBox1 do begin
    idx := ItemIndex;
    if idx >= 0 then
      i := Integer(Items.Objects[idx])
    else
      i := -1;
  end;
  if (i >= 0) and (i < Length(DwgDocAry)) then begin
    with DrawGrid1 do begin
      Col := i mod ColCount;
      Row := i div ColCount;
    end;
  end;
end;

procedure TForm2.DrawGrid1Click(Sender: TObject);
var
  i : integer;
begin
  with DrawGrid1 do
    i := Row * ColCount + col;
  ComboBox1.ItemIndex := i;
end;

procedure TForm2.DrawGrid1DblClick(Sender: TObject);
var
  i, id : integer;
  app : IAcadApplication;
  docs : IAcadDocuments;
begin
  with DrawGrid1 do begin
    i := Row * ColCount + col;
    if (i >= 0) and (i < Length(DwgDocAry)) then begin
      try
        app := GetActiveOleObject('BricscadApp.AcadApplication') as IAcadApplication;
        docs := app.Documents;
        id := DwgDocAry[i].Index;
        ComboBox1.ItemIndex := i;
        if id < docs.Count then begin
          docs.Item(id).Activate;
          if BcadActiveFlag then
            // Bricscad をアクティブに
            SetForegroundWindow(app.HWND);
        end;
      except
        ShowMessage('有効な BricsCAD が見つかりません．');
      end;
    end;
  end;
end;

// **************************
// キャプチャ画像を描画
// **************************
procedure TForm2.DrawGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);
var
  i, w, h, dx, dy : integer;
  idx : integer;
begin
  with DrawGrid1 do begin
    // 現在の表示位置
    i := ARow * ColCount + Acol;

    idx := -1;
    if (i >= 0) and (i < Length(DwgDocAry)) then
      idx := DwgDocAry[i].Index;

    if (idx >= 0) and (idx < Length(BmpAry)) then begin
      w := BmpAry[idx].Width;
      h := BmpAry[idx].Height;

      dx := (DefaultColWidth - w) div 2;

      if not CmtDispFlag then
        dy := (DefaultRowHeight - h - TitleH1) div 2
      else
        dy := (DefaultRowHeight - h - TitleH2) div 2;

      with Canvas do begin
        if not CmtDispFlag then
          Draw(Rect.Left + dx, Rect.Top + dy + TitleH1, BmpAry[idx])
        else
          Draw(Rect.Left+dx,Rect.Top+dy + TitleH2, BmpAry[idx]);

        // 背景を塗りつぶし
        if (ARow = Row) and (ACol = Col) then
          Brush.Color := clBlue
        else
          Brush.Color := clGray;

        if not CmtDispFlag then
          Rectangle(Rect.Left + 1, Rect.Top + 1, Rect.Right - 1, Rect.Top + TitleH1 + 1)
        else
          Rectangle(Rect.Left + 1, Rect.Top + 1, Rect.Right - 1, Rect.Top + TitleH2 + 1);

        Font.Color := clWHITE;
        // タイトルを描画
        TextOut(Rect.Left + 3, Rect.Top + 3, ExtractFileName(DwgDocAry[i].Name));
        // コメントを描画
        if CmtDispFlag then
          TextOut(Rect.Left + 3, Rect.Top + 3 + TitleH1 + 1, DwgDocAry[i].Comment);

        // 標準の設定に戻す
        Pen.Style := psSolid;
        Brush.Style := bsClear;
        Pen.Color := clGray;
        Pen.Width := 1;
        Rectangle(Rect);
      end;
    end
    else begin
      with Canvas do begin
        Brush.Color := clWhite;
        FillRect(Rect);
      end;
    end;
  end;
end;

procedure TForm2.FormCreate(Sender: TObject);
var
  ini : TIniFile;
begin
  BmpH := 168;
  BmpW := 240;
  TitleH1 := 20;
  TitleH2 := 42;

  with DrawGrid1 do begin
    DefaultColWidth := BmpW;
    DefaultRowHeight := BmpH + 20;
    Options := Options + [goThumbTracking];
  end;

  BlkName := 'TITLE';
  AttName := 'ZSHEET';
  BlkName1 := BlkName;
  AttName1 := AttName;
  BlkName2 := BlkName;
  AttName2 := AttName;
  AttFlag1 := True;
  AttFlag2 := False;

  // ダブルクリックで Bricscad をアクティブに
  BcadActiveFlag := False;
  // コメント表示
  CmtDispFlag := True;
  // キャプチャ時、コメントを取得
  CmtGetFlag := True;

  LspFileName := '';
  LspCmdName := '';
  LspCommand := '';

  ini := TIniFile.Create(ChangeFileExt(ParamStr(0), '.ini'));
  try
    with Ini do begin
      Top := ReadInteger('Form', 'Top', Top);
      Left := ReadInteger('Form', 'Left', Left);
      Width:= ReadInteger('Form', 'Width', Width);
      Height := ReadInteger('Form', 'Height', Height);
      if Left >=  Screen.Width then Left := (Screen.Width + Width) div 2;
      if Top >= Screen.Height then Top := (Screen.Height + Height) div 2;

      BlkName1 := ReadString('Bcad', 'BlkName1', BlkName1);
      BlkName2 := ReadString('Bcad', 'BlkName2', BlkName2);
      AttName1 := ReadString('Bcad', 'AttName1', AttName1);
      AttName2 := ReadString('Bcad', 'AttName2', AttName2);
      AttFlag1 := ReadBool('Bcad', 'AttFlag1', AttFlag1);
      AttFlag2 := ReadBool('Bcad', 'AttFlag2', AttFlag2);

      BcadActiveFlag := ReadBool('Bcad', 'ActiveFlag', BcadActiveFlag);

      CmtDispFlag := ReadBool('BcadCapt', 'CmtDispFlag', CmtDispFlag);
      CmtGetFlag := ReadBool('BcadCapt', 'CmtGetFlag', CmtGetFlag);

      LspFileName := ReadString('Bcad', 'LispFileName', LspFileName);
      LspCmdName := ReadString('Bcad', 'LispCmdName', LspCmdName);
      LspCommand := ReadString('Bcad', 'LispCommand', LspCommand);

      // メニュー
      N2.Caption := LspCmdName;
      SpeedButton2.Caption := LspCmdName;
    end;
  finally
    ini.Free;
  end;

end;

procedure TForm2.FormDestroy(Sender: TObject);
var
  i : integer;
  ini : TIniFile;
begin
  if Length(BmpAry) > 0 then begin
    for i := 0 to Length(BmpAry) -1 do
      BmpAry[i].Free;
  end;
  ini := TIniFile.Create(ChangeFileExt(ParamStr(0), '.ini'));
  try
    with Ini do begin
      WriteInteger('Form', 'Top', Top);
      WriteInteger('Form', 'Left', Left);
      WriteInteger('Form', 'Width', Width);
      WriteInteger('Form', 'Height', Height);

      WriteString('Bcad', 'BlkName1', BlkName1);
      WriteString('Bcad', 'BlkName2', BlkName2);
      WriteString('Bcad', 'AttName1', AttName1);
      WriteString('Bcad', 'AttName2', AttName2);
      WriteBool('Bcad', 'AttFlag1', AttFlag1);
      WriteBool('Bcad', 'AttFlag2', AttFlag2);

      WriteBool('Bcad', 'ActiveFlag', BcadActiveFlag);

      WriteBool('BcadCapt', 'CmtDispFlag', CmtDispFlag);
      WriteBool('BcadCapt', 'CmtGetFlag', CmtGetFlag);

      WriteString('Bcad', 'LispFileName', LspFileName);
      WriteString('Bcad', 'LispCmdName', LspCmdName);
      WriteString('Bcad', 'LispCommand', LspCommand);


    end;
  finally
    ini.Free;
  end;
end;

// ***************************
// フォームリサイズ
// ***************************
procedure TForm2.FormResize(Sender: TObject);
var
  n, xcnt, ycnt:Integer;
begin
  n := Length(BmpAry);
  if n > 0 then begin
    with DrawGrid1 do begin
      xcnt := (Width - 23) div DefaultColWidth;
      if xcnt=0 then xcnt:=1;
      ycnt := n div xcnt;
      if n mod xcnt > 0 then Inc(ycnt);
      ColCount := xcnt;
      RowCount := ycnt;
    end;
  end;
end;

procedure TForm2.N2Click(Sender: TObject);
var
  app : IAcadApplication;
  docs : IAcadDocuments;
  adoc, doc : IAcadDocument;
  i : integer;
begin
  if (LspCommand <> '') then begin
    try
      app := GetActiveOleObject('BricscadApp.AcadApplication') as IAcadApplication;
      adoc := app.ActiveDocument;
      docs := app.Documents;
      for i := 0 to docs.Count - 1 do begin
        doc := docs.Item(i);
        doc.Activate;
        if LspFileName <> '' then
          doc.SendCommand(#27 + '(load "' + LspFileName + '")' + #13#10);
        doc.SendCommand(LspCommand + #13#10);
      end;
      adoc.Activate;
    except
      ShowMessage('有効な BricsCAD が見つかりません．');
    end;
  end;
end;

// ************************************
// 設定フォーム
// ************************************
procedure TForm2.N3Click(Sender: TObject);
begin
  Form3 := TForm3.Create(Form2);
  with Form3 do begin
    try
      Edit1.Text := BlkName1;
      Edit2.Text := AttName1;
      Edit3.Text := BlkName2;
      Edit4.Text := AttName2;
      Edit5.Text := BmpW.ToString;
      Edit6.Text := BmpH.ToString;
      Edit7.Text := TitleH1.ToString;
      Edit8.Text := TitleH2.ToString;

      CheckBox1.Checked := AttFlag1;
      CheckBox2.Checked := AttFlag2;
      CheckBox4.Checked := BcadActiveFlag;

      CheckBox3.Checked := CmtGetFlag;
      CheckBox5.Checked := CmtDispFlag;

      Edit9.Text := LspFileName;
      Edit10.Text := LspCommand;
      Edit11.Text := LspCmdName;


      if ShowModal = mrOk then begin
        BlkName1 := Edit1.Text;
        AttName1 := Edit2.Text;
        BlkName2 := Edit3.Text;
        AttName2 := Edit4.Text;

        BmpW := StrToIntDef(Edit5.Text, BmpW);
        BmpH := StrToIntDef(Edit6.Text, BmpH);
        TitleH1 := StrToIntDef(Edit7.Text, TitleH1);
        TitleH2 := StrToIntDef(Edit8.Text, TitleH2);

        AttFlag1 := CheckBox1.Checked;
        if AttFlag1 and (BlkName1 <> '') and (AttName1 <> '') then begin
          BlkName := BlkName1;
          AttName := AttName1;
        end;
        AttFlag2 := CheckBox2.Checked;
        if AttFlag2 and (BlkName2 <> '') and (AttName2 <> '') then begin
          BlkName := BlkName2;
          AttName := AttName2;
        end;

        BcadActiveFlag := CheckBox4.Checked;

        CmtGetFlag := CheckBox3.Checked;
        CmtDispFlag := CheckBox5.Checked;

        LspFileName := Edit9.Text;
        LspCommand := Edit10.Text;
        LspCmdName := Edit11.Text;
              // メニュー
        N2.Caption := LspCmdName;
        SpeedButton2.Caption := LspCmdName;

      end;
    finally
      Free;
    end;
  end;
end;

// ***********************************
// 画面キャプチャ
// ***********************************
procedure TForm2.SpeedButton1Click(Sender: TObject);
var
  app : IAcadApplication;
  docs : IAcadDocuments;
  doc, docOrg : IAcadDocument;
  limmax, limmin : OleVariant;
  scrsize : OleVariant;
  scrH, scrW : integer;
  hnd : THandle;
  ARect : TRect;
  ALeft, ATop : integer;
  gridMode : Integer;
  ucsIcon : integer;
  dwgName : TFileName;
  i : integer;
  idxOrg : integer;
  scale : double;

begin
  // Bricscad を見つける
  try
    if not Supports(GetActiveOleObject('BricscadApp.AcadApplication'), AcadApplication, app) then begin
      ShowMessage('サポートされていません.');
      exit;
    end;
  except
    ShowMessage('有効な BricsCAD が見つかりません．');
    Exit;
  end;
  docs := app.Documents;

  // 自フォームを最小に
  WindowState := wsMinimized;
  Sleep(50);
  try
    if Length(BmpAry) > 0 then begin
      for i := 0 to Length(BmpAry) -1 do
        BmpAry[i].Free;
    end;

    SetLength(BmpAry, docs.Count);
    SetLength(DwgDocAry, docs.Count);

    with DrawGrid1 do begin
      // 適当な大きさを確保
      RowCount := docs.Count div ColCount;
      if docs.Count mod ColCount > 0 then RowCount := RowCount + 1;
    end;

    // 最小化されていれば、最大にする
    if app.WindowState = acMin then begin
      app.WindowState := acMax;
    end;


    // アクティブドキュメントを取得
    docOrg := app.ActiveDocument;
    idxOrg := 0;

    for i := 0 to docs.Count - 1 do begin
      doc := docs.Item(i);
      // 現在のドキュメントの位置
      if doc = docOrg then idxOrg := i;

      // 配列に格納
      with DwgDocAry[i] do begin
        Index := i;
        Name := doc.Name;
        // シート番号またはページ番号
        if CmtGetFlag then
          Comment := GetAttString(doc, BlkName, AttName)
        else
          Comment := '';
      end;
      doc.Activate;

      // ファイル名を表示
      dwgName := doc.Name;

      // Bricscad をアクティブに
      SetForegroundWindow(doc.HWND);

      // 図面範囲を取得
      limmax := doc.GetVariable('LIMMAX');
      limmin := doc.GetVariable('LIMMIN');

      // 図面範囲をズーム
      app.ZoomWindow(limmin, limmax);

      // グラフィック画面のサイズを取得
      scrsize := doc.GetVariable('SCREENSIZE');
      scrW := scrsize[0];
      scrH := scrsize[1];

      // グリッドの表示モードを取得
      gridMode := doc.GetVariable('GRIDMODE');

      // UCSアイコンの表示モードを取得
      ucsICon := doc.GetVariable('UCSICON');

      // グリッドを非表示に
      if gridMode > 0 then
        doc.SetVariable('GRIDMODE', 0);

      // UCSアイコンを非表示に
      if ucsIcon > 0 then
        doc.SetVariable('UCSICON', 0);

      // キャプチャするビットマップの大きさに縮小
      if BmpH / BmpW < scrH / scrW then
        scale := BmpW / scrW
      else
        scale := BmpH / scrH;


      app.ZoomScaled(scale, 0);

      // グラフィックウィンドウのハンドルを取得
      hnd := FindWindowEx(app.ActiveDocument.HWND, 0, 'AfxFrameOrView100u', nil);
      // ウィンドウの位置と大きさを取得
      GetWindowRect(hnd, ARect);
      // グラフィックウィンドウの左上座標
      ALeft := ARect.Left;
      ATop := ARect.Top;

      // キャプチャ用ビットマップを作成
      BmpAry[i] := TBitmap.Create;
      BmpAry[i].PixelFormat := pf32bit;
      // ビットマップの大きさ
      BmpAry[i].Width := BmpW;
      BmpAry[i].Height := BmpH;

      // キャプチャ
      CaptureToBmp(
        ALeft + (scrW - BmpW) div 2,
        ATop + (scrH - BmpH) div 2,
        BmpAry[i].Width, BmpAry[i].Height, BmpAry[i]);

      // ズームを元に戻す
      app.ZoomWindow(limmin, limmax);
      // グリッドの表示を戻す
      if gridMode > 0 then
        doc.SetVariable('GRIDMODE', gridMode);
      // UCSアイコンの表示を戻す
      if ucsIcon > 0 then
        doc.SetVariable('UCSICON', ucsIcon);
    end;
    // 元の図面をアクティブに
    docOrg.Activate;

    // シート番号、ページ番号順にソート
    SortDwgDocAry;

    with ComboBox1 do begin
      Items.Clear;
      Sorted := False;
      for i := 0 to Length(DwgDocAry) - 1 do begin
        Items.AddObject(DwgDocAry[i].Comment +':'+ DwgDocAry[i].Name , TObject(i));
        if DwgDocAry[i].Index = IdxOrg then
          ItemIndex := i;
      end;
    end;
    FormResize(self);
    ComboBox1Change(self);
  except
    ;
  end;
  // 自フォームを戻す
  WindowState := wsNormal;
  // 自フォームをアクティブに
  SetForegroundWindow(Handle);

end;

procedure TForm2.SpeedButton2Click(Sender: TObject);
begin
  // コマンド実行
  N2Click(self);
end;

procedure TForm2.SpeedButton3Click(Sender: TObject);
begin
  // 設定
  N3Click(self);
end;

end.