AcadCapture.exe 2015/04/28 for Autocad / LT 2016

■概要
Autocad / LT 2016 で縮小画面をキャプチャします。
キャプチャした画像をダブルクリックすると、アクティブな図面が切り替わります。

・ビュワ~ンズームが設定してあると、キャプチャのタイミングが合いません。
 VTOPTIONSコマンドで、「画面移動とズームでアニメーションを使用」のチェックを外しておいて下さい。
・キャプチャ位置が合わないときは、AcadCapture.exe のプロパティー「互換性」で、高解像度DPI ... をチェックしてみて下さい。
・他の環境(PC)で、どの程度うまく動くのかは、不明です。タイミングが合わない可能性大です。
 プロパティパレットを表示させているだけでも、図面切り替えが遅くなり、タイミングが合わないことがあります。

※BricsCAD用、DraftSight用のキャプチャソフトを改造しているため、不要な設定項目が残っています。

■開発・動作確認環境
・Delphi XE5 Professional / Windows 8.1 64bit

・Autocad LT 2016 64bit (体験版)

■履歴
・2015/04/23
 初版作成
・2015/04/27
 初回起動時、読込エラーが連続で出るのを修正
 画面キャプチャ時、自フォームを最小化していたのを取りやめ
・2015/04/28
 シート番号、またはページ番号の属性取得を追加
 マウス右クリックのポップアップメニューに「再キャプチャ」を追加



■ダウンロード
 AcadCapture.zip(2015/04/28 exe本体のみ)

■ソースコード


unit AcadCaptureUnit;

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, ClipBrd ;

type
  TDwgDoc = record
    Index : integer;
    Name : string;
    Comment : string;
    Hnd : HWND;

  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;
    N4: TMenuItem;
    N5: TMenuItem;
    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);
    procedure N5Click(Sender: TObject);
    procedure DrawGrid1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
  private
    { Private 宣言 }
  public
    { Public 宣言 }

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

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

    // マウス移動座標
    MoveX, MoveY: integer;
  end;

var
  Form2: TForm2;

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

  // メインウィンドウ
  ACadMainWinHandle : HWND;
  // "テキストウィンドウ"
  ACadTextWinHandle : HWND;
  // テキストウィンドウのコマンド履歴ウィンドウのハンドル
  ACadTextHistHandle : HWND;
  // テキストウィンドウのコマンドラインウィンドウのハンドル
  ACadTextLineHandle : HWND;

  // MDIウィンドウ
  AcadMDIClientHandle:HWND;
  AcadMDIActiveHandle:HWND;
  AcadGraphicHandle : HWND;

  //プロセスID
  ACadProcessID : DWORD;

implementation


{$R *.dfm}

uses AcadCaptureCfgUnit;
//****************************************
// 最後の指定文字列より後を得る
//****************************************
function LastSubstringAfter(const ststr, s: string):String;
var
  st, stlen : integer;
  temp : string;
begin
  Result := '';
  if Pos(ststr, s) > 0 then begin
    temp := s;

    stlen := Length(ststr);
    while Pos(ststr, temp) > 0 do begin
      st := Pos(ststr, temp) + stlen;
      temp := Copy(temp, st, Length(temp) - st + 1);
      if temp = '' then break;
    end;
    Result := Trim(temp);
  end;
end;
//最初に現れたststrからedstrまでを返す
function StrAfterStrBefore(const ststr, edstr, s:string):String;
var
  st, ed:integer;
  temp : string;
begin
  Result:='';
  st:=Pos(ststr,s);
  if st > 0 then begin
    temp := s;
    Delete(temp,1,st + Length(ststr)-1);
    ed := Pos(edstr, temp)-1;
    if ed >= 0 then
      Result := Trim(Copy(temp, 1, ed));
  end;
end;
//****************************************
// 最後の指定文字列より後を得る
//****************************************
function LastStrAfter(const ststr, s: string):String;
var
  st, stlen : integer;
  temp : string;
begin
  Result := '';
  if Pos(ststr, s) > 0 then begin
    temp := s;

    stlen := Length(ststr);
    while Pos(ststr, temp) > 0 do begin
      st := Pos(ststr, temp) + stlen;
      temp := Copy(temp, st, Length(temp) - st + 1);
      if temp = '' then break;
    end;
    Result := Trim(temp);
  end;
end;
//******************************************
// ウィンドウのタイトル(キャプション)を得る
//******************************************
function GetWindowCaption(h : HWND) : string;
var
  Title : array [0..255] of char;
begin
  result := '';
  if GetWindowText(h, Title, 255) <> 0 then
    result := Title;
end;
//******************************************
// 他のプロセス内のコントロールの文字列を得る
//******************************************
function GetWindowString(h : HWND) : string;
var
  p : PChar;
  len : LongInt;
begin
  result := '';
  //ウィンドウの文字列のバイト数を取得
  //終端のNULL文字を含まない文字列の長さ(バイト数)
  len := SendMessage(h, WM_GETTEXTLENGTH, 0, 0);

  if len > 0 then begin
    //終端のNULL文字を含むサイズを確保
    GetMem(p, (len + 1) * 2);
    //格納するバッファの最大サイズ(終端のNULL文字を含む長さ)
    //文字列バッファ
    SendMessage(h, WM_GETTEXT, (len+1)*2, LongInt(p));
    //文字列がバッファサイズより長いとき、後部がカットされる
    result := string(p);
    FreeMem(p);
  end;
end;

//****************************************
// 画面の指定位置を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 EnumWindowProcMainWin(h: HWND; lp: LParam): BOOL; stdcall;
var
  Title : array [0..255] of char;
  ClassName : array [0..255] of char;
begin
  result := true;
  // タイトルを得る
  if GetWindowText(h, Title, 255) <> 0 then begin
    if (StrLComp(Title, 'DWG TrueView ', 13) = 0) or
       (StrLComp(Title, 'AutoCAD ', 8 )= 0) or
       (StrLComp(Title, 'Autodesk ', 9 )= 0) then begin
      GetClassName(h, ClassName, 255);
      if ((StrLComp(ClassName, 'Afx:', 4) = 0) and (StrPos(ClassName, ':8:') <> nil)) or
        (StrLComp(ClassName, 'AfxMDIFrame', 11) = 0) then begin
        ACadMainWinHandle := h;
        GetWindowThreadProcessId(h, @ACadProcessID);
        result := false;
      end;
    end;
  end;
end;
//****************************************
// メインウィンドウのハンドルを得る
//****************************************
function GetACadMainWinHandle : HWND;
begin
  EnumWindows(@EnumWindowProcMainWin, 0);
  Result := ACadMainWinHandle;

end;
//****************************************
// トップレベルのテキストウィンドウ
//****************************************
function EnumWindowProcTextWin(h: HWND; lp: LParam): BOOL; stdcall;
var
  Title : array [0..255] of char;
  ClassName : array [0..255] of char;
  PID : DWORD;
begin
  result := true;
  if GetWindowText(h, Title, 255) <> 0 then begin
    if (AnsiStrLComp(Title, 'AutoCAD ', 8) = 0 ) or
       (AnsiStrLComp(Title, 'DWG TrueView ', 13) = 0 ) or
       (AnsiStrLComp(Title, 'Autodesk ', 9) = 0) then begin
      GetClassName(h, ClassName, 255);
      if (StrLComp(ClassName, 'Afx:', 4) = 0) and (StrPos(ClassName, ':b:') <> nil) then begin
        if AnsiStrPos(Title, 'テキスト ウィンドウ') <> nil then begin
          GetWindowThreadProcessId(h, @PID);
          if PID = ACadProcessID then begin
            ACadTextWinHandle := h;
            result := false;
          end;
        end;
      end;
    end;
  end;
end;

//****************************************
// トップレベルのテキストウィンドウ
//****************************************
function GetAcadTextWinHandle:HWND;
var
  h : HWND;
begin
  // プロセスIDを取得するため
  GetAcadMainWinHandle;

  //トップレベルにあるテキストウィンドウのハンドルを取得
  EnumWindows(@EnumWindowProcTextWin, 0);
  Result := ACadTextWinHandle;
  h := GetWindow(ACadTextWinHandle, GW_CHILD);
  h := GetWindow(h, GW_CHILD);
  // コマンドライン
  ACadTextLineHandle := GetWindow(h, GW_CHILD);
  // コマンド履歴
  ACadTextHistHandle := GetWindow(ACadTextLineHandle, GW_HWNDNEXT);
end;

//****************************************
// 描画ウィンドウ
//****************************************
function EnumCWinProc_Graph(h: HWND; lparam: Integer):Bool;stdcall;
var
  ClassName : array [0..255] of char;
begin
  Result := True;

  GetClassName(h, ClassName, 255);
  if (Pos('Afx:', ClassName) = 1) and (Pos(':28:', ClassName) > 1) then begin
    AcadGraphicHandle := h;
    Result := False;
  end;
end;

//****************************************
// MDIClient ウィンドウ
//****************************************
function EnumCWinProc_MDIClient(h:HWND;lparam:Integer):Bool;stdcall;
var
  ClassName : array [0..255] of char;
begin
  Result := True;
  GetClassName(h, ClassName, 255);
  if ClassName = 'MDIClient' then begin
    AcadMDIClientHandle := h;
    Result := False;
  end;
end;
//****************************************
// MDIClient ウィンドウ
//****************************************
function GetAcadMDIClientHandle:HWND;
begin
  GetAcadMainWinHandle;
  EnumChildWindows(AcadMainWinHandle, @EnumCwinProc_MDIClient, 0);
  result := AcadMDIClientHandle;
end;

//****************************************
// MDIActive ウィンドウ
//****************************************
function GetAcadMDIActiveHandle:HWND;
begin
  result := 0;
  GetAcadMDIClientHandle;
  if IsWindow(AcadMDIClientHandle) then begin
    //アクティブなウィンドウハンドル
    //どちらでもOK
    //AcadMDIActiveHandle:= GetWindow(AcadMDIClientHandle,GW_CHILD);
    AcadMDIActiveHandle := SendMessage(AcadMDIClientHandle, WM_MDIGETACTIVE, 0, 0);
    result := AcadMDIActiveHandle;
  end;
end;

//****************************************
//アクティブなグラフィック画面のハンドル
//****************************************
function GetAcadGraphicHandle:HWND;
begin
  GetAcadMainWinHandle;
  GetAcadMDIActiveHandle;
  EnumChildWindows(AcadMDIActiveHandle, @EnumCwinProc_Graph,0);
  result := AcadGraphicHandle;
end;
//****************************************
// テキストウィンドウのコマンドラインの文字列を得る
//****************************************
function GetACadTextLine:string;
begin
  GetACadTextWinHandle;
  result := GetWindowString(ACadTextLineHandle);
end;

//****************************************
// テキストウィンドウのコマンド履歴の文字列を得る
//****************************************
function GetACadTextHist:string;
begin
  GetACadTextWinHandle;
  result := GetWindowString(ACadTextHistHandle);
end;

//******************************************
// AutoCAD(LT)2007以上に文字列を送信
//******************************************
function SendACadCommand(const cmd: String):boolean;
var
   wmes: array[0..511] of WideChar;
   cs: TCopyDataStruct;
   len: integer;
begin
  result := false;
  GetACadMainWinHandle;
  if IsWindow(ACadMainWinHandle) then begin
    len := Length(cmd) + 1;

    //String から UNICODE 文字列に変換
    StringToWideChar(cmd, wmes, len);

    cs.dwData:= 1;//必ず1
    // 2バイトずつ
    cs.cbData:= len * 2;
    cs.lpData:= @wmes;

    SendMessage(ACadMainWinHandle, WM_COPYDATA, 0, LPARAM(@cs));
    PostMessage(ACadMainWinHandle, WM_NULL, 0, 0);

    result := true;
  end;
end;

//****************************************
// システム変数を取得 (2016)
//****************************************
function GetACadVariable(const syscmd: string): string;
var
  st, ed: integer;
  s : string;
begin
  result := '';
  s := '';
  if IsWindow(ACadMainWinHandle) then begin
    if (UpperCase(syscmd) = 'ACADVER') or (UpperCase(syscmd) = 'LAYERPMODE') then
      SendACadCommand(syscmd + #13)
    else
      SendACadCommand('''SETVAR ' + syscmd + #13);

    // 2015/04/22 追加
    // 実際のコマンドラインではなく、隠れているコマンドラインから文字列を
    // 取得するため、若干のタイムラグが必要みたい
    Sleep(100);
    // トップレベルのテキストウィンドウのコマンドラインの文字列を取得
    s := GetACadTextLine;    //2015.4.22 変更

    // 区切り文字の位置を取得
    st := LastDelimiter('<', s);
    ed := LastDelimiter('>', s);
    if (st > 0) and (st < ed) then
      result := Trim(Copy(s, st + 1, ed - st - 1));

    if result <> '' then
      // キャンセルを発行
      SendACadCommand(#3)
    else begin
      SendACadCommand(#3);
      s := GetACadTextHist;
      // 2015/04/22 追加
      Sleep(100);

      s := LastStrAfter(syscmd, s);
      st := LastDelimiter('=', s);
      ed := LastDelimiter('(', s);
      if (st > 0) and (st < ed) then
        result := Trim(Copy(s, st + 1, ed - st - 1));
    end;
    {
    // " を削除する
    if Copy(result,1,1) = '"' then begin
      s := Copy(result,2,Length(result)-1);
      if Pos('"', s) > 0 then s := Copy(s,1,Pos('"', s));
      result := '"' + s;
    end;
    }
  end;
end;

// *******************************
// ActoCAD をアクティブに
// *******************************
function SetAcadActive: boolean;
begin
  Result := False;
  GetAcadMainWinHandle;
  if IsWindow(AcadMainWinHandle) then begin
    SetForegroundWindow(AcadMainWinHandle);
    Result := True;
  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 : integer;
begin

  with DrawGrid1 do begin
    i := Row * ColCount + col;
    if (i >= 0) and (i < Length(DwgDocAry)) then begin

      if GetACadMainWinHandle = 0 then Exit;

      // MDI のウィンドウを探す
      GetAcadMDIClientHandle;

      // 図面を切り替え
      SendMessage(AcadMDIClientHandle, WM_MDIACTIVATE, DwgDocAry[i].Hnd, 0);

      if BcadActiveFlag then
        // AutoCADをアクティブに
        SetForegroundWindow(AcadMainWinHandle)
      else
        // 自フォームをアクティブに
        SetForegroundWindow(Handle);

      ComboBox1.ItemIndex := i;
    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.DrawGrid1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  MoveX := X;
  MoveY := Y;
end;

procedure TForm2.FormCreate(Sender: TObject);
var
  ini : TIniFile;
begin

  // 2015/04/27 追加
  SetLength(BmpAry, 0);
  SetLength(DwgDocAry, 0);

  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 := 'ZITEM9';

  AttFlag1 := True;
  AttFlag2 := False;

  // ダブルクリックで Bricscad をアクティブに
  BcadActiveFlag := True;

  // コメント表示
  CmtDispFlag := False;

  // キャプチャ時、コメントを取得
  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('Dcad', 'BlkName1', BlkName1);
      BlkName2 := ReadString('Dcad', 'BlkName2', BlkName2);
      AttName1 := ReadString('Dcad', 'AttName1', AttName1);
      AttName2 := ReadString('Dcad', 'AttName2', AttName2);
      AttFlag1 := ReadBool('Dcad', 'AttFlag1', AttFlag1);
      AttFlag2 := ReadBool('Dcad', 'AttFlag2', AttFlag2);

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

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

      LspFileName := ReadString('Dcad', 'LispFileName', LspFileName);
      LspCmdName := ReadString('Dcad', 'LispCmdName', LspCmdName);
      LspCommand := ReadString('Dcad', '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
  // Bitmap を破棄
  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('Dcad', 'BlkName1', BlkName1);
      WriteString('Dcad', 'BlkName2', BlkName2);
      WriteString('Dcad', 'AttName1', AttName1);
      WriteString('Dcad', 'AttName2', AttName2);
      WriteBool('Dcad', 'AttFlag1', AttFlag1);
      WriteBool('Dcad', 'AttFlag2', AttFlag2);

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

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

      WriteString('Dcad', 'LispFileName', LspFileName);
      WriteString('Dcad', 'LispCmdName', LspCmdName);
      WriteString('Dcad', '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);
begin
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.N5Click(Sender: TObject);
var
  i,idx : integer;
  ACol, ARow :integer;
  s, s1 : string;
  n : integer;
  scrW, scrH : Integer;
  ARect : TREct;
  ALeft, ATop : integer;
  scale : Double;
  APoint : TPoint;
begin
  with DrawGrid1 do begin

    // マウス座標をCol,Rowに
    MouseToCell(MoveX, MoveY, ACol, ARow);
    Row := ARow;
    Col := ACol;
    i := Row * ColCount + Col;
    if (i >= 0) and (i < Length(DwgDocAry)) then begin
      idx := DwgDocAry[i].Index;

      if GetACadMainWinHandle = 0 then Exit;

      // MDI のウィンドウを探す
      GetAcadMDIClientHandle;
      // 図面を切り替え
      SendMessage(AcadMDIClientHandle, WM_MDIACTIVATE, DwgDocAry[i].Hnd, 0);
      SetForegroundWindow(AcadMainWinHandle);
      ComboBox1.ItemIndex := i;

      // MDI のウィンドウを探す
      GetAcadMDIClientHandle;
      // 描画ウィンドウを探す
      GetAcadGraphicHandle;
      // ウィンドウの位置と大きさを取得
      GetWindowRect(AcadGraphicHandle, ARect);
      // グラフィックウィンドウの左上座標
      ALeft := ARect.Left;
      ATop  := ARect.Top;

      // Autocad からグラフィック画面のサイズを取得
      s := GetAcadVariable('SCREENSIZE');
      n := Pos(',', s);
      scrW := Trunc(StrToFloatDef(Copy(s, 1, n -1), 0));
      scrH := Trunc(StrToFloatDef(Copy(s, n + 1  ), 0));

      // システム変数取得失敗であれば、終了
      if (scrW = 0) or (scrH = 0) then Exit;

      // 高解像度DPI対策
      ALeft := Trunc(ALeft * scrW / (ARect.Right  - ARect.Left));
      ATop  := Trunc(ATop  * scrH / (ARect.Bottom - ARect.Top));

      // キャプチャするビットマップの大きさに縮小する尺度
      if BmpH / BmpW < scrH / scrW then
        scale := BmpW / scrW
      else
        scale := BmpH / scrH;
      //
      SetCursorPos(ALeft + 1, ATop + 1);

      // 図面範囲でズーム
      s1 := GetAcadVariable('LIMMIN');
      s  := GetAcadVariable('LIMMAX');

      if (s <> '') and (s1 <> '') then
        SendAcadCommand(#3 + 'ZOOM '+ s + #13 + s1 + #13)
      else
        SendAcadCommand(#3 + 'ZOOM ALL' + #13);

      SendAcadCommand(#3 + 'ZOOM ' + Format('%.3f', [scale]) + 'X' + #13);

      // 描画待ち
      Sleep(500);

      if Length(BmpAry) > idx then begin
        // キャプチャ
        CaptureToBmp(
          ALeft + (scrW - BmpW) div 2,
          ATop  + (scrH - BmpH) div 2,
          BmpAry[idx].Width, BmpAry[idx].Height, BmpAry[idx]);
      end;
      // 直前の画面表示に戻す
      SendAcadCommand(#3 + 'ZOOM PRE' + #13);
      Repaint;
    end;
  end;

  // マウスカーソルを戻す
  APoint.X := MoveX;
  APoint.Y := MoveY;
  APoint := DrawGrid1.ClientToScreen(APoint);
  SetCursorPos(APoint.X, APoint.Y);


  SetForegroundWindow(Handle);
end;

// ************************************
// DXFファイルを作成し、属性を1個取得
// ************************************
function ReadDxfAtt(const InsertName: string; const AttRibName: string):string;
var
  sl : TStringList;
  fname : TFileName;
  i : integer;
  insFlag, attFlag, hasAtt : boolean;
  s : string;
  AblkName , AattName, AattString : string;
  cd, idx : integer;
begin
  Result := '';

  if (InsertName = '') or (AttRibName = '')  then Exit;

  fname := ChangeFileExt(ParamStr(0), '.dxf');
  DeleteFile(fname);

  if SetAcadActive then begin
    SendAcadCommand(#3 + 'FILEDIA 0'+#13);
    SendAcadCommand('DXFOUT' + #13 + fname + #13 + 'V 2004 16' + #13);
    SendAcadCommand('''FILEDIA 1' + #13);

    // ファイル作成待ち
    Sleep(500);

    if FileExists(fname) then begin
      sl := TStringList.Create;
      try
        sl.LoadFromFile(fname);
        if sl.Count > 1 then begin

          insFlag := False;
          hasAtt  := False;
          attFlag := False;

          // ENTITIESセクションを探す
          idx := sl.IndexOf('ENTITIES');

          for i := idx div 2 + 1 to sl.Count div 2 - 1 do begin
            // DXFコード
            cd := StrToInt(sl[i * 2]);
            // その値
            s := sl[i * 2 + 1];

            if insFlag then begin

              // 属性取得終了
              if hasAtt and (cd = 0) and (s = 'SEQEND') then begin
                insFlag := False;
                hasAtt  := False;
                attFlag := false;
              end;

              if hasAtt and (AblkName = '') and (cd = 2) then
                AblkName := s;

              if attFlag then begin
                // 属性の値を保持
                if cd = 1 then
                  AattString := s;
                // 属性名
                if cd = 2 then begin
                  AattName := s;
                  // ブロック名、属性名が同じ
                  if (InsertName = ABlkName) and (AttRibName = AattName) then begin
                    Result := AattString;
                    Break;
                  end;
                end;
              end;
              if hasAtt and (cd = 0) and (s = 'ATTRIB') then
                attFlag := True;
            end;

            if (cd = 0) and (s = 'INSERT') then begin
              insFlag := True;
              hasAtt  := False;
              attFlag := False;
              AblkName := '';
            end;
            // 属性有
            if (cd = 66) and (Trim(s) = '1') then
              hasAtt := True;
            // ENTITIES セクション終わり
            if (cd = 0) and (s = 'ENDSEC') then
              Break;
          end;
        end;
      finally
        sl.Free;
      end;
    end;
  end;
end;

// ***********************************
// 画面キャプチャ
// ***********************************
// あらかじめ、ビュワ~ンズームを止めておくこと
// VTOPTIONS コマンド「推移を表示」
// 「画面移動とズームでアニメーションを使用」のチェックを外す
procedure TForm2.SpeedButton1Click(Sender: TObject);
var
  scrH, scrW : integer;
  ARect : TRect;
  ALeft, ATop{, AWidth, AHeight} : integer;
  i : integer;
  scale : double;
  h : HWND;
  dwgTitle : string;
  cnt : integer;
  s, s1 : string;
  n :integer;
  horg : HWND;
begin

  // すでにBitmap が作成されているときは、破棄
  if Length(BmpAry) > 0 then begin
    for i := 0 to Length(BmpAry) -1 do
      BmpAry[i].Free;
  end;

  // メインウィンドウのハンドルを取得
  if GetACadMainWinHandle = 0 then Exit;

  // 最小化されていれば戻す
  if isIconic(AcadMainWinHandle) then
    OpenIcon(AcadMainWinHandle);

  SetForegroundWindow(AcadMainWinHandle);

  // MDI のウィンドウを探す
  GetAcadMDIClientHandle;

  // 描画ウィンドウを探す
  GetAcadGraphicHandle;

  // ウィンドウの位置と大きさを取得
  GetWindowRect(AcadGraphicHandle, ARect);

  // グラフィックウィンドウの左上座標
  ALeft := ARect.Left;
  ATop  := ARect.Top;

  // 適当な大きさで動的配列を確保
  SetLength(DwgDocAry, 100);
  SetLength(BmpAry,    100);

  // 図面数を取得
  cnt := 0;

  // MDIClient下の最初のウィンドウ(ActiveWindow)
  h := GetWindow(AcadMDIClientHandle, GW_CHILD);
  while h <> 0 do begin
    // タイトルを取得
    dwgTitle := GetWindowCaption(h);
    s := Uppercase(dwgTitle);
    // 「スタート」「Drawing1.dwg」は無視
    if (Pos('.DWG', s) > 1) and (Pos('DRAWING', s) = 0) then begin
      with DwgDocAry[cnt] do begin
        Name    := dwgTitle;
        Index   := cnt;
        Comment := '';
        Hnd     := h;
      end;
      Inc(cnt);
    end;
    // 次のウィンドウへ
    h := GetWindow(h, GW_HWNDNEXT);
  end;

  SetLength(DwgDocAry, cnt);
  SetLength(BmpAry,    cnt);

  // Autocad からグラフィック画面のサイズを取得
  s := GetAcadVariable('SCREENSIZE');
  n := Pos(',', s);
  scrW := Trunc(StrToFloatDef(Copy(s, 1, n -1), 0));
  scrH := Trunc(StrToFloatDef(Copy(s, n + 1  ), 0));

  // システム変数取得失敗であれば、終了
  if (scrW = 0) or (scrH = 0) then Exit;

  // 高解像度DPI対策
  ALeft := Trunc(ALeft * scrW / (ARect.Right  - ARect.Left));
  ATop  := Trunc(ATop  * scrH / (ARect.Bottom - ARect.Top));

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

  // 2015/04/27 取りやめ
  // 自フォームを最小に
  //WindowState := wsMinimized;
  //Sleep(100);

  SetCursorPos(ALeft + 1, ATop + 1);

  try

    // アクティブなドキュメントを取得
    h := SendMessage(AcadMDIClientHandle, WM_MDIGETACTIVE, 0, 0);
    horg := h;

    for i := 0 to Length(DwgDocAry) -1 do begin

      SendMessage(AcadMDIClientHandle, WM_MDIACTIVATE, DwgDocAry[i].Hnd, 0);

      // ウィンドウ切り替え待ち
      Sleep(600);

      // 図面範囲でズーム
      s1 := GetAcadVariable('LIMMIN');
      s  := GetAcadVariable('LIMMAX');
      if (s <> '') and (s1 <> '') then
        SendAcadCommand(#3 + 'ZOOM '+ s + #13 + s1 + #13)
      else
        SendAcadCommand(#3 + 'ZOOM ALL' + #13);

      SendAcadCommand(#3 + 'ZOOM ' + Format('%.3f', [scale]) + 'X' + #13);

      // 描画待ち
      Sleep(500);

      // キャプチャ用ビットマップを作成
      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]);

      // 直前の画面表示に戻す
      SendAcadCommand(#3 + 'ZOOM PRE' + #13);

      // 描画待ち
      Sleep(300);

      if CmtGetFlag then begin
        s := ReadDxfAtt(BlkName, AttName);
        DwgDocAry[i].Comment := s;
      end;


    end;
    SendMessage(AcadMDIClientHandle, WM_MDIACTIVATE, horg, 0);

    // シート番号、ページ番号順にソート
    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 horg = DwgDocAry[i].Hnd then ItemIndex := i;

      end;
    end;
    FormResize(self);
    ComboBox1Change(self);
  except
    ;
  end;

  // 2015/04/27 取りやめ
  // 自フォームを戻す
  //WindowState := wsNormal;
  // 自フォームをアクティブに
  SetForegroundWindow(Handle);
end;

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

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

end.