■ダウンロード
ダウンロードは中止しました。
■ソースコード
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.