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.