＞パラメータを配列に入れると処理が楽になるかもです。論理値の配列も作っておい
＞て，カウントしたらtrueにするとか。
構造体の配列利用したら、もの凄く楽に処理出来るようになりました...。

＞PIOの移動等のコマンド再実行は常にチェックを入れて使っております。なぜなら、PIO
＞のそのものの位置情報を使いたい場合が多いので。
ナットクです。

＞そう言えば、同一PIOの同一設定をカウントするScriptをずっとやっているのですが
＞Repeat文の階層が深くなり、わけ分からなくなっています...。
パラメータを配列に入れると処理が楽になるかもです。論理値の配列も作っておいて，
カウントしたらtrueにするとか。

PIOの移動等のコマンド再実行は常にチェックを入れて使っております。なぜなら、PIO
のそのものの位置情報を使いたい場合が多いので。
＞ResetObject
なるほど...。これでも良いのですか。
＞VW8だと...
もう、VW8では対処しきれないScriptとばかりでして、更に最近では自分の能力の限界
いっぱいいっぱい書くことが多く、まともに仕上がりません。

そう言えば、同一PIOの同一設定をカウントするScriptをずっとやっているのですが
Repeat文の階層が深くなり、わけ分からなくなっています...。

与太郎さんのご依頼により、重複書き込みを削除しました。
それから、
そろそろメンテナンスしないと重すぎますね。
トライしますので、
皆様、不測の事態に備えて下さい。

＞石男さん
VW8とVW10の場合なのですが、
PIOのプロパティで「移動すると、コマンドを再実行」をチェックしてない場合、
SetRField(h, recName, fldName, value); のあと、
MoveObjs(0, 0, false, false); を実行してもPIOは描き直されませんでした。
データパレットでなにか変更すれば描き直されますが...
VW9は MoveObjs でも問題ないようです。
石男さんは、「移動すると、コマンドを再実行」は常にチェックしてますか？
私は，移動や回転でコマンド再実行をすると無駄な時間がかかるので、必要な場合だけ
チェックしていました。それで問題ないはずだったのですが、スクリプトでパラメータ
を書き換えて変形するのは想定外だったようです。（VW8の場合）

対処法ですが、
VW10なら、MoveObjs のかわりに ResetObject で良いようです。
VW8だと、「移動すると、コマンドを再実行」または「回転すると、コマンドを再実行」
にチェックをいれて、距離ゼロ移動か角度ゼロ回転するしかないです。（たぶん）

＞管理人さん
下の書き込みが日本語になってないので、削除していただけたらありがたいのですが。
だめですか？

下のスクリプトの42行目が間違っていました。
LayerObj: FInLayer;
↓　↓　↓
LayerObj: h:= FInLayer;

いままで見て見ぬ振りをしていましたが、
グループやシンボルの中で、選択図形を処理するスクリプトは、組み込みサブ
ルーチンでは作れません。たとえば、
h:= FSActLayer;
＿while h <> nil do begin
＿＿{ 行いたい処理 }
＿h:= NextSObj;
end;{while}
のようなスクリプトでは、トップレベルからの実行にしか対応できません。

グループやシンボルの中に入っているとき、スクリプトで選択図形を処理する
には、スクリプト実行時の状態（グループ内、シンボル内、トップレベル）を
知る必要があります。試しに、
Message(GetType(GetParent(nil)));
を実行してみましたが、エラーが出てしまいます。
やはり自前で関数を作るしかないようです。
何か図形を描いて、そのハンドルから親を探すことにします。
下がテスト用スクリプトです。

procedure test;

function GetDrawingHeader:handle;
{VW8.5以降に対応}
var
＿h:＿handle;
begin
＿Locus(0, 0);
＿h:= LNewObj;
＿GetDrawingHeader:= GetParent(h);
＿DelObject(h);
end;{GetDrawingHeader}

begin{test}
＿Message(GetType(GetDrawingHeader));
end;{test}
Run(test);

実行すると、実行時の状態によって、それぞれのタイプ（レイヤ、グループ、
シンボル定義）が返ってきます。

実際に使用するときは、下のようになります。

procedure DoSelectObjs;
const
＿GroupObj = 11;
＿SymbolDef = 16;
＿LayerObj = 31;
＿
var
＿h, hP＿;handle;
＿
function GetDrawingHeader:handle;
{VW8.5以降に対応}
var
＿h:＿handle;
begin
＿Locus(0, 0);
＿h:= LNewObj;
＿GetDrawingHeader:= GetParent(h);
＿DelObject(h);
end;{GetDrawingHeader}
＿
procedure DoInGroup(hGrp:handle);
var
＿hObj:handle;
begin
＿hObj:= FInGroup(hGrp);
＿while hObj <> nil do begin
＿＿if GetType(hObj) = GroupObj then begin
＿＿＿DoInGroup(hObj);
＿＿end{if}
＿＿else begin
＿＿＿{ 目的の処理 }
＿＿end;{else}
＿hObj:= NextObj(hObj);
＿end;{while}
end;{DoInGroup}
＿
begin{main}
＿hP:= GetDrawingHeader;
＿case GetType(hP) of
＿＿GroupObj: h:= FInGroup;
＿＿SymbolDef: h:= FInSymDef;
＿＿LayerObj: FInLayer;
＿end;{case}
＿while h <> nil do begin
＿＿if Selected(h) then begin
＿＿＿if GetType(h) = GroupObj then begin
＿＿＿＿DoInGroup(h);
＿＿＿end{if}
＿＿＿else begin
＿＿＿＿{ 目的の処理 }
＿＿＿end;{else}
＿＿end;{if}
＿＿h:= NextObj;
＿end;{while}
end;{main}
Run(DoSelectObjs);

「目的の処理」が複数出てきますので、そこをprocedureにすれば、別の処理
をするスクリプトを書くときは、そこだけの変更で済みます。

...

フォントとサイズを変更するスクリプトに修正もれがありました。
そのままだとデフォルト・サイズが変更されません。

begin{main}
hObj:= FSActLayer;
if hObj = nil then begin
TextFont(GetFontID(FontName));
の次に、
TextSize(FontSize);{ デフォルト・サイズ設定用に追加 }
の１行を追加してください。

あ、ほんとだ。
これが使えましたね。

でも、ﾀﾞﾌﾞﾙｸﾘｯｸでできるので、
とっても便利に使えるスクリプトだと思います！

サイズ設定のほうもさっそく使わせていただきます。
ありがとうございます！

使わないので忘れてましたが、メニュー「文字」−「文字...」でもフォントを変更
できました。

ふうりんさんおめでとうございます。これは○○○の道への第一歩です。

＞登録画面やコマンドを作っていたのも、スクリプトなのですね。
用語の混乱がありまして、コマンド、マクロ、スクリプトといろんな呼び方をされま
すが、全部VectorScriptコマンドのことなのです。

コマンドパレットから実行するスクリプトの呼び方は、
旧(MC)→MiniPascalコマンド
現(VW)→VectorScriptコマンド
と変わりましたが、バージョンによる差以外は同じものです。
「図形選択マクロ...」、「図形表示マクロ...」、「ツールマクロ...」で自動生成さ
れるのもこのタイプです。
ただし「画面登録」だけは、コマンドパレットに登録されますが、VectorScriptコマ
ンドではありません。
以前はMiniPascalコマンドでしたが、コマンド作成後のレイヤとクラスの追加、削除、
名称変更等に対応しきれなかったのか、現在の形式に変更されました。
使うぶんには関係ありませんので、気にすることはありませんが。

＞あ、ちなみに文字サイズも先ほどのスクリプトで
＞設定することはできますか？
フォントとサイズを一度に設定するように修正しました。

procedure SetFont;
{ アクティブレイヤの選択図形のフォントとサイズを変更する }
{ 選択図形がないときは、デフォルト・フォントとサイズを変更する }
{ VW9以降に対応 }
const
FontName = 'ＭＳ Ｐ明朝';
FontSize = 10;{ サイズ設定用に追加 }
TextObj = 10;
GroupObj = 11;
DimObj = 63;

var
hObj:handle;
sizeID:integer;{ サイズ設定用に追加 }
ver, var2, ver3, os:integer;{ バージョン取得用に追加 }

procedure SetTxtFont(h:handle);
begin
SetTextFont(h, 0, GetTextLength(h), GetFontID(FontName));
SetTextSize(h, 0, GetTextLength(h), FontSize);{ サイズ設定用に追加 }
end;{SetFont}

procedure SetDimFont(h:handle);
begin
GetVersion(ver, var2, ver3, os);{ バージョン取得用に追加 }
if ver = 9 then { サイズ設定用に追加 }
sizeID:= 17
else
sizeID:= 40;
SetObjectVariableInt(h, 28, GetFontID(FontName));
SetObjectVariableInt(h, sizeID, GetFontID(FontName));{ サイズ設定用に追加 }
ResetObject(h);
end;{SetDimFont}

procedure DoInGroup(hGrp:handle);
var
hObj:handle;
begin
hObj:= FInGroup(hGrp);
while hObj <> nil do begin
case GetType(hObj) of
TextObj: SetTxtFont(hObj);
GroupObj: DoInGroup(hObj);
DimObj: SetDimFont(hObj);
end;{case}
hObj:= NextObj(hObj);
end;{while}
end;{DoInGroup}

begin{main}
hObj:= FSActLayer;
if hObj = nil then begin
TextFont(GetFontID(FontName));
AlrtDialog(Concat('フォントを「', FontName, '」', Num2Str(0, FontSize), 'に変更しました。'));
{ ↑サイズ設定用に変更 }
end{if}
else begin
while hObj <> nil do begin
case GetType(hObj) of
TextObj: SetTxtFont(hObj);
GroupObj: DoInGroup(hObj);
DimObj: SetDimFont(hObj);
end;{case}
hObj:= NextSObj(hObj);
end;{while}
end;{else}
end;{main}
Run(SetFont);

サイズだけ変更したいのなら、スクリプトのフォント変更の部分を削除すればいいです。

与太郎さん　ありがとうございます！！
さっそく試させていただきました。
とっても助かりました！

恥かしながら私は、返事をいただいてからまず、
ん〜！？スクリプト？？
というところから始まったので、
たどり着くのにちょっと時間がかかってしまいました。。。
登録画面やコマンドを作っていたのも、スクリプトなのですね。
また勉強になりました！
こんなことができるとは驚きです。(知らなかったとはいえオーバー？)
スクリプトの意味、使い方がようやくわかったので、
これから色々と参考にさせていただきます

本当にありがとうございました。

あ、ちなみに文字サイズも先ほどのスクリプトで
設定することはできますか？

アクティブレイヤ上の選択図形のフォントを変更するスクリプトです。
文字図形と寸法のフォントを変更します。
グループ内でも変更できます。
選択図形がないときは、デフォルト・フォントを変更します。
（先ほどのスクリプトの機能を含みます。）
フォントの指定は、FontName = 'ＭＳ Ｐ明朝'; を書き換えてください。

procedure SetFont;
{ アクティブレイヤの選択図形のフォントを変更する }
{ 選択図形がないときは、デフォルト・フォントを変更する }
const
FontName = 'ＭＳ Ｐ明朝';
TextObj = 10;
GroupObj = 11;
DimObj = 63;
var
hObj:handle;

procedure SetTxtFont(h:handle);
begin
SetTextFont(h, 0, GetTextLength(h), GetFontID(FontName));
end;{SetFont}

procedure SetDimFont(h:handle);
begin
SetObjectVariableInt(h, 28, GetFontID(FontName));
ResetObject(h);
end;{SetDimFont}

procedure DoInGroup(hGrp:handle);
var
hObj:handle;
begin
hObj:= FInGroup(hGrp);
while hObj <> nil do begin
case GetType(hObj) of
TextObj: SetTxtFont(hObj);
GroupObj: DoInGroup(hObj);
DimObj: SetDimFont(hObj);
end;{case}
hObj:= NextObj(hObj);
end;{while}
end;{DoInGroup}

begin{main}
hObj:= FSActLayer;
if hObj = nil then begin
TextFont(GetFontID(FontName));
AlrtDialog(Concat('フォントを「', FontName, '」に変更しました。'));
end{if}
else begin
while hObj <> nil do begin
case GetType(hObj) of
TextObj: SetTxtFont(hObj);
GroupObj: DoInGroup(hObj);
DimObj: SetDimFont(hObj);
end;{case}
hObj:= NextSObj(hObj);
end;{while}
end;{else}
end;{main}
Run(SetFont);

DoMenuTextByNameでフォントを設定できれば簡単だったのですが、どう
やら駄目みたいです。フォントメニューだと文字の一部だけ別のフォント
に変えられますが、スクリプトでは文字の選択部分が判らないので、難し
いです。
一応、これで完成ということにします。

デフォルト・フォントを設定するスクリプトを作ります。

手始めに、自分のシステムで使えるフォント名を調べるため、
下のスクリプトを実行します。

procedure FontList;{ フォント名一覧をOutput.txtに書き出します。 }
var
i:integer;
fontNm, lastFontNm:string;
begin
lastFontNm:= '';
for i:= 1 to 32767 do begin
fontNm:= GetFontName(i);
if (fontNm <> '') & (fontNm <> lastFontNm) then begin
Message(i, ':', fontNm);
Writeln(fontNm);
lastFontNm:= fontNm;
end;{if}
end;{for}
ClrMessage;
end;
Run(FontList);

結果は、VWフォルダの中の「Output.txt」ファイルに書き出されます。
一部重複する名前がありますが、気にしないでください。
VWフォルダを開くには、
＿Win: VWのショートカットのプロパティを開き、「リンク先を探す」。
＿Mac: VWのエイリアスの「オリジナルを表示」。

デフォルト・フォントを設定するスクリプトは、

TextFont(GetFontID('「フォント」'));

となります。「フォント」にフォント名を入れます。Output.txtから
コピペすれば間違いがありません。

TextFont(GetFontID('ＭＳ Ｐゴシック'));
とか、
TextFont(GetFontID('ＭＳ Ｐ明朝'));
のようなスクリプトを、コマンド名をフォント名と同じにして、Vector
Scriptコマンドとして作成します。
コマンドパレットの名前は、「フォント設定」とします。

すでに書かれている文字のフォントを変更するスクリプトは、もっと複
雑になります。

＞AutoCADみたいに、データパレットでレイヤ情報を変えられると、便利そうですが。
「オブジェクトプロパティ管理」でいじれるのはレイヤ情報でなくて、書類情報でした。
まあ、どっちでもいいんですけど...

レイヤにデータベース（X,Y倍率）を割り当てるスクリプトです。
用途は、土木縦断図などで縦横の縮尺が異なるときに、スクリプトで寸法や面積を算出す
るときの参照用です。
他にも、レイヤにデータベースを割り当てると便利な例がありますか？

なお、レイヤに割り当てたデータベースは、データパレットではアクセスできません。
AutoCADみたいに、データパレットでレイヤ情報を変えられると、便利そうですが。

Procedure SetLayerMagnification;
{$ DEBUG}
const
＿LayerScaleDB = 'レイヤ倍率DB';
＿Field_X = 'X倍率';
＿Field_Y = 'Y倍率';
var
＿kX, kY＿:real;
＿sKx, sKy＿:string;
＿i, iRec,
＿nRec＿:integer;
＿h, hRec＿:handle;
＿
begin
＿h:= ActLayer;
＿nRec:= NumRecords(h);
＿iRec:= 0;
＿for i:= 1 to nRec do
＿＿if GetName(GetRecord(h, i)) = LayerScaleDB then
＿＿＿iRec:= i;
＿if iRec = 0 then begin
＿＿NewField('レイヤ倍率DB', Field_X, '1.000', 3, 1);
＿＿NewField('レイヤ倍率DB', Field_Y, '1.000', 3, 1);
＿＿iRec:= 1;
＿＿Record(h, LayerScaleDB);
＿＿Field(h, LayerScaleDB, Field_X, '1.000');
＿＿Field(h, LayerScaleDB, Field_Y, '1.000');
＿end;
＿hRec:= GetRecord(h, iRec);
＿sKx:= GetRField(h, LayerScaleDB, Field_X);
＿sKy:= GetRField(h, LayerScaleDB, Field_Y);
＿PtDialog(Concat('「', GetLName(h), '」レイヤーのＸ、Ｙの倍率 ＝'), sKx, sKy, kX, kY);
＿if not DidCancel then begin
＿＿AlrtDialog('レイヤ倍率を設定しました。');
＿＿Field(h, LayerScaleDB, Field_X, Num2Str(3, kX));
＿＿Field(h, LayerScaleDB, Field_Y, Num2Str(3, kY));
＿end;
end;
Run(SetLayerMagnification);

与太郎さま、こんにちは。
お力になれてうれしいです。
MacとWinでも結構動作が異なるときってありますよね〜。
以前はフォントの位置などで困る事もありましたし、
カスタムダイアログでは、Macでビシッと各パーツの位置決めを
してあっても、Windowsにもっていくと、文字の大きさの違い
などから、大きくレイアウトが崩れたりしますよね。

今回のフィールドの高さは自分にとっても発見になったので良かったです。(^^v

vvさま、ありがとうございます。

＞現状では、AddFieldのフィールドの高さが「16」になっていますが、
＞これを、「15」にすることによって、Enterキーが有効になりました。
こちらのVW9,10(デモ版)/Win2000でも、高さを15pixcelにするとEnter
キーでダイアログから抜けられました。
Macだと、フィールドの高さを大きくしても関係ありません。（大きく
する意味もありませんが）

ダイアログのテキストフィールドがOSのAPIを利用してるせいで（普通
しますけど）、OSによって動作が違うんでしょうね。
そういえば、フィールド内での↑キーと↓キーの動作も違います。
Mac：キャレットがテキストの先頭か最後に移動。
Win：キャレットが１文字分前か後ろへ移動。

与太郎さま
こんにちは。
先日はDoMenuTextBynameの件では、どうもお世話になりました。

win版カスタムダイアログをEnterキーで終了する件ですが、
驚きの事実を発見したんです。ちょい裏技っぽいです。

現状では、AddFieldのフィールドの高さが「16」になっていますが、
これを、「15」にすることによって、Enterキーが有効になりました。
どうも、複数行入力できるフィールドサイズか、そうではないか
によって、Enterキーが有効、無効になるようです。

以下に訂正しました。

・・・・・
AddField('fieldValue', fldValueField, EditableTextField, 10, 60, 210, 75);
・・・・・

（一番最後の項目を76→75に変更しました）

ちなみに、私の環境はVW8.5.2 Windows2000です。
もし、そちらでうまく行かなかったらごめんなさいです。

選択図形のレコード・フィールドをダイアログで変更するスクリプト（未完成）です。
図形を選択して実行します。選択図形にレコードが割り当てられていればダイアログ
が出るので、レコード、フィールドを選択して変更できます。

問題は、Win版だと、値を変更してEnterキーを押してもダイアログを閉じてくれない
ことです。Enterキーを押すと、入力フィールドの中で改行されてしまいます。
OKボタンを押さないとダイアログから出られません。
フィールド内に改行コードが入ったかどうかを、自分で調べて処理する以外の方法が
あるのでしょうか？

procedure SetRF;
{ レコード・フィールドをダイアログで変更する }
{ 複数図形に対応する予定 }
{ 最後に変更したレコード、フィールドを保存して、デフォルトとする予定 }
{$ DEBUG}
const
＿RFieldDialog = 1;
＿
＿StandardButton = 1;
＿StaticTextField = 1;
＿EditableTextField = 2;

＿OKButton = 1;
＿CancelButton = 2;
＿RecNameField = 3;
＿RecSepField = 4;
＿RecListChoice = 5;
＿FldNameField = 6;
＿FldSepField = 7;
＿FldListChoice = 8;
＿fldValueField = 9;
＿
var
＿h ＿:handle;
＿nRec＿:integer;
＿recName, fldName＿:string;
＿
＿procedure CreateDialog;
＿begin
＿＿BeginDialog(RFieldDialog, 1, 100, 100, 320, 210);
＿＿＿AddButton('OK', OKButton, StandardButton, 60, 85, 130, 105);
＿＿＿AddButton('Cancel', CancelButton, StandardButton, 140, 85, 210, 105);
＿＿＿AddField('レコード名', RecNameField, StaticTextField, 10, 5, 85, 21);
＿＿＿AddField(':', RecSepField, StaticTextField, 85, 5, 90, 21);
＿＿＿AddChoiceItem('Record List', RecListChoice, 1, 90, 5, 210, 21);
＿＿＿AddField('フィールド名', FldNameField, StaticTextField, 10, 30, 85, 46);
＿＿＿AddField(':', FldSepField, StaticTextField, 85, 30, 90, 46);
＿＿＿AddChoiceItem('Field List', FldListChoice, 1, 90, 30, 210, 46);
＿＿＿AddField('fieldValue', fldValueField, EditableTextField, 10, 60, 210, 76);
＿＿EndDialog;
＿end;{CreateDialog}
＿
＿procedure DoDialog;
＿var
＿＿hRec＿:handle;
＿＿nFld＿:integer;
＿＿i, item＿:integer;
＿＿iRec, iFld＿:integer;
＿＿fldName, recName＿:string;
＿＿value＿:string;
＿＿
＿＿procedure SetFldList;
＿＿var
＿＿＿i＿:integer;
＿＿begin
＿＿＿for i:= NumChoices(FldListChoice) downto 1 do
＿＿＿＿DelChoice(FldListChoice, i);
＿＿＿hRec:= GetRecord(h, iRec);
＿＿＿nFld:= NumFields(hRec);
＿＿＿for i:= 1 to nFld do
＿＿＿＿InsertChoice(FldListChoice, i, GetFldName(hRec, i));
＿＿＿recName:= GetName(hRec);
＿＿end;{SetFldList}
＿＿
＿＿procedure SetFldValue;
＿＿begin
＿＿＿fldName:= GetFldName(hRec, iFld);
＿＿＿value:= GetRField(h, recName, fldName);
＿＿＿SetField(fldValueField, value);
＿＿＿SelField(fldValueField);
＿＿end;{SetFldValue}
＿＿
＿＿procedure ChoiceFldList(item:integer);
＿＿begin
＿＿＿GetSelChoice(item, 0, iFld, fldName);
＿＿＿SetFldValue;
＿＿end;{ChoiceFldList}
＿＿
＿＿procedure ChoiceRecList(item:integer);
＿＿begin
＿＿＿GetSelChoice(item, 0, iRec, recName);
＿＿＿SetFldList;
＿＿＿iFld:= 1;
＿＿＿SetFldValue;
＿＿end;{ChoiceRecList}
＿＿
＿＿procedure ChoiceFldValue(item:integer);
＿＿begin
＿＿＿value:= GetField(FldValueField);
＿＿end;{ChoiceFldValue}
＿＿
＿begin{DoDialog}
＿＿if (0 < nRec) & (h <> nil) then begin
＿＿＿GetDialog(RFieldDialog);
＿＿＿SetTitle('レコード・フィールド入力');
＿＿＿for i:= 1 to nRec do begin
＿＿＿＿hRec:= GetRecord(h, i);
＿＿＿＿InsertChoice(RecListChoice, i, GetName(hRec));
＿＿＿end;{for}
＿＿＿
＿＿＿iRec:= 1;
＿＿＿SelChoice(RecListChoice, iRec, false);
＿＿＿SetFldList;
＿＿＿iFld:= 1;
＿＿＿SetFldValue;
＿＿＿repeat
＿＿＿＿DialogEvent(item);
＿＿＿＿case item of
＿＿＿＿＿RecListChoice: ChoiceRecList(item);
＿＿＿＿＿FldListChoice: ChoiceFldList(item);
＿＿＿＿＿FldValueField: ChoiceFldValue(item);
＿＿＿＿end;{case}
＿＿＿until (item = OKButton) | (item = CancelButton){ | (item = FldValueField)};
＿＿＿ClrDialog;
＿＿＿if not(item = CancelButton) then begin
＿＿＿＿SetRField(h, recName, fldName, value);{ オブジェクトのレコード・フィールドを変更 }
＿＿＿end;{if}
＿＿end;{if}
＿end;{SetDialog}
＿
begin{main}
＿h:= FSActLayer;
＿nRec:= NumRecords(h);
＿CreateDialog;
＿DoDialog;
end;
Run(SetRF);

＞与太郎 さん
どうもです、SetRField()で書き換えた後、Move3DObj()で移動距離「0」で確認したと
ころ、こちらもOKでした。パラメータの書き換えは表示専用と思っていたところ、この
手を発見した時はうれしかったですね。だから、やめられないのですが...。

石男さん、
＞SetRField()でパラメータの書き換えを行った後、PIOを移動させまた元の位置に移動
＞させることでパラメータの書き換えが完全に行われます。
移動距離がゼロでもいいみたいですよ。下は自作PIMの中身ですが、

procedure SetHeightOffset;
{ 選択されている'高さ表示'オブジェクトのオフセット値を変更します。 }
var
x0, dX,
y0, dY:real;
hObj, hGrp, hLyr:handle;

Function ChangeCObjOffset(h:handle):boolean;
{ ForEachObjectInLayerから呼ばれる関数 }
const
CObj = '高さ表示';
FldName = 'hOffset';
var
hRec:handle;
nameRec:string;
fld:string;
begin
hRec:= GetRecord(h, 1);
if (hRec <> nil) then begin
nameRec:= GetName(hRec);
if (nameRec = CObj) then begin
fld:= Num2Str(6, dY + y0);
SetRField(h, nameRec, FldName, fld);{ パラメータを書き換える }
end;{if}
end;{if}
end;{ChangeCObjOffset}

begin{Main}
GetOrigin(x0, y0);
PtDialog('原点のオフセット','0.0', '0.0', dX, dY);
MoveObjs(0, 0, false, false);{ 選択図形をゼロ移動する }
ForEachObjectInLayer(ChangeCObjOffset, 3, 1, 6);
end;{SetHeightOffset}
Run(SetHeightOffset);

移動距離はゼロですし、移動後にパラメータ（レコード・フィールド）を書き換えてますが、
それでも正常に動いています。
（改めて見ると、ForEachObjectInLayerの最後のパラメータは怪しい...）

> CombineIntoSurface → VW10.1以降ですね。
そうなんですか〜調べてませんでした。

> VW9に移植しようとしたら大変でしたね。今まで待って正解？
正解です^^;　なんとか、VW10対応にスクリプトを書き換えたいのですが、
「互換あり」と謳ってはあるものの、実際問題なかなかうまくいきませんね〜
MCDのころから、新しいバージョンが出るたびにこうした厄介な問題に
直面してるので、正直、もううんざりなところです。(><)

> そんな事はないと思います、ダイアログを表示するメニューはきちんと処理を待ってい
> ますから。ただ、今回の件に限らずVW10から文法的に？少々うるさくなってきたような
> 気がします。「DoMenuTextByname」を使わなくて済むものはそうした方が良さそうです
> ね。
そうですね〜。こんどから、代換となる関数が無いかよく調べてみます。

> かなり関数が増えていますよ
ますます便利になってくれるのはいいことですね(^^)
勉強します！！

石男さんの書き込みを見ずに送ってしまいました。（ハズカシイ）
CombineIntoSurface → VW10.1以降ですね。
手元にVW9のデモ版しかなかったので...（言い訳）
VW9に移植しようとしたら大変でしたね。今まで待って正解？

＞「合成」に限らず「DoMenuTextByname」は、その内容の
＞処理を待たない仕様になったのでしょうか？
そんな事はないと思います、ダイアログを表示するメニューはきちんと処理を待ってい
ますから。ただ、今回の件に限らずVW10から文法的に？少々うるさくなってきたような
気がします。「DoMenuTextByname」を使わなくて済むものはそうした方が良さそうです
ね。
＞関数の知識等がVW8のときで止まっているので...
かなり関数が増えていますよ、ただVW8から変わらない部分も多いですが...。

与太郎様こんにちは。はじめまして。

> VW9以降だと「合成」コマンドのマウスクリックを待たずに次の処理に進んで
しまいますね。

そうだったんですね〜 困った「機能削除」です。
「合成」に限らず「DoMenuTextByname」は、その内容の
処理を待たない仕様になったのでしょうか？
VW8.5で組んだ膨大な量のスクリプトをVW9に移行するときに
挫折（あまりにもエラーが多くて）してたので、気付きませんでした。
しかし、そろそろVW10を使いたいのでいま一生懸命移行しているところです。

> 自分で「合成」サブルーチンを書くことに
これは、何度か組んだ事がありますが、なかなか難しいです^^;
与太郎さんの考えとほぼ同じですが、いくつか障害にぶつかって
構想の段階でストップすています。
ただ、プログラムの技術的にはかなりおもしろいですよね^^

今回の件は、「CombineIntoSurface()」を使って見事に解決しました。
まだ関数の知識等がVW8のときで止まっているので、VW10の関数を
もう少し勉強します。

確かに、VW9以降だと「合成」コマンドのマウスクリックを待たずに次の処理に進んで
しまいますね。

＞スクリプトの実行最中に合成のコマンドを実行できるようにできないでしょうか？
A&Aに訊いてみるのが良いと思います。
だめなら、自分で「合成」サブルーチンを書くことになりますが、
1. クリックする点(xc,yc)をGetPtで取得。
2. (xc,yc)に一番近い直線をLn0とする。
3. Ln0と交わる直線を探す。
と、ここまで書いて思ったのですが、交点が複数ある場合、最初の交点で処理を進めて
いって途中でエラー（多角形が閉じない）になったら、分岐点に戻って次の交点で処理
する、という具合にしないといけませんね。
迷路の経路を探す問題に似ています。再帰にすると楽そうです。
それにしても、かなり手強いです。

自分で「合成」サブルーチンを書く以外の方法がありますかね？

PIOの話題の続編です。パラメータの書き換えの件です。
以前はPIOはプログラムの開始のきっかけがわからないのでパラメータの書き換えが出
来ない、難しいということでしたが、PIOが移動、回転で再実行するものでしたら、
SetRField()でパラメータの書き換えを行った後、PIOを移動させまた元の位置に移動
させることでパラメータの書き換えが完全に行われます。厳密に言えば問題が出るかも
しれませんが...。

石男様
こんにちは。返信ありがとうございます。
「CombineIntoSurface()」という関数があったんですね！
これは、メニューの「合成」と同じ動きをすると考えてよろしいんですね？
さっそく試してみます。^^
ありがとうございました！

図形の合成は以下のもので出来ます。ただし、前処理と後処理のことは考慮していません。前処理でCoolTool辺りで図形の選択をしているなら、GetPt(),
CombineIntoSurface()だけを使うのも手です。

Procedure Test ;
Var
h : Handle ;
x , y : Real ;
Begin
MoveTo( 0 , 0 ) ;
LineTo( 10 , 0 ) ;

MoveTo( 10 , 0 ) ;
LineTo( 10 , 5 ) ;

MoveTo( 10 , 5 ) ;
LineTo( 0 , 5 ) ;

MoveTo( 0 , 5 ) ;
LineTo( 0 , 0 ) ;
ReDrawAll ;

GetPt( x , y ) ;
h := CombineIntoSurface( x , y ) ;

End ;
Run( Test ) ;

はじめまして、こんにちは。
VW8.5で動かしてたスクリプトをVW10.5へ移行作業でものすごく苦労(^^ゞしております。

以下のスクリプトでDoMenuTextBynameの処理（合成）を待たずに次に移ってしまいます。対処法などありますでしょうか？（環境MacOSX10.3　VW10.5）

（前処理・・・ある図形の選択）
DoMenuTextByname('Combine Into Surface',0);{図形合成}
（後処理・・・合成に成功か不成功かで分岐）

上記のスクリプトを実行すると、合成に不成功の処理をして、
プログラムは正常終了します。その時点で、マウスの
アイコンがここで、バケツマークになっていて、”合成”コマンドを実行
しています。
これを、スクリプトの実行最中に合成のコマンドを実行できるようにできないでしょうか？

ファイル間でビューをコピーするスクリプトです。

実行方法
1.　ふたつのスクリプトを、別々のテキストファイルにコピーして、保存する。
2.　VW9.5以前：リソースパレットから実行。
＿　VW10以降：「階層」メニュー→「コマンドを実行...」から実行。

使用頻度が高いなら、プラグインメニューにすると便利です。

{ビューをコピーする。}
procedure CopyView;
VAR
xAngleR, yAngelR, zAngleR, offsetX, offsetY, offsetZ:REAL;
centerX, centerY:REAL;
zoom:REAL;
begin
GetView(xAngleR, yAngelR, zAngleR, offsetX, offsetY, offsetZ);
GetVCenter(centerX, centerY);
zoom:= GetZoom;
ReWrite('View Info');
Writeln(xAngleR);
Writeln(yAngelR);
Writeln(zAngleR);
Writeln(offsetX);
Writeln(offsetY);
Writeln(offsetZ);
Writeln(centerX);
Writeln(centerY);
Writeln(zoom);
Close('View Info');
AlrtDialog('ビューをコピーしました。');
end;
Run(CopyView);

{ビューをペーストする。}
procedure PasteView;
VAR
xAngleR, yAngelR, zAngleR, offsetX, offsetY, offsetZ:REAL;
centerX, centerY:REAL;
zoom:REAL;
begin
Open('View Info');
Readln(xAngleR);
Readln(yAngelR);
Readln(zAngleR);
Readln(offsetX);
Readln(offsetY);
Readln(offsetZ);
Readln(centerX);
Readln(centerY);
Readln(zoom);
Close('View Info');
SetView(xAngleR, yAngelR, zAngleR, offsetX, offsetY, offsetZ);
SetVCenter(centerX, centerY);
SetZoom(zoom);
end;
Run(PasteView);

下のレスの関数ですが、
while (i < ln) & (Ord(Copy(source, i, 1)) <> TabCode) do の、
(i < ln) を (i <= ln) に直さないと、最後の１文字を取りこぼします。
また、constTabCode = 9; は、const TabCode = 9; としないとエラーになります。
（コピペしたら const と TabCode の間のタブが消えてしまいました。）

修正した関数です。
{ 文字列の先頭からタブまでの文字列を返します }
{ 同時に、元の文字列から、その文字列とタブ１個を削除します }
function ReadStrToTab(var source:string):string;
const
TabCode = 9;
var
i, ln:integer;
result:string;
begin
i:= 1;
ln:= Len(source);
while (i <= ln) & (Ord(Copy(source, i, 1)) <> TabCode) do
i:= i + 1;
if i = 1 then begin
result:= '';
source:= Copy(source, 2, ln-1);
end{if}
else if ln < i then begin
result:= source;
source:= '';
end{else if}
else begin
result:= copy(source, 1, i-1);
source:= copy(source, i+1, ln-i);
end;{else}
ReadStrToTab:= result;
end;{ReadStrToTab}

今まで、スクリプトにデータを渡すのにはワークシートばかり使ってました。
今回はファイルから直接読んでみたのですが、Readではタブ区切りデータの文字列を
うまく読み取れないので、読み取り関数を書きました。
（環境が変わるたびに似たような関数を作ってる気がする。）

{ 文字列の先頭からタブまでの文字列を返します }
{ 同時に、元の文字列から、その文字列とタブ１個を削除します }
function ReadStrToTab(var source:string):string;
constTabCode = 9;
var
i, ln:integer;
result:string;
begin
i:= 1;
ln:= Len(source);
while (i < ln) & (Ord(Copy(source, i, 1)) <> TabCode) do
i:= i + 1;
if i = 1 then begin
result:= '';
source:= Copy(source, 2, ln-1);
end{if}
else if ln < i then begin
result:= source;
source:= '';
end{else if}
else begin
result:= copy(source, 1, i-1);
source:= copy(source, i+1, ln-i);
end;{else}
ReadStrToTab:= result;
end;{ReadStrToTab}

使い方は、StdReadlnで１行全体を変数に読み込んで、
strData:= ReadStrToTab(「変数」);
とすれば、strDataに先頭のデータが入り、「変数」からそのデータと１個のタブが
削除されます。
データが数値なら、
numData:= Str2Num(ReadStrToTab(「変数」));
です。
当然ながら、１行の長さは、タブを含めて255バイト以内です。

シンボル生成用パラメータをファイルから読み込もうとしたら、
文字列データを含んでいるため、失敗しました。トホホ...
StdReadlnで一行全部読み込んで、自分でタブごとに分割するしかないみたい。
こんなところで引っかかるとは思わなかった...

＞与太郎さん
気にしないでください、まあ私もベクトルを使わずに三角関数でやっていました。
それでも、数学の参考書を買ってお勉強したら、結構便利なのに気がつき使い始めた
ものです。3Dをやり始めるとどうしても力技が必要になってくるので...。

石男さん、こん○○は。
つい先日、「データ構造とアルゴリズムのナンタラカンタラ...」（Ｃの本）をレジに持っ
ていくのをなんとか思いとどまった与太郎です。
同じような本を何冊ももってるのでした。でも新しいのが出るとつい手を伸ばしてしまう。
Macのようだ。

もしかして、
＞＞しかし、VSのベクトル関数が３Ｄ対応なら、シンボルを入れ子にする必要もないかも知
＞＞れません。
が、下の書き込みの原因でしょうか？
だったとしたらスイマセン。じつはベクトル計算は、よくわかりません。高校からやり直さ
ないといけません。
なんでもかんでも三角関数で済ませてきたので、ベクトル計算はしたことがないんです。

＞C言語で書かれていたものをVSに移植したものがあります。
C言語だと参考文献が豊富ですよね。

＞ちなみに数学は嫌いでした。
プログラミングには数学よりも、文章の構成力のほうが大事とか。私はどちらも...

＞ご要望に応じて出していきますが...。
ご厚意ありがとうがざいます。私には使いこなせそうにないですが、ここをご覧になった人
からリクエストがあるかも。
いろんな人が同じようなスクリプトを必要としていることって、けっこうあるようですし、
3Dベクトルのサブルーチンなら、標準で装備されていてもおかしくないものですよね。

C言語で書かれていたものをVSに移植したものがあります。3Dは検証の術がありませ
ん。それに文系の人間が書いたコードですので、保証できません。ちなみに数学は嫌い
でした。全コードは長くなりますので、載せませんが以下のもがあります。
ご要望に応じて出していきますが...。

・3次元ベクトルの大きさを返す
・3次元ベクトルの単位ベクトルを返す
・2つの3次元ベクトルのなす角度を返す
・ある点から3次元直線に垂直なベクトルを返す
・ある点から3次元直線の距離を求める
・3次元直線と3次元直線の交点を求める
・2つの3次元ベクトルの中点を求める
・2、3次元ベクトルの相対移動
・2、3次元ベクトルの回転ベクトル

石男さん、レスサンクスです。
＞蛇足をもうひとつ、VSのベクトル関数は全て2次元用です。3次元には利用できません。
今回のスクリプトは精度は必要ないので、パラメーターは取付け角度等を直接指定する
格好になります。結果を見てパラメータを変更するので、角度計算は必要ないです。

しかし、VSのベクトル関数が３Ｄ対応なら、シンボルを入れ子にする必要もないかも知
れません。
階層の先の方のシンボル挿入点を計算するのが面倒なので、入れ子シンボルにしてしま
いました。それにパーツ同士が繋がらないという心配もないので。

今日は（備後は）暑かったです〜。石男さんは（関東方面？）いかがでしたか？
こちらは週末から雨／曇りが続くようです。（梅雨入りかな）

＞たいへん申し訳ないです。
いえ、Ver.8.5や9.5ではこんなものぐらいなのであきらめて...の意味で書いたもので
す。
＞パーツの取付け角度を変えたり捻ったりします。
蛇足をもうひとつ、VSのベクトル関数は全て2次元用です。3次元には利用できません。

石男さん、
＞Set3DRotとSetRot3Dの違いは
＞Ver.10以降のレファレンスではサポートしている図形が違うような感じです。

Set3DRot と SetRot3D を試してみました。
Set3DRot→3D図形を現在の角度から指定角度だけ回転させる、
SetRot3D→3D図形を指定角度に回転させる、
で正解のようです。
マニュアルの訳が良くないのですね。英語の説明だとちゃんと違いがわかります。

SetRot3Dはプリミティブな３Ｄ図形（柱状体、回転体）では動きましたが、グループや
シンボル（多分ソリッドも）はサポートしないようです。（これも英文では書いてますね）
しかし、回転中心の座標は生成時の位置に固定されていて、x,y,zを変えても動きません。
パラメータのx,y,z（xDistance,yDistance,zDistance）の意味は、英語マニュアルで
もよくわかりません。なので、使える状況がかなり限定されますね。

うわ〜、また書き込みが。
たいへん申し訳ないです。
残念ですが、シンボルが傾むいたり、挿入基点が底面でなかったりするので、
VW8や9では無理かも知れません。とりあえずVW10でGetSymLoc3Dを使って書
くことにします。

目的は、60個くらいのパーツを持つ3Ｄシンボルを変形するスクリプトです。
それぞれのパーツが3Ｄシンボルで、パーツ同士はジョイントで繋がってます。
パーツ自体は変形しなくて、パーツの取付け角度を変えたり捻ったりします。
パーツ間には従属関係があり、3Ｄシンボルが別の3Ｄシンボルを含みます。
（最大７階層くらい）
いまは、3Ｄシンボルを作るスクリプトを書いてるところで、変形は先の話です。
パーツ自体は単純な形状ですが、パーツ（シンボル）に名前を付けるのに知恵
を絞ってます。

＞Set3DRotとSetRot3Dの違いは
＞Ver.10以降のレファレンスではサポートしている図形が違うような感じです。
やっぱり一度角度をゼロに戻してから回転させないとダメみたいですね。
ver.10のマニュアルをよく読んでみます。

Ver.8.5や9.5ですとこんな感じです。
Procedure Test ;
Var
x , y , z : Real ;
{-------------------------------------------------------------}
Procedure MyGetSym( SymHadle : Handle ; Var sym_x , sym_y , sym_z : Real ) ;
Var
sx , sy , sz , cntr_x , cntr_y , cntr_z : Real ;
Begin
GetSymLoc( SymHadle , sym_x , sym_y ) ;
Get3DInfo( SymHadle , sy , sx , sz ) ;
Get3DCntr( SymHadle , cntr_x , cntr_y , cntr_z ) ;
sym_z := cntr_z-sz/2 ;
End ;
{-------------------------------------------------------------}
Begin
MyGetSym( FSActLayer , x , y , z ) ;
Message( Concat('Loc3D: x=' , x , 'y=' , y , 'z=' , z ) ) ;


End ;
Run( Test ) ;
この方法しかありません。
＞＞ Set3DRotとSetRot3Dの違いは
Ver.10以降のレファレンスではサポートしている図形が違うような感じです。

石男さん、ありがとうございます。

＞＞2DのGetSymLocのように、3Dシンボルの挿入基点の座標を得る方法はありますか？
＞Ver10.からGetSymLoc3D(SymHandle:Handle;Var x,y,z:Real) ;で3Dシンボル、PIOの挿
＞入点の3次元座標の値が取得できます。
VW10のマニュアルは調べてませんでした (^_^; 。やはりVW8.5や9.5では無理ですか...

＞＞ResetOrientation3Dは何に使うのでしょうか？
＞これはいまいちわかりません。
とりあえずは使う必要はないものと理解いたしました。

＞＞ Set3DRotとSetRot3Dの違いは、
＞これはバックナンバーに私とトトロさんとのやりとりがあります。参考にしてください。
バックナンバーを見ましたが、結論が出てなかったようなので、あれから進展があったか
と思いまして...
すでに回転してある図形を任意の角度に回転しようとすると、いったん角度ゼロに戻して
から回転しないとややこしいことになりますので、それを一度に出来るサブルーチンがな
いかなあと思った次第です。
急ぐものではないので、いろいろ実験しながらやってみます。

以下、蛇足です。
>１. 2DのGetSymLocのように
Ver10.からGetSymLoc3D(SymHandle:Handle;Var x,y,z:Real) ;で3Dシンボル、PIOの挿
入点の3次元座標の値が取得できます。ちなみに、2DのようにGetSymLocでもとれます。
回転角度に関してはGetSymRotでもとれます。ただし、x-y角度です。
>（角度はGet3DOrientationで得られました）
こちらの方がベストだと思います。

それと、3次元全般に言えるのですが、Ver.8から使える関数が増えていません。
Get3DInfoとGet3DCntrぐらいです。この組み合わせでなんとかするぐらいです。

>１. 2DのGetSymLocのように
確かVer.10から3Dシンボルのx,y,z値を取る関数があります。
>２. ResetOrientation3Dは何に使うのでしょうか？
これはいまいちわかりません。
>３. Set3DRotとSetRot3Dの違いは、
これはバックナンバーに私とトトロさんとのやりとりがあります。参考にしてくださ
い。取り急ぎ...。

３Ｄのスクリプトを書こうとしているのですが、２Ｄとは勝手がちがって、わからな
いことだらけです。どうかアドバイスをお願いします。

１. 2DのGetSymLocのように、3Dシンボルの挿入基点の座標を得る方法はありますか？
（角度はGet3DOrientationで得られました）
２. ResetOrientation3Dは何に使うのでしょうか？
３. Set3DRotとSetRot3Dの違いは、
Set3DRot→3D図形を現在の角度から指定角度だけ回転させる、
SetRot3D→3D図形を指定角度に回転させる、でいいのでしょうか？

ご存知の方、よろしくお願いします。

＞きっと、３D多角形を貼り付けるのが現状でのベストアンサーでしょう
確かに、３D多角形を貼り付ける＝型枠のモデリングですから、間違いがないですね。

残念ですがそれでカバーできるほどの単純な図形はなかなか存在しません
またそのような単純図形を積み上げて複雑な図形を組んでも
かみ合いの所はどうするという問題が出てきます
きっと、３D多角形を貼り付けるのが現状でのベストアンサーでしょう

言葉足らずで判りにくかったですね。

BeginSym('3Dシンボル');
BeginXtrd(startHt, endHt);
NameObject('柱状体の断面');
ClosePoly;
Poly(x1, y1, x2, y2...);
EndXtrd;
EndSym;
で作ったシンボル(柱状体)の断面図形(多角形)のハンドルを、別のスクリプトから、
h:= GetObject('柱状体の断面');
で得て、変形や情報の取得ができます。

自分でつっこむのもなんですが、
=Surface って、そんなＷＳ関数はありません。
ワークシートには関数ペーストしたので、ちゃんと =SurfaceArea となってましたが、
書き込むときに脳ない変換で =Surface としてしまいました。

>どんなに深い階層（ソリッドの中でも）にあっても、直接アクセスできます。
何度も考えているんですが、決定打がありません。基本的に底面が四角形の 柱状体な
ら簡単にいけるのですが、その先にある多角形、円弧を含む多角形となると絶望的に
なります。柱状体が回転している時のことなども考えなければいけないので...。
そんな事でPIOを自分なりの仕様で作っています。変数名を出来るだけ共通化すれば
後から簡単に情報がとれますから。

石男さん、3Dのスクリプトにも使えません？

ハンドルはファイルに保存しては使えないけど、
名前なら可能です。
しかも、どんなに深い階層（ソリッドの中でも）にあっても、直接アクセスできます。

達人の本を読んでいます。書店でチラチラとみてはいたのですが、
高価なので、今まで買う決心がつかなかったんです。
ファイル共有によるシンボル管理や、データベースの使い方など、
たいへん参考になります。それから...
シンボルの中の図形の名前も参照できるということなので、柱状体、
多段柱状体、ソリッドの元図形でも試したら、参照できました。
そこで、
すこし前に、辺境地のコンサルさんの質問で、型枠面積の算出とい
うのがありましたが、それに応用すると、

柱状体の型枠面積は、
=Surface(N='柱状体の名前') から、
=Area(N='柱状体の断面図形の名前')*2 を差し引きます。

多段柱状体なら、
=Surface(N='多段柱状体の名前') から、
=Area(N='多段柱状体の一番上の断面図形の名前') と、
=Area(N='多段柱状体の一番下の断面図形の名前') を差し引きます。

複雑な形状だと無理ですが、この方法だと、余計な３D多角形を作る
必要がありません。

わぁ〜！、すごい工程ですね。読んでいるだけで、目眩がしそう・・・。
それでも、与太郎さん言うように図形の種類別にひとつずつ作って行けば何とかなりそうですね。
実行時間が気になりますが、パソコンの性能も良くなっていることだし、こんな感じで進めて見ま
しょうか。
今すぐって訳にはいきませんが、空き時間を見つけながらやってみます。

あっ、与太郎さんは私に遠慮せず、どんどん先に作成して下さいね。

きちんと処理するなら、図形の種類でソート方法を変えたほうが良いようです。

「重複図形を削除」
設定値をファイルから読み込む
パラメータをダイアログで設定
配列にハンドル、タイプを入れる
配列に辺の端点、角度、タイプ、元図形のハンドルを入れる
タイプでソート
タイプでループ
＿「線、辺の処理」
＿＿配列に端点、角度を入れる
＿＿角度でソート
＿＿角度でループ
＿＿＿座標変換（回転）
＿＿＿ｙ座標(変換後)でソート
＿＿＿ｙ座標(変換後)でループ
＿＿＿＿ｘ座標(変換後)でソート
＿＿＿＿ｘ座標(変換後)でループ
＿＿＿＿＿比較および削除
＿「多角形、四角形の処理」
＿＿配列にBoundRectを入れる
＿＿Bottomでソート
＿＿Bottomでループ
＿＿＿Leftでソート
＿＿＿Leftでループ
＿＿＿＿Topでソート
＿＿＿＿Topでループ
＿＿＿＿＿Rightでソート
＿＿＿＿＿Rightでループ
＿＿＿＿＿＿比較および削除
＿「円、円弧の処理」
＿＿配列に中心座標、半径、開始角、円弧角を入れる
＿＿ｘ座標でソート
＿＿ｘ座標でループ
＿＿＿ｙ座標でソート
＿＿＿ｙ座標でループ
＿＿＿＿半径でソート
＿＿＿＿半径でループ
＿＿＿＿＿比較および削除
＿「文字の処理」
＿＿配列にBoundRectを入れる
＿＿Bottomでソート
＿＿Bottomでループ
＿＿＿Leftでソート
＿＿＿Leftでループ
＿＿＿＿Topでソート
＿＿＿＿Topでループ
＿＿＿＿＿Rightでソート
＿＿＿＿＿Rightでループ
＿＿＿＿＿＿角度でソート
＿＿＿＿＿＿角度でループ
＿＿＿＿＿＿＿比較および削除
＿「シンボルの処理」
＿「基準点の処理」
＿「角丸四角形の処理」
＿「カーブの処理」
＿以下、図形の種類だけ続ける
設定値をファイルに保存
終了。

図形の比較は、隣合ったものだけでなく、ソート条件が一致したもの全部を調べないと、
部分的に重なった線や、別の線に隠れる線を見つけられません。
部分的に重なった線や円弧は、一本の線や円弧にできます。
許容誤差、属性が異なる図形を削除するかどうかは、ダイアログで設定します。

けっこうな分量になりますが、種類ごとに完成させていけば、なんとかならないですか？

1. 配列を角度でソートする。
2. 同じ角度（または誤差を考えて近い角度）のデータを、水平になるように座標変換する。
3. それをｙ座標（下側）でソートする。
4. ｙ座標を比べて、高さの差がゼロ（または誤差の範囲内）なら２つの線は同一線上にあるので、
5. それをｘ座標（左側）でソートする。
6. ｘ座標で線が他の線に含まれるか判断し、
7. 含まれる方の（短い）線を消す。

が正しいです。

VW9以降なら、各種データをまとめて、

type
＿objectInfo = structure
＿＿h : handle;
＿＿tp : integer;{Object Type。例外として、多角形と四角形の辺なら辺の番号(-1,-2,-3...)。}
＿＿tempInt : integer;{タイプ別ソートに使用。直線と辺、円と円弧、多角形と四角形の番号は同じにする。}
＿＿x1, y1, x2, y2 : real;{BoundRect、直線の端点、円／円弧の中心。}
＿＿xa1,ya1,xa2,ya2: real;{座標変換後の座標}
＿＿tempReal : real;{半径、角度でのソートに使用。}
＿end;{objectInfo}

var
＿data : arrray[MinArray..MaxArray] of objectInfo;

とすると一個の配列にできます。
ソートでのデータの入れ替えも早くなります。

多角形と四角形の線上に有る直線を消すために、多角形と四角形の辺も配列に追加します。
（多角形の開と閉に注意）

図形タイプによるソートは最初にしたほうが良いと思います。
直線と辺、円と円弧、多角形と四角形は同じ番号としてソートします。
integer型のソートなので、ビンソートが高速です。
その際、配列内の図形タイプの開始位置と終了位置の配列も作りましょう。

半端な位置にある直線を消すには、
1. 配列を角度でソートする。
2. 同じ角度（または誤差を考えて近い角度）のデータを、水平になるように座標変換する。
3. それをｙ座標（下側）でソートした後、ｘ座標（左側）でソートする。
4. ｙ座標を比べて、高さの差がゼロ（または誤差の範囲内）なら２つの線は同一線上にあるので、
5. ｘ座標で線が他の線に含まれるか判断し、
6. 含まれる方の（短い）線を消す。

角度でソート
角度でループ
＿座標変換
＿ｙ座標でソート
＿ｙ座標でループ
＿＿ｘ座標でソート
＿＿ｘ座標でループ
＿＿＿比較および削除

で可能です（たぶん）。

こんばんは、masafumiです。

石男さん
＞やはり、この辺りは難しいですよね。3D図形を2Dに変換した場合、結構こんな状態になるんですよ。

そうですねぇ、多角形の各辺にて個別にループするしかなさそうですね。それでも半端な位置にあ
る直線は拾えません。それを何とかしようとすると実行時間が膨大になりそうで・・・考える前か
らもう、あきらめモードに突入ですね。

＞＞配列ですが、-32768 から 32767 までですので、下限いっぱい(-32768)まで使用しました。
＞これには目から鱗でした。

与太郎さん
＞配列の下限が -32768 なのは思い付きませんでした。個数だからゼロから数えるという先入観
＞があったようです。

お二方にこう言って頂けるだけで、Ｕｐした甲斐が有ります。普段何気なく使用している事が、
実は他の人に取っては、とっても新鮮に感じる事があります。今回の中心座標によるソートも私
にとっては同様です。
底辺が広がれば広がるほど、こういった感覚も増して来るのではないかと思っています。
皆さん、いっぱい書き込んでください。そして私に新鮮な感覚をいっぱい与えてください（欲張り？）。

＞10万5千点の図形図面は、テスト用データでなくて実際に仕事で使われているものですか？

はい、土木工事の完工図を作成するのに頂いたモノです。同様の図面が三枚有り、これを合体
して一枚の図面にして、ＧＷ後に欲しいと・・・。

＞図形タイプ別にソートする部分が見つけらないのですが？

上記図面が直線と円・円弧ばかりの図面だったので、最初から必要ないと決めつけていました（笑）。
指摘されて初めて、やっぱり必要なんだ・・・っと。
う〜ん、何とかなるかな。

> if (((GetType(h[i])=2) and (GetType(h[i+1])=2)) and
> ((x[i]=x[i+1]) and (y[i]=y[i+1]))) then
> begin
> j:=j+1;
> if j=1 then startCo:=i;
> if j > 2 then chkFlg:=True;
> endCo:=i;
> end else
> begin

の部分を下の様にすればイケそうですね。

> if ((x[i]=x[i+1]) and (y[i]=y[i+1])) then
> begin
> j:=j+1;
> if j=1 then startCo:=i;
> if j > 2 then chkFlg:=True;
> endCo:=i;
> end else
> begin
> if chkFlg=True then
> begin
> {中心座標が同じ図形の時、同種別が隣に有れば良い訳ですから}
> {ここで図形種別によるソートを実行}
> end;
>
> {その後で中心座標が同じ直線が複数有る時、角度によるソート}
> {っん、他の図形でも再ソートが必要そう・・・。ソートの条件はどうする？}

ってな感じになると思います。
これは時間が取れる時に、やってみます。それともどなたか、やってみます？。

＞同形状の図形で、面と外形線を分けたりすることがあるので、属性を無視するかどうかのオプ
＞ションも、是非付けたいです。

悩みはつきないですね・・・。

＞課題としては、長さの違う重なり合った直線や、四角形・多角形の線上に有る直線、円の下
＞に有る円弧等をどうするか。
やはり、この辺りは難しいですよね。3D図形を2Dに変換した場合、結構こんな状態になるんですよ。
やりかけて断念した経緯があります...。
＞配列ですが、-32768 から 32767 までですので、下限いっぱい(-32768)まで使用しました。
これには目から鱗でした。

masafumiさん、速攻で直してしまいましたね。
元のスクリプトは、ずいぶん詰めが甘かったようです。

＞図形の中心座標でソートしていますので、中心が一緒で半径が違う円や、同一円周上に有る
＞円弧も同順位に位置して来ますから、重複図形と元図形との間にソートされる事も有り、そ
＞れを防ぐ為に、円・円弧の時は中心座標ではなく、円弧の中点の座標でソートするようにし
＞ました。
確かに中心点が同じでサイズが異なる同タイプの図形はあり得ます。四角形でもありますね。

＞配列ですが、-32768 から 32767 までですので、下限いっぱい(-32768)まで使用しました。
配列の下限が -32768 なのは思い付きませんでした。個数だからゼロから数えるという先入観
があったようです。
じつはちゃんと動くようになってから、複数の配列(1..32767)を使ってマージソートするよう
に改造する構想はあったのですが、65535個処理できれば当面は充分です。
masafumiさんの10万5千点の図形図面は、テスト用データでなくて実際に仕事で使われている
ものですか？

＞また、図形別ソート（ループ）を、全ての図形を一度にソートするように変更しましたので、
＞全体で65535個の図形しか識別出来ません。それ以上に選択された図形は無視します。
＞この事情で先に図形を選択した状態で実行するように変更しました
このために図形タイプ別のループをやめましたね。
図形タイプ別にソートする部分が見つけらないのですが？

＞カウント用変数の i , j がグローバル変数に有り、ローカルでも i , j を使用しているので
＞勘違いミスを防ぐ為、少し全体の雰囲気を変更しました。
ソート・ルーチンが本の引き写しなのがバレバレです。
サブルーチンの中と外に同じ変数名があるのは、バグの元でもあります。グローバル変数は意味
のある名前でないといけませんね。

＞課題としては、長さの違う重なり合った直線や、四角形・多角形の線上に有る直線、円の下
＞に有る円弧等をどうするか。
＞でも、現実的にはこんな図形のある図面は少ないでしょうね。
＞ファイル容量を少なくするのが主な目的ですから、多少取り残しが有ってもどうって事ない
＞ですね。
同形状の図形で、面と外形線を分けたりすることがあるので、属性を無視するかどうかのオプ
ションも、是非付けたいです。

帰り際だったのに、こんな時間になってしまった...

下記の修正スクリプトですが、私に必要な部分（直線・円・円弧）を中心に修正してみました。

図形の中心座標でソートしていますので、中心が一緒で半径が違う円や、同一円周上に有る
円弧も同順位に位置して来ますから、重複図形と元図形との間にソートされる事も有り、そ
れを防ぐ為に、円・円弧の時は中心座標ではなく、円弧の中点の座標でソートするようにし
ました。

また直線は複数の図形が中心で交差している時（直線上に有る×印とか）、重複図形が有ると
これも期待道理にソートされません。この場合は直線の角度を使って再ソートしてみました。

配列ですが、-32768 から 32767 までですので、下限いっぱい(-32768)まで使用しました。
また、図形別ソート（ループ）を、全ての図形を一度にソートするように変更しましたので、
全体で65535個の図形しか識別出来ません。それ以上に選択された図形は無視します。
この事情で先に図形を選択した状態で実行するように変更しました

他には、座標値が Real型だと浮動小数点の関係で微妙に違う値になる事が有り、比較時に同一
と判断されない時が有ったので、Longint型に変換して比較する様にしました。その為に単位を
強制的に mm に変更しています。

カウント用変数の i , j がグローバル変数に有り、ローカルでも i , j を使用しているので
勘違いミスを防ぐ為、少し全体の雰囲気を変更しました。

2万点位の図形図面では一発で全て削除、10万5千点の図形図面で 40 点位残りました。
Pen 3 1.0G メモリ 500MB のパソコンで10万5千点の図形を、２回に分けて削除するのに
時間は約３分でした。削除図形数 54505 個、ファイル容量 8.53MB が 4.19MB になりました。

む〜ん、１０日程早くＵＰしてくれていたら、ＧＷはもっとゆったりと休めたのに・・・
中心座標でソートするなんて考えても見ませんでした。ちなみに私の試作品では上の作業
に５時間掛かりました（泣き）。

課題としては、長さの違う重なり合った直線や、四角形・多角形の線上に有る直線、円の下
に有る円弧等をどうするか。
でも、現実的にはこんな図形のある図面は少ないでしょうね。
ファイル容量を少なくするのが主な目的ですから、多少取り残しが有ってもどうって事ない
ですね。

{
アクティブレイヤの選択図形の中から重複図形を削除します。
３Ｄ図形、グループ図形は対象外です。
図形属性の比較はしていません。(手抜きです)
配列の制限から、同じタイプの図形は65535個までしか処理できません。
単純なアルゴリズムだと、最悪の場合65535x65535回の比較となり、
処理時間が膨大（42億回！）になるので、
ハンドルと中心座標の配列をX,Yでソートして、隣り合ったハンドルだけ比較しています。
ソート方法はクイックソートです。再帰呼び出しをしているので、
データによってはスタック・オーバーフロー・エラーが出る可能性があります。
（まだ起こったことはありませんが）
}
{*************************** 重複図形削除 *****************************}
procedure DelEqualObject;
const
＿Dist=100;＿＿＿＿＿{Message表示を100回置き}
＿MinArray=-32768;
＿MaxArray =32767;
＿cP=10000;
var
＿h,th:array[MinArray..MaxArray] of handle;
＿x,y :array[MinArray..MaxArray] of real;
＿tAng:array[MinArray..MaxArray] of real;
＿gCount＿:longint;
＿gSquName:String;

{****************************** 既定値を取得 ****************************}
PROCEDURE Get_Fixed_Vlue;
VAR
＿＿upi:Real;
＿＿fraction,display:LONGINT;
＿＿format:INTEGER;
＿＿name,squareName:STRING;
Begin
＿＿{単位（平方）を取得}
＿＿GetUnits( fraction,display,format,upi,name,squareName);
＿＿gSquName:= squareName;
＿＿Units(4);＿＿＿＿＿＿ {単位を「ミリメートル」に変更}
End;

{**************************** 値を初期値に戻す****************************}
PROCEDURE Set_Fixed_Vlue;
Begin
＿＿{単位を元に戻す}
＿＿if gSquName = ' sq ft' then Units(2)＿＿＿ {フィート}
＿＿else if gSquName = ' sq in' then Units(3)＿{インチ}
＿＿else if gSquName = ' sq mm' then Units(4)＿{ミリメートル}
＿＿else if gSquName = ' sq cm' then Units(5)＿{センチメートル}
＿＿else if gSquName = ' sq m' then＿Units(6); {メートル}
End;

{****************************** ＸY座標を計算 *****************************}
{XX,YY:求めるXY座標; ax,ay:基準となるXY座標; sideOfLength:距離;＿DirectionAngle:方向角}
procedure GetXYzahyou(var XX:Real; var YY:Real; ax,ay,sideOfLength,DirectionAngle:REAL);
begin
＿XX:=ax + Cos(Deg2Rad(DirectionAngle)) * sideOfLength;
＿YY:=ay + Sin(Deg2Rad(DirectionAngle)) * sideOfLength;
end;

{*********************** ２点の角度を取得 ******************************}
function GetAngle(ax,ay,bx,by:Real):Real;
var
＿pV1,pV2:Vector;
begin
＿pV1.x:=ax;
＿pV1.y:=ay;
＿pV2.x:=bx;
＿pV2.y:=by;
＿GetAngle:=Vec2Ang(pV2-pV1);
end;

{**************************** Ｙ座標ソート ******************************}
procedure QSortY (left, right:integer);
var
＿i, j :integer;
＿pivot,{ 境界値 }
＿tempX, tempY :real;
＿tempH :handle;
＿ret:longint;
begin
＿ret:=left-MinArray;
＿if (ret mod Dist)=0 then Message('Sort Y ', gCount, ' / ',ret);
＿if left < right then begin
＿＿pivot:= (y[left]+y[right])/2;
＿＿i:= left;
＿＿j:= right;
＿＿repeat
＿＿＿while y[i] < pivot do i:= i+1;
＿＿＿while y[j] > pivot do j:= j-1;
＿＿＿if i <= j then begin
＿＿＿＿tempX:= x[i]; tempY:= y[i]; tempH:= h[i];
＿＿＿＿x[i]:= x[j]; y[i]:= y[j]; h[i]:= h[j];
＿＿＿＿x[j]:= tempX; y[j]:= tempY; h[j]:= tempH;
＿＿＿＿i:= i+1;
＿＿＿＿j:= j-1;
＿＿＿end;{if}
＿＿until i > j;
＿＿QSortY(left, j);
＿＿QSortY(i, right);
＿end;{if}
end; { QSortY }

{**************************** Ｘ座標ソート ******************************}
procedure QSortX (left, right:integer);
var
＿i, j :integer;
＿pivot,
＿tempX, tempY :real;
＿tempH :handle;
＿ret:longint;
begin
＿ret:=left-MinArray;
＿if (ret mod Dist)=0 then Message('Sort X ', gCount, ' / ',ret);
＿if left < right then begin
＿＿pivot:= (x[left]+x[right])/2;
＿＿i:= left;
＿＿j:= right;
＿＿repeat
＿＿＿while x[i] < pivot do i:= i+1;
＿＿＿while x[j] > pivot do j:= j-1;
＿＿＿if i <= j then begin
＿＿＿＿tempX:= x[i]; tempY:= y[i]; tempH:= h[i];
＿＿＿＿x[i]:= x[j]; y[i]:= y[j]; h[i]:= h[j];
＿＿＿＿x[j]:= tempX; y[j]:= tempY; h[j]:= tempH;
＿＿＿＿i:= i+1;
＿＿＿＿j:= j-1;
＿＿＿end;{if}
＿＿until i > j;
＿＿QSortX(left, j);
＿＿QSortX(i, right);
＿end;{if}
end; { QSortX }

{*********************** 角度を使って再ソート **************************}
procedure SortX2(count:integer);
var
＿＿tmpXX:Real;
＿＿tmpX,tmpY:Real;
＿＿tmpH:Handle;
begin
＿＿tmpXX:=tAng[count];
＿＿tmpH:=h[count];
＿＿tmpX:=x[count];
＿＿tmpY:=y[count];
＿＿tAng[count]:=tAng[count+1];
＿＿h[count]:=h[count+1];
＿＿x[count]:=x[count+1];
＿＿y[count]:=y[count+1];
＿＿tAng[count+1]:=tmpXX;
＿＿h[count+1]:=tmpH;
＿＿x[count+1]:=tmpX;
＿＿y[count+1]:=tmpY;
end;

{************************* 削除図形チェック ****************************}
function EqualObject(h1, h2:handle):boolean;
const
＿MaxVertex = 10000;
var
＿tp1, tp2 :integer;
＿a11, a12, a21, a22,
＿x11, y11, x12, y12,
＿x21, y21, x22, y22 :real;
＿x1, y1, x2, y2, r1, r2 :real;
＿v1, v2 :integer;
＿i, n1, n2 :longint;
＿result :boolean;
＿La11,La12,La21,La22:longint;
＿Lx11,Ly11,Lx12,Ly12:longint;
＿Lx21,Ly21,Lx22,Ly22:longint;
begin
＿tp1:= GetType(h1);＿＿＿＿＿＿＿＿ {図形の種類を取得}
＿tp2:= GetType(h2);
＿GetBBox(h1, x11, y11, x12, y12);＿ {図形がおさまる最小の四角形の座標}
＿GetBBox(h2, x21, y21, x22, y22);
＿EqualObject:= false;
＿Lx11:=round(x11); Ly11:=round(y11); Lx12:=round(x12); Ly12:=round(y12);
＿Lx21:=round(x21); Ly21:=round(y21); Lx22:=round(x22); Ly22:=round(y22);
＿{２つの図形を比較・分岐処理}
＿if (tp1 = tp2) & EqualRect(Lx11, Ly11, Lx12, Ly12, Lx21, Ly21, Lx22, Ly22) then
＿begin
＿＿case tp1 of
＿＿2: begin{Line}
＿＿＿{２直線の始点の座標と終点の座標とを比較}
＿＿＿GetSegPt1(h1, x11, y11);
＿＿＿GetSegPt2(h1, x12, y12);
＿＿＿GetSegPt1(h2, x21, y21);
＿＿＿GetSegPt2(h2, x22, y22);
＿＿＿Lx11:=round(x11);＿Ly11:=round(y11);＿Lx12:=round(x12);＿Ly12:=round(y12);
＿＿＿Lx21:=round(x21);＿Ly21:=round(y21);＿Lx22:=round(x22);＿Ly22:=round(y22);
＿＿＿if (EqualPt(Lx11, Ly11, Lx21, Ly21) & EqualPt(Lx12, Ly12, Lx22, Ly22)) |
＿＿＿＿＿＿＿＿(EqualPt(Lx11, Ly11, Lx22, Ly22) & EqualPt(Lx12, Ly12, Lx21, Ly21)) then
＿＿＿begin
＿＿＿＿EqualObject:= true;
＿＿＿end;{if}
＿＿end;{Line}
＿＿3,4: begin{Rect, Oval}
＿＿＿EqualObject:= true;
＿＿end;{Rect}
＿＿5: begin{Poly}
＿＿＿n1:= GetVertNum(h1);
＿＿＿n2:= GetVertNum(h2);
＿＿＿if n1 = n2 then
＿＿＿begin
＿＿＿＿result:= true;
＿＿＿＿while (i <= n1) & result do
＿＿＿＿begin
＿＿＿＿＿GetPolyPt(h1, i, x1, y1);
＿＿＿＿＿GetPolyPt(h2, i, x2, y2);
＿＿＿＿＿if not EqualPt(x1, y1, x2, y2) then result:= false;
＿＿＿＿＿i:= i + 1;
＿＿＿＿end;{while}
＿＿＿＿EqualObject:= result;
＿＿＿end;{if}
＿＿end;{Poly}
＿＿6: begin{Arc}
＿＿＿{開始角度と円弧の角度を比較}
＿＿＿GetArc(h1, a11, a12);
＿＿＿GetArc(h2, a21, a22);
＿＿＿La11:=round(a11*cP); La12:=round(a12*cP);
＿＿＿La21:=round(a21*cP); La22:=round(a22*cP);
＿＿＿if (La11=La21) & (La12=La22) then EqualObject:= true;
＿＿end;{Arc}
＿＿8,9,11,12,14: begin{FreeHand, Locus3D, Group, QArc, BitMap}
＿＿＿{ 未処理 }
＿＿end;
＿＿10: begin{Text}
＿＿＿if GetText(h1) = GetText(h2) then
＿＿＿begin
＿＿＿＿EqualObject:= true;
＿＿＿end;{if}
＿＿end;{Text}
＿＿13: begin{RRect}
＿＿＿GetRRDiam(h1, x11, y11);
＿＿＿GetRRDiam(h2, x21, y21);
＿＿＿if EqualPt(x11, y11, x21, y21) then
＿＿＿begin
＿＿＿＿EqualObject:= true;
＿＿＿end;{if}
＿＿end;{RRect}
＿＿15: begin{Symbol}
＿＿＿if GetSymName(h1) = GetSymName(h2) then
＿＿＿begin
＿＿＿＿EqualObject:= true;
＿＿＿end;{if}
＿＿end;{Symbol}
＿＿17: begin{Locus}
＿＿＿EqualObject:= true;
＿＿end;{Locus}
＿＿21: begin{PolyLine}
＿＿＿n1:= GetVertNum(h1);
＿＿＿n2:= GetVertNum(h2);
＿＿＿if n1 = n2 then
＿＿＿begin
＿＿＿＿result:= true;
＿＿＿＿while (i <= n1) & result do
＿＿＿＿begin
＿＿＿＿＿GetPolylineVertex(h1, i, x1, y1, v1, r1);
＿＿＿＿＿GetPolylineVertex(h2, i, x2, y2, v2, r2);
＿＿＿＿＿if (not EqualPt(x1, y1, x2, y2)) | (v1 <> v2) | (r1 <> r2) then
＿＿＿＿＿＿＿＿＿result:= false;
＿＿＿＿＿i:= i + 1;
＿＿＿＿end;{while}
＿＿＿＿EqualObject:= result;
＿＿＿end;{if}
＿＿end;{PolyLine}
＿＿end;{case}
＿end;{if}
end;{EqualObject}

{**************************************************************************}
procedure DelEqualObject2;
var
＿＿i,j,k,iCo＿＿ :integer;
＿＿nCount,nDel＿ :longint;
＿＿startCo,endCo :integer;
＿＿chkFlg,sortFlg:Boolean;
＿＿msg:string;
＿＿px1,py1,x1,y1,angleH,startAngle,arcAngle:Real; {円弧の中点座標用}
(*
＿＿tp :array[1..255] of integer; {チェック用}
＿＿objT:integer;
*)
begin
＿＿nDel:= 0;
＿＿gCount:= NumSObj(ActLayer);＿＿＿＿{削除候補図形の総数}
＿＿if 0 < gCount then
＿＿begin
＿＿＿ msg:='アクティブレイヤ上の重複図形を削除します。';
＿＿＿ msg:=Concat(msg,'３Ｄ図形、グループ図形は対象外です。');
＿＿＿ AlrtDialog(msg);
＿＿＿ nCount:=MaxArray-MinArray;＿＿{最大実行図形数}
＿＿＿ if nCount < gCount then
＿＿＿ begin
＿＿＿＿ AlrtDialog(Concat( Num2StrF(gCount),' 個の図形が選択されています。',
＿＿＿＿＿＿＿＿＿＿＿＿ Num2StrF(nCount),'個以上の図形は処理されません。'));
＿＿＿＿ gCount:= nCount;
＿＿＿ end;{if}

{＿＿＿SelectAll;}
＿＿＿i:= MinArray;
＿＿＿{アクティブなレイヤ上で選択されている最上位の図形のハンドル}
＿＿＿h[MinArray]:= FSActLayer;
＿＿＿while (i < MaxArray) & (h[i] <> nil) do
＿＿＿begin
＿＿＿＿h[i+1]:= NextSObj(h[i]);
＿＿＿＿i:=i+1;
＿＿＿end;{while}

＿＿＿iCo:= MinArray+gCount;
＿＿＿for i:= MinArray to iCo do
＿＿＿begin
＿＿＿＿if (i mod Dist)=0 then Message('Set CenterXY(', gCount, ') /', (i-MinArray));
＿＿＿＿{円・円弧の時は円弧の中点の座標を計算、他の図形は中心座標}
＿＿＿＿if GetType(h[i])=6 then
＿＿＿＿begin
＿＿＿＿＿ Get2DPt(h[i],1,px1,py1);
＿＿＿＿＿ Get2DPt(h[i],2,x1,y1);
＿＿＿＿＿ GetArc(h[i],startAngle,arcAngle);
＿＿＿＿＿ {円の中心から円弧中点への方向角}
＿＿＿＿＿ angleH:=GetAngle(px1,py1,x1,y1)+arcAngle*0.5;
＿＿＿＿＿ {円弧中点の座標}
＿＿＿＿＿ GetXYzahyou(x[i], y[i],px1,py1,distance(px1,py1,x1,y1),angleH);
＿＿＿＿end else HCenter(h[i], x[i], y[i]);＿ {中心の座標を取得}
＿＿＿end;

＿＿＿{Sort X}
＿＿＿if gCount <> 0 then QSortX(MinArray, iCo);
＿
＿＿＿{Sort Y}
＿＿＿if gCount <> 0 then
＿＿＿begin
＿＿＿＿i:= MinArray;
＿＿＿＿while (i < iCo) do
＿＿＿＿begin
＿＿＿＿＿ j:= i;
＿＿＿＿＿ while x[j] = x[j+1] do
＿＿＿＿＿＿＿j:= j + 1;
＿＿＿＿＿ if i < j then QSortY(i, j);
＿＿＿＿＿ i:= j + 1;
＿＿＿＿end;{while}
＿＿＿end;{if}

＿＿＿{中心座標の同じ直線が３個以上の時、角度を使用して再ソート}
＿＿＿j:=0;
＿＿＿startCo:=0;
＿＿＿endCo:=0;
＿＿＿chkFlg:=False;
＿＿＿for i:= MinArray to iCo-1 do
＿＿＿begin
＿＿＿＿＿if (i mod Dist)=0 then＿Message('ReChkXY(', gCount, ') /', (i-MinArray));
＿＿＿＿＿if＿(((GetType(h[i])=2) and (GetType(h[i+1])=2)) and
＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿ ((x[i]=x[i+1]) and (y[i]=y[i+1]))) then
＿＿＿＿＿begin
＿＿＿＿＿＿＿j:=j+1;
＿＿＿＿＿＿＿if j=1 then startCo:=i;
＿＿＿＿＿＿＿if j > 2 then chkFlg:=True;
＿＿＿＿＿＿＿endCo:=i;
＿＿＿＿＿end else
＿＿＿＿＿begin
＿＿＿＿＿＿＿if chkFlg=True then
＿＿＿＿＿＿＿begin
＿＿＿＿＿＿＿＿＿for k:=startCo to endCo do
＿＿＿＿＿＿＿＿＿begin
＿＿＿＿＿＿＿＿＿＿＿tAng[k]:=HAngle(h[k]);
＿＿＿＿＿＿＿＿＿＿＿tAng[k+1]:=HAngle(h[k+1]);
＿＿＿＿＿＿＿＿＿end;
＿＿＿＿＿＿＿＿＿{ソート開始}
＿＿＿＿＿＿＿＿＿repeat
＿＿＿＿＿＿＿＿＿＿＿sortFlg:=False;
＿＿＿＿＿＿＿＿＿＿＿for k:=startCo to endCo do
＿＿＿＿＿＿＿＿＿＿＿begin
＿＿＿＿＿＿＿＿＿＿＿＿＿if tAng[k] > tAng[k+1] then
＿＿＿＿＿＿＿＿＿＿＿＿＿begin
＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿SortX2(k);
＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿sortFlg:=True;
＿＿＿＿＿＿＿＿＿＿＿＿＿end;
＿＿＿＿＿＿＿＿＿＿＿end;
＿＿＿＿＿＿＿＿＿until (sortFlg=False);
＿＿＿＿＿＿＿end;
＿＿＿＿＿＿＿j:=0;
＿＿＿＿＿＿＿chkFlg:=False;
＿＿＿＿＿end;
＿＿＿end;

＿＿＿{Del Object}
＿＿＿j:= 0;
(*
＿＿＿objT:=0;＿{チェック用初期化}
*)
＿＿＿for i:= MinArray to iCo-1 do
＿＿＿begin
＿＿＿＿ if EqualObject(h[i], h[i+1]) then
＿＿＿＿ begin
(*
＿＿＿＿＿＿objT:=GetType(h[i]);＿ {チェック用図形の種類}
＿＿＿＿＿＿tp[objT]:=tp[objT]+1;＿{チェック用種類の数をカウント}
*)
＿＿＿＿＿＿DelObject(h[i]);
＿＿＿＿＿＿j:= j + 1;
＿＿＿＿＿＿if (j mod Dist)=0 then Message('Delete Object ', j);
＿＿＿＿ end;{if}
＿＿＿end;{for}
(*
＿＿ {削除図形チェック用}
＿＿＿Rewrite('chkList.txt');
＿＿＿for objT:=1 to 255 do
＿＿＿begin
＿＿＿＿＿if tp[objT] <> 0 then
＿＿＿＿＿＿＿Writeln('Delete Object(', objT, ')=', tp[objT]);
＿＿＿end;
＿＿＿Close('chkList.txt');
*)
＿＿＿nDel:= nDel + j;
＿＿＿DSelectAll;
＿＿＿clrmessage;
＿＿＿msg:=Concat('Finished! Deleted ', Num2StrF(nDel),' objects');
＿＿＿AlrtDialog(msg);
＿ end else AlrtDialog('図形が選択されていません。');
end;

{************************** スタート ***********************************}
begin
＿＿Get_Fixed_Vlue;
＿＿DelEqualObject2;
＿＿Set_Fixed_Vlue;
end;
Run(DelEqualObject);

完成できなかったスクリプトです。一応動くまでにはしたのですが、
バグがあるようで、全ての図形が削除されるとは限りません。
（何度も実行すれば全部削除されるようです。）
長い間ほおっておいて、当分直せそうにありませんので、
（まるで他人が書いたスクリプトのようです）
参考にするなり、直すなり、自由に使ってください。

{
アクティブレイヤの重複図形を削除します。
３Ｄ図形、グループ図形は対象外です。
図形属性の比較はしていません。(手抜きです)
配列の制限から、同じタイプの図形は32767個までしか処理できません。
単純なアルゴリズムだと、最悪の場合32767x32766回の比較となり、
処理時間が膨大（10億回！）になるので、
ハンドルと中心座標の配列をX,Yでソートして、隣り合ったハンドルだけ比較しています。
ソート方法はクイックソートです。再帰呼び出しをしているので、
データによってはスタック・オーバーフロー・エラーが出る可能性があります。
（まだ起こったことはありませんが）
}
procedure DelEqualObject;
const
＿MaxArray =32767;
＿Dist = 100;{Message表示を100回置きにする}
var
＿h＿:array[1..MaxArray] of handle;
＿x, y＿:array[1..MaxArray] of real;
＿tp＿:integer;
＿i, j, n, nDel＿:longint;
＿name＿:string;
＿
＿procedure QSortY (left, right:integer);
＿var
＿＿i, j＿:integer;
＿＿pivot,{ 境界値 }
＿＿tempX, tempY＿:real;
＿＿tempH＿:handle;
＿begin
＿＿Message('Sort Y (', tp, ') ', left, ' to ', right);
＿＿if left < right then begin
＿＿＿pivot:= (y[left]+y[right])/2;
＿＿＿i:= left;
＿＿＿j:= right;
＿＿＿repeat
＿＿＿＿while y[i] < pivot do
＿＿＿＿＿i:= i+1;
＿＿＿＿while y[j] > pivot do
＿＿＿＿＿j:= j-1;
＿＿＿＿if i <= j then begin
＿＿＿＿＿tempX:= x[i]; tempY:= y[i]; tempH:= h[i];
＿＿＿＿＿x[i]:= x[j]; y[i]:= y[j]; h[i]:= h[j];
＿＿＿＿＿x[j]:= tempX; y[j]:= tempY; h[j]:= tempH;
＿＿＿＿＿i:= i+1;
＿＿＿＿＿j:= j-1;
＿＿＿＿end;{if}
＿＿＿until i > j;
＿＿＿QSortY(left, j);
＿＿＿QSortY(i, right);
＿＿end;{if}
＿end; { QSortY }
＿
＿procedure QSortX (left, right:integer);
＿var
＿＿i, j＿:integer;
＿＿pivot,
＿＿tempX, tempY＿:real;
＿＿tempH＿:handle;
＿begin
＿＿Message('Sort X (', tp, ') ', left, ' to ', right);
＿＿if left < right then begin
＿＿＿pivot:= (x[left]+x[right])/2;
＿＿＿i:= left;
＿＿＿j:= right;
＿＿＿repeat
＿＿＿＿while x[i] < pivot do
＿＿＿＿＿i:= i+1;
＿＿＿＿while x[j] > pivot do
＿＿＿＿＿j:= j-1;
＿＿＿＿if i <= j then begin
＿＿＿＿＿tempX:= x[i]; tempY:= y[i]; tempH:= h[i];
＿＿＿＿＿x[i]:= x[j]; y[i]:= y[j]; h[i]:= h[j];
＿＿＿＿＿x[j]:= tempX; y[j]:= tempY; h[j]:= tempH;
＿＿＿＿＿i:= i+1;
＿＿＿＿＿j:= j-1;
＿＿＿＿end;{if}
＿＿＿until i > j;
＿＿＿QSortX(left, j);
＿＿＿QSortX(i, right);
＿＿end;{if}
＿end; { QSortX }
＿
＿function EqualObject(h1, h2:handle):boolean;
＿const
＿＿MaxVertex = 10000;
＿var
＿＿tp1, tp2＿:integer;
＿＿a11, a12, a21, a22,
＿＿x11, y11, x12, y12,
＿＿x21, y21, x22, y22＿:real;
＿＿x1, y1, x2, y2, r1, r2＿:real;
＿＿v1, v2＿:integer;
＿＿i, n1, n2＿:integer;
＿＿result＿:boolean;
＿begin
＿＿tp1:= GetType(h1);
＿＿tp2:= GetType(h2);
＿＿GetBBox(h1, x11, y11, x12, y12);
＿＿GetBBox(h2, x21, y21, x22, y22);
＿＿EqualObject:= false;
＿＿if (tp1 = tp2) & EqualRect(x11, y11, x12, y12, x21, y21, x22, y22) then begin
＿＿＿case tp1 of
＿＿＿＿2: begin{Line}
＿＿＿＿＿GetSegPt1(h1, x11, y11);
＿＿＿＿＿GetSegPt2(h1, x12, y12);
＿＿＿＿＿GetSegPt1(h2, x21, y21);
＿＿＿＿＿GetSegPt2(h2, x22, y22);
＿＿＿＿＿if (EqualPt(x11, y11, x21, y21) & EqualPt(x12, y12, x22, y22)) |
＿＿＿＿＿ (EqualPt(x11, y11, x22, y22) & EqualPt(x12, y12, x21, y21)) then begin
＿＿＿＿＿＿EqualObject:= true;
＿＿＿＿＿end;{if}
＿＿＿＿end;{Line}
＿＿＿＿3,4: begin{Rect, Oval}
＿＿＿＿＿EqualObject:= true;
＿＿＿＿end;{Rect}
＿＿＿＿5: begin{Poly}
＿＿＿＿＿n1:= GetVertNum(h1);
＿＿＿＿＿n2:= GetVertNum(h2);
＿＿＿＿＿if n1 = n2 then begin
＿＿＿＿＿＿result:= true;
＿＿＿＿＿＿while (i <= n1) & result do begin
＿＿＿＿＿＿＿GetPolyPt(h1, i, x1, y1);
＿＿＿＿＿＿＿GetPolyPt(h2, i, x2, y2);
＿＿＿＿＿＿＿if not EqualPt(x1, y1, x2, y2) then
＿＿＿＿＿＿＿＿result:= false;
＿＿＿＿＿＿＿i:= i + 1;
＿＿＿＿＿＿end;{while}
＿＿＿＿＿＿EqualObject:= result;
＿＿＿＿＿end;{if}
＿＿＿＿end;{Poly}
＿＿＿＿6: begin{Arc}
＿＿＿＿＿GetArc(h1, a11, a12);
＿＿＿＿＿GetArc(h2, a21, a22);
＿＿＿＿＿if (a11 = a21) & (a12 = a22) then begin
＿＿＿＿＿＿EqualObject:= true;
＿＿＿＿＿end;{if}
＿＿＿＿end;{Arc}
＿＿＿＿8,9,11,12,14: begin{FreeHand, Locus3D, Group, QArc, BitMap}
＿＿＿＿＿{ 未処理 }
＿＿＿＿end;
＿＿＿＿10: begin{Text}
＿＿＿＿＿if GetText(h1) = GetText(h2) then begin
＿＿＿＿＿＿EqualObject:= true;
＿＿＿＿＿end;{if}
＿＿＿＿end;{Text}
＿＿＿＿13: begin{RRect}
＿＿＿＿＿GetRRDiam(h1, x11, y11);
＿＿＿＿＿GetRRDiam(h2, x21, y21);
＿＿＿＿＿if EqualPt(x11, y11, x21, y21) then begin
＿＿＿＿＿＿EqualObject:= true;
＿＿＿＿＿end;{if}
＿＿＿＿end;{RRect}
＿＿＿＿15: begin{Symbol}
＿＿＿＿＿if GetSymName(h1) = GetSymName(h2) then begin
＿＿＿＿＿＿EqualObject:= true;
＿＿＿＿＿end;{if}
＿＿＿＿end;{Symbol}
＿＿＿＿17: begin{Locus}
＿＿＿＿＿EqualObject:= true;
＿＿＿＿end;{Locus}
＿＿＿＿21: begin{PolyLine}
＿＿＿＿＿n1:= GetVertNum(h1);
＿＿＿＿＿n2:= GetVertNum(h2);
＿＿＿＿＿if n1 = n2 then begin
＿＿＿＿＿＿result:= true;
＿＿＿＿＿＿while (i <= n1) & result do begin
＿＿＿＿＿＿＿GetPolylineVertex(h1, i, x1, y1, v1, r1);
＿＿＿＿＿＿＿GetPolylineVertex(h2, i, x2, y2, v2, r2);
＿＿＿＿＿＿＿if (not EqualPt(x1, y1, x2, y2)) | (v1 <> v2) | (r1 <> r2) then
＿＿＿＿＿＿＿＿result:= false;
＿＿＿＿＿＿＿i:= i + 1;
＿＿＿＿＿＿end;{while}
＿＿＿＿＿＿EqualObject:= result;
＿＿＿＿＿end;{if}
＿＿＿＿end;{PolyLine}
＿＿＿end;{case}
＿＿end;{if}
＿end;{EqualObject}
＿
begin{DelEqualObject}
＿AlrtDialog('アクティブレイヤ上の重複図形を削除します。３Ｄ図形、グループ図形は対象外です。');
＿nDel:= 0;
＿name:= GetLName(ActLayer);
＿for tp:= 1 to 255 do begin{図形タイプ1〜255を処理する。}
＿＿n:= Count((L=name)&(T=tp));
＿＿if MaxArray < n then begin
＿＿＿AlrtDialog(Concat('タイプ(', Num2Str(0, tp), ')の図形が', Num2Str(0, n), '個ありますが、'
＿＿＿＿, Num2Str(0, MaxArray),'個以上の図形は処理されません。'));
＿＿＿n:= MaxArray;
＿＿end;{if}
＿＿if 0 < n then begin
＿＿＿DSelectAll;
＿＿＿Message(Concat('select (T=', tp, ')'));
＿＿＿SelectObj((L=name)&(T=tp));
＿＿＿i:= 1;
＿＿＿j:= Dist;
＿＿＿h[1]:= FSActLayer;
＿＿＿while (i < MaxArray) & (h[i] <> nil) do begin
＿＿＿＿h[i+1]:= NextSObj(h[i]);
＿＿＿＿if j = i then begin
＿＿＿＿＿Message('Set Array(', tp, ') ', i, '/', n);
＿＿＿＿＿j:= j + Dist;
＿＿＿＿end;{if}
＿＿＿＿if GetType(h[i]) = tp then
＿＿＿＿＿i:= i + 1
＿＿＿＿else
＿＿＿＿＿h[i]:= h[i+1];
＿＿＿end;{while}
＿＿＿Message('Set Array(', tp, ') ', i-1, '/', n);
＿＿＿n:= i-1;
＿＿＿
＿＿＿for i:= 1 to n do
＿＿＿＿HCenter(h[i], x[i], y[i]);
＿＿＿
＿＿＿{Sort X}
＿＿＿if n <> 0 then begin
＿＿＿＿QSortX(1, n);
＿＿＿end;{if}
＿＿＿
＿＿＿{Sort Y}
＿＿＿if n <> 0 then begin
＿＿＿＿i:= 1;
＿＿＿＿while (i < n) do begin
＿＿＿＿＿j:= i;
＿＿＿＿＿while x[j] = x[j+1] do
＿＿＿＿＿＿j:= j + 1;
＿＿＿＿＿if i < j then begin
＿＿＿＿＿＿QSortY(i, j);
＿＿＿＿＿end;{if}
＿＿＿＿＿i:= j + 1;
＿＿＿＿end;{while}
＿＿＿end;{if}
＿＿＿
＿＿＿{Del Object}
＿＿＿j:= 0;
＿＿＿for i:= 1 to n-1 do begin
＿＿＿＿if EqualObject(h[i], h[i+1]) then begin
＿＿＿＿＿DelObject(h[i]);
＿＿＿＿＿j:= j + 1;
＿＿＿＿＿Message('Delete Object ', j);
＿＿＿＿end;{if}
＿＿＿end;{for}
＿＿＿Writeln('Delete Object(', tp, ')=', j);
＿＿＿nDel:= nDel + j;
＿＿end;{if}
＿end;{for}
＿Message('Finished! Deleted ', nDel, ' objects');
＿DSelectAll;
end;{DelEqualObject}
Run(DelEqualObject);

ARcoatingさん、お久しぶりです。

＞読むばっかりで手が動いてない、、
しばらく書いてないと、だんだん書くのが億劫になりますね。
反転文字も飽きてきた...

こんちには、ご無沙汰しております。
その後、図形情報をワークシートに関連付ける方法を色々考えていると、自分の中で
多方面に可能性が広がってしまい(^^ゞ、全く別の物ですが先に作ってみたいと思っ
てしまいました！、、。与太郎さん、アドバイス頂いていたのにすみませーん。
必ず「図形情報をワークシートに関連付ける方法」は完成させたいと思っております！！
また紹介頂いた「MiniPascalプログラミング入門」と「Ｃプログラミング診断室」
を現在読んでおります。スクリプトはほんとに色々なことが出来るのだなあと
改めて可能性を感じました！しかし、、読むばっかりで手が動いてない、、(>_<)

どうやら環境設定の「文字の反転禁止」を誤解していたようです。
すでに描かれている文字は「文字の反転禁止」をON/OFFしても表示は変わりません。
表示が変わるのはシンボル内の文字だけでした。
文字図形に関しては、「文字の反転禁止」のON/OFFは反転ツールを使ったときに
文字を反転させるかどうかを決めるもので、文字の表示状態を決めるものではありません。
要するに、設定の異なるマシンで反転文字の表示が問題になるのは、
文字を含んだシンボルを反転したときなんですね。

今度は GotoFlipSymbolHasText が必要です。
シンボルが反転してるかどうかは、GetSymRot で得た角度が正か負かで判ります。
角度がマイナスなら反転状態です。
しかし、シンボルを含んだシンボルが反転していたら、どうすればいいの？

アクティブレイヤ以外のシンボルに移動できないバグを直しました。

{ 反転文字に移動し、選択状態にします。 }
procedure GoToFlipText;
{DEBUG}
const
Zoom = 400; { パーセント }
TextObj = 10;
GroupObj = 11;
SymbolObj = 15;
SymbolDef = 16;
LayerObj = 31;
AllObjects = 0; { 図形オプション }
TraverseDeep = 2; { 詳細オプション }
InAllLayer = 1; { レイヤオプション }
var
hSel:handle;
xC, yC:real;
numFT:integer; { Number of Flip Text}

function FindFlipText(h:handle):boolean; {反転文字のハンドルを hSel に入れます。}
var
x, y, ang:real;
textIsMirrored:boolean;
begin
if GetType(h) = TextObj then begin
GetTextOrientation(h, x, y, ang, textIsMirrored);
if textIsMirrored then begin
hSel := h;
numFT:= numFT + 1;
end; {if}
end; {if}
end; {FindFlipText}

function SymObjOfSymDef(h:handle):handle;
var
criteria,
symName:string;
hSymObj:handle;

procedure GetSymObj(h:handle);
begin
hSymObj:= h;
end; {GetSymObj}

begin{SymObjOfSymDef}
hSymObj:= nil;
symName:= GetSDName(h);
criteria:= Concat('S=''', symName, '''');
ForEachObject(GetSymObj, criteria);
if hSymObj = nil then
AlrtDialog(Concat(symName, 'は未使用のシンボルなのでシンボル内に移動できません。'
, 'リソースパレットから編集するか、削除してください。'));
SymObjOfSymDef:= hSymObj;
end; {SymObjOfSymDef}

procedure GotoParent(h:handle);
var
hParent:handle;
begin
hParent:= GetParent(h);
if hParent <> nil then begin
case GetType(hParent) of
SymbolDef:GotoParent(hParent);
GroupObj:GotoParent(hParent);
LayerObj:Layer(GetLName(hParent));
end; {case}
if (h <> nil) then begin
if GetType(h) = SymbolDef then begin
h:= SymObjOfSymDef(h);
hParent:= GetParent(h);
GotoParent(hParent);
end; {if}
case GetType(h) of
GroupObj, SymbolObj: begin
DSelectAll;
SetSelect(h);
DoMenuTextByName('Group Navigation Chunk', 1);
end;
LayerObj: begin { 04/05/01 バグ修正で追加 }
Layer(GetLName(h));
end;
end; {case}
end; {if}
end; {if}
end; {GotoParent}

begin {Main}
numFT:= 0;
hSel:= nil;
DoMenuTextByName('Group Navigation Chunk', 3);
ForEachObjectInList(FindFlipText, AllObjects, TraverseDeep, FSymDef);
ForEachObjectInLayer(FindFlipText, AllObjects, TraverseDeep, InAllLayer);
if hSel <> nil then begin
GotoParent(GetParent(hSel));
DSelectAll;
SetSelect(hSel);
HCenter(hSel, xC, yC);
SetVCenter(xC, yC);
SetZoom(Zoom);
Message(numFT, '個の反転文字があります。');
end {if}
else begin
DSelectAll;
ClrMessage;
AlrtDialog('反転文字はありません。');
end; {else}
end; {Main}
Run(GoToFlipText);

反転文字を正常に直したいときは、
このスクリプトで反転文字に移動できますので、
ミラー反転ツールなどで修正してください。
シンボル内、グループ内にも移動します。
環境設定によっては警告が出ますが、無視して構いません。

{ 反転文字に移動し、選択状態にします。 }
procedure GoToFlipText;
{DEBUG}
const
LFCode = 13;
Zoom = 400;{ パーセント }
TextObj = 10;
GroupObj = 11;
SymbolObj = 15;
SymbolDef = 16;
LayerObj = 31;
AllObjects = 0;{ 図形オプション }
TraverseDeep = 2;{ 詳細オプション }
InAllLayer = 1; { レイヤオプション }
var
hSel:handle;
xC, yC:real;
numFT:integer;

function FindFlipText(h:handle):boolean;{反転文字のハンドルを hSel に入れます。}
var
x, y, ang:real;
textIsMirrored:boolean;
begin
if GetType(h) = TextObj then begin
GetTextOrientation(h, x, y, ang, textIsMirrored);
if textIsMirrored then begin
hSel := h;
numFT:= numFT + 1;
end;{if}
end;{if}
end;{FindFlipText}

function SymObjOfSymDef(h:handle):handle;
var
criteria,
symName:string;
hSymObj:handle;

procedure GetSymObj(h:handle);
begin
hSymObj:= h;
end;{GetSymObj}
begin
hSymObj:= nil;
symName:= GetSDName(h);
criteria:= Concat('S=''', symName, '''');
ForEachObject(GetSymObj, criteria);
if hSymObj = nil then
AlrtDialog(Concat(symName, 'は未使用のシンボルなので、'
, Chr(LFCode), 'シンボル内に移動できません。'));
SymObjOfSymDef:= hSymObj;
end;{SymObjOfSymDef}

procedure GotoParent(h:handle);
var
hParent:handle;
objType:integer;
begin
objType:= GetType(h);
hParent:= GetParent(h);
if hParent <> nil then begin
objType:= GetType(hParent);
case objType of
SymbolDef:GotoParent(hParent);
GroupObj:GotoParent(hParent);
LayerObj:Layer(GetLName(hParent));
end;{case}
if (h <> nil) then begin
objType:= GetType(h);
if objType = SymbolDef then begin
h:= SymObjOfSymDef(h);
hParent:= GetParent(h);
GotoParent(hParent);
end;{if}
objType:= GetType(h);
case objType of
GroupObj, SymbolObj: begin
DSelectAll;
SetSelect(h);
DoMenuTextByName('Group Navigation Chunk', 1);
end;
end;{case}
end;{if}
end;{if}
end;{GotoParent}

begin {Main}
numFT:= 0;
hSel:= nil;
DSelectAll;
DoMenuTextByName('Group Navigation Chunk', 3);
SelectObj((T=Text));
ForEachObjectInList(FindFlipText, AllObjects, TraverseDeep, FSymDef);
ForEachObjectInLayer(FindFlipText, AllObjects, TraverseDeep, InAllLayer);
{ この時点での hSel は最後に見つけた反転文字 }
if hSel <> nil then begin
GotoParent(GetParent(hSel));
DSelectAll;
SetSelect(hSel);
HCenter(hSel, xC, yC);
SetVCenter(xC, yC);
SetZoom(Zoom);
Message(numFT, '個の反転文字があります。');
end{if}
else begin
ClrMessage;
AlrtDialog('反転文字はありません。');
end;{else}
end; {Main}
Run(GoToFlipText);

ハンドルに FSymDef を入れたらシンボル内を探索できました。

procedure CountFlipText;{ ファイル内の反転文字をカウントする }
const
TextObj = 10;
LFCode = 13;
AllObjects = 0;{ 図形オプション }
TraverseDeep = 2;{ 詳細オプション }
InAllLayer = 1; { レイヤオプション }
var
c, cL, cS:longint;
msg:string;
{ サブルーチン（ForEachObjectIn...より呼ばれる。） }
function FindFlipText(h:handle):boolean;
var
x, y, ang:real;
textIsMirrored:boolean;
begin
if GetType(h) = TextObj then begin
GetTextOrientation(h, x, y, ang, textIsMirrored);
if textIsMirrored then begin
c:= c + 1;
Message('FlipText = ', c);
end;
end;
end;{FindFlipText}

begin{ メインルーチン }
c:= 0;
ForEachObjectInLayer(FindFlipText, AllObjects, TraverseDeep, InAllLayer);
cL:= c;
c:= 0;
ForEachObjectInList(FindFlipText, AllObjects, TraverseDeep, FSymDef);
cS:= c;
ClrMessage;
if cL = 0 then
msg:= ''
else
msg:= Concat('レイヤ内に', cL, '個の反転文字があります。');
if cS > 0 then
msg:= Concat(msg, chr(LFCode), 'シンボル内に', cS, '個の反転文字があります。');
AlrtDialog(msg);
end;
Run(CountFlipText);

図形オプションを色々試してみたのですが、
ロック図形や選択図形だけを処理することは出来ませんでした。

＞ForEachObjectInList(MySetFPat, 1, 2, h); の h に何も入ってなくても動くんす
＞ね。
どうも今までForEachObject等はあなたまかせの感じがして嫌だったので使っていなか
たので、実はどうも良く分からないのです。サブルーチンでGetType( )を使ったのは
もしかしてhが入ってくるのかなーと思ったからです。
やはり、このままではシンボルの中まで入れないようで、シンボル用のルーチンを
作った方が良いのではと思っています。コンテナの情報がもっと取れるようになると
いけるのですが...。

石男さん、ありがとうございます。

ForEachObjectInList(MySetFPat, 1, 2, h); の h に何も入ってなくても動くんですね。
てっきりエラーになるものと思っていました。
何かを入れたらシンボルの中まで探してくれるでしょうか？
h にあれこれ入れて試してみます。

あれから FSymDef、NextSymDef を使って書こうと、参考に昔のスクリプトを見ていました。
シンボルフォルダは使ったことがないのですが、公開することを考えて、
今回はシンボルフォルダの中まで処理しようと思っていたので。
ところが、別の気になる箇所があったので、そちらに手をとられて、ほったらかしにしてました。
（そっちも日曜日以来さわってないので、はやいとこ終わらせないと記憶が危ないです。）

シンボルの中までは探索していないようですが、参考になるでしょうか？
Procedure Test ;
{$DEBUG}
Var
h : Handle ;

{--------------------------Sub------------------------}
Function MySetFPat( objH : Handle ) : Boolean ;
Var
gType : Integer ;
r , g , b : Longint ;
Begin
gType := GetType( objH ) ;
If ( gType = 3 ) Then{-----------四角形-----------}
Begin
ColorIndexToRGB( 4 , r , g , b ) ;{-----------カラーパレットの4-----------}
SetFillBack( objH , r , g , b ) ;
ReDrawAll ;
End ;
End ;
{================Main===============}
Begin
ForEachObjectInList( MySetFPat , 1 , 2 , h ) ;{-----------見えている図形、柱状体等の中の図形も-----------}

End ;
Run( Test ) ;

最近のＶＷ談話室の質問だったんですが、
環境設定で文字の反転禁止を設定していると、文字を反転しても正常に表示されますが、
他人にデータを渡すときに、相手側が反転禁止になっているとはかぎりません。
文字を90度以上の角度で書かせる為に、わざと反転禁止にしない場合もあります。
そうすると、文字の反転禁止／許可がファイル別に設定できないので、
ファイルを開くたびに設定を変えねばなりません。
やはりファイルを渡す前に反転文字を直したほうが良いでしょう。
（個人的には、「文字の反転禁止」はレイヤかクラスごとに設定出来ればよいと思う。）
（現状のままなら無いほうがマシ？）
で、
スクリプトで一度に直せれば良いのですが、水平反転と垂直反転の判定が難しいので、
とりあえず、反転文字の数を返すスクリプトを作ってみます。

procedure CountFlipText;{ ファイル内の反転文字をカウントする（シンボル内は除く） }
var
c:longint;
{サブルーチン}
procedure FindFlipText(h:handle);
var
x, y, ang:real;
textIsMirrored:boolean;
begin
GetTextOrientation(h, x, y, ang, textIsMirrored);
if textIsMirrored then begin
c:= c + 1;
Message('FlipText = ', c);
end;
end;{FindFlipText}

begin{ メインルーチン }
c:= 0;
ForEachObject(FindFlipText, (T=TEXT));
ClrMessage;
if c = 0 then
AlrtDialog(Concat('反転文字はありません。（シンボル内は除く）'))
else
AlrtDialog(Concat(c, '個の反転文字があります。（シンボル内は除く）'));
end;
Run(CountFlipText);

上のスクリプトでは（毎度ながら）シンボル内の反転文字はカウントされません。
シンボル内の図形を探すには、FSymDefでシンボル定義のハンドルを拾って、
リンクを辿っていくしかないでしょうか？
あるいは、ForEachObjectInListでシンボル定義内の図形を探せるのでしょうか？
（ForEachObjectInList の「List」って何のリスト？）
どなたか ForEachObjectInList の使い方をご存知ありませんか。

名前も題も忘れてしまいました。
内容は下です。

WS_to_GroupObj を修正しました。

ワークシートをグループ図形にするスクリプトを修正しました。
変更点は、
1. ワークシート図形を選択しても実行するように修正。
　その場合は同じ位置にグループ図形を作り、元のワークシート図形は削除する。
2. 列幅がゼロのときは文字を表示しないように修正。
3. グリッドの色をシアンに変更。（与太郎の好みです）

procedure WS_to_GroupObj;
{ ワークシートをグループ図形にします（var9以降に対応）}
{ by 与太郎 2004/04/03〜2004/04/03 }
{ 2004/04/12ワークシート図形を選択しても実行するように修正}
{ ワークシート図形を選択したときは同位置にグループ図形を作成、ワークシート図形を削除する }
{ 列幅がゼロのときは文字を表示しないように修正 }
{ グリッドの色をシアンに変更 }

{ 図形化したいワークシートを表示、またはワークシート図形を選択して、実行する }
{ 属性はクラス属性で変更可能 }
{ クラス名、クラス属性、セルの余白は好みで書き換えてください。 }
const
{ クラス名とクラス属性 }
ClsWSText = 'WS-Text';
ClsWSGrid = 'WS-Grid';
ClsWSOutLine = 'WS-Outline';
ClsWSBorder = 'WS-Border';
OutlineWidth = 21;{ 0.53ミリ }
OutlineColor = 15;{ 赤色 }
GridWidth = 1;{ 0.025ミリ }
GridColor = 2;{ シアン }
LnWidth = 11;{ 0.28ミリ }
LnColor = 4;{ 青色 }
txtColor = 15;{ 赤色 }

{ セルの余白 }
LeftMargin = 3;{ 3ポイント=1.06ミリ }
RightMargin = 3;{ 3ポイント=1.06ミリ }

type
wsCell = structure
align:integer;{ 0=標準／1=左よせ／2=センタ／3=右よせ }
txt:string;{ セルの内容 }
fontID:integer;
size:integer;
Style:integer;{Plain:0／Bold:1／Italic:2／Underline:4／Outline:8／Shadow:16}
end;

var
k:real; { 描画倍率 }
hWS, hTbl:handle;{ ----2004/4/12hTblを追加 }
maxRow, MaxClm:integer;
wd:dynArray[] of integer;
ht:dynArray[] of integer;
x:dynArray[] of real;
y:dynArray[] of real;
hLine:dynArray[,] of boolean;
vLine:dynArray[,] of boolean;


procedure Set_k;{ 描画倍率を計算します。 }
var
scale:real;
upi:real;
fraction, display:longint;
format:integer;
name, squareName:string;
begin
scale:= GetLScale(ActLayer);
GetUnits(fraction, display, format, upi, name, squareName);
k:= upi * scale / 25.4 / 72 * 25.4;
end;{Set_k}

procedure GetWSHandle(var hWS, hTbl:handle);
{ ワークシートとワークシート図形のハンドルを返します。----2004/4/12追加 }
begin
hWS:= ActSSheet;
if hWS = nil then begin
hTbl:= FSActLayer;
if (hTbl <> nil) & (GetType(hTbl) = 56) then begin
hWS:= GetWSFromImage(hTbl);
end;{if}
end;{if}
end;{GetWSHandle}

procedure Init_Vars;{ 変数を初期化します。 }
var
row, clm:integer;
top, left, bottom, right:boolean;

procedure Set_or(var source:boolean; dist:boolean);
begin
source:= source or dist;
end;{Set_or}

begin{Init_Vars}
{ 配列を確保 }
GetWSRowColumnCount(hWS, maxRow, MaxClm);
Allocate ht[1..MaxRow];
Allocate wd[1..MaxClm];
Allocate x[0..MaxClm];
Allocate y[0..MaxRow];
Allocate hLine[0..MaxRow, 0..MaxClm];
Allocate vLine[0..MaxRow, 0..MaxClm];

{ セルの寸法を取得 }
for row:= 1 to maxRow do
GetWSRowHeight(hWS, row, ht[row]);
for clm:= 1 to maxClm do
GetWSColumnWidth(hWS, clm, wd[clm]);

{ 罫線を取得 }
for row:= 0 to maxRow do begin
for clm:= 0 to maxClm do begin
hLine[row, clm]:= false;
vLine[row, clm]:= false;
end;{for}
end;{for}
for row:= 1 to maxRow do begin
for clm:= 1 to maxClm do begin
GetWSCellBorder(hWS, row, clm, top, left, bottom, right);
Set_or(hLine[row-1, clm], top);
Set_or(hLine[row, clm], bottom);
Set_or(vLine[row, clm-1], left);
Set_or(vLine[row, clm], right);
end;{for}
end;{for}
end;{Init_Vars}

procedure Set_XY;{ ＸＹ座標を計算します。 }
var
row, clm:integer;
begin
for clm:= 1 to maxClm do
x[clm]:= x[clm-1] + k * wd[clm];

for row:= 1 to maxRow do
y[row]:= y[row-1] - k * ht[row];
end;{Set_XY}

function BeClass(cls:string):boolean;
{ クラスの有無を返します。 }
var
i:integer;
be:boolean;
begin
i:= 1;
be:= false;
while (i <= ClassNum) & (not be) do begin
if cls = ClassList(i) then
be:= true;
i:= i + 1;
end;{while}
BeClass:= be;
end;{BeClass}

procedure SetClassAttrs;
{ クラス属性を設定します。クラスがある場合は何もしません。 }
begin
if not BeClass(ClsWSGrid) then begin
NameClass(ClsWSGrid);
SetClPenFore(ClsWSGrid, GridColor);
SetClLW(ClsWSGrid, GridWidth);
end;{if}

if not BeClass(ClsWSOutline) then begin
NameClass(ClsWSOutline);
SetClPenFore(ClsWSOutline, OutlineColor);
SetClLW(ClsWSOutline, OutlineWidth);
end;{if}

if not BeClass(ClsWSBorder) then begin
NameClass(ClsWSBorder);
SetClPenFore(ClsWSBorder, lnColor);
SetClLW(ClsWSBorder, lnWidth);
end;{if}

if not BeClass(ClsWSText) then begin
NameClass(ClsWSText);
SetClPenFore(ClsWSText, txtColor);
end;{if}
end;{SetClassAttrs}

procedure DrawGrid;
{ グリッドを描きます。 }
var
row, clm:integer;
begin
BeginGroup;
for row:= 1 to maxRow-1 do begin
MoveTo(x[0], y[row]);
LineTo(x[maxClm], y[row]);
end;{for}

for clm:= 1 to maxClm-1 do begin
MoveTo(x[clm], y[0]);
LineTo(x[clm], y[maxRow]);
end;{for}
EndGroup;
end;{DrawGrid}

procedure DrawOutline;
{ 外枠を描きます。 }
begin
Rect(x[0], y[0], x[maxClm], y[maxRow]);
end;{DrawOutline}

procedure DrawHBorders;
{ 水平線を書きます。 }
var
row, c1, c2:integer;

function StartClm(c:integer):integer;
begin
repeat
c:= c + 1;
until (maxClm <= c) | (hLine[row, c]);
if (c <= maxClm) & (hLine[row, c]) then
StartClm:= c
else
StartClm:= 0;
end;{StartClm}

function EndClm(c:integer):integer;
begin
while (c < maxClm) & hLine[row, c+1] do
c:= c + 1;
EndClm:= c;
end;{EndClm}

begin{DrawHBorders}
for row:= 0 to maxRow do begin
c1:= StartClm(0);
while (c1 <> 0) do begin
c2:= EndClm(c1);
MoveTo(x[c1-1], y[row]);
LineTo(x[c2], y[row]);
c1:= StartClm(c2);
end{while}
end;{for}
end;{DrawHBorders}

procedure DrawVBorders;
{ 垂直線を描きます。 }
var
clm, r1, r2:integer;

function StartRow(r:integer):integer;
begin
repeat
r:= r + 1;
until (maxRow <= r) | (vLine[r, clm]);
if (r <= maxRow) & (vLine[r, clm]) then
StartRow:= r
else
StartRow:= 0;
end;{StartRow}

function EndRow(r:integer):integer;
begin
while (r < maxRow) & vLine[r+1, clm] do
r:= r + 1;
EndRow:= r;
end;{EndRow}

begin
for clm:= 0 to maxClm do begin
r1:= StartRow(0);
while (r1 <> 0) do begin
MoveTo(x[clm], y[r1-1]);
LineTo(x[clm], y[r2]);
r2:= EndRow(r1);
r1:= StartRow(r2);
end{while}
end;{for}
end;{DrawVBorders}

procedure GetCell(h:handle; row, clm:integer; var c:wsCell);
{ セルの情報を取得します。 }
begin
GetWSCellAlignment(h, row, clm, c.align);
if c.align = 0 then begin
if CellHasNum(h, row, clm) then
c.align:= 3
else
c.align:= 1;
end;
GetWSCellString(h, row, clm, c.txt);
GetWSCellTextFormat(h, row, clm, c.fontID, c.size, c.style);
end;{GetCell}

procedure DrawTexts;
{ セルの文字を描きます。 }
var
row, clm:integer;
cell:wsCell;
xT, yT:real;
begin
TextVerticalAlign(5);{ 下揃え }
for row:= 1 to maxRow do begin
yT:= y[row];
for clm:= 1 to maxClm do begin
GetCell(hWS, row, clm, cell);
if (cell.txt <> '') & (0 < wd[clm]) then begin{ ----2004/4/12&(0<wd[clm])を追加 }
case cell.align of
0, 1: xT:= x[clm-1] + k * LeftMargin;
2: xT:= (x[clm-1] + x[clm]) / 2;
3: xT:= x[clm] - k * RightMargin;
end;{case}
TextJust(cell.align);
TextFont(cell.fontID);
TextSize(cell.size);
TextOrigin(xT, yT);
CreateText(cell.txt);
SetTextStyle(LNewObj, 0, GetTextLength(LNewObj), cell.style);
end;{if}
end;{for}
end{for}
end;{DrawTexts}

begin{WS_to_GroupObj}{ ----2004/4/12修正 }
GetWSHandle(hWS, hTbl);
if hWS = nil then begin
AlrtDialog('ワークシートを開くか、選択してください。');
end{if}
else begin
PushAttrs;
DSelectAll;
Set_k;
Init_Vars;
if hTbl = nil then begin
Message('図形を描く位置（左上）をクリックしてください。');
GetPt(x[0], y[0]);
end{if}
else begin
GetBBox(hTbl, x[0], y[0], x[maxClm], y[maxRow]);
end;{else}
Set_XY;
SetClassAttrs;
BeginGroup;
FillPat(0);
LSByClass;
LWByClass;
PenColorByClass;
NameClass(ClsWSText);
DrawTexts;
NameClass(ClsWSGrid);
DrawGrid;
NameClass(ClsWSBorder);
BeginGroup;
DrawHBorders;
DrawVBorders;
EndGroup;
NameClass(ClsWSOutline);
DrawOutline;
EndGroup;
if hTbl <> nil then
DelObject(hTbl)
else
ClrMessage;
PopAttrs;
ReDrawAll;
end;{else}
end;{WS_to_GroupObj}
Run(WS_to_GroupObj);

いつも長レスでスイマセン（与太郎）

とりあえず、４月１日時点での面積辺長スタンプをバージョン１としてベクターに
登録させてもらいました。
みなさん、よかったら使ってみてください。
ちなみに、ＷＩＮ版ＶＷ１０で作ってますが、ＭＡＣでも使えると思います。

■面積辺長スタンプ　Ver1.0■
http://www.vector.co.jp/soft/dl/win95/business/se324409.html

与太郎さんへ

なるほどなるほど！
プログラムの手法について大変参考になりました！
これは、まさにテクノロジー（技術）ですね！！
スクリプトを書出そうとしたのですが、さすがに何から書いて良いのかまとまらず、
とりあえず、フローチャートと思ったのですが、これまた慣れが必要みたいでうまく
書けませんでした、、。
的確なアドバイス感謝致します！
トップダウン形式で検討していきたいと思います。

＞実は「前記号」を忘れていました。Ｃ列を使いますか？
前記号はＣ列のNo.にConcat()でナンバーと一緒に入れてしまおうと思っておりましたが、
確かに別の方が良さそうですね。

コマンドの件
コマンドメニューは、幾つもあるとどれを押していいのか瞬時に判断できず、作業の流れを
阻害することになり、しいては、コマンドを使うことがおっくうになる面があると思いますので
あくまでも目標ですが、コマンド１つですべての作業をこなせる様にしたと思います！

よーーし書いていくぞーー！！しかし、飛込みの仕事が、、、(*_*)

＞＞専用のツールコマンドでCreateCustomObjectを呼んで描かせています。
プラグインを描くときにパラメータをダイアログで入力したりもできます。（引出線の文字など）

＞＞原点を変更したり断面を移動すると高さの数字が変わってしまうので...
自前の「原点指示...」、「移動...」コマンドを作る方法もあるかと。
必要な処理の前か後で DoMenuTextByName を使えばよさそうです。

＞プラグインオブジェクトは使うには便利なようですが、作るには
＞不便？簡単にデバッグできればいいのですが。
テスト用にプラグインを作ったり、パラメーターを追加するのは面倒です。
パラメーターをテキストに書き出したり読み込んだり出来たら便利ですよね。

＞ですが、 のあとが気になるのですが、
なぜか、「ですが、」が入ってしまいました。他意はございません。
＞専用のツールコマンドでCreateCustomObjectを呼んで描かせています。
おお、そのような手もありますか？プラグインオブジェクトは使うには便利なようですが、作るには
不便？簡単にデバッグできればいいのですが。

石男さんへ、

ですが、 のあとが気になるのですが、

プラグインオブジェクトで原点を得る件に関しては、
パラメータに原点(y0)を追加して、プラグインではそれを原点として高さを計算してます。
プラグインは直接描かず、専用のツールコマンドでCreateCustomObjectを呼んで描かせています。
その中でプラグインのパラメータに原点を設定しています。
結果的にはそれで良かったと思っています。
図面に複数の断面を描いたときは、各断面の原点を変える必要があるので、
いずれにしても原点(y0)は必要になりますので。
ただ、原点を変更したり断面を移動すると高さの数字が変わってしまうので、
選択したプラグインの y0 を一括で変更するコマンドと、
専用の移動コマンドを用意して、y0 を書き換えています。

＞与太郎さん
以前、プラグインオブジェクト内でGetOrigin()を使い原点を得たいといっていました
が、ご本家のMLのアーカイブをみていたら同じことがあったので報告します。
プラグインオブジェクト内でGetOrigin()を使うとプラグインオブジェクトの原点を返
すようです。
パラメータの設定でControlPointやPointを使えばなんとかなりそうですが、実際これ
らの値を返す関数がないので無理かもしれません...。

親プラグインオブジェクトから子プラグインオブジェクトを呼び出すものを作ってい
たのですが、子プラグインオブジェクトの位置情報が全て0、0、0になってしまうの
も同じことかもしれません。
ですが、

それは与太郎がひまを持て余してるからですか？
今日の管理人さんの早業は、与太郎がいらんことを書くのを心配したからです。（ウソ）

さっき気づいたのですが、
スクリプトのポップアップメニュー項目の半角カタカナは、
談話室に書き込むときは全角カタカナに直してください。

メニューの幅が広がるのを嫌ってのことだとは判りますが、
半角カタカナ禁止はインターネットの常識のようですので。

すごいな〜ァ！。
短時間で・・・・。
最近のScriptサイトは中身が濃すぎます。

ARcoatingさんへ、

拘束機能についてはサラっと書き流してしまいましたが、
うまくいけば寸法等を描き直すコードが不要になるので、
試してみる価値はありそうです。


＞表の名前については、ディフォルトの名前はこのツールの「一番最初からの起動カウンタ」を
＞ファイルに保存（←こんなことが出来るのですね！）しておいて、それを呼出して使うという
＞のを思いついたんですが、可能ですよね？

問題ありません。
設定値のファイル保存／読み込みは簡単なので、近いうちに書き込みします。


＞＞Ａ列、Ｂ列を非表示にして管理情報を書き込んでいます。

実は「前記号」を忘れていました。Ｃ列を使いますか？
ワークシートのセル指定で、列の指定は定数にすると判りやすいし、変更も楽です。
Clm_StampType = 1;{Ａ列}
Clm_ObjName = 2;{Ｂ列}
のようにします。


＞今週末から書始めてみますので

いきなりコードを書きたい気持ちはわかりますが...

仕様がはっきりしないうちにコードを書き始めると、後戻りや修正でよけいに手間がかかりかねません。
最初から書き直したほうが早いと判っても、いったん書いたコードはなかなか捨てられません。
（特に忙しいときは。本当はそういうときほど書き直すべきなのですが。）
結局はデバッグに時間を取られて、後悔することになります。

と書きましたが、これは一般論ですね。
プログラムの経験を積む意味で、（書き直し覚悟で）コードを書くのは良いことだと考え直しました。
どんどん書いて、どんどん壁にぶち当たってください。

プログラムの手法には、トップダウンとボットムアップがあります。

トップダウンは、まず大きな処理を考えて、小さな処理に分割してゆきます。
処理を箇条書きする。
擬似コードを書く。同時に必要なデータ（ファイル、ＷＳ、変数など）を検討する。
随時、必要な関数／手続きを決めてゆく。
コードを書く。
のような流れで設計を進めます。
たとえば、

図形に番号、面積、寸法をスタンプし、面積表に登録する（最終目標）

　↓

ダイアログで諸設定。
選択図形があれば、
　それぞれの図形に番号、面積、寸法をスタンプし、
　必要なら面積表に登録する。
選択図形がなければ、
　マウスクリックで選択した図形に番号、面積、寸法をスタンプし、
　必要なら面積表に登録する。
終了。

　↓

設定を読み込んでダイアログを作成。
ダイアログで諸設定。対象となる面積表を決定。
選択図形があれば、
選択図形が無くなるまで、
　それぞれの図形に番号、面積、寸法をスタンプし、
　必要なら面積表に登録する。
選択図形がなければ、
無効なマウスクリックがあるまで、
　マウスクリックで選択した図形に番号、面積、寸法をスタンプし、
　必要なら面積表に登録する。
設定を保存する。
終了。

のようにどんどん細かくしていきます。
同じような箇所が何度も出てきたら、その箇所はサブルーチンの候補です。
文章にできないのは、理解できてない＝コードを書き始めるべきではない、ということなので、
もっと検討の必要があります。（場合によっては基本方針を変えてやり直す）

ボットムアップでは必要な関数／手続きを作ってから、それらを使ってプログラムを作っていきます。
どちらかというと古い手法です。

実際にはトップダウンで始めると同時に、処理を実現する具体的なコードも検討します。
また、簡単な（短いのではなく、処理が直線的で分枝などがない）プログラムならコードから始めても
構いません。
ちなみに与太郎はフローチャートなるものは使ったことがありません。（教わらなかったからですが）
現在ではフローチャートは「好ましくないもの」と評価されてるようです。

プログラムではコードよりデータ（ファイル、ＷＳ、変数など）のほうが重要だと考えてください。
データが決まれば、処理するコードも（ほぼ自動的に）決まります。
プログラム実行中、データがどのように変化するかを把握してないと、デバックもできません。

変数、定数、関数、手続きの名前も重要です。
適切な名前が付けられていると、コメント文が無くても理解しやすいコードになります。
Pascalの命名基準は、変数→小文字で始める／サブルーチン→大文字で始める、です。
Ｃ言語とちがって、Pascalは小文字と大文字を区別しませんが、自分にも他人にも判りやすい名前
をを付けるのは大事なことです。
たとえば、pfontsize よりは pFontSize, p_fontSize, p_font_size のほうが理解しやすいです。


ところで、「Ｃプログラミング診断室」という本があるのですが、お勧めです。
Ｃだけでなくプログラミング一般について見識が広がります。
Ｃを理解できなくても、読み物としても面白いので、充分楽しめると思います。
（ＣとPascalは兄弟みたいなものですから、どちらかを知っていればもう一方を覚えるのは比較的簡単です）
最近版型が小さくなって再刊しましたが、作者はＷＥＢ上でも内容を公開しているようです。

うわーー！息をのんじゃいました、、。
すごい、、、、、。

今週末ぐらいにぼちぼち書直していこうと思ってましたので、
まだ手を付けてませんでした！！よかった〜。

アイデアがてんこ盛りでどこからコメントしていいのやら、、。
(^^ゞ　

■名前の案

＞とにかく全ての図形に名前を付けます。名前からハンドルを得て、スクリプトで全ての図形をコントロールするつもりです。
　なるほど！これはグッド！是非そうさせていただきます！

　表の名前については、ディフォルトの名前はこのツールの「一番最初からの起動カウンタ」をファイルに保存（←こんなこと
　が出来るのですね！）しておいて、それを呼出して使うというのを思いついたんですが、可能ですよね？

　
■ワークシートの案
　
＞Ａ列、Ｂ列を非表示にして管理情報を書き込んでいます。
　なるほどこんな使い方があったんですね！だいぶ可能性が広がります！！


■コマンドの案

　確かに、メニューコマンドの方がよさそうですね！
　初期設定をファイルに保存というのは理想的な感じがします！ＶＷの最初からのすべてのツールもこうであってほしい物です。
　特に、インポート、エクスポートのＤＸＦ、ＪＷＣが毎回線の太さとか線種を指定しないといけないのは大変ですよね。

　コマンドの例、大変に参考になります！というかこのままが良い様な、、、。

　図形とワークシートの両方の変更をどう整合性をとるか私なりにもちょっと考えてみます！
　なんか、イメージ的にはＰａｌｍとＰＣを接続する「HotSync」の考え方が一番しっくりきそうです。



与太郎さんへ、ほんとに感謝です！今週末から書始めてみますので、分らないことがおそらくいっぱい出てきそうなので、
またアドバイスお願いします！！

ARcoatingさんへ、

寸法の自動調節は拘束機能で可能かも知れません。
図形に寸法を拘束させるにはSetBinaryConstraintを使います。
パラメータの頂点番号はGet2DPtの頂点番号と同じだと思います。
VW9からGet2DPtの守備範囲が増えたのは、こういう理由があったのです。
しかし意味のわからないパラメータも...

まあ、図形に名前さえ付いていれば、スクリプトでハンドルを取って変形出来ますから、
無理に拘束機能を使う必要はないです。


ところで、まだコードを書き始めてないなら、（書いてないとよいのですが）
与太郎も色々考えてみましたので、参考にしてみてください。
（どうか書いていませんように）


名前の案（漢字以外は半角文字です）

とにかく全ての図形に名前を付けます。名前からハンドルを得て、スクリプトで全ての図形をコントロールするつもりです。

「表１−」　．：表の名前、ワークシート名と同じ必要はない。表面には出ないのでどんな名前でも良い（乱数でも）。
「表１−１」　：対象図形の名前、表の名前＋番号。対象図形は四角形、多角形（三角形、台形、斜め四角形など）。
「表１−１Ａ」：面積（文字）
「表１−１Ｗ」：幅寸法
「表１−１Ｈ」：高さ寸法
「表１−１Ｎ」：番号（文字）
「表１−１Ｃ」：番号（長円）
「表１−１Ｓ」：対角線



ワークシートの案（レイアウトの都合上、すべて全角文字になってますが、数字、アルファベットは半角文字です。）

Ａ列、Ｂ列を非表示にして管理情報を書き込んでいます。
それをスクリプトで利用して、図形のハンドルを得たり、スタンプする項目や面積の単位を決めます。


＿　┌───非表示列────┐
┌─┬────┬──────┬───┬─────┬───┬─────┬───┬───┬──────┬──────┐
│＿│＿＿Ａ＿│＿＿＿Ｂ＿＿│＿Ｃ＿│＿＿Ｄ＿＿│＿Ｅ＿│＿＿Ｆ＿＿│＿Ｇ＿│＿Ｈ＿│＿＿＿Ｊ＿＿│＿＿＿Ｋ＿＿│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│１│ｍ２＿＿│表１−＿＿＿│Ｎｏ．│＿＿Ｗ＿＿│＿ｘ＿│＿＿Ｈ＿＿│＿＿＿│＿＝＿│面積（ｍ２）│合計（ｍ２）│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│２│＿＿＿１│＿＿＿＿＿２│＿＿＿│＿＿＿＿＿│＿＿＿│＿＿＿＿＿│＿＿＿│＿＿＿│＿＿＿＿＿＿│＿＿＿＿＿＿│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│３│ＡＤＮ＿│表１−１＿＿│＿１＿│＿２５００│＿ｘ＿│＿２０００│＿＿＿│＿＝＿│＿＿５．００│＿＿＿＿＿＿│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│４│ＡＤＮ＿│表１−２＿＿│＿２＿│＿３５００│＿ｘ＿│＿２０００│＿＿＿│＿＝＿│＿＿７．００│＿＿＿＿＿＿│
└─┴────┴──────┴───┴─────┴───┴─────┴───┴───┴──────┴──────┘
A1セル：面積の単位。
B1セル：表の名前。
A2セル：番号の初期値。
B2セル：最後に振った番号。
A3〜　：スタンプする項目。Ａ：面積／Ｄ：寸法／Ｎ：番号
B3〜　：登録図形の名前。
B列の「表1-1」,「表1-2」はC列の「1」,「2」と末尾の数字を対応させますが、（登録時）
その後は番号を付け替えるなどして対応しなくなっても良しとします。


コマンドの案

スクリプトはツールコマンドでなく、メニューコマンドということで考えてみました。
メニューコマンドだと、設定はカスタムダイアログとなります。
ファイルに設定を保存して、次回はその設定を初期状態にしたらどうでしょう。ＶＷを終了しても設定が残ります。
設定をワークシートに保存すると、ファイルごとに設定を変えられます。
下のようなコマンドが必要でしょうか。


「図形を面積表に登録..．」＿＿＿図形を選択して実行する。または、面積表を選択するかワークシートを開いて実行する。
　（選択またはクリックした図形に番号、面積、寸法をスタンプして、面積表に登録する。）
　（ワークシートを開いているときは、そこに登録する。）
　（開いてなければダイアログで既存の面積表か新しい面積表かを指定する。）

「図形の番号を更新」＿＿＿＿＿＿面積表のワークシートを開いて実行する。（ワークシートの番号を変えてから実行する。）
　（登録図形の番号を打ち直し、面積表を番号順にソートする。）
　（番号に欠番、重複があれば警告する。）

「面積表を再計算」＿＿＿＿＿＿＿リサイズした登録図形を選択して実行する。または、面積表を選択して実行する。
　（選択図形が登録されている面積表、または選択されている面積表の全ての登録図形の番号、面積、寸法を修正する。）
　（同時に面積表を書き直す。）
　（最後に「図形の番号を更新」を実行する。）

「図形を面積表から除外..．」＿＿＿登録図形を選択して実行する。またはワークシートの行を選択して実行する。
　（番号、面積、寸法等を削除する。それらを削除する前に図形名称を削除する。）
　（そのあと面積表から行を削除する。）

「指定した番号の図形を選択」＿＿面積表を選択するかワークシートを開いて実行する。
　（ダイアログで番号を指定して、その番号の図形を選択する。）

「未登録の図形を選択」＿＿＿＿＿面積表を選択するかワークシートを開いて実行する。
　（面積表に無いが名前が付けられている図形を選択する。）
　（ワークシートの行を削除したり、情報を消去すると、そういう状態になるかも。）

「ＷＳの列幅を保存」＿＿＿＿＿＿面積表を選択するかワークシートを開いて実行する。
　（複数のワークシートの列幅を合わせるために使用します。）

「ＷＳの列幅を保存値に設定」＿＿面積表を選択するかワークシートを開いて実行する。
　（複数のワークシートの列幅を合わせるために使用します。）

最後の２つは一般のワークシートでも使えます。


＝＝＝番号を打ち直す例＝＝＝

図形を４個選択して、メニューコマンド「図形を面積表に登録...」を実行します。
新しい面積表が作られました。
┌─┬────┬──────┬───┬─────┬───┬─────┬───┬───┬──────┬──────┐
│＿│＿＿Ａ＿│＿＿＿Ｂ＿＿│＿Ｃ＿│＿＿Ｄ＿＿│＿Ｅ＿│＿＿Ｆ＿＿│＿Ｇ＿│＿Ｈ＿│＿＿＿Ｊ＿＿│＿＿＿Ｋ＿＿│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│１│ｍ２＿＿│表１−＿＿＿│Ｎｏ．│＿＿Ｗ＿＿│＿ｘ＿│＿＿Ｈ＿＿│＿＿＿│＿＝＿│面積（ｍ２）│合計（ｍ２）│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│２│＿＿＿１│＿＿＿＿＿４│＿＿＿│＿＿＿＿＿│＿＿＿│＿＿＿＿＿│＿＿＿│＿＿＿│＿＿＿＿＿＿│＿＿＿＿＿＿│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│３│ＡＤＮ＿│表１−１＿＿│＿１＿│＿２５００│＿ｘ＿│＿２０００│＿＿＿│＿＝＿│＿＿５．００│＿＿＿＿＿＿│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│４│ＡＤＮ＿│表１−２＿＿│＿２＿│＿３５００│＿ｘ＿│＿２０００│＿＿＿│＿＝＿│＿＿７．００│＿＿＿＿＿＿│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│５│ＡＤＮ＿│表１−３＿＿│＿３＿│＿６０００│＿ｘ＿│＿２５００│＿＿＿│＿＝＿│＿１５．００│＿＿＿＿＿＿│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│６│ＡＤＮ＿│表１−４＿＿│＿４＿│＿３０００│＿ｘ＿│＿４５００│＿＿＿│＿＝＿│＿１８．００│＿＿＿＿＿＿│
└─┴────┴──────┴───┴─────┴───┴─────┴───┴───┴──────┴──────┘
登録直後はB列とC列の数字は一致しています。
登録順序が逆だったので、ワークシートの番号（C列）を変えます。

┌─┬────┬──────┬───┬─────┬───┬─────┬───┬───┬──────┬──────┐
│＿│＿＿Ａ＿│＿＿＿Ｂ＿＿│＿Ｃ＿│＿＿Ｄ＿＿│＿Ｅ＿│＿＿Ｆ＿＿│＿Ｇ＿│＿Ｈ＿│＿＿＿Ｊ＿＿│＿＿＿Ｋ＿＿│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│１│ｍ２＿＿│表１−＿＿＿│Ｎｏ．│＿＿Ｗ＿＿│＿ｘ＿│＿＿Ｈ＿＿│＿＿＿│＿＝＿│面積（ｍ２）│合計（ｍ２）│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│２│＿＿＿１│＿＿＿＿＿４│＿＿＿│＿＿＿＿＿│＿＿＿│＿＿＿＿＿│＿＿＿│＿＿＿│＿＿＿＿＿＿│＿＿＿＿＿＿│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│３│ＡＤＮ＿│表１−１＿＿│＿４＿│＿２５００│＿ｘ＿│＿２０００│＿＿＿│＿＝＿│＿＿５．００│＿＿＿＿＿＿│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│４│ＡＤＮ＿│表１−２＿＿│＿３＿│＿３５００│＿ｘ＿│＿２０００│＿＿＿│＿＝＿│＿＿７．００│＿＿＿＿＿＿│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│５│ＡＤＮ＿│表１−３＿＿│＿２＿│＿６０００│＿ｘ＿│＿２５００│＿＿＿│＿＝＿│＿１５．００│＿＿＿＿＿＿│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│６│ＡＤＮ＿│表１−４＿＿│＿１＿│＿３０００│＿ｘ＿│＿４５００│＿＿＿│＿＝＿│＿１８．００│＿＿＿＿＿＿│
└─┴────┴──────┴───┴─────┴───┴─────┴───┴───┴──────┴──────┘
ワークシートの番号を書き直しました。
メニューコマンド「図形の番号を更新」を実行します。

┌─┬────┬──────┬───┬─────┬───┬─────┬───┬───┬──────┬──────┐
│＿│＿＿Ａ＿│＿＿＿Ｂ＿＿│＿Ｃ＿│＿＿Ｄ＿＿│＿Ｅ＿│＿＿Ｆ＿＿│＿Ｇ＿│＿Ｈ＿│＿＿＿Ｊ＿＿│＿＿＿Ｋ＿＿│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│１│ｍ２＿＿│表１−＿＿＿│Ｎｏ．│＿＿Ｗ＿＿│＿ｘ＿│＿＿Ｈ＿＿│＿＿＿│＿＝＿│面積（ｍ２）│合計（ｍ２）│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│２│＿＿＿１│＿＿＿＿＿４│＿＿＿│＿＿＿＿＿│＿＿＿│＿＿＿＿＿│＿＿＿│＿＿＿│＿＿＿＿＿＿│＿＿＿＿＿＿│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│３│ＡＤＮ＿│表１−４＿＿│＿１＿│＿３０００│＿ｘ＿│＿４５００│＿＿＿│＿＝＿│＿１８．００│＿＿＿＿＿＿│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│４│ＡＤＮ＿│表１−３＿＿│＿２＿│＿６０００│＿ｘ＿│＿２５００│＿＿＿│＿＝＿│＿１５．００│＿＿＿＿＿＿│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│５│ＡＤＮ＿│表１−２＿＿│＿３＿│＿３５００│＿ｘ＿│＿２０００│＿＿＿│＿＝＿│＿＿７．００│＿＿＿＿＿＿│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│６│ＡＤＮ＿│表１−１＿＿│＿４＿│＿２５００│＿ｘ＿│＿２０００│＿＿＿│＿＝＿│＿＿５．００│＿＿＿＿＿＿│
└─┴────┴──────┴───┴─────┴───┴─────┴───┴───┴──────┴──────┘
ワークシートが並べ替えられました。
続いて別の図形を選択して、「図形を面積表に登録...」を実行します。

┌─┬────┬──────┬───┬─────┬───┬─────┬───┬───┬──────┬──────┐
│＿│＿＿Ａ＿│＿＿＿Ｂ＿＿│＿Ｃ＿│＿＿Ｄ＿＿│＿Ｅ＿│＿＿Ｆ＿＿│＿Ｇ＿│＿Ｈ＿│＿＿＿Ｊ＿＿│＿＿＿Ｋ＿＿│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│１│ｍ２＿＿│表１−＿＿＿│Ｎｏ．│＿＿Ｗ＿＿│＿ｘ＿│＿＿Ｈ＿＿│＿＿＿│＿＝＿│面積（ｍ２）│合計（ｍ２）│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│２│＿＿＿１│＿＿＿＿＿５│＿＿＿│＿＿＿＿＿│＿＿＿│＿＿＿＿＿│＿＿＿│＿＿＿│＿＿＿＿＿＿│＿＿＿＿＿＿│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│３│ＡＤＮ＿│表１−４＿＿│＿１＿│＿３０００│＿ｘ＿│＿４５００│＿＿＿│＿＝＿│＿１８．００│＿＿＿＿＿＿│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│４│ＡＤＮ＿│表１−３＿＿│＿２＿│＿６０００│＿ｘ＿│＿２５００│＿＿＿│＿＝＿│＿１５．００│＿＿＿＿＿＿│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│５│ＡＤＮ＿│表１−２＿＿│＿３＿│＿３５００│＿ｘ＿│＿２０００│＿＿＿│＿＝＿│＿＿７．００│＿＿＿＿＿＿│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│６│ＡＤＮ＿│表１−１＿＿│＿４＿│＿２５００│＿ｘ＿│＿２０００│＿＿＿│＿＝＿│＿＿５．００│＿＿＿＿＿＿│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│７│ＡＤＮ＿│表１−５＿＿│＿５＿│＿２０００│＿ｘ＿│＿４５００│＿＿＿│＿＝＿│＿＿９．００│＿＿＿＿＿＿│
└─┴────┴──────┴───┴─────┴───┴─────┴───┴───┴──────┴──────┘
ワークシートに行が追加されます。


以上のような感じですが、どうでしょうか。
複数の面積表の場合は、まだ考えていません。
一定の行数を超えたら新しい面積表を作って、続きの番号で登録する機能や、
登録図形を別の面積表に移動するコマンドも必要でしょうか？

イロイロなアイデアありがとうございます！
＞寸法線にも名前を付けているのなら、
＞四角形を変形後、寸法線も書き直すとか、
＞ワークシートで表示形式を変更して書き直すことも可能です。
最初に四角形と寸法線をグループ化してあると同時に変更できるかなと思いました！
しかし、BeginGroup;はBeginGroup;の後に描いた図形だけしかグループ化できませんね。んー。

＞図形の名前にワークシート名を含めると、複数の表と図形を関連付けやすいかも。
これがなぜかNameObjectで名前を付けることができないんですよ！！
SetNameで名前を付けるとリソースブラウザ上の名前が変ってしまい「面積表+
ランダム数字」の名前だと順番がバラバラになってしまいます。

＞選択図形が多すぎるときの処理。
＞図面に貼るワークシートだと百行くらいが上限ですね。それを超えたときはどうましょうか？
考えてませんでした、、、。これは意外に自動処理むつかしそうですね。

＞スクリプトに追加／変更をくりかえしてると、だんだんわかり難くなっていくので、
＞ワークシートの使い方や名前の付け方もよく検討して、最初から書き直したらどうでしょうか。
＞（同じルーチンでも、書き直すと前よりすっきりしたコードになったりします。）
確かに、私も思っておりました！！
只今、与太郎さんのスクリプトを参考に描画した寸法線とか連番をグループ化する様にしたのですが、
いろんな処理がBeginGroup;以降に入ってしまい図形数が多いとランタイムエラーが出る始末、、。
せっかく与太郎さんがすっきり書直してくださったのに、かなりコテコテにしてしまったのもあり、
また、頭の中の整理もかねて書直したいと思っております！

＞IF nametuke = true THEN は IF nametuke THEN と同じなので、
＞「= true」は無くても構いません。
ありがとうございます！！

以下、ちょっと長くなりますが、現在のスクリプト内容です。
■面積算定スクリプト

{■フィールドフォーマット設定
名前：＿フィールド名：＿＿型：＿＿初期値：
Noyn＿図形上に連番表示＿boolean＿＿true
menyn＿図形上に面積表示＿boolean＿＿true
fontsize＿フォントサイズ＿Integer＿＿9
boforeSymbol＿前　 記　 号＿Text＿＿
decimal＿＿小数点桁数＿Integer＿＿2
units＿＿単位＿＿RadioButtons＿下記４種類をそのままコピペしてください。

m2+辺長 (辺長と表をﾘﾝｸする)
m2 (図形と表をﾘﾝｸする)
坪 /3.3058 (図形と表をﾘﾝｸする)
帖 /1.6529 (図形と表をﾘﾝｸする

sheet＿＿面積表を作成 (単位：m2)＿＿boolean＿＿true
myname＿＿図形に名前を付ける(表リンク時必須)＿boolean＿＿true

__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/}

PROCEDURE mennseki;
VAR
＿fraction, display : LONGINT;＿format : INTEGER;＿upi: REAL;＿name, squareName : STRING;
＿x, y, cou1, fon, rndm :REAL;
＿h, hn2 : HANDLE;

{__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/　サブルーチン　__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/}
＿PROCEDURE RectToAreaText(h:HANDLE; VAR hn2:HANDLE; unitType, leftText:STRING; keta, fraction:LONGINT;
＿＿＿＿＿＿ men_yn, nametuke, No_tuke, Sheetkaku:boolean; fons, cou1s, rndms :REAL);
＿CONST
＿＿RectObj = 3; {四角形}
＿VAR
＿＿hn1 ,h_W , h_H: HANDLE;
＿＿x1, x2, y1, y2, scl : REAL;
＿＿xd, yd :REAL;{longint;}
＿＿mens : STRING;


＿＿PROCEDURE DrawArea(h:HANDLE; keisuu:Real; rightText:STRING; var men:STRING ); { 面積を描きます }
＿＿VAR
＿＿＿xs, ys :REAL;
＿＿BEGIN
＿＿＿HCenter(h, xs, ys);
＿＿＿TextOrigin(xs,ys-fons*0.28346*scl*1.6);
＿＿＿IF (unitType = 'm2+辺長 (辺長と表をﾘﾝｸする)') and (GetType(h) = RectObj) THEN{m2+辺長で図形が四角形か判断します }
＿＿＿BEGIN
＿＿＿＿men := Num2Str ( keta, xd*yd / (1000 / fraction ) ^ 2 );
＿＿＿END
＿＿＿ELSE BEGIN
＿＿＿＿men := Num2Str ( keta , HArea ( h ) / keisuu /(1000 / fraction ) ^ 2 );
＿＿＿END;
＿＿＿IF men_yn = true THEN
＿＿＿BEGIN
＿＿＿＿BeginText;
＿＿＿＿Concat( men, ' ', rightText )
＿＿＿＿EndText;
＿＿＿＿hn1 := LNewObj;
＿＿＿＿SetTextVerticalAlign(hn1, 3);
＿＿＿＿SetTextJust(hn1, 2);
＿＿＿＿SetDSelect(hn1);
＿＿＿END ELSE BEGIN
＿＿＿END;
＿＿END; { DrawArea }


＿＿PROCEDURE DrawNo(h:HANDLE); { No.を描きます }
＿＿VAR
＿＿＿xs, ys :REAL;
＿＿BEGIN
＿＿＿HCenter(h, xs, ys);
＿＿＿begingroup;
＿＿＿Oval(xs-fons*0.28346*scl*2,ys+fons*0.28346*scl*0.9,
＿＿＿＿xs+fons*0.28346*scl*2,ys-fons*0.28346*scl*0.9);
＿＿＿TextOrigin (xs,ys);
＿＿＿BeginText;
＿＿＿＿Concat ( leftText, cou1s)
＿＿＿EndText;
＿＿＿hn1 := LNewObj;
＿＿＿SetTextVerticalAlign (hn1,3);
＿＿＿SetTextJust (hn1,2);
＿＿＿SetDSelect(hn1);
＿＿＿endgroup;
＿＿＿hn1 := LNewObj;
＿＿＿SetDSelect(hn1);
＿＿END; { DrawNo }


＿＿PROCEDURE DrawDim(var hd:HANDLE; var dimlength:REAL; x1, y1, x2, y2:REAL); { 寸法を描きます }
＿＿BEGIN
＿＿＿MoveTo(x1, y1);
＿＿＿LineTo(x2, y2);
＿＿＿DimText;
＿＿＿hd := LNewObj;
＿＿＿dimlength:=Str2Num(getdimtext(hd));
＿＿＿SetDSelect(hd);
＿＿＿SetClass(hd,'面積算定');
＿＿＿IF nametuke = true THEN BEGIN
＿＿＿＿MoveTo(x1, y1);
＿＿＿＿LineTo(x2, y2);
＿＿＿＿hd := LNewObj;
＿＿＿＿SetDSelect(hd);
＿＿＿END ELSE BEGIN
＿＿＿END;

＿＿END; { DrawDim }


＿＿PROCEDURE sheetins(hn2, h, h_W, h_H:HANDLE; cou, xdR, ydR:REAL; menSS:STRING); { 表に入力します }
＿＿VAR
＿＿＿couS, xdS, ydS : STRING;
＿＿BEGIN
＿＿＿TextSize(9);
＿＿＿SprdFormat(0,0,'',''); {表示形式の種類 桁数 前記号 後記号 }
＿＿＿couS := Concat (leftText, cou1s);
＿＿＿loadcell(cou+2, 1, couS);
＿＿＿IF (unitType = 'm2+辺長 (辺長と表をﾘﾝｸする)') and (GetType(h) = RectObj) THEN {m2+辺長で図形が四角形か判断します }
＿＿＿BEGIN
＿＿＿＿SprdFormat(5,keta,'',''); {表示形式の種類 桁数 前記号 後記号 }
＿＿＿＿＿IF nametuke = true THEN BEGIN
＿＿＿＿＿＿loadcell(cou+2, 2, Concat('=LENGTH(N=',chr(39),GetName(h_W),chr(39),')'));
＿＿＿＿＿＿loadcell(cou+2, 4, Concat('=LENGTH(N=',chr(39),GetName(h_H),chr(39),')'));
＿＿＿＿＿END ELSE BEGIN
＿＿＿＿＿＿xdS := Num2Str(1,xdR);
＿＿＿＿＿＿ydS := Num2Str(1,ydR);
＿＿＿＿＿＿loadcell(cou+2, 2, xdS);
＿＿＿＿＿＿loadcell(cou+2, 4, ydS);
＿＿＿＿＿END;
＿＿＿＿loadcell(cou+2, 3, 'x');
＿＿＿＿SprdFormat(2,keta,'',''); {表示形式の種類 桁数 前記号 後記号 }
＿＿＿＿loadcell(cou+2, 7, Concat('=ROUND(B',cou+2,'*D',cou+2,'/10000)/100'));
＿＿＿＿{loadcell(cou+2, 7, menss); 面積の数値を入れる場合}
＿＿＿END
＿＿＿ELSE BEGIN
＿＿＿＿SprdFormat(2,keta,'',''); {表示形式の種類 桁数 前記号 後記号 }
＿＿＿＿loadcell(cou+2, 7, Concat( '=AREA(N=',chr(39),GetName(h),chr(39),')/1000000'));
＿＿＿END;
＿＿＿loadcell(cou+2, 6, '=');
＿＿＿loadcell(cou+2, 8, Concat('=H',cou+1,'+G',cou+2));
＿＿＿SetWSCellAlignment(ActSSheet, cou+2, 1, cou+2, 1, 2); {左右中央揃え}
＿＿＿SetWSCellAlignment(ActSSheet, cou+2, 3, cou+2, 3, 2); {左右中央揃え}
＿＿＿SetWSCellAlignment(ActSSheet, cou+2, 6, cou+2, 6, 2); {左右中央揃え}
＿＿＿InsertWSRows (hn2, cou+3, 1);
＿＿＿SetWSCellBorder (hn2, cou+2, 1, cou+3, 1, false, true, false, false, false); {枠線、上左下右周り}
＿＿＿SetWSCellBorder (hn2, cou+2, 8, cou+3, 8, false, false, false, true, false); {枠線、上左下右周り}
＿＿END; { sheetins }


＿BEGIN { RectToAreaText }
＿＿hn1 := ActLayer;
＿＿scl := GetLScale(hn1);
＿＿xd := 0; yd :=0;
＿＿IF nametuke = true THEN BEGIN
＿＿＿setname(h,Concat(' ',rndms,'-',leftText,cou1s)); {図形に名前をつけます}
＿＿END ELSE BEGIN
＿＿END;
＿＿＿IF unitType = 'm2+辺長 (辺長と表をﾘﾝｸする)' THEN
＿＿＿BEGIN
＿＿＿＿IF GetType(h) = RectObj THEN { 図形が四角形かチェックします }
＿＿＿＿BEGIN
＿＿＿＿＿GetBBox (h, x1, y1, x2, y2);
＿＿＿＿＿{xd := x2-x1 ; yd := y1-y2 ;}
＿＿＿＿＿DrawDim(h_W, xd, x1, y2, x2, y2);
＿＿＿＿＿DrawDim(h_H, yd, x2, y2, x2, y1);
＿＿＿＿＿MoveTo(x2, y1);
＿＿＿＿＿LineTo(x1, y2);
＿＿＿＿＿SetLS(LNewObj,-1);
＿＿＿＿＿SetDSelect(LNewObj);
＿＿＿＿＿IF nametuke = true THEN BEGIN
＿＿＿＿＿＿setname(h_W,Concat(' ',rndms,'-',leftText,cou1s,'-W')); {名前をつけます}
＿＿＿＿＿＿setname(h_H,Concat(' ',rndms,'-',leftText,cou1s,'-H')); {名前をつけます}
＿＿＿＿＿END ELSE BEGIN
＿＿＿＿＿END;
＿＿＿＿END
＿＿＿＿ELSE BEGIN
＿＿＿＿END;
＿＿＿＿DrawArea(h, 1, 'm2',mens);
＿＿＿END
＿＿＿ELSE IF unitType = 'm2 (図形と表をﾘﾝｸする)' THEN
＿＿＿BEGIN
＿＿＿＿DrawArea(h, 1, 'm2',mens);
＿＿＿END
＿＿＿ELSE IF unitType = '坪 /3.3058 (図形と表をﾘﾝｸする)' THEN
＿＿＿BEGIN
＿＿＿＿DrawArea(h, 3.3058, '坪',mens);
＿＿＿END
＿＿＿ELSE IF unitType = '帖 /1.6529 (図形と表をﾘﾝｸする)' THEN
＿＿＿BEGIN
＿＿＿＿DrawArea(h, 1.6529, '帖',mens);
＿＿＿END
＿＿＿ELSE BEGIN
＿＿＿＿{ 処理はありません。 }
＿＿＿END;
＿＿IF No_tuke = true THEN BEGIN
＿＿＿DrawNo(h);{ No.を描きます }
＿＿END ELSE BEGIN
＿＿END;
＿＿IF Sheetkaku = true THEN BEGIN
＿＿＿sheetins(hn2, h, h_W, h_H, cou1s, xd, yd, mens);{ 表に入力します }
＿＿END ELSE BEGIN
＿＿END;
＿＿TextSize(fons);
＿＿ReDrawAll;
＿END; { RectToAreaText }


＿PROCEDURE Drawsheet(VAR hn2:HANDLE; rndm:REAL); { 表を描きます }
＿BEGIN
＿GetPt ( x, y );
＿NameObject (Concat(Num2Str(0,rndm),'-面積表'));
＿{新しいワークシートを作成します。ｼｰﾄ名 , 座標xy , 行数 , 列数 , 図形モード , ウインドウを開く}
＿NewSprdSheet('面積表', x, y, 4, 8, true, false) ;
＿hn2 := ActSSheet ;
＿IF hn2 <> NIL THEN
＿BEGIN
＿SetWSPlacement (hn2, 200, 420, 768, 850);
＿SetWSColumnWidth(hn2, 1, 1, 34);
＿SetWSColumnWidth(hn2, 2, 2, 57);
＿SetWSColumnWidth(hn2, 3, 3, 16);
＿SetWSColumnWidth(hn2, 4, 4, 57);
＿SetWSColumnWidth(hn2, 5, 5, 22);
＿SetWSColumnWidth(hn2, 6, 6, 16);
＿SetWSColumnWidth(hn2, 7, 7, 65);
＿SetWSColumnWidth(hn2, 8, 8, 65);
＿{ハンドル、 左上（行、列）、右下（行、列）、入力したい文字}
＿SetWSCellFormula(hn2, 1, 1, 1, 1, 'No.') ;
＿SetWSCellFormula(hn2, 1, 2, 1, 2, 'Ｗ') ;
＿SetWSCellFormula(hn2, 1, 3, 1, 3, 'x') ;
＿SetWSCellFormula(hn2, 1, 4, 1, 4, 'Ｈ') ;
＿SetWSCellFormula(hn2, 1, 5, 1, 5, '') ;
＿SetWSCellFormula(hn2, 1, 6, 1, 6, '=') ;
＿SetWSCellFormula(hn2, 1, 7, 1, 7, '面積(m2)') ;
＿SetWSCellFormula(hn2, 1, 8, 1, 8, '合計(m2)') ;
＿SetWSCellBorder (hn2, 1, 1, 4, 8, false, false, false, false, true); {枠線、上、左、下、右、周り}
＿SetWSCellBorder (hn2, 1, 1, 1, 8, false, false, false, false, true); {枠線、上、左、下、右、周り}
＿SetWSCellAlignment(hn2, 1, 1, 1, 8, 2); {左右中央揃え}
＿h := LSActLayer;
＿SetDSelect(h);
＿END
＿ELSE BEGIN
＿＿{ 処理はありません。 }
＿END;
＿END;{ Drawsheet }


＿PROCEDURE SmallHandling(VAR hna:HANDLE); { 一番左上にある図形を選択します }
＿VAR
＿＿hnb : HANDLE;
＿＿ax1, ax2, ay1, ay2, bx1, bx2, by1, by2, za, zb : REAL;
＿BEGIN
＿＿hnb := NextSObj(hna);
＿＿WHILE hnb <> NIL DO
＿＿BEGIN
＿＿＿GetBBox (hna, ax1, ay1, ax2, ay2);
＿＿＿GetBBox (hnb, bx1, by1, bx2, by2);
＿＿＿za := ax1*1000-ay1;
＿＿＿zb := bx1*1000-by1;
＿＿＿IF za <= zb THEN
＿＿＿BEGIN
＿＿＿＿hnb := NextSObj(hnb);
＿＿＿END
＿＿＿ELSE BEGIN
＿＿＿＿hna := hnb;
＿＿＿＿hnb := NextSObj(hnb);
＿＿＿END;
＿＿END;＿
＿END; { SMALLHANDLE }

{__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/　メインルーチン　__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/}
BEGIN { mennseki }
＿PushAttrs;
＿NameClass('面積算定');
＿FillBACK (0);
＿fon := pfontsize;
＿TextSize(fon);
＿GetUnits ( fraction, display, format, upi, name, squareName );
＿cou1 := 0;
＿rndm := Round (Random*10000);
＿IF Psheet = true THEN BEGIN
＿＿Drawsheet(hn2, rndm);＿{ サブルーチン　表を描きます }
＿END ELSE BEGIN
＿＿GetPt ( x, y );
＿END;
＿h := FSActLayer;
＿IF h <> NIL THEN
＿BEGIN {__/__/__/__/__/__/__/__/__/__/__/__/図形が選択されている場合__/__/__/__/__/__/__/__/__/__/__/__/}
＿＿WHILE h <> NIL DO
＿＿BEGIN
＿＿＿SmallHandling(h);
＿＿＿cou1 := cou1+1;
＿＿＿begingroup;
＿＿＿RectToAreaText(h, hn2, PUNITS, PBOFORESYMBOL, PDECIMAL, fraction, Pmenyn, Pmyname, PNoyn, Psheet, fon, cou1, rndm);
＿＿＿endgroup;
＿＿＿SetDSelect(LNewObj);
＿＿＿SetDSelect(h);
＿＿＿h := FSActLayer;
＿＿END;
＿ReDrawAll;
＿END
＿ELSE
＿BEGIN
＿END;
＿＿{__/__/__/__/__/__/__/__/__/__/__/__/図形が選択されていない場合__/__/__/__/__/__/__/__/__/__/__/__/}
＿Message('アクティブレイヤの図形をクリックしてください。 何もない所をクリックすると終了します。');
＿REPEAT
＿＿cou1 := cou1+1;
＿＿GetPt ( x, y );
＿＿h := PickObject ( x, y );
＿＿IF h <> NIL THEN
＿＿BEGIN
＿＿＿begingroup;
＿＿＿RectToAreaText(h, hn2, PUNITS, PBOFORESYMBOL, PDECIMAL, fraction, Pmenyn, Pmyname, PNoyn, Psheet, fon, cou1, rndm);
＿＿＿SetDSelect(LNewObj);
＿＿＿endgroup;
＿＿＿ReDrawAll;
＿＿END;
＿UNTIL h = NIL;
＿ClrMessage;
＿DSelectAll;
＿ReDrawAll;
＿PopAttrs;
＿SETTOOL(-240);
END;
Run ( mennseki );

下のソースコードだけではよく判らなかったのですが、
図形を変形した後、自動的に面積と辺長を再計算するために
ワークシート関数を使っているのですね。（かなり高度なところを狙ってますね。）

すごいものが出来そうなので、与太郎もアイデアを上乗せしていいですか？

寸法線にも名前を付けているのなら、
四角形を変形後、寸法線も書き直すとか、
ワークシートで表示形式を変更して書き直すことも可能です。

メニューコマンドで「面積表に図形を登録」とか「面積／辺長を再計算」とかすると、
ショートカットキーで実行できて便利です。
複数のスクリプトに同じサブルーチンがあるときは、サブルーチンを別ファイルにして、
{$INCLUDE}で読み込めばいいです。

あと、

図形の名前にワークシート名を含めると、複数の表と図形を関連付けやすいかも。

選択図形が多すぎるときの処理。
図面に貼るワークシートだと百行くらいが上限ですね。それを超えたときはどうしましょうか？

二重登録の禁止。
すでに有効な名前が付けられた図形は面積表に書き込まない、などの処理が必要です。

スクリプトに追加／変更をくりかえしてると、だんだんわかり難くなっていくので、
ワークシートの使い方や名前の付け方もよく検討して、最初から書き直したらどうでしょうか。
（同じルーチンでも、書き直すと前よりすっきりしたコードになったりします。）

ところで、
IF nametuke = true THEN は IF nametuke THEN と同じなので、
「= true」は無くても構いません。

今気づいたのですが、WS_to_GroupObjで、
セルの幅がゼロのときは文字を描かないように修正する必要がありますね。

なるほどなるほど。
スクリプトで再計算ボタンを作って更新するということですね。
ちょっとやってみます！ありがとうございます！！

ワークシート関数では無理なので、
ワークシートに図形の名前の列を作って、
それをスクリプトで参照して、長さを記入するのはどうでしょうか？

与太郎さん、アドバイスありがとうございます。
「GetDimText」試してみましたが、ちょっとちがいました、、。

説明が下手で申訳ありませーん。(>_<)
ベクタースクリプトでワークシートに下記の様な形式で寸法線の寸法を
入力したいのです。（Lengthの代りに寸法線の寸法を取得する関数）
=Length(N='寸法線の名前')

現在やむなく、寸法線の寸法を取得できないので、寸法線の所に線をもう一本描いて、
それに名前を付けて、「　=Length(N='線の名前')　」をワークシートに送ってるのですが
なんとなくスマートではないのです。

＞ところで、「ナナメ寸法」は何に使うのですか？
今のところは関係ないのですが、将来的に角度を振った四角形や台形の辺長もワークシートに
送りたいと思っております！（いつになるか分りませんが、、、。）

{__/__/__/__/__/__/__/__/__/__/__/ 孫サブルーチン __/__/__/__/__/__/__/__/__/__/__/}
＿＿PROCEDURE DrawDim(var hd:HANDLE; var dimlength:REAL; x1, y1, x2, y2:REAL); { 寸法を描きます }
＿＿BEGIN
＿＿＿MoveTo(x1, y1);
＿＿＿LineTo(x2, y2);
＿＿＿DimText;
＿＿＿hd := LNewObj;
＿＿＿dimlength:=Str2Num(getdimtext(hd));
＿＿＿SetDSelect(hd);
＿＿＿SetClass(hd,'面積算定');
＿＿＿IF nametuke = true THEN BEGIN{←■ここでもう一本線を書く■}
＿＿＿＿MoveTo(x1, y1);
＿＿＿＿LineTo(x2, y2);
＿＿＿＿hd := LNewObj;
＿＿＿＿SetDSelect(hd);
＿＿＿END ELSE BEGIN
＿＿＿END;
＿＿END; { DrawDim }


＿＿PROCEDURE sheetins(hn2, h, h_W, h_H:HANDLE; cou, xdR, ydR:REAL; menSS:STRING); { 表に入力します }
＿＿VAR
＿＿＿couS, xdS, ydS : STRING;
＿＿BEGIN
＿＿＿TextSize(9);
＿＿＿SprdFormat(0,0,'',''); {表示形式の種類 桁数 前記号 後記号 }
＿＿＿couS := Concat (leftText, cou1s);
＿＿＿loadcell(cou+2, 1, couS);
＿＿＿IF (unitType = 'm2+辺長 (辺長と表をﾘﾝｸする)') and (GetType(h) = RectObj) THEN {m2+辺長で図形が四角形か判断します }
＿＿＿BEGIN
＿＿＿＿SprdFormat(5,keta,'',''); {表示形式の種類 桁数 前記号 後記号 }
＿＿＿＿＿IF nametuke = true THEN BEGIN
＿＿＿＿＿＿loadcell(cou+2, 2, Concat('=LENGTH(N=',chr(39),GetName(h_W),chr(39),')'));{←■ここでワークシートに入力■}
＿＿＿＿＿＿loadcell(cou+2, 4, Concat('=LENGTH(N=',chr(39),GetName(h_H),chr(39),')'));{←■ここでワークシートに入力■}
＿＿＿＿＿END ELSE BEGIN
＿＿＿＿＿＿xdS := Num2Str(1,xdR);
＿＿＿＿＿＿ydS := Num2Str(1,ydR);
＿＿＿＿＿＿loadcell(cou+2, 2, xdS);
＿＿＿＿＿＿loadcell(cou+2, 4, ydS);
＿＿＿＿＿END;
＿＿＿＿loadcell(cou+2, 3, 'x');
＿＿＿＿SprdFormat(2,keta,'',''); {表示形式の種類 桁数 前記号 後記号 }
＿＿＿＿loadcell(cou+2, 7, Concat('=ROUND(B',cou+2,'*D',cou+2,'/10000)/100'));
＿＿＿＿{loadcell(cou+2, 7, menss); 面積の数値を入れる場合}
＿＿＿END
＿＿＿ELSE BEGIN
＿＿＿＿SprdFormat(2,keta,'',''); {表示形式の種類 桁数 前記号 後記号 }
＿＿＿＿loadcell(cou+2, 7, Concat( '=AREA(N=',chr(39),GetName(h),chr(39),')/1000000'));
＿＿＿END;
＿＿＿loadcell(cou+2, 6, '=');
＿＿＿loadcell(cou+2, 8, Concat('=H',cou+1,'+G',cou+2));
＿＿＿SetWSCellAlignment(ActSSheet, cou+2, 1, cou+2, 1, 2); {左右中央揃え}
＿＿＿SetWSCellAlignment(ActSSheet, cou+2, 3, cou+2, 3, 2); {左右中央揃え}
＿＿＿SetWSCellAlignment(ActSSheet, cou+2, 6, cou+2, 6, 2); {左右中央揃え}
＿＿＿InsertWSRows (hn2, cou+3, 1);
＿＿＿SetWSCellBorder (hn2, cou+2, 1, cou+3, 1, false, true, false, false, false); {枠線、上左下右周り}
＿＿＿SetWSCellBorder (hn2, cou+2, 8, cou+3, 8, false, false, false, true, false); {枠線、上左下右周り}
＿＿END; { sheetins }


{__/__/__/__/__/__/__/__/__/__/__/__/ 子サブルーチン __/__/__/__/__/__/__/__/__/__/__/__/__/__/}
＿BEGIN { RectToAreaText }
＿＿hn1 := ActLayer;
＿＿scl := GetLScale(hn1);
＿＿xd := 0; yd :=0;
＿＿IF nametuke = true THEN BEGIN
＿＿＿setname(h,Concat(' ',rndms,'-',leftText,cou1s)); {図形に名前をつけます}
＿＿END ELSE BEGIN
＿＿END;
＿＿＿IF unitType = 'm2+辺長 (辺長と表をﾘﾝｸする)' THEN
＿＿＿BEGIN
＿＿＿＿IF GetType(h) = RectObj THEN { 図形が四角形かチェックします }
＿＿＿＿BEGIN
＿＿＿＿＿GetBBox (h, x1, y1, x2, y2);
＿＿＿＿＿{xd := x2-x1 ; yd := y1-y2 ;}
＿＿＿＿＿DrawDim(h_W, xd, x1, y2, x2, y2);{ ↑■孫サブルーチンへ（寸法を描きます）■ }
＿＿＿＿＿DrawDim(h_H, yd, x2, y2, x2, y1);{ ↑■孫サブルーチンへ（寸法を描きます）■ }
＿＿＿＿＿MoveTo(x2, y1);
＿＿＿＿＿LineTo(x1, y2);
＿＿＿＿＿SetLS(LNewObj,-1);
＿＿＿＿＿SetDSelect(LNewObj);
＿＿＿＿＿IF nametuke = true THEN BEGIN
＿＿＿＿＿＿setname(h_W,Concat(' ',rndms,'-',leftText,cou1s,'-W')); {■線に名前をつけます■}
＿＿＿＿＿＿setname(h_H,Concat(' ',rndms,'-',leftText,cou1s,'-H')); {■線に名前をつけます■}
＿＿＿＿＿END ELSE BEGIN
＿＿＿＿＿END;
＿＿＿＿END
＿＿＿＿ELSE BEGIN
＿＿＿＿END;
＿＿＿＿DrawArea(h, 1, 'm2',mens);
＿＿＿END
＿＿＿ELSE IF unitType = 'm2 (図形と表をﾘﾝｸする)' THEN
＿＿＿BEGIN
＿＿＿＿DrawArea(h, 1, 'm2',mens);
＿＿＿END
＿＿＿ELSE IF unitType = '坪 /3.3058 (図形と表をﾘﾝｸする)' THEN
＿＿＿BEGIN
＿＿＿＿DrawArea(h, 3.3058, '坪',mens);
＿＿＿END
＿＿＿ELSE IF unitType = '帖 /1.6529 (図形と表をﾘﾝｸする)' THEN
＿＿＿BEGIN
＿＿＿＿DrawArea(h, 1.6529, '帖',mens);
＿＿＿END
＿＿＿ELSE BEGIN
＿＿＿＿{ 処理はありません。 }
＿＿＿END;
＿＿IF No_tuke = true THEN BEGIN
＿＿＿DrawNo(h);{ No.を描きます }
＿＿END ELSE BEGIN
＿＿END;
＿＿IF Sheetkaku = true THEN BEGIN
＿＿＿sheetins(hn2, h, h_W, h_H, cou1s, xd, yd, mens);{ ↑■孫サブルーチンへ（表に入力します）■ }
＿＿END ELSE BEGIN
＿＿END;
＿＿TextSize(fons);
＿＿ReDrawAll;
＿END; { RectToAreaText }

皆さんをちょっと心配させてしまいましたが、なんとかしのげました。
事務所にひとりで居ると、こういう脱線もあります。

ARcoatingさん、
GetDimTextを使ってみてください。
データパレットで指定した精度で丸められた数字が文字列で返ってきます。
Str2Numで数値に変換してください。
精度がそれ以上必要だとこの方法では無理ですが、今回はこれで間に合うと思います。

ところで、「ナナメ寸法」は何に使うのですか？

寸法線（Dimensions）の寸法をArea関数みたいにワークシートに関連付けさせたいのですが、どなたかご存じないでしょうか？

床面積算定スクリプトを改良してまして、図形寸法（辺長）の変更をワークシート
に反映したいと思っております。Area関数を使うと計算過程が見えないので気分的
に気持悪いので（小数点第３位以下の端数処理が不安）、図面の寸法の値をワーク
シートに入れて計算させたいのです。
Length関数、Width関数（←ナナメ寸法が難しい）では思う様にいきませんでした。

与太郎さん、お忙しい中レスありがとうございます。
typeの件、教えていただいたエーアンドエーのホームページにありました！
http://www.aanda.co.jp/VIPRoom/index.html
「多くの複雑なデータをひと固まりとして、簡単に取り扱うことができるよう
に考えられたもの。」ということですね。
dynArray[]と合わせて、情報取得系のスクリプトを書くときは、与太郎さんの
スクリプトを参考にさせていただいて活用してみたいと思います。


＞ARcoatingさんのおかげで SetTextStyle の使い方が理解できました。
＞ありがとうございました。
いえいえどういたしまして！というか、はずかしながら意味も分からずAandA
さんのOTツールの中身をコピペしただけなんです。(^_^.)


＞スクリプトを書く人が増えればいいなと思っています。

私も共感を覚えました。
私は自分の脳と手の一部と思えるぐらいＶＷがお気に入りです！しかしながら、
フリーのＪＷＣＡＤも使っているのですが、作図効率を比較するとＪＷのほうが
よかったりするんです。しかも、フリーの有用なプラグインがいっぱい落ちてい
たりもします。かたやＶＷの方はほとんどのプラグインが有料だったりして、
とても安月給の私には個人的に手が出る代物ではなく、又、自分でツールを作ろ
うとしても、プログラムを組む経験のほとんどない私としてはなかなか思うよう
に出来ず、日々悔しい思いをしておりました。そんな中、このScript談話室では
経験豊富な方々が有難いことに教えてくださりますし、具体的に有用なツールが
生み出されていくので大変心強く思っております。

与太郎さんとても便利なスクリプトをありがとうございます。
私の所では Ver10 を Ver8.5 に変換して納品することが多く、ワークシート
は一度 Excel にコピー＆ペーストしてから Ver8.5 のワークシート上へ再度
コピペ、もしくは最初から Excel で作成し、Ver8.5 上でコピペしています。
これからは WS_to_GroupObj を利用させて頂きます。

>スクリプトを書く人が増えればいいなと思っています。

私もこれに賛成です。もっともっと裾野が広がってくれると良いですね。
本業に差し支えない程度に頑張って下さい。
・・・っん、なんか人事モードになってますね。
私も解る範囲で書き込みますので、よろしくお願いします。

字下げするとこうなります。
（先頭の"＿"は消すかタブに変換しないと実行できません）

プログラムの流れは単純なので、順を追ってゆけば理解できると思います。
苦労したのはDrawVBordersとDrawHBordersのところです。

procedure WS_to_GroupObj;
{ ワークシートをグループ図形にします。（var9以降に対応） }
{DEBUG}
const
＿{ クラス名とクラス属性 }
＿ClsWSText = 'WS-Text';
＿ClsWSGrid = 'WS-Grid';
＿ClsWSOutLine = 'WS-Outline';
＿ClsWSBorder = 'WS-Border';
＿OutlineWidth = 21;＿{ 0.53ミリ }
＿OutlineColor = 15;＿{ 赤色 }
＿GridWidth = 1;＿{ 0.025ミリ }
＿GridColor = 5;＿{ 黄色 }
＿LnWidth = 11;＿{ 0.28ミリ }
＿LnColor = 4;＿{ 青色 }
＿txtColor = 15;＿{ 赤色 }
＿
＿{ セルの余白 }
＿LeftMargin = 3;＿{ 3ポイント=1.06ミリ }
＿RightMargin = 3;＿{ 3ポイント=1.06ミリ }
＿
type
＿wsCell = structure
＿＿align＿:integer;{ 0=標準／1=左よせ／2=センタ／3=右よせ }
＿＿txt＿:string;{ セルの内容 }
＿＿fontID＿:integer;
＿＿size＿:integer;
＿＿Style＿:integer;{Plain:0／Bold:1／Italic:2／Underline:4／Outline:8／Shadow:16}
＿end;
＿
var
＿k＿:real; { 描画倍率 }
＿hWS＿:handle;
＿maxRow, MaxClm＿:integer;
＿wd＿:dynArray[] of integer;
＿ht＿:dynArray[] of integer;
＿x＿:dynArray[] of real;
＿y＿:dynArray[] of real;
＿hLine＿:dynArray[,] of boolean;
＿vLine＿:dynArray[,] of boolean;
＿

＿procedure Set_k;{ 描画倍率を計算します。 }
＿var
＿＿scale＿:real;
＿＿upi＿:real;
＿＿fraction, display＿:longint;
＿＿format＿:integer;
＿＿name, squareName＿:string;
＿begin
＿＿scale:= GetLScale(ActLayer);
＿＿GetUnits(fraction, display, format, upi, name, squareName);
＿＿k:= upi * scale / 25.4 / 72 * 25.4;
＿end;{Set_k}
＿
＿procedure Init_Vars;{ 変数を初期化します。 }
＿var
＿＿row, clm＿:integer;
＿＿top, left, bottom, right＿:boolean;
＿＿
＿＿procedure Set_or(var source:boolean; dist:boolean);
＿＿begin
＿＿＿source:= source or dist;
＿＿end;{Set_or}
＿＿
＿begin{Init_Vars}
＿＿{ 配列を確保 }
＿＿GetWSRowColumnCount(hWS, maxRow, MaxClm);
＿＿Allocate ht[1..MaxRow];
＿＿Allocate wd[1..MaxClm];
＿＿Allocate x[0..MaxClm];
＿＿Allocate y[0..MaxRow];
＿＿Allocate hLine[0..MaxRow, 0..MaxClm];
＿＿Allocate vLine[0..MaxRow, 0..MaxClm];
＿＿
＿＿{ セルの寸法を取得 }
＿＿for row:= 1 to maxRow do
＿＿＿GetWSRowHeight(hWS, row, ht[row]);
＿＿for clm:= 1 to maxClm do
＿＿＿GetWSColumnWidth(hWS, clm, wd[clm]);
＿＿
＿＿{ 罫線を取得 }
＿＿for row:= 0 to maxRow do begin
＿＿＿for clm:= 0 to maxClm do begin
＿＿＿＿hLine[row, clm]:= false;
＿＿＿＿vLine[row, clm]:= false;
＿＿＿end;{for}
＿＿end;{for}
＿＿for row:= 1 to maxRow do begin
＿＿＿for clm:= 1 to maxClm do begin
＿＿＿＿GetWSCellBorder(hWS, row, clm, top, left, bottom, right);
＿＿＿＿Set_or(hLine[row-1, clm], top);
＿＿＿＿Set_or(hLine[row, clm], bottom);
＿＿＿＿Set_or(vLine[row, clm-1], left);
＿＿＿＿Set_or(vLine[row, clm], right);
＿＿＿end;{for}
＿＿end;{for}
＿end;{Init_Vars}
＿
＿procedure Set_XY;{ ＸＹ座標を計算します。 }
＿var
＿＿row, clm＿:integer;
＿begin
＿＿for clm:= 1 to maxClm do
＿＿＿x[clm]:= x[clm-1] + k * wd[clm];
＿＿
＿＿for row:= 1 to maxRow do
＿＿＿y[row]:= y[row-1] - k * ht[row];
＿end;{Set_XY}
＿
＿function BeClass(cls:string):boolean;
＿{ クラスの有無を返します。 }
＿var
＿＿i＿:integer;
＿＿be＿:boolean;
＿begin
＿＿i:= 1;
＿＿be:= false;
＿＿while (i <= ClassNum) & (not be) do begin
＿＿＿if cls = ClassList(i) then
＿＿＿＿be:= true;
＿＿＿i:= i + 1;
＿＿end;{while}
＿＿BeClass:= be;
＿end;{BeClass}
＿
＿procedure SetClassAttrs;
＿{ クラス属性を設定します。クラスがある場合は何もしません。 }
＿begin
＿＿if not BeClass(ClsWSGrid) then begin
＿＿＿NameClass(ClsWSGrid);
＿＿＿SetClPenFore(ClsWSGrid, GridColor);
＿＿＿SetClLW(ClsWSGrid, GridWidth);
＿＿end;{if}
＿＿
＿＿if not BeClass(ClsWSOutline) then begin
＿＿＿NameClass(ClsWSOutline);
＿＿＿SetClPenFore(ClsWSOutline, OutlineColor);
＿＿＿SetClLW(ClsWSOutline, OutlineWidth);
＿＿end;{if}
＿＿
＿＿if not BeClass(ClsWSBorder) then begin
＿＿＿NameClass(ClsWSBorder);
＿＿＿SetClPenFore(ClsWSBorder, lnColor);
＿＿＿SetClLW(ClsWSBorder, lnWidth);
＿＿end;{if}
＿＿
＿＿if not BeClass(ClsWSText) then begin
＿＿＿NameClass(ClsWSText);
＿＿＿SetClPenFore(ClsWSText, txtColor);
＿＿end;{if}
＿end;{SetClassAttrs}
＿
＿procedure DrawGrid;
＿{ グリッドを描きます。 }
＿var
＿＿row, clm＿:integer;
＿begin
＿＿BeginGroup;
＿＿for row:= 1 to maxRow-1 do begin
＿＿＿MoveTo(x[0], y[row]);
＿＿＿LineTo(x[maxClm], y[row]);
＿＿end;{for}
＿＿
＿＿for clm:= 1 to maxClm-1 do begin
＿＿＿MoveTo(x[clm], y[0]);
＿＿＿LineTo(x[clm], y[maxRow]);
＿＿end;{for}
＿＿EndGroup;
＿end;{DrawGrid}
＿
＿procedure DrawOutline;
＿{ 外枠を描きます。 }
＿begin
＿＿Rect(x[0], y[0], x[maxClm], y[maxRow]);
＿end;{DrawOutline}
＿
＿procedure DrawHBorders;
＿{ 水平線を書きます。 }
＿var
＿＿row, c1, c2＿:integer;
＿＿
＿＿function StartClm(c:integer):integer;
＿＿begin
＿＿＿repeat
＿＿＿＿c:= c + 1;
＿＿＿until (maxClm <= c) | (hLine[row, c]);
＿＿＿if (c <= maxClm) & (hLine[row, c]) then
＿＿＿＿StartClm:= c
＿＿＿else
＿＿＿＿StartClm:= 0;
＿＿end;{StartClm}
＿＿
＿＿function EndClm(c:integer):integer;
＿＿begin
＿＿＿while (c < maxClm) & hLine[row, c+1] do
＿＿＿＿c:= c + 1;
＿＿＿EndClm:= c;
＿＿end;{EndClm}
＿＿
＿begin{DrawHBorders}
＿＿for row:= 0 to maxRow do begin
＿＿＿c1:= StartClm(0);
＿＿＿while (c1 <> 0) do begin
＿＿＿＿c2:= EndClm(c1);
＿＿＿＿MoveTo(x[c1-1], y[row]);
＿＿＿＿LineTo(x[c2], y[row]);
＿＿＿＿c1:= StartClm(c2);
＿＿＿end{while}
＿＿end;{for}
＿end;{DrawHBorders}
＿
＿procedure DrawVBorders;
＿{ 垂直線を描きます。 }
＿var
＿＿clm, r1, r2＿:integer;
＿＿
＿＿function StartRow(r:integer):integer;
＿＿begin
＿＿＿repeat
＿＿＿＿r:= r + 1;
＿＿＿until (maxRow <= r) | (vLine[r, clm]);
＿＿＿if (r <= maxRow) & (vLine[r, clm]) then
＿＿＿＿StartRow:= r
＿＿＿else
＿＿＿＿StartRow:= 0;
＿＿end;{StartRow}
＿＿
＿＿function EndRow(r:integer):integer;
＿＿begin
＿＿＿while (r < maxRow) & vLine[r+1, clm] do
＿＿＿＿r:= r + 1;
＿＿＿EndRow:= r;
＿＿end;{EndRow}
＿＿
＿begin
＿＿for clm:= 0 to maxClm do begin
＿＿＿r1:= StartRow(0);
＿＿＿while (r1 <> 0) do begin
＿＿＿＿MoveTo(x[clm], y[r1-1]);
＿＿＿＿LineTo(x[clm], y[r2]);
＿＿＿＿r2:= EndRow(r1);
＿＿＿＿r1:= StartRow(r2);
＿＿＿end{while}
＿＿end;{for}
＿end;{DrawVBorders}
＿
＿procedure GetCell(h:handle; row, clm:integer; var c:wsCell);
＿{ セルの情報を取得します。 }
＿begin
＿＿GetWSCellAlignment(h, row, clm, c.align);
＿＿if c.align = 0 then begin
＿＿＿if CellHasNum(h, row, clm) then
＿＿＿＿c.align:= 3
＿＿＿else
＿＿＿＿c.align:= 1;
＿＿end;
＿＿GetWSCellString(h, row, clm, c.txt);
＿＿GetWSCellTextFormat(h, row, clm, c.fontID, c.size, c.style);
＿end;{GetCell}
＿
＿procedure DrawTexts;
＿{ セルの文字を描きます。 }
＿var
＿＿row, clm＿:integer;
＿＿cell＿:wsCell;
＿＿xT, yT＿:real;
＿begin
＿＿TextVerticalAlign(5);{ 下揃え }
＿＿for row:= 1 to maxRow do begin
＿＿＿yT:= y[row];
＿＿＿for clm:= 1 to maxClm do begin
＿＿＿＿GetCell(hWS, row, clm, cell);
＿＿＿＿if cell.txt <> '' then begin
＿＿＿＿＿case cell.align of
＿＿＿＿＿＿0, 1: xT:= x[clm-1] + k * LeftMargin;
＿＿＿＿＿＿2: xT:= (x[clm-1] + x[clm]) / 2;
＿＿＿＿＿＿3: xT:= x[clm] - k * RightMargin;
＿＿＿＿＿end;{case}
＿＿＿＿＿TextJust(cell.align);
＿＿＿＿＿TextFont(cell.fontID);
＿＿＿＿＿TextSize(cell.size);
＿＿＿＿＿TextOrigin(xT, yT);
＿＿＿＿＿CreateText(cell.txt);
＿＿＿＿＿SetTextStyle(LNewObj, 0, GetTextLength(LNewObj), cell.style);
＿＿＿＿end;{if}
＿＿＿end;{for}
＿＿end{for}
＿end;{DrawTexts}
＿
begin{WS_to_GroupObj}
＿hWS:= ActSSheet;
＿if hWS = nil then begin
＿＿AlrtDialog('ワークシートが開かれていません。');
＿end{if}
＿else begin
＿＿PushAttrs;
＿＿DSelectAll;
＿＿Set_k;
＿＿Init_Vars;
＿＿Message('図形を描く位置（左上）をクリックしてください。');
＿＿GetPt(x[0], y[0]);
＿＿Set_XY;
＿＿SetClassAttrs;
＿＿BeginGroup;
＿＿＿FillPat(0);
＿＿＿LSByClass;
＿＿＿LWByClass;
＿＿＿PenColorByClass;
＿＿＿NameClass(ClsWSText);
＿＿＿DrawTexts;
＿＿＿NameClass(ClsWSGrid);
＿＿＿DrawGrid;
＿＿＿NameClass(ClsWSBorder);
＿＿＿BeginGroup;
＿＿＿＿DrawHBorders;
＿＿＿＿DrawVBorders;
＿＿＿EndGroup;
＿＿＿NameClass(ClsWSOutline);
＿＿＿DrawOutline;
＿＿EndGroup;
＿＿ClrMessage;
＿＿PopAttrs;
＿＿ReDrawAll;
＿end;{else}
end;{WS_to_GroupObj}
Run(WS_to_GroupObj);

>質問ですが、宣言部分のtypeはVarとは違いがあるのですか？

dynArray[]、Allocateは動的配列、
type、structureは構造体(ユーザ定義データタイプ)の予約語です。
いずれもVW9以降の機能です。
できるだけ多くのひとにスクリプトを使ってもらうという意味では、
VW9以降とかの制限がある機能は使いたくないのですが、
今回のスクリプトはVW9以降が対象なので使ってみました。

typeとVarとの違いですが、簡単に説明する自信がないので、
VW9の「マニュアル和訳」を読んでみてください。
（本業のほうをサボったので、あまり長いレスは無理な状況です）

エーアンドエーのホームページの「サポート」-「開発情報」で
ダウンロードできます。VW10の英語版マニュアルもあります。

ARcoatingさんのおかげで SetTextStyle の使い方が理解できました。
ありがとうございました。

TextStyle(cell.style); がうまくいかないので、
SetTextStyle(LNewObj, 1, GetTextLength(LNewObj), cell.style);
に変えたのですが、エラーが出て、原因が判りませんでした。

とりあえずテキストスタイルの再現は見送って発表しようかと思いましたが、
ARcoatingさんのスクリプトで SetTextSize を使っていたのを思い出して、
SetTextSize(h, 0, FontLength, Size);
となっているのを見て理解できました。
２番目のパラメータ（開始位置）が１だと思い込んでいたのが原因でした。
おかげで完全な(？)スクリプトになりました。

GetTextSize の同様なエラーのため、
ちょっと前に作ったスクリプトが中途半端な出来になっていましたが、
それも修正できそうです。

>宣言してわずが１日で、これまたすごいやつを作られましたね！
触りだけでもと軽く考えて始めたら、途中でやめられなくなって、
結局仕事そっちのけで完成させる羽目になりました。
ほとんどトラブらなかったので、予想より早くできました。

>与太郎さんは一体何者ですか？！？！妖怪だったりして、、。(^.^)
いえっけっしてそのようなものではありません、ぜったいちがいます〜。

このスクリプトを書く動機は...
MC7とExcel5のときは、Excelの表をMCにコピペして、
線の太さを変えれば良かったんですが、
VW8.5とExcel2001の組合わせだと、所々文字サイズが変わってしまって、
後で修正しないと使えなくなりました。
OS9にしてからはExcel5が動かなくなったので、
ずっとスクリプトを書こうと思っていました。

DWG や JWC にファイル変換するときにワークシートが変換されないので、
それも動機の一つです。
VW談話室でも誰かが質問されてましたが、
そのときは「VWではできません」という答えでした。（事実ですが）
でも、「VWではできません」ばかりだと、
VWを使ってみようかと思っている人の出端をくじくようでイヤです。
自分が使ってる（気に入ってもいる）CADですから、
たくさんの人に使ってもらいたいですからね。

印刷トラブル以外なら、大抵のことはスクリプトで解決できると感じてますが、
与太郎ひとりの力でなんとかなるわけもありません。
スクリプトを書く人が増えればいいなと思っています。
Script談話室に書き込んでいるのも、そういう理由からです。

本当に凄いですね。
こんなに簡単に作るとは・・・・。
理解しようと、見てるだけで頭が痛くなりました。
どうしたら、この様に・・・・う〜む。

与太郎さんこんにちは！
宣言してわずが１日で、これまたすごいやつを作られましたね！
与太郎さんは一体何者ですか？！？！妖怪だったりして、、。(^.^)

早速、コピペして使ってみました！
これは便利ですね！
ワークシートの枠線の太さとセル高さが変更できないのが哀しかったんですけど、
これを使えば解決できますね。面積表などの最終的なレイアウト調整の時かなり便利です！
それに、数式が文字列に変換されるので表の変更前のﾊﾞｯｸｱｯﾌﾟとしても使えそうです。

スクリプト、いつもながら勉強になります。
dynArray[]は強力ですね！「IF THEN」とかを使うよりずっときれい！
質問ですが、宣言部分のtypeはVarとは違いがあるのですか？

ワークシートをグループ図形にするスクリプトが出来ましたんで、書いときます。

使い方は、
下のスクリプトをテキストファイルとして保存して、
「階層」-「コマンドを実行...」か、リソースパレットで実行します。
（実行する前に、図形化したいワークシートを表示しておくこと。）
メッセージがでたら、図形を描く位置（左上）をクリックしてください。

図形は「WS-」で始まるクラスに設定されるので、線の色や太さは、クラス属性で変更出来ます。
なお、このスクリプトはVW9以降でないと動きません。


procedure WS_to_GroupObj;
{ ワークシートをグループ図形にします（var9以降に対応）}
{ by 与太郎 2004/04/03〜2004/04/03 }
{ 図形化したいワークシートを表示して、実行する }
{ 属性はクラス属性で変更可能 }
{DEBUG}
const
{ クラス名とクラス属性 }
ClsWSText = 'WS-Text';
ClsWSGrid = 'WS-Grid';
ClsWSOutLine = 'WS-Outline';
ClsWSBorder = 'WS-Border';
OutlineWidth = 21;{ 0.53ミリ }
OutlineColor = 15;{ 赤色 }
GridWidth = 1;{ 0.025ミリ }
GridColor = 5;{ 黄色 }
LnWidth = 11;{ 0.28ミリ }
LnColor = 4;{ 青色 }
txtColor = 15;{ 赤色 }

{ セルの余白 }
LeftMargin = 3;{ 3ポイント=1.06ミリ }
RightMargin = 3;{ 3ポイント=1.06ミリ }

type
wsCell = structure
align:integer;{ 0=標準／1=左よせ／2=センタ／3=右よせ }
txt:string;{ セルの内容 }
fontID:integer;
size:integer;
Style:integer;{Plain:0／Bold:1／Italic:2／Underline:4／Outline:8／Shadow:16}
end;

var
k:real; { 描画倍率 }
hWS:handle;
maxRow, MaxClm:integer;
wd:dynArray[] of integer;
ht:dynArray[] of integer;
x:dynArray[] of real;
y:dynArray[] of real;
hLine:dynArray[,] of boolean;
vLine:dynArray[,] of boolean;

{ ====================サブルーチン==================== }
procedure Set_k;{ 描画倍率を計算します。 }
var
scale:real;
upi:real;
fraction, display:longint;
format:integer;
name, squareName:string;
begin
scale:= GetLScale(ActLayer);
GetUnits(fraction, display, format, upi, name, squareName);
k:= upi * scale / 25.4 / 72 * 25.4;
end;{Set_k}

procedure Init_Vars;{ 変数を初期化します。 }
var
row, clm:integer;
top, left, bottom, right:boolean;

procedure Set_or(var source:boolean; dist:boolean);
begin
source:= source or dist;
end;{Set_or}

begin{Init_Vars}
{ 配列を確保 }
GetWSRowColumnCount(hWS, maxRow, MaxClm);
Allocate ht[1..MaxRow];
Allocate wd[1..MaxClm];
Allocate x[0..MaxClm];
Allocate y[0..MaxRow];
Allocate hLine[0..MaxRow, 0..MaxClm];
Allocate vLine[0..MaxRow, 0..MaxClm];

{ セルの寸法を取得 }
for row:= 1 to maxRow do
GetWSRowHeight(hWS, row, ht[row]);
for clm:= 1 to maxClm do
GetWSColumnWidth(hWS, clm, wd[clm]);

{ 罫線を取得 }
for row:= 0 to maxRow do begin
for clm:= 0 to maxClm do begin
hLine[row, clm]:= false;
vLine[row, clm]:= false;
end;{for}
end;{for}
for row:= 1 to maxRow do begin
for clm:= 1 to maxClm do begin
GetWSCellBorder(hWS, row, clm, top, left, bottom, right);
Set_or(hLine[row-1, clm], top);
Set_or(hLine[row, clm], bottom);
Set_or(vLine[row, clm-1], left);
Set_or(vLine[row, clm], right);
end;{for}
end;{for}
end;{Init_Vars}

procedure Set_XY;{ ＸＹ座標を計算します。 }
var
row, clm:integer;
begin
for clm:= 1 to maxClm do
x[clm]:= x[clm-1] + k * wd[clm];

for row:= 1 to maxRow do
y[row]:= y[row-1] - k * ht[row];
end;{Set_XY}

function BeClass(cls:string):boolean;
{ クラスの有無を返します。 }
var
i:integer;
be:boolean;
begin
i:= 1;
be:= false;
while (i <= ClassNum) & (not be) do begin
if cls = ClassList(i) then
be:= true;
i:= i + 1;
end;{while}
BeClass:= be;
end;{BeClass}

procedure SetClassAttrs;
{ クラス属性を設定します。クラスがある場合は何もしません。 }
begin
if not BeClass(ClsWSGrid) then begin
NameClass(ClsWSGrid);
SetClPenFore(ClsWSGrid, GridColor);
SetClLW(ClsWSGrid, GridWidth);
end;{if}

if not BeClass(ClsWSOutline) then begin
NameClass(ClsWSOutline);
SetClPenFore(ClsWSOutline, OutlineColor);
SetClLW(ClsWSOutline, OutlineWidth);
end;{if}

if not BeClass(ClsWSBorder) then begin
NameClass(ClsWSBorder);
SetClPenFore(ClsWSBorder, lnColor);
SetClLW(ClsWSBorder, lnWidth);
end;{if}

if not BeClass(ClsWSText) then begin
NameClass(ClsWSText);
SetClPenFore(ClsWSText, txtColor);
end;{if}
end;{SetClassAttrs}

procedure DrawGrid;{ グリッドを描きます。 }
var
row, clm:integer;
begin
BeginGroup;
for row:= 1 to maxRow-1 do begin
MoveTo(x[0], y[row]);
LineTo(x[maxClm], y[row]);
end;{for}

for clm:= 1 to maxClm-1 do begin
MoveTo(x[clm], y[0]);
LineTo(x[clm], y[maxRow]);
end;{for}
EndGroup;
end;{DrawGrid}

procedure DrawOutline;{ 外枠を描きます。 }
begin
Rect(x[0], y[0], x[maxClm], y[maxRow]);
end;{DrawOutline}

procedure DrawHBorders;{ 水平線を書きます。 }
var
row, c1, c2:integer;

function StartClm(c:integer):integer;
begin
repeat
c:= c + 1;
until (maxClm <= c) | (hLine[row, c]);
if (c <= maxClm) & (hLine[row, c]) then
StartClm:= c
else
StartClm:= 0;
end;{StartClm}

function EndClm(c:integer):integer;
begin
while (c < maxClm) & hLine[row, c+1] do
c:= c + 1;
EndClm:= c;
end;{EndClm}

begin{DrawHBorders}
for row:= 0 to maxRow do begin
c1:= StartClm(0);
while (c1 <> 0) do begin
c2:= EndClm(c1);
MoveTo(x[c1-1], y[row]);
LineTo(x[c2], y[row]);
c1:= StartClm(c2);
end{while}
end;{for}
end;{DrawHBorders}

procedure DrawVBorders;{ 垂直線を描きます。 }
var
clm, r1, r2:integer;

function StartRow(r:integer):integer;
begin
repeat
r:= r + 1;
until (maxRow <= r) | (vLine[r, clm]);
if (r <= maxRow) & (vLine[r, clm]) then
StartRow:= r
else
StartRow:= 0;
end;{StartRow}

function EndRow(r:integer):integer;
begin
while (r < maxRow) & vLine[r+1, clm] do
r:= r + 1;
EndRow:= r;
end;{EndRow}

begin
for clm:= 0 to maxClm do begin
r1:= StartRow(0);
while (r1 <> 0) do begin
MoveTo(x[clm], y[r1-1]);
LineTo(x[clm], y[r2]);
r2:= EndRow(r1);
r1:= StartRow(r2);
end{while}
end;{for}
end;{DrawVBorders}

procedure GetCell(h:handle; row, clm:integer; var c:wsCell);{ セルの情報を取得します。 }
begin
GetWSCellAlignment(h, row, clm, c.align);
if c.align = 0 then begin
if CellHasNum(h, row, clm) then
c.align:= 3
else
c.align:= 1;
end;
GetWSCellString(h, row, clm, c.txt);
GetWSCellTextFormat(h, row, clm, c.fontID, c.size, c.style);
end;{GetCell}

procedure DrawTexts;{ セルの文字を描きます。 }
var
row, clm:integer;
cell:wsCell;
xT, yT:real;
begin
TextVerticalAlign(5);{ 下揃え }
for row:= 1 to maxRow do begin
yT:= y[row];
for clm:= 1 to maxClm do begin
GetCell(hWS, row, clm, cell);
if cell.txt <> '' then begin
case cell.align of
0, 1: xT:= x[clm-1] + k * LeftMargin;
2: xT:= (x[clm-1] + x[clm]) / 2;
3: xT:= x[clm] - k * RightMargin;
end;{case}
TextJust(cell.align);
TextFont(cell.fontID);
TextSize(cell.size);
TextOrigin(xT, yT);
CreateText(cell.txt);
SetTextStyle(LNewObj, 0, GetTextLength(LNewObj), cell.style);
end;{if}
end;{for}
end{for}
end;{DrawTexts}

{ ====================メインルーチン==================== }
begin{WS_to_GroupObj}
hWS:= ActSSheet;
if hWS = nil then begin
AlrtDialog('ワークシートが開かれていません。');
end{if}
else begin
PushAttrs;
DSelectAll;
Set_k;
Init_Vars;
Message('図形を描く位置（左上）をクリックしてください。');
GetPt(x[0], y[0]);
Set_XY;
SetClassAttrs;
BeginGroup;
FillPat(0);
LSByClass;
LWByClass;
PenColorByClass;
NameClass(ClsWSText);
DrawTexts;
NameClass(ClsWSGrid);
DrawGrid;
NameClass(ClsWSBorder);
BeginGroup;
DrawHBorders;
DrawVBorders;
EndGroup;
NameClass(ClsWSOutline);
DrawOutline;
EndGroup;
ClrMessage;
PopAttrs;
ReDrawAll;
end;{else}
end;{WS_to_GroupObj}
Run(WS_to_GroupObj);

「おいっ与太郎」
「なんですか父さん」

「おいっ与太公」
「なんだい八っつぁん」

今年度の目標は、
1. ワークシートを図形化するスクリプト。
2. 図面の中の表をワークシート化するスクリプト。
ということを宣言しときます。
（生来のナマケものなので、こうでもしないと途中でやめてしまいそうなので。）

ワークシートの図形化は難しくなさそう。（VW9以降なら）
表のワークシート化は面倒そうです。

完成の暁には、ここで発表させていただきます。

>与太郎の御助力には、何時も感謝、感謝ですね。
頭が下がります。

与太郎さん、大変失礼しました。
敬語が抜けてました。ごめんなさい。

与太郎さん、いつもいつもフォローありがとうございます！！

今度は「case」！！、、、。メモっときます! __〆(°°)ｶｷｶｷ..。

エラーの件ですが元のスクリプトでWIN_VW10環境では条件分岐せずに
なぜかエラーがでてませんでした、、、。

あと、WIN_VW10.0環境では{ResetObject (h) };がないと寸法のフォント
サイズが見た目変わりません。寸法を触ると初めて指定サイズに変わります。
与太郎さんの方ではどうでしょうか？WIN_VW10.0環境だけの問題かもしれません。

ARcoatingさん、

SetObjectVariableRealの使い方、とても参考になりました。
SetObjectVariableReal → VW9以降
ResetObject → VW10以降
なので使ったことがありませんでした。
やっぱり新しいほうが出来ることも多いということですね。

寸法線のオブジェクト識別番号もVW9とVW10では違っているので、
このスクリプトはVW10以降に対応ということです。

ところで、今のままだとエラーメッセージが出るので、
図形タイプ毎に処理を分けないとまずいですよ。

{ 条件分けしたサブルーチン }
FUNCTION MozReFontSize(h :HANDLE) :BOOLEAN;
VAR
＿FontLength : INTEGER;
BEGIN
＿case GetType(h) of
＿＿63 : begin {Dimension}
＿＿＿SetObjectVariableReal (h, 40, Size );
＿＿＿{ResetObject (h) };
＿＿end; {Dimension}
＿＿10 : begin {Text}
＿＿＿FontLength := GetTextLength( h );
＿＿＿SetTextSize(h, 0, FontLength, Size);
＿＿end; {Text}
＿end;{case}
END; {MozReFontSize}

早々の回答ありがとうございます！
すみません！！ちょっと説明不足でした、、。
フォント＿サイズ規定値と同じ機能で私的にお気に入りの７pointと１１pointを
作りたいと思い試行錯誤しておりました。ＡandＡさんのＯＴでフォントサイズ
変更ツールがありましたが、寸法サイズが変更できませんでした、、。
ということで、DoMenuTextByNameでは無理でしたが、
与太郎さんの「Re:色とレイヤの自動変更」であったForEachObject()が
非常にヒントになりました！！
いちおう、フォントサイズ変更ツールが出来ました。

■フォントサイズ変更ツール
{ 選択された文字と寸法のフォントサイズを変更 }
PROCEDURE ReFontSize;
Const
Size = 7;{目的のフォントサイズ}

{__/__/__/__/__/__/__/__/__/__/　サブルーチン　__/__/__/__/__/__/__/__/__/__/}
FUNCTION MozReFontSize(h :HANDLE) :BOOLEAN;
VAR
criteria:string; { 検索条件 }
FontLength : INTEGER;
BEGIN
SetObjectVariableReal (h, 40, Size );
ResetObject (h) ;
FontLength := GetTextLength( h );
SetTextSize(h, 0, FontLength, Size);
END; {MozReFontSize}

{__/__/__/__/__/__/__/__/__/__/　メインルーチン　__/__/__/__/__/__/__/__/__/__/}
begin
ForEachObjectInLayer ( MozReFontSize, 2, 1, 4);
end;

Run(ReFontSize);

飯田さんへ

winデモ版VW9で試したところ、確かにエラーがでました。
「エラーを確認...」でエラーメッセージウィンドウを開いてから、
もう一度読み込んでみてください。
何故か上手くゆきました。

VectorScriptコマンドを作って実行する手もあります。

与太郎の御助力には、何時も感謝、感謝ですね。
頭が下がります。

与太郎さん：
ありがとうございます。　m(_ _)m
VectorScriptエラーになるのですが。。。

実は体験版のCDを急遽借り受けたので、参考書すらありません。
体験版とはいえ、ヘルプがないのはつらいです。

どこが間違っているかすらわかりません。

寸法を選択して、
DoMenuTextByName('Font Size', メニューアイテム番号);
でメニューコマンドを呼び出せば出来ると思います。

飯田さん、
下のスクリプトをテキストファイルとして保存して、
「ファイル」-「取り込む」-「VectorScript...」で取り込んでください。
良かったらレベル-5以降を追加して使ってください。
ダメだったら、どこが違うか教えてもらえれば修正します。


{ ハッチングを生成するスクリプト }
procedure MakeHatchs;
procedure MakeHatch(name:string; x, y, dX, dY, dashFactor, ofstX, ofstY:real; lineWt, colorID:integer; pageSpace, rotateInWall:boolean);
const
K = 25.4;
var
s:string;
begin
s:= name;
BeginVectorFillN(name, pageSpace, rotateInWall, 0);
AddVectorFillLayer(x/K, y/K, dX/K, dY/K, ofstX/K, ofstY/K, dashFactor, lineWt, colorID);
EndVectorFill;
if s <> name then
AlrtDialog(Concat('「', s, '」はすでに使われているので、「', name, '」で作成しました。'));
end;

begin
{ レベル-1 第１基準点 X:9.3 Y:5 第２基準点 ΔX:10 ΔY:0 破線間隔 0.14 間隔 ΔX:0 ΔY:10 線の太さ:6ミル 線色:255 縮尺を無視する 壁の中で回転する}
MakeHatch('レベル-1', 9.3, 5, 10, 0, 0.14, 0, 10, 6, 255, TRUE, TRUE);
MakeHatch('レベル-2', 0.7, 5, 40, 10, 0.03, 10, 0, 6, 255, TRUE, TRUE);
MakeHatch('レベル-3', 8.1, 4.7, 40, 10, 0.03, 10, 0, 6, 255, TRUE, TRUE);
MakeHatch('レベル-4', 1.9, 5.3, 120, 70, 0.01, 50, 30, 6, 255, TRUE, TRUE);
end;
Run(MakeHatchs);

スクリプトで既にある図面上の寸法のフォントの大きさを変えるにはどうしたらよいのでしょうか？
どなたかご存じでしたら教えてください。

SetTextSize();とResetObject();では変更は無理でした、、、。

なるほどーー。ForEachObject()を使うとグループ図形の中まで検索できるのですね。
勉強になりました！
しかし、かなりハイレベルなことですね！！(@_@)
奥が深い、、、。

下のレス、題名とハンドル名を書き忘れました。

{ メインルーチン２ }の次の行の { は不要です。消してください。

ARcoatingさん、
その方法だとグループ図形の中がうまくいかないので、
ForEachObject()を使ってみてください。

メインルーチンが二つあるので、どちらかを消して実行してください。

{ 属性（線色）を一括変換 }
procedure ChangeObjAttr;
var
col:integer; { メインルーチン２では不要 }

{ サブルーチン --- 線色を変更します。(シンボル内は対象外です) }
procedure ChangeLineColor(beforeColor, afterColor:integer);
var
criteria:string; { 検索条件 }

{ ForEachObjectから呼ばれるプロシージャ }
procedure ChangeLineColorSub(h:handle);
begin
SetPenFore(h, afterColor);
end;{ChangeLineColorSub}

begin{ChangeLineColor}
criteria:= Concat('(PF=', Num2Str(0, beforeColor), ') & (T=Rect)'); { (PF=000) }
ForEachObject(ChangeLineColorSub, criteria);
ReDrawAll;
end;{ChangeLineColor}

{ メインルーチン1（TEST）---黒色(255)から(0)まで色をかえてゆき、最後に(255)にする}
begin{ChangeObjAttr}
for col:= 255 downto 1 do begin
Message(col, ' to ', col-1);
ChangeLineColor(col, col-1);
end;
ChangeLineColor(0, 255);
ClrMessage;
end;
Run(ChangeObjAttr);

{ メインルーチン２ }
{
begin{ChangeObjAttr}
ChangeLineColor(7, 5);
ChangeLineColor(6, 4);
{ 必要なだけ続ける }
end;
Run(ChangeObjAttr);

ARcoatingさん、
みごと黄色に変わりました。感動です！
ありがとうございました。

＞「レイヤ１をレイヤ２に変換」というのは、レイヤ１にある図形をレイヤ２に移動するということでしょうか？
そうですね、そういう事になると思います。

与太郎さん、レスありがとうございます。
がんばって出来る限り調べてみたいと思います。

こんにちは、コニーネさん。
特定の色を変換は下記のスクリプトでいけると思います。
「レイヤ１をレイヤ２に変換」というのは、レイヤ１にある図形をレイヤ２に移動するということでしょうか？

■特定面地色の面地色を変換（赤色→黄色）

PROCEDURE test;
VAR
h : HANDLE;

begin
DSelectAll;
SelectObj((FB=7)); {7は色パレットの番号：赤}
h := FSActLayer;
WHILE h <> NIL DO
BEGIN
SetFillBack (h, 5); {5は色パレットの番号：黄色}
h := NextSObj(h);
end;
end;

Run ( test );

VectorScriptだけでは無理のようです。
このサイトの「連載コラム」の記事、「ファイル共有って便利ですよ 」が
参考になるかと思います。

こんにちわ。私はまったくの初心者なのですが、
例えば赤色を黄色、レイヤ１をレイヤ２など、
特定の色やレイヤを一括で変換できるVectorScriptの
ソースはどうなるのでしょうか？

VectorWorksは人並みに使えるのですが、
VectorScriptの全くの初心者です。
AutoCADデータ（70フロアほど）をVectorWorksに自動に一括で全て読込みたいのですが、
VectorScriptで可能でしょうか？
時間があればゆっくり解読していきたいのですが、
近々に、可能であれば使いたいとの要望があります。
もし可能でしたら、そのソース等を教えて頂けないでしょうか？
もしくはヒントを教えていただけると助かります。

以下が「面積辺長スタンプ.vst」の内容説明です。

機　　能：選択図形や任意にクリックした図形の面積表示や表の作成をする。四角形の場合は辺長も表示可能。

用　　途：面積表作成、積算時の拾い出し、面積の検討。

インスト：１・ダウンロードした「 面積辺長スタンプ.vst」を以下のフォルダーに入れる。
ール方法　　　ウインドウズの場合　Program Files/VectorWorks/Plug-Ins
　　　　　２・VectorWorksを起動して　ファイル/作業画面/設計/現在の画面を設計変更を選ぶ。
　　　　　３・作業画面/ツールを選び。左側の「 ARc」のフォルダの中の「面積辺長スタンプ」を
　　　　　　　右側の任意の任意の場所にドラッグアンドドロップ。そして「ＯＫ」を押す。

メ　　モ：Windows版VectorWorks10.0で作りました。他のバージョンやMacでもおそらく動作すると思います。

ご了承ありがとうございます！
与太郎さんに整理してもらえたおかげでイロイロと機能を盛込むことが出来ました。
「乱数+番号の図形の名前」はワークシートに図形を関連付けるのが意外とめんどくさいので思いつきました！
あと、図形に連番を振るところも小ネタを効かしました(^o^)ので是非一度見てやってください！

スクリプトは最終的にフィールドフォーマットも改良しましたのでこの掲示板ではアップが難しいのでリンクという形にさせてもらいました。

■完成版　Ver1.0

面積辺長スタンプ.vst

http://jp.y42.briefcase.yahoo.co.jp/bc/ys337/vwp2?.tok=bcvB0jAB2AXBL0IO&.dir=/%b8%f8%b3%ab&.dnm=%cc%cc%c0%d1%ca%d5%c4%b9%a5%b9%a5%bf%a5%f3%a5%d7.vst.vst&.src=bc

スクリプト完成おめでとうございます！！！

>あとご相談ですが、この床面積算定スクリプトをフリースクリプト？として公開したいと
>思っておりますがよろしいでしょうか？
私はお手伝いしただけで、ARcoatinさんのアイデアなんですから、
ご自由にされたら良いと思います。

アイデアといえば、
乱数と番号を組合わせて図形の名前を付けるのはユニークですね。
あとで検索とかに使うのですか？
今まで図形の名前は数回しか使ったことがありませんが、
こういう使い方もあるんだと思いました。

与太郎さん、おかげさまで自分なりに満足いく床面積スクリプトが完成しました！
いろいろとアドバイスいただきありがとうございました。今後ともよろしくおねがいします。
あとご相談ですが、この床面積算定スクリプトをフリースクリプト？として公開したいと思っておりますがよろしいでしょうか？

与太郎さん、エラーがなくなりました！！

目を通しただけ！でエラーの原因が分るなんて信じられません、、、、。
わたくしの場合はエディタで書いて、祈りながらＶＷにコピペ。そして、必ずエラーがでるので手直し。これを５、６回ぐらいは必ずやることになります。　
そして「コンパイル成功！」がでた時は感無量になるといった感じです。

本当にありがとうございます！

PROCEDURE DrawArea(h:HANDLE; keisuu:Real; rightText, var men:STRING );
を下のように直せばエラーは出なくなると思います。

PROCEDURE DrawArea(h:HANDLE; keisuu:Real; rightText:STRING; var men:STRING );

スクリプトは字下げだけ確認しながら目を通したのですが、

＿PROCEDURE Drawsheet; { 表を描きます }
＿VAR
＿＿hn2 : HANDLE;
＿BEGIN
＿{新しいワークシートを作成します。ｼｰﾄ名 , 座標xy , 行数 , 列数 , 図形モード , ウインドウを開く}
＿＿NewSprdSheet('面積表', 20000, -10000, 20, 9, true, false) ;
＿＿hn2 := LNewObj ;
＿＿IF hn2 <> NIL THEN

この後の BEGIN と END が抜けているようです。

kenさん、役にたって何よりでした。
それほど真剣に読まれると、書くほうも気合が入ります。

複数の選択図形を処理する場合、
他のレイヤが編集できない状態（アクティブレイヤの図形しか選択できない）なら、

h:= FSActLayer;
while h <> NIL do begin
＿実行したい処理;
＿h:= NextSObj(h);
end;

で問題ありません。
ですが、他のレイヤを「表示+スナップ+編集」にしていると、
選択されたのがアクティブレイヤの図形とは限りません。
また、複数の図形を選択すると、それが一つのレイヤにあるとも限りません。
NextSObj() では同じのレイヤ内の図形しか辿れないので、
下のように全てのレイヤを調べる必要があります。

hL:= FLayer; { hL = 最上位のレイヤ }
while hL <> NIL do begin
＿if hL = 編集可能なレイヤ then begin
＿＿h:= FSObjct(hL); { h = レイヤ内の最上位の選択図形 }
＿＿while h <> NIL do begin
＿＿＿実行したい処理;
＿＿＿h:= NextSObj(h);
＿＿end;
＿＿hL:= NextLayer;
＿end;
end;

アクティブレイヤ以外を調べるのは、
1. 他のレイヤを「表示+スナップ+編集」にしていて、
2. アクティブレイヤが２Ｄ表示である
場合です。
そうでない場合はアクティブレイヤ以外は無視できます。

編集可能なレイヤかどうかの判定は、
1. レイヤが「表示」になっていて、
2. レイヤが２Ｄ表示で、
3. レイヤの縮尺がアクティブレイヤと同じ
かどうかで決定します。

前に書いたように、レイヤが２Ｄ表示かどうかを調べる方法がわかりませんので、
３Ｄ表示レイヤの図形は選択できないにもかからわず、
それまでの選択状態が保持されているために、
使用者の意図に反して選択図形と判定してしまう場合もあるかと思います。
そういった意味では、アクティブレイヤだけを対象とするのも正解かもしれません。

FSEditObject---------編集可能な一番上の図形のハンドルを得る
NextSEditObject()----次の編集可能な図形のハンドルを得る

上のような関数があれば、

h:= FSEditObject;
while h <> NIL do begin
＿実行したい処理;
＿h:= NextSEditObject(h);
end;

のように簡単にできるのですが。


ところで、アクティブクラスを変えるのは NameClass(); です。
マニュアルには「直後に作成される図形に、指定した名前のクラスを設定します。」
とありますが、アクティブクラスを設定するという意味です。

すいません、エラー内容を書き忘れました、、、。
以下がvarを付けたときのエラーです。

Line #17: PROCEDURE DrawArea(h:HANDLE; keisuu:Real; rightText, var men:STRING ); { 面積を描きます }

|
{ Error: Identifier not declared. }

|
{ Error: Expected name of a variable type. }

ローカル変数だったんですね。見落しておりました！
ありがとうございます！！

「サブルーチン内で外側の h を変えたいときは、、、」のことですが、
孫ルーチン「DrawArea」で計算した面積（men）を上位ルーチンで再利用
したいのですが、「var」を付けてもエラーが出ます、、、。
使い方が間違っているのでしょうか？


■新たに付け加えた機能
　・図形に連番を打つ。
　・表に出力
　・おうちゃくなツールにしたかったので四角以外もいちおう面積だけは表示する。

■原因不明のバグ
　・上記の孫ルーチンの値を上位ルーチンでうまくつかえない問題
　・ワークシートの選択がなぜか解除できず、ワークシート図形の面積も表示されてしまう問題

■床面積算定スクリプト
PROCEDURE mennseki;
VAR
＿fraction, display : LONGINT;＿format : INTEGER;＿upi: REAL;＿name, squareName : STRING;
＿x, y, cou1, fon, rndm :REAL;
＿h : HANDLE;

{__/__/__/__/__/__/__/__/__/__/サブルーチン__/__/__/__/__/__/__/__/__/__/}
＿PROCEDURE RectToAreaText(h:HANDLE; unitType, leftText:STRING; keta, fraction:LONGINT; fons, cou1s, rndms:REAL);
＿CONST
＿＿RectObj = 3;
＿VAR
＿＿hn1 : HANDLE;
＿＿x1, x2, y1, y2, scl : REAL;
＿＿xd, yd :REAL;{longint;}
＿＿mens : STRING;

＿＿PROCEDURE DrawArea(h:HANDLE; keisuu:Real; rightText, var men:STRING ); { 面積を描きます }
＿＿VAR
＿＿＿xs, ys :REAL;
＿＿BEGIN
＿＿＿HCenter(h, xs, ys);
＿＿＿TextOrigin(xs,ys);
＿＿＿IF (unitType = 'm2+辺長') and (GetType(h) = RectObj) THEN{m2+辺長で図形が四角形か判断します }
＿＿＿＿BEGIN
＿＿＿＿men := Num2Str ( keta, xd*yd / (1000 / fraction ) ^ 2 );
＿＿＿＿BeginText;
＿＿＿＿Concat( leftText, ' ', men, ' ', rightText )
＿＿＿＿EndText;
＿＿＿＿END
＿＿＿ELSE
＿＿＿BEGIN
＿＿＿men := Num2Str ( keta , HArea ( h ) / keisuu /(1000 / fraction ) ^ 2 );
＿＿＿BeginText;
＿＿＿Concat( leftText, ' ', men, ' ', rightText )
＿＿＿EndText;
＿＿＿END;
＿＿＿hn1 := LNewObj;
＿＿＿SetTextVerticalAlign(hn1, 3);
＿＿＿SetTextJust(hn1, 2);
＿＿＿SetDSelect(hn1);
＿＿END; { DrawArea }
＿

＿＿PROCEDURE DrawNo(h:HANDLE); { No.を描きます }
＿＿VAR
＿＿＿xs, ys :REAL;
＿＿BEGIN
＿＿＿HCenter(h, xs, ys);
＿＿＿TextOrigin (xs,ys+fons*0.28346*scl*1.5);
＿＿＿BeginText;
＿＿＿＿Concat (cou1s)
＿＿＿EndText;
＿＿＿hn1 := LNewObj;
＿＿＿SetTextVerticalAlign (hn1,3);
＿＿＿SetTextJust (hn1,2);
＿＿＿SetDSelect(hn1);
＿＿＿Oval(xs-5*scl,ys+fons*0.28346*scl*1.5+3*scl,xs+5*scl,ys+fons*0.28346*scl*1.5-3*scl);
＿＿＿hn1 := LNewObj;
＿＿＿SetDSelect(hn1);
＿＿END; { DrawNo }


＿＿PROCEDURE DrawDim(x1, y1, x2, y2:REAL); { 寸法を描きます }
＿＿BEGIN
＿＿＿MoveTo(x1, y1);
＿＿＿LineTo(x2, y2);
＿＿＿DimText;
＿＿＿SetDSelect(LNewObj);
＿＿END; { DrawDim }


＿＿PROCEDURE sheetins(cou, xdR, ydR:REAL; menSS:STRING); { 表に入力します }
＿＿VAR
＿＿＿couS, couSS, xdS, ydS : STRING;
＿＿BEGIN
＿＿＿TextSize(7);
＿＿＿couS := Num2Str(0,cou);
＿＿＿couSS :=Num2Str(0,cou+1);
＿＿＿xdS := Num2Str(1,xdR);
＿＿＿ydS := Num2Str(1,ydR);
＿＿＿loadcell(cou+1, 2, couS);
＿＿＿loadcell(cou+1, 3, xdS);
＿＿＿loadcell(cou+1, 5, ydS);
＿＿＿loadcell(cou+1, 7, menss);

＿＿END; { sheetins }


＿
＿BEGIN { RectToAreaText }
＿＿setname(h,Concat(rndms,'_',cou1s));
＿＿hn1 := ActLayer;
＿＿scl := GetLScale(hn1);
＿＿DrawNo(h);
＿＿xd := 0; yd :=0;
＿＿IF GetType(h) <> 18 THEN { ワークシート（18）かチェックします }
＿＿BEGIN
＿＿＿IF unitType = 'm2+辺長' THEN
＿＿＿BEGIN
＿＿＿＿IF GetType(h) <> RectObj THEN { 図形が四角形かチェックします }
＿＿＿＿BEGIN
＿＿＿＿＿DrawArea(h, 1, 'm2',mens);
＿＿＿＿END
＿＿＿＿ELSE
＿＿＿＿BEGIN
＿＿＿＿GetBBox (h, x1, y1, x2, y2);
＿＿＿＿{xd := x2-x1 ; yd := y1-y2 ;}
＿＿＿＿DrawDim(x1, y2, x2, y2);
＿＿＿＿xd:=Str2Num(getdimtext(LNewObj));
＿＿＿＿DrawDim(x2, y2, x2, y1);
＿＿＿＿yd:=Str2Num(getdimtext(LNewObj));
＿＿＿＿MoveTo(x2, y1);
＿＿＿＿LineTo(x1, y2);
＿＿＿＿SetLS(LNewObj,-1);
＿＿＿＿SetDSelect(LNewObj);
＿＿＿＿DrawArea(h, 1, 'm2',mens);
＿＿＿＿END
＿＿＿END
＿＿＿ELSE IF unitType = 'm2' THEN
＿＿＿BEGIN
＿＿＿＿DrawArea(h, 1, 'm2',mens);
＿＿＿END
＿＿＿ELSE IF unitType = '坪 /3.3058' THEN
＿＿＿BEGIN
＿＿＿＿DrawArea(h, 3.3058, '坪',mens);
＿＿＿END
＿＿＿ELSE IF unitType = '帖 /1.6529' THEN
＿＿＿BEGIN
＿＿＿＿DrawArea(h, 1.6529, '帖',mens);
＿＿＿END
＿＿＿ELSE
＿＿＿BEGIN
＿＿＿＿{ 処理はありません。 }
＿＿＿END;
＿＿END
＿＿ELSE
＿＿BEGIN
＿＿＿＿{ 処理はありません。 }
＿＿END;
＿＿sheetins(cou1s, xd, yd, mens);
＿＿TextSize(fons);
＿＿ReDrawAll;
＿END; { RectToAreaText }


＿PROCEDURE Drawsheet; { 表を描きます }
＿VAR
＿＿hn2 : HANDLE;
＿BEGIN
＿{新しいワークシートを作成します。ｼｰﾄ名 , 座標xy , 行数 , 列数 , 図形モード , ウインドウを開く}
＿NewSprdSheet('面積表', 20000, -10000, 20, 9, true, false) ;
＿hn2 := LNewObj ;
＿IF hn2 <> NIL THEN
＿SetWSColumnWidth(hn2, 1, 1, 50);
＿SetWSColumnWidth(hn2, 2, 2, 30);
＿SetWSColumnWidth(hn2, 3, 3, 40);
＿SetWSColumnWidth(hn2, 4, 4, 16);
＿SetWSColumnWidth(hn2, 5, 5, 40);
＿SetWSColumnWidth(hn2, 6, 6, 16);
＿SetWSColumnWidth(hn2, 7, 7, 50);
＿SetWSColumnWidth(hn2, 8, 8, 16);
＿SetWSColumnWidth(hn2, 9, 9, 50);
＿{ハンドル、 左上（行、列）、右下（行、列）、入力したい文字}
＿SetWSCellFormula(hn2, 1, 1, 1, 1, '　') ;
＿SetWSCellFormula(hn2, 1, 2, 1, 2, 'No') ;
＿SetWSCellFormula(hn2, 1, 3, 1, 3, '幅') ;
＿SetWSCellFormula(hn2, 1, 4, 1, 4, '×') ;
＿SetWSCellFormula(hn2, 1, 5, 1, 5, '高さ') ;
＿SetWSCellFormula(hn2, 1, 6, 1, 6, '+-') ;
＿SetWSCellFormula(hn2, 1, 7, 1, 7, '面積(m2)') ;
＿SetWSCellFormula(hn2, 1, 8, 1, 8, '　') ;
＿SetWSCellFormula(hn2, 1, 9, 1, 9, '合計(m2)') ;
＿{ハンドルで指定したワークシートの、指定したセルの位置揃えを設定します。}
＿SetWSCellBorder (hn2, 1, 1, 1, 9, true, true, true, true, false);
＿SetWSCellAlignment(hn2, 1, 1, 1, 9, 2);
＿SetDSelect(ActSSheet);
＿end;{ Drawsheet }


{__/__/__/__/__/__/__/__/__/__/__/__/__/__/メインルーチン__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/}
BEGIN { mennseki }
＿PushAttrs;
＿NameClass('面積算定');
＿fon := 14;
＿TextSize(fon);
＿GetUnits ( fraction, display, format, upi, name, squareName );
＿cou1 := 0;
＿rndm := Round (Random*10000);
＿Drawsheet;＿{ サブルーチン　表を描きます }
＿h := FSActLayer;
＿IF h <> NIL THEN
＿BEGIN {__/__/__/__/__/__/__/__/__/__/__/__/図形が選択されている場合__/__/__/__/__/__/__/__/__/__/__/__/}
＿＿WHILE h <> NIL DO
＿＿BEGIN
＿＿＿cou1 := cou1+1;
＿＿＿RectToAreaText(h, PUNITS, PBOFORESYMBOL, PDECIMAL, fraction, fon, cou1, rndm);
＿＿＿h := NextSObj(h);
＿＿END;
＿END
＿ELSE
＿BEGIN {__/__/__/__/__/__/__/__/__/__/__/__/図形が選択されていない場合__/__/__/__/__/__/__/__/__/__/__/__/}
＿＿Message('アクティブレイヤの四角形をクリックしてください。');
＿＿REPEAT { 何もない点をクリックするまで繰り返します。 }
＿＿＿cou1 := cou1+1;
＿＿＿GetPt ( x, y );
＿＿＿h := PickObject ( x, y );
＿＿＿IF h <> NIL THEN
＿＿＿BEGIN
＿＿＿＿RectToAreaText(h, PUNITS, PBOFORESYMBOL, PDECIMAL, fraction, fon, cou1, rndm);
＿＿＿END;
＿＿UNTIL h = NIL;
＿＿ClrMessage;
＿END;
＿DSelectAll;
＿PopAttrs;
END;
Run ( mennseki );

以上、アドバイスお願いします。

unitType は、
PROCEDURE RectToAreaText(h:HANDLE; unitType, leftText:STRING; keta, fraction:LONGINT);
で定義したローカル変数です。勝手に付けた変数名です。

RectToAreaText(h, PUNITS, PBOFORESYMBOL, PDECIMAL, fraction);
でサブルーチンを実行したときに、
h → h
PUNITS → unitType
PBOFORESYMBOL → leftText
PDECIMAL → keta
fraction → fraction
のように RectToAreaText のローカル変数に値が渡されます。

RectToAreaText の中で h, unitType, leftText, keta, fraction の値を変えても、
外側の h, PUNITS, PBOFORESYMBOL, PDECIMAL, fraction は変化しないので、
よけいなバグが減らせます。

h → h のように同じ名前でも別の変数となります。
サブルーチン内で触れるのはサブルーチン内の h で、外側の h は触れません。

サブルーチン内で外側の h を変えたいときは、
PROCEDURE RectToAreaText(var h:HANDLE; unitType, leftText:STRING; keta, fraction:LONGINT);
のように H の前に var を付けます。

与太郎さん、レスありがとうございます。
「MiniCADプログラミング入門」一年ほど前にビックカメラで見かけました！
そのときは立ち読みして、PDFスクリプトマニュアルとほぼ同じ内容だと思い
買わなかった記憶があります。週末にでも早々に買いに行ってみます！

インターネットで調べてみました。結構ありました！
なるほどー、Pascalはサブルーチンが「ミソ」なプログラムなんですね。
BASICとはやはりだいぶちがいますね。(^_^;)

与太郎さんのスクリプトの中で質問です。どうしても謎なので教えてください。
サブルーチンRectToAreaTextの「IF unitType = 'm2+辺長' THEN」の「unitType」とは何者！でしょうか？レファレンスには載ってないファンクションのようですが、、、。

ARcoatingさん、役にたって良かったです。
でもあんまり誉めないでくださいね、木に登っちゃいますから。

参考書ですが、
私がPascalを始めた10年ちょっと前はTurbo Pascalの全盛期でして、
書店で選り取り見取りだったのですが、
最近はさっぱり見かけませんね。Ｃ言語とかVisualBasicの本ばかりです。

「MiniCADプログラミング入門」がベストですが、今もあるかどうか...
特定の処理系（Delphi, TurboPascal等）の本は余り参考にならないと思いますが、
「Pascal入門」のような題名の本なら良いと思います。
それでも、VectorScript は Pascal言語のサブセットなので、
VWにはない機能や異なる箇所があって混乱するかも知れません。

元々Pascalは覚えやすい言語ですが、VectorScriptはさらに覚えることが少ないです。
文法はランゲージガイドで十分だと思います。
苦労するのは膨大な組み込みサブルーチンの使い方です。

書籍ではありませんが、インターネットで探せばPascalの情報はあると思います。
「Pascal 入門」、「VectorScript」などで検索してみてはいかがでしょうか。

VWのファイルをVectorScript形式で取り出したものとか、
includesフォルダの中にある.vssファイルや、
プラグインの中身（見れるのもあります）を見るのも勉強になると思います。

クラスのスクリプト完璧です。
与太郎さんありがとうございます。（感謝です！！）
スクリプトって奥深いですね。
解読するのに、悩んで1ヶ月かかりました。
おかげで、返事が遅くなってしまって申し訳ありません!!
解読できた結果、少々疑問があります。
クラスの取得なのにレイヤを取得するのは何故なのでしょう？？？？
どうしてレイヤを取得するのは必要なものなのでしょうか？
その部分でかなり悩んでいます。
それと、与太郎さんが作ってくれたスクリプトを発展させて
選んだオブジェクトのクラスをアクティブクラスにするというスクリプトを
作ろうと思ったのですが、アクティブクラスにするというscriptがないのでしょうか？
レイヤ−ではlayerがそれにあたると思うのですが、
classではそれと同じようなものはないのでしょうか？
しかし、scriptは頭痛いですね。
さっぱり式の意味がわからなかったので
1から、Pascalを勉強しました。
それでやっとのことで少しは納得できました。

まー！！なんてことでしょう!(^^)!
まるで「ビフォーアフター」を見ているような気分になりました！
よ、与太郎さんは、す、すごい人だ！
一昨日からPDFスクリプトマニュアルのサブルーチンの項を見てこれは使えるなー
とは思っておりましたが、いまいちイメージ出来ずにおりました。
サブルーチンはほんと威力絶大ですね。大変勉強になりました。

一応、私の企み(^^)ではもう少し機能を拡張(表に自動入力等)したいと思っております。
また、イロイロと教えてください！！

PS、ベクタースクリプトを通してプログラムを勉強したいと思っておりますが、PDFスクリプトマニュアルだけでは、肝心のプログラムの初歩を勉強できないような気がします。
みなさん、もしお勧めの本などがありましたら、教えてください。

ARcoatingさん、
気になる点を指摘させてください。

同じ内容が２回以上出てきたり、ひとつの処理が長くなるときは、
サブルーチンにしたほうが後々楽です。（修正等）
そのとき、サブルーチンのパラメータは、グローバル変数にするより引数としたほうが、
サブルーチンを再利用しやすいです。

今回は問題ないですが、たいていはハンドルの種類が適切でないとエラーになります。
常にハンドルの種類を確認するようにしたほうがいいですよ。

以下が修正したスクリプトです。修正や機能追加はこちらのほうが楽だと思います。

■床面積算定スクリプト
PROCEDURE mennseki;
VAR
＿fraction, display : LONGINT;
＿format : INTEGER;
＿upi: REAL;
＿name, squareName : STRING;
＿x, y :REAL;
＿h : HANDLE;

{__/__/__/__/__/__/__/__/__/__/サブルーチン__/__/__/__/__/__/__/__/__/__/}
＿PROCEDURE RectToAreaText(h:HANDLE; unitType, leftText:STRING; keta, fraction:LONGINT);
＿CONST
＿＿RectObj = 3;
＿VAR
＿＿hn1 : HANDLE;
＿＿x1, x2, y1, y2 :REAL;

＿＿PROCEDURE DrawArea(h:HANDLE; rightText:STRING ); { 面積を描きます }
＿＿VAR
＿＿＿xs, ys :REAL;
＿＿BEGIN
＿＿＿HCenter(h, xs, ys);
＿＿＿TextOrigin(xs,ys);
＿＿＿BeginText;
＿＿＿＿Concat( leftText, ' ', Num2Str ( keta, HArea ( h ) / (1000 / fraction ) ^ 2 ), ' ', rightText )
＿＿＿EndText;
＿＿＿hn1 := LNewObj;
＿＿＿SetTextVerticalAlign(hn1, 3);
＿＿＿SetTextJust(hn1, 2);
＿＿＿SetDSelect(hn1);
＿＿END; { DrawArea }
＿
＿＿PROCEDURE DrawDim(x1, y1, x2, y2:REAL); { 寸法を描きます }
＿＿BEGIN
＿＿＿MoveTo(x1, y1);
＿＿＿LineTo(x2, y2);
＿＿＿DimText;
＿＿＿SetDSelect(LNewObj);
＿＿END; { DrawDim }
＿
＿BEGIN { RectToAreaText }
＿＿IF GetType(h) <> RectObj THEN { 図形が四角形か確認します }
＿＿BEGIN
＿＿＿AlrtDialog('四角形を選択してください。');
＿＿END
＿＿ELSE
＿＿BEGIN
＿＿＿IF unitType = 'm2+辺長' THEN
＿＿＿BEGIN
＿＿＿＿DrawArea(h, 'm2');
＿＿＿＿GetBBox (h, x1, y1, x2, y2);
＿＿＿＿DrawDim(x1, y2, x2, y2);
＿＿＿＿DrawDim(x2, y2, x2, y1);
＿＿＿＿MoveTo(x2, y1);
＿＿＿＿LineTo(x1, y2);
＿＿＿＿SetLS(LNewObj,-1);
＿＿＿＿SetDSelect(LNewObj);
＿＿＿END
＿＿＿ELSE IF unitType = '坪 /3.3058' THEN
＿＿＿BEGIN
＿＿＿＿DrawArea(h, '坪');
＿＿＿END
＿＿＿ELSE IF unitType = '帖 /1.6529' THEN
＿＿＿BEGIN
＿＿＿＿DrawArea(h, '帖');
＿＿＿END
＿＿＿ELSE
＿＿＿BEGIN
＿＿＿＿{ 処理はありません。 }
＿＿＿END;
＿＿END;
＿＿ReDrawAll;
＿END; { RectToAreaText }

{__/__/__/__/__/__/__/__/__/__/__/__/__/__/メインルーチン__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/}
BEGIN { mennseki }
＿PushAttrs;
＿TextSize(14);
＿GetUnits ( fraction, display, format, upi, name, squareName );
＿h := FSActLayer;
＿IF h <> NIL THEN
＿BEGIN {__/__/__/__/__/__/__/__/__/__/__/__/図形が選択されている場合__/__/__/__/__/__/__/__/__/__/__/__/}
＿＿WHILE h <> NIL DO
＿＿BEGIN
＿＿＿RectToAreaText(h, PUNITS, PBOFORESYMBOL, PDECIMAL, fraction);
＿＿＿h := NextSObj(h);
＿＿END;
＿END
＿ELSE
＿BEGIN {__/__/__/__/__/__/__/__/__/__/__/__/図形が選択されていない場合__/__/__/__/__/__/__/__/__/__/__/__/}
＿＿Message('アクティブレイヤの四角形をクリックしてください。');
＿＿REPEAT { 何もない点をクリックするまで繰り返します。 }
＿＿＿GetPt ( x, y );
＿＿＿h := PickObject ( x, y );
＿＿＿IF h <> NIL THEN
＿＿＿BEGIN
＿＿＿＿RectToAreaText(h, PUNITS, PBOFORESYMBOL, PDECIMAL, fraction);
＿＿＿END;
＿＿UNTIL h = NIL;
＿＿ClrMessage;
＿END;
＿DSelectAll;
＿PopAttrs;
END;
Run ( mennseki );

与太郎さん、ありがとうございます！！
おかげさまで解決いたしたました！！
初歩的なミスでお恥ずかしい限りです。
このエラーで４時間ぐらい悪戦苦闘していまして、
最後の頼みの綱と思い書き込ませて頂きました。
本当に感謝感激です！。
あと、ほかにもエラー箇所がありましたので訂正した分を
無駄に長いスクリプト(^_^;)ですが、もう一度アップします。
■床面積算定スクリプト
PROCEDURE mennseki;
VAR
＿fraction, display : LONGINT;
＿format : INTEGER;
＿upi: REAL;
＿name, squareName : STRING;
＿x, y, x1, x2, xs, y1, y2, ys :REAL;
＿hn0, hn1, hn2, hn3 : HANDLE;
BEGIN
＿PushAttrs;
＿TextSize(14);
＿GetUnits ( fraction, display, format, upi, name, squareName );
hn0 := FSActLayer;
{__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/図形が選択されている場合__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/}
WHILE hn0 <> NIL DO
BEGIN
＿GetBBox ( hn0, x1, y1, x2, y2 );
＿HCenter ( hn0, xs, ys);

＿＿IF PUNITS = 'm2+辺長' THEN
＿＿BEGIN
＿＿＿TextOrigin (xs,ys);
＿＿＿BeginText;
＿＿＿＿Concat ( PBOFORESYMBOL, ' ', Num2Str ( PDECIMAL, (x2-x1)*(y1-y2) / (1000 / fraction ) ^ 2 ), ' ', 'm2' )
＿＿＿EndText;
＿＿＿hn1 := LNewObj;
＿＿＿SetTextVerticalAlign (hn1,3);
＿＿＿SetTextJust (hn1,2);
＿＿＿SetDSelect(hn1);
＿＿＿MoveTo(x1,y2);
＿＿＿LineTo(x2,y2);
＿＿＿DimText;
＿＿＿hn1 := LNewObj;
＿＿＿SetDSelect(hn1);
＿＿＿MoveTo(x2,y2);
＿＿＿LineTo(x2,y1);
＿＿＿DimText;
＿＿＿hn1 := LNewObj;
＿＿＿SetDSelect(hn1);
＿＿＿MoveTo(x2,y1);
＿＿＿LineTo(x1,y2);
＿＿＿hn1 := LNewObj;
＿＿＿SetLS(hn1,-1);
＿＿＿SetDSelect(hn1);
＿＿END
＿＿ELSE

＿＿IF PUNITS = '坪 /3.3058' THEN
＿＿BEGIN
＿＿＿TextOrigin (xs,ys);
＿＿＿BeginText;
＿＿＿＿Concat ( PBOFORESYMBOL, ' ', Num2Str ( PDECIMAL, HArea ( hn0 ) / 3.3058 / ( 1000 / fraction ) ^ 2 ), ' ', '坪' )
＿＿＿EndText;
＿＿＿hn1 := LNewObj;
＿＿＿SetTextVerticalAlign (hn1,3);
＿＿＿SetTextJust (hn1,2);
＿＿＿SetDSelect(hn1);
＿＿END
＿＿ELSE

＿＿BEGIN
＿＿＿TextOrigin (xs,ys);
＿＿＿BeginText;
＿＿＿＿Concat ( PBOFORESYMBOL, ' ', Num2Str ( PDECIMAL, HArea ( hn0 ) / 1.6529 / ( 1000 / fraction ) ^ 2), ' ', '帖' )
＿＿＿EndText;
＿＿＿hn1 := LNewObj;
＿＿＿SetTextVerticalAlign (hn1,3);
＿＿＿SetTextJust (hn1,2);
＿＿＿SetDSelect(hn1);
＿＿END;

hn0 := NextSObj(hn0);
END;
{__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/図形が選択されていない場合__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/}
＿GetPt ( x, y );
＿hn0 := PickObject ( x, y );
＿GetBBox ( hn0, x1, y1, x2, y2 );
＿HCenter ( hn0, xs, ys);
＿IF hn0 <> NIL THEN
＿BEGIN
＿＿IF PUNITS = 'm2+辺長' THEN
＿＿BEGIN
＿＿＿TextOrigin (xs,ys);
＿＿＿BeginText;
＿＿＿＿Concat ( PBOFORESYMBOL, ' ', Num2Str ( PDECIMAL, (x2-x1)*(y1-y2) / (1000 / fraction ) ^ 2 ), ' ', 'm2' )
＿＿＿EndText;
＿＿＿hn1 := LNewObj;
＿＿＿SetTextVerticalAlign (hn1,3);
＿＿＿SetTextJust (hn1,2);
＿＿＿MoveTo(x1,y2);
＿＿＿LineTo(x2,y2);
＿＿＿DimText;
＿＿＿MoveTo(x2,y2);
＿＿＿LineTo(x2,y1);
＿＿＿DimText;
＿＿＿MoveTo(x2,y1);
＿＿＿LineTo(x1,y2);
＿＿＿hn1 := LNewObj;
＿＿＿SetLS(hn1,-1);＿
＿＿END
＿＿ELSE

＿＿IF PUNITS = '坪 /3.3058' THEN
＿＿BEGIN
＿＿＿TextOrigin (xs,ys);
＿＿＿BeginText;
＿＿＿＿Concat ( PBOFORESYMBOL, ' ', Num2Str ( PDECIMAL, HArea ( hn0 ) / 3.3058 / ( 1000 / fraction ) ^ 2 ), ' ', '坪' )
＿＿＿EndText;
＿＿＿hn1 := LNewObj;
＿＿＿SetTextVerticalAlign (hn1,3);
＿＿＿SetTextJust (hn1,2);
＿＿END
＿＿ELSE

＿＿BEGIN
＿＿＿TextOrigin (xs,ys);
＿＿＿BeginText;
＿＿＿＿Concat ( PBOFORESYMBOL, ' ', Num2Str ( PDECIMAL, HArea ( hn0 ) / 1.6529 / ( 1000 / fraction ) ^ 2), ' ', '帖' )
＿＿＿EndText;
＿＿＿hn1 := LNewObj;
＿＿＿SetTextVerticalAlign (hn1,3);
＿＿＿SetTextJust (hn1,2);
＿＿END;
＿END;
＿DSelectAll;
＿PopAttrs;
END;
Run ( mennseki );

THENやELSEの後のBEGINを忘れるとか、
IF、ELSE、ELSEIFの数が合わなくてエラーが出ることも多いです。
ベテランでも忘れます。

19行目の行末に「;」がありません。
良くあるミスです。

■みなさん、はじめまして。いつも大変参考にさせていただいております。
さっそくですが、教えてください。
建物の床面積や積算の時の面積算定を自動化したいと思い
VwctorScriptと格闘中ですが、どうしても原因不明のエラーがでます。
アドバイスをよろしくお願いします！！
ツールの機能
１、対象は四角形のみ。
２、選択図形の面積とタテヨコ寸法を個々の図形ごとに表記する。
３、選択図形がない場合は図形をクリックして表記していく。
４、単位（ｍ２と坪と畳）と小数点以下の位を選択できる様にする。

スクリプト自体はＡアンドＡさんの「面積スタンプ」を元に作りました。

■エラー内容
Line #20: IF PUNITS = 'm2+辺長' THEN
{ Error: Did not expect this after end of statement - missing ;? }

■フィールドフォーマット内容
UNITS　　（ラジオボタン）メニュー項目→（m2+辺長）（坪 /3.3058）（帖 /1.6529）
PDECIMAL
BOFORESYMBOL

■以下がスクリプトです。

PROCEDURE mennseki;
VAR
＿fraction, display : LONGINT;
＿format : INTEGER;
＿upi: REAL;
＿name, squareName : STRING;
＿x, y, x1, x2, xs, y1, y2, ys :REAL;
＿hn0, hn1, hn2, hn3 : HANDLE;
BEGIN
＿PushAttrs;
＿TextSize(14);
＿GetUnits ( fraction, display, format, upi, name, squareName );
hn0 := FSActLayer;
{__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/図形が選択されている場合__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/}
WHILE hn0 <> NIL DO
BEGIN
＿GetBBox ( hn0, x1, y1, x2, y2 );
＿HCenter ( hn0, xs, ys)

＿＿IF PUNITS = 'm2+辺長' THEN
＿＿BEGIN
＿＿＿TextOrigin (xs,ys);
＿＿＿BeginText;
＿＿＿＿Concat ( PBOFORESYMBOL, ' ', Num2Str ( PDECIMAL, (x2-x1)*(y1-y2) / (1000 / fraction ) ^ 2 ), ' ', 'm2' )
＿＿＿EndText;
＿＿＿hn1 := LNewObj;
＿＿＿SetTextVerticalAlign (hn1,3);
＿＿＿SetTextJust (hn1,2);
＿＿＿MoveTo(x1,y2);
＿＿＿LineTo(x2,y2);
＿＿＿DimText;
＿＿＿MoveTo(x2,y2);
＿＿＿LineTo(x2,y1);
＿＿＿DimText;
＿＿＿MoveTo(x2,y1);
＿＿＿LineTo(x1,y2);
＿＿＿hn1 := LNewObj;
＿＿＿SetLS(hn1,-1);＿
＿＿END
＿＿ELSE

＿＿IF PUNITS = '坪 /3.3058' THEN
＿＿BEGIN
＿＿＿TextOrigin (xs,ys);
＿＿＿BeginText;
{＿＿＿＿Concat ( PBOFORESYMBOL, ' ', Num2StrF ( HArea ( hn0 ) / 3.3058 / 1000000 ), ' ', ' 坪 ' )}
＿＿＿＿Concat ( PBOFORESYMBOL, ' ', Num2Str ( PDECIMAL, HArea ( hn0 ) / 3.3058 / ( 1000 / fraction ) ^ 2 ), ' ', '坪' )
＿＿＿EndText;
＿＿＿hn1 := LNewObj;
＿＿＿SetTextVerticalAlign (hn1,3);
＿＿＿SetTextJust (hn1,2);
＿＿END
＿＿ELSE

＿＿BEGIN
＿＿＿TextOrigin (xs,ys);
＿＿＿BeginText;
{＿＿＿＿Concat ( PBOFORESYMBOL, ' ', Num2StrF ( HArea ( hn0 ) / 1.6529 / 1000000 ), ' ', ' 帖 ' )}
＿＿＿＿Concat ( PBOFORESYMBOL, ' ', Num2Str ( PDECIMAL, HArea ( hn0 ) / 1.6529 / ( 1000 / fraction ) ^ 2), ' ', '帖' )
＿＿＿EndText;
＿＿＿hn1 := LNewObj;
＿＿＿SetTextVerticalAlign (hn1,3);
＿＿＿SetTextJust (hn1,2);
＿＿END;

hn0 := NextSObj(hn0);
END;
{__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/図形が選択されていない場合__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/__/}
＿GetPt ( x, y );
＿hn0 := PickObject ( x, y );
＿GetBBox ( hn0, x1, y1, x2, y2 );
＿HCenter ( hn0, xs, ys)
＿IF hn0 <> NIL THEN
＿BEGIN
＿＿IF PUNITS = 'm2+辺長' THEN
＿＿BEGIN
＿＿＿TextOrigin (xs,ys);
＿＿＿BeginText;
＿＿＿＿Concat ( PBOFORESYMBOL, ' ', Num2Str ( PDECIMAL, (x2-x1)*(y1-y2) / (1000 / fraction ) ^ 2 ), ' ', 'm2' )
＿＿＿EndText;
＿＿＿hn1 := LNewObj;
＿＿＿SetTextVerticalAlign (hn1,3);
＿＿＿SetTextJust (hn1,2);
＿＿＿MoveTo(x1,y2);
＿＿＿LineTo(x2,y2);
＿＿＿DimText;
＿＿＿MoveTo(x2,y2);
＿＿＿LineTo(x2,y1);
＿＿＿DimText;
＿＿＿MoveTo(x2,y1);
＿＿＿LineTo(x1,y2);
＿＿＿hn1 := LNewObj;
＿＿＿SetLS(hn1,-1);＿
＿＿END
＿＿ELSE

＿＿IF PUNITS = '坪 /3.3058' THEN
＿＿BEGIN
＿＿＿TextOrigin (xs,ys);
＿＿＿BeginText;
＿＿＿＿Concat ( PBOFORESYMBOL, ' ', Num2Str ( PDECIMAL, HArea ( hn0 ) / 3.3058 / ( 1000 / fraction ) ^ 2 ), ' ', '坪' )
＿＿＿EndText;
＿＿＿hn1 := LNewObj;
＿＿＿SetTextVerticalAlign (hn1,3);
＿＿＿SetTextJust (hn1,2);
＿＿END
＿＿ELSE

＿＿BEGIN
＿＿＿TextOrigin (xs,ys);
＿＿＿BeginText;
＿＿＿＿Concat ( PBOFORESYMBOL, ' ', Num2Str ( PDECIMAL, HArea ( hn0 ) / 1.6529 / ( 1000 / fraction ) ^ 2), ' ', '帖' )
＿＿＿EndText;
＿＿＿hn1 := LNewObj;
＿＿＿SetTextVerticalAlign (hn1,3);
＿＿＿SetTextJust (hn1,2);
＿＿END;
＿END;
＿DSelectAll;
＿PopAttrs;
END;
END;
Run ( mennseki );

宜しくお願いします。〆

初めましてn.okamotoともうします。
ご存じの方教えて欲しいのですが、VW10.5上でなんらかのコマンドを実行すると
必ず「Error Output」ファイルができ、エラーメッセージとして
「Seconds to Execute: 2.50」等と書かれています。
多分掛かった時間（秒）だと思います。
VW9.5ではそのようなことはありませんでしたが、10.5からの仕様なのでしょうか。
あまり気持ちのよいものではないのでこれを出さない方法などもありましたら
教えてください。

>・選択したオブジェクト以外のクラス（レイヤ）を非表示したい

Re4,Re6のスクリプトを修正して作ります。

選択したオブジェクト以外の「レイヤ」を非表示にする
procedure HideOtherLayerObjs;
const
＿＿MaxNum = 255;
var
＿＿h,
＿＿hL,
＿＿hAL :handle;
＿＿scale :real;
＿＿i :integer;
＿＿s :string;
＿＿hHL :array[1..MaxNum] of handle;
＿＿j, n :integer;
begin
＿＿for j:= 1 to MaxNum do
＿＿＿＿hHL[j]:= Nil;
＿＿n:= 0;
＿＿i:= 0;
＿＿s:= '';
＿＿hAL:= ActLayer;
＿＿scale:= GetLScale(hAL);
＿＿hL:= FLayer;
＿＿while (hL <> Nil) do begin
＿＿＿＿if (hL = hAL) | ((GetLVis(hL) = 0) & (GetLScale(hL) = scale)) then begin
＿＿＿＿＿＿h:= FSObject(hL);
＿＿＿＿＿＿if h <> Nil then begin
＿＿＿＿＿＿＿＿i:= i + 1;
＿＿＿＿＿＿＿＿s:= Concat(s, GetLName(hL), '、');
＿＿＿＿＿＿else {h = Nil} begin
＿＿＿＿＿＿＿＿n:= n + 1;
＿＿＿＿＿＿＿＿hHL[n]:= hL;
＿＿＿＿＿＿end;{if}
＿＿＿＿end;{if}
＿＿＿＿hL:= NextLayer(hL);
＿＿end;{while}
＿＿if i = 0 then
＿＿＿＿AlrtDialog('選択図形がありません！')
＿＿else begin
＿＿＿＿for j:= 1 to n
＿＿＿＿＿＿Layer(GetLName(hHL[j]));
＿＿＿＿＿＿HideLayer;
＿＿＿＿end;{for}
＿＿＿＿Layer(GetLName(hAL));
＿＿＿＿s:= Copy(s, 1, Len(s)-2);
＿＿＿＿AlrtDialog(Concat('「', s, '」レイヤ以外を非表示にしました。'));
＿＿end;{if}
end;
Run(HideOtherLayerObjs);

選択したオブジェクト以外の「クラス」を非表示にする
procedure HideOtherClassObjs;
const
＿＿MaxNum = 255;
var
＿＿h,
＿＿hL,
＿＿hAL :handle;
＿＿scale :real;
＿＿i :integer;
＿＿s :string;
＿＿shwCls :string;
＿＿shwClass :array[1..MaxNum] of string;
＿＿isShow :boolean;
＿＿j, n, nH :integer;
begin
＿＿for j:= 1 to MaxNum do
＿＿＿＿shwClass[j]:= '';
＿＿n:= 0;
＿＿s:= '';
＿＿hAL:= ActLayer;
＿＿scale:= GetLScale(hAL);
＿＿hL:= FLayer;
＿＿while (hL <> Nil) do begin
＿＿＿＿if (hL = hAL) | ((GetLVis(hL) = 0) & (GetLScale(hL) = scale)) then begin
＿＿＿＿＿＿h:= FSObject(hL);
＿＿＿＿＿＿while (h <> Nil) do begin
＿＿＿＿＿＿＿＿n:= n + 1;
＿＿＿＿＿＿＿＿shwCls:= GetClass(h);
＿＿＿＿＿＿＿＿shwClass[n]:= shwCls;
＿＿＿＿＿＿＿＿s:= Concat(s, shwCls, '、');
＿＿＿＿＿＿＿＿DSelectObj(C=shwCls);
＿＿＿＿＿＿＿＿h:= NextSObj(h);
＿＿＿＿＿＿end;{while}
＿＿＿＿end;{if}
＿＿＿＿hL:= NextLayer(hL);
＿＿end;{while}
＿＿if n = 0 then
＿＿＿＿AlrtDialog('選択図形がありません！')
＿＿else begin
＿＿＿＿nH:= 0;
＿＿＿＿for i:= 1 to ClassNum do begin
＿＿＿＿＿＿isShow:= false;
＿＿＿＿＿＿j:= 1;
＿＿＿＿＿＿repeat
＿＿＿＿＿＿＿＿if shwClass[j] = ClassList(i) then
＿＿＿＿＿＿＿＿＿＿isShow:= true;
＿＿＿＿＿＿＿＿j:= j + 1;
＿＿＿＿＿＿until (isShow) | (n < j);
＿＿＿＿＿＿if not isShow then begin
＿＿＿＿＿＿＿＿HideClass(ClassList(i));
＿＿＿＿＿＿＿＿nH:= nH + 1;
＿＿＿＿＿＿end
＿＿＿＿＿＿else if 1 < n then begin
＿＿＿＿＿＿＿＿shwClass[j-1]:= shwClass[n];
＿＿＿＿＿＿＿＿n:= n - 1;
＿＿＿＿＿＿end;{if}
＿＿＿＿end;{for}
＿＿＿＿if 0 = nH then
＿＿＿＿＿＿AlrtDialog('非表示にするクラスはありませんでした。')
＿＿＿＿else begin
＿＿＿＿＿＿s:= Copy(s, 1, Len(s)-2);
＿＿＿＿＿＿AlrtDialog(Concat('「', s, '」クラス以外を非表示にしました。'));
＿＿＿＿end;
＿＿end;{if}
end;
Run(HideOtherClassObjs);

大幅変更（追加）になりました。
前半で選択オブジェクトのあるクラス名を配列に保存しておいて、
後半で全クラスと配列を比較して処理しています。
全クラス名は ClassList(1〜ClassNum) で取りだせます。

とりあえず終わりです。

Re4 のスクリプトでは、各レイヤの選択オブジェクトの内、
一番上のオブジェクトのクラスしか調べていませんでした。
また、複数のレイヤで同じクラスのオブジェクトが選択されていると、
同じクラスに対して何度も HideClass() を実行してしまいます。
それらを修正すると、下のようになります。

選択したオブジェクトの「クラス」を非表示にする（改定版）
procedure HideClassObjs;
var
＿＿h,
＿＿hL,
＿＿hAL :handle;
＿＿scale :real;
＿＿i :integer;
＿＿s :string;
＿＿hdClass :string;
begin
＿＿i:= 0;
＿＿s:= '';
＿＿hAL:= ActLayer;
＿＿scale:= GetLScale(hAL);
＿＿hL:= FLayer;
＿＿while (hL <> Nil) do begin
＿＿＿＿if (hL = hAL) | ((GetLVis(hL) = 0) & (GetLScale(hL) = scale)) then begin
＿＿＿＿＿＿h:= FSObject(hL);
＿＿＿＿＿＿while (h <> Nil) do begin
＿＿＿＿＿＿＿＿i:= i + 1;
＿＿＿＿＿＿＿＿s:= Concat(s, GetClass(h), '、');
＿＿＿＿＿＿＿＿hdClass:= GetClass(h);
＿＿＿＿＿＿＿＿DSelectObj(C=hdClass);
＿＿＿＿＿＿＿＿HideClass(hdClass);
＿＿＿＿＿＿＿＿h:= NextSObj(h);
＿＿＿＿＿＿end;{while}
＿＿＿＿end;{if}
＿＿＿＿hL:= NextLayer(hL);
＿＿end;
＿＿if i = 0 then
＿＿＿＿AlrtDialog('選択図形がありません！')
＿＿else begin
＿＿＿＿s:= Copy(s, 1, Len(s)-2);
＿＿＿＿AlrtDialog(Concat('「', s, '」クラスを非表示にしました。'));
＿＿end;{if}
end;
Run(HideClassObjs);

レイヤ内の複数の選択オブジェクトを調べるため、
if文 を while文 に変えて、h:= NextSObj(h);を最後に追加しています。
同じクラスに何度も HideClass() を実行させないために、
DSelectObj() で非表示にしたクラスを選択解除します。
その際、DSelectObj(C=GetClass(h));ではエラーになるので、クラス名を変数に保存して、
DSelectObj(C=hideClass);としています。

>・選択したオブジェクトを現在のクラス（レイヤ）に移動したい

選択したオブジェクトを現在のレイヤに移動するスクリプトは下のようになります。
DoMenuTextByName('Cut', 0);
DoMenuTextByName('Paste In Place', 0);
AlrtDialog(Concat('選択したオブジェクトを「', GetLName(ActLayer), '」に移動しました。'));

変数、if、while などを使わないので、このように簡単になります。
選択したオブジェクトが無いとエラーが出ますが、無視してかまいません。


選択したオブジェクトのクラスをアクティブクラスに変更するスクリプトは下のようになります。
procedure SetActClassSeldObjs;
var
＿＿h,
＿＿hL,
＿＿hAL :handle;
＿＿scale :real;
＿＿i :integer;
begin
＿＿i:= 0;
＿＿hAL:= ActLayer;
＿＿scale:= GetLScale(hAL);
＿＿hL:= FLayer;
＿＿while hL <> Nil do begin
＿＿＿＿if (hL = hAL) | ((GetLVis(hL) = 0) & (GetLScale(hL) = scale)) then
＿＿＿＿＿＿h:= FSObject(hL);
＿＿＿＿＿＿while h <> Nil do begin
＿＿＿＿＿＿＿＿if h <> Nil then begin
＿＿＿＿＿＿＿＿＿＿SetClass(h, ActiveClass);
＿＿＿＿＿＿＿＿＿＿i:= i + 1;
＿＿＿＿＿＿＿＿end;{if}
＿＿＿＿＿＿＿＿h:= NextSObj(h);
＿＿＿＿＿＿end;{while}
＿＿＿＿hL:= NextLayer(hL);
＿＿end;{while}
＿＿if 0 < i then
＿＿＿＿AlrtDialog(Concat('選択したオブジェクトのクラスを「', ActiveClass, '」に変更しました。'))
＿＿else
＿＿＿＿AlrtDialog('選択図形がありません！');
end;
Run(SetActClassSeldObjs);

>・選択したオブジェクトのクラス（レイヤ）を非表示にしたい

複数の選択オブジェクトに対応したスクリプトは下のようになります。

選択したオブジェクトの「レイヤ」を非表示にする
procedure HideLayerObjs;
var
＿＿h,
＿＿hL,
＿＿hAL :handle;
＿＿scale :real;
＿＿i :integer;
＿＿s :string;
begin
＿＿i:= 0;
＿＿s:= '';
＿＿hAL:= ActLayer;
＿＿scale:= GetLScale(hAL);
＿＿hL:= FLayer;
＿＿while (hL <> Nil) do begin
＿＿＿＿if (hL = hAL) | ((GetLVis(hL) = 0) & (GetLScale(hL) = scale)) then begin
＿＿＿＿＿＿h:= FSObject(hL);
＿＿＿＿＿＿if h <> Nil then begin
＿＿＿＿＿＿＿＿i:= i + 1;
＿＿＿＿＿＿＿＿s:= Concat(s, GetLName(hL), '、');
＿＿＿＿＿＿＿＿Layer(GetLName(hL));
＿＿＿＿＿＿＿＿HideLayer;
＿＿＿＿＿＿end;{if}
＿＿＿＿end;{if}
＿＿＿＿hL:= NextLayer(hL);
＿＿end;
＿＿if i = 0 then
＿＿＿＿AlrtDialog('選択図形がありません！')
＿＿else begin
＿＿＿＿Layer(GetLName(hAL));
＿＿＿＿s:= Copy(s, 1, Len(s)-2);
＿＿＿＿AlrtDialog(Concat('「', s, '」レイヤを非表示にしました。'));
＿＿end;{if}
end;
Run(HideLayerObjs);

選択したオブジェクトの「クラス」を非表示にする
procedure HideClassObjs;
var
＿＿h,
＿＿hL,
＿＿hAL :handle;
＿＿scale :real;
＿＿i :integer;
＿＿s :string;
begin
＿＿i:= 0;
＿＿s:= '';
＿＿hAL:= ActLayer;
＿＿scale:= GetLScale(hAL);
＿＿hL:= FLayer;
＿＿while (hL <> Nil) do begin
＿＿＿＿if (hL = hAL) | ((GetLVis(hL) = 0) & (GetLScale(hL) = scale)) then begin
＿＿＿＿＿＿h:= FSObject(hL);
＿＿＿＿＿＿if h <> Nil then begin
＿＿＿＿＿＿＿＿i:= i + 1;
＿＿＿＿＿＿＿＿s:= Concat(s, GetClass(h), '、');
＿＿＿＿＿＿＿＿HideClass(GetClass(h));
＿＿＿＿＿＿end;{if}
＿＿＿＿end;{if}
＿＿＿＿hL:= NextLayer(hL);
＿＿end;
＿＿if i = 0 then
＿＿＿＿AlrtDialog('選択図形がありません！')
＿＿else begin
＿＿＿＿s:= Copy(s, 1, Len(s)-2);
＿＿＿＿AlrtDialog(Concat('「', s, '」クラスを非表示にしました。'));
＿＿end;{if}
end;
Run(HideClassObjs);

今日はここまで...

>・選択したオブジェクトのクラス（レイヤ）を非表示にしたい

先日のスクリプトには、かなり間違いがありました。

Layer(hL); → Layer(GetLName(hL));
Layer(hLA); → Layer(GetLName(hAL));
Layer() の引数はレイヤのハンドルでなく、レイヤ名でないといけません。また、hLA は hAL のタイプミスです。

AlrtDialog('選択図形がありません！'); の最後の ";" は、あとに else があるので不要です。

hL:= GetLayer(GetLayer); → hL:= GetLayer(h);
コピペのミスです。

下が修正したスクリプトです。AlrtDialog() を追加しています。
先頭の"＿"は消すか、タブに置き換えてください。

選択したオブジェクトの「レイヤ」を非表示にするスクリプトは下のようになります。
複数のオブジェクトが選択されているときは、一番上のオブジェクトが対象になります。
procedure HideLayerObj;
var
＿＿h,
＿＿hL,
＿＿hAL :handle;
＿＿scale :real;
begin
＿＿hAL:= ActLayer;
＿＿scale:= GetLScale(hAL);
＿＿h:= Nil;
＿＿hL:= FLayer;
＿＿while (h = Nil) & (hL <> Nil) do begin
＿＿＿＿if (hL = hAL) | ((GetLVis(hL) = 0) & (GetLScale(hL) = scale)) then
＿＿＿＿＿＿h:= FSObject(hL);
＿＿＿＿hL:= NextLayer(hL);
＿＿end;{while}
＿＿if h = Nil then
＿＿＿＿AlrtDialog('選択図形がありません！')
＿＿else begin
＿＿＿＿hL:= GetLayer(h);
＿＿＿＿Layer(GetLName(hL));
＿＿＿＿HideLayer;
＿＿＿＿Layer(GetLName(hAL));
＿＿＿＿AlrtDialog(Concat('「', GetLName(hL), '」レイヤを非表示にしました。'));
＿＿end;{if}
end;
Run(HideLayerObj);

選択したオブジェクトの「クラス」を非表示にするスクリプトは下のようになります。
複数のオブジェクトが選択されているときは、一番上のオブジェクトが対象になります。
procedure HideClassObj;
var
＿＿h,
＿＿hL,
＿＿hAL :handle;
＿＿scale :real;
begin
＿＿hAL:= ActLayer;
＿＿scale:= GetLScale(hAL);
＿＿h:= Nil;
＿＿hL:= FLayer;
＿＿while (h = Nil) & (hL <> Nil) do begin
＿＿＿＿if (hL = hAL) | ((GetLVis(hL) = 0) & (GetLScale(hL) = scale)) then
＿＿＿＿＿＿h:= FSObject(hL);
＿＿＿＿hL:= NextLayer(hL);
＿＿end;{while}
＿＿if h = Nil then
＿＿＿＿AlrtDialog('選択図形がありません！')
＿＿else begin
＿＿＿＿HideClass(GetClass(h));
＿＿＿＿AlrtDialog(Concat('「', GetClass(h), '」クラスを非表示にしました。'));
＿＿end;{if}
end;
Run(HideClassObj);

字下げされなかったので、とても見難くなってしまいました。
うまいやり方があるのでしょうか？

21:行の先頭に全角スペースが入ってしまったので、
そのままコピペするとエラーになります。

>・選択したオブジェクトのクラス（レイヤ）を非表示にしたい

選択したオブジェクトの「レイヤ」を非表示にするスクリプトは下のようになります。

procedure HideLayerObj;{ :1}
var { 変数定義 :2 }
h, { オブジェクトのハンドル :3}
hL, { レイヤのハンドル :4}
hAL :handle; { アクティブレイヤのハンドル :5}
scale :real; { アクティブレイヤの縮尺 :6}
begin {HideLayerObj開始 :7}
hAL:= ActLayer; { アクティブレイヤのハンドルを得る。 :8}
scale:= GetLScale(hAL); { アクティブレイヤの縮尺を得る。 :9}
h:= Nil; { ハンドルを初期化。 :10}
hL:= FLayer; { 一番上のレイヤのハンドルを得る。 :11}
while (h = Nil) & (hL <> Nil) do begin
{ オブジェクトハンドルを得るか、レイヤがなくなるまで繰り返す :12}
if (hL = hAL) | ((GetLVis(hL) = 0) & (GetLScale(hL) = scale)) then
{ アクティブレイヤか、表示レイヤで同縮尺ならば、 :13}
h:= FSObject(hL); { オブジェクトのハンドルを得る。 :14}
hL:= NextLayer(hL); { 次のレイヤを得る。 :15}
end; { 繰り返しはここまで :16}
if h = Nil then { 選択オブジェクトがないなら、 :17}
AlrtDialog('選択図形がありません！');
{ 警告ダイアログを出す。 :18}
else begin { 選択オブジェクトがあるなら、 :19}
hL:= GetLayer(GetLayer); { レイヤのハンドルを得て、 :20}
　 Layer(hL); { そのレイヤをアクティブにし、 :21}
HideLayer; { 非表示にし、 :22}
Layer(hLA); { アクティブレイヤを元にもどす。 :23}
end; { if文終わり。 :24}
end; {HideLayerObj終わり :25}
Run(HideLayerObj); { :26}

動作確認していませんが、
「表示」でない、または縮尺の違うレイヤの図形は選択できないので、
その処理をすると、このぐらいの長さのスクリプトになります。

３Ｄ表示のレイヤも図形が選択できないので、その処理もする必要がありますが、
面倒なので無視しています。
（２Ｄ表示と「上から」の表示を区別できないので、無理かも知れない。）

SetLVis()というサブルーチンがないので、Layer(hL);　HideLayer; Layer(hLA); としています。

選択したオブジェクトの「クラス」を非表示にするには、
:21〜:23を HideClass(GetClass(h)); に書き換えます。

ここまでで力尽きました。

scriptをはじめたばかりで、かなり頭を悩ませています。
よろしく御願いします。
・選択したオブジェクトのクラス（レイヤ）を非表示にしたい
・選択したオブジェクトを現在のクラス（レイヤ）に移動したい
・選択したオブジェクト以外のクラス（レイヤ）を非表示したい
というscriptなどを作りたいのですが、
選択したオブジェクトのクラスの属性を取得して
hideclassにすれば出きるのかな？とも思うのですが・・・
いかかでしょうか？
それともバ−ジョン10にあるSetParentのようなもの使うのですか？
バ−ジョンは9.0を使っているので、SetParentに変わるなにかありませんかね？
質問ばかりですいませんが、宜しくお願いします。

masafumiさん、ありがとうございました。

Rotate → HRotete に変更で直りました。
また、DelObject, SetSelect, SetDSelect, Locus が不要になり、
スクリプトが少し短くなりました。

masafumiさん、ありがとうございます。
早速試してみます。

こんにちは、与太郎さん。

>Rotate, HMove, DelObject, SetSelect, SetDSelectを使ってるプラグインで、
>症状が出るようです。(文字を水平に描くためにそれらのサブルーチンを使ってます。)

Rotate の代わりに HRotate を使って見てください。
他はそのままでも大丈夫だと思います。

自作プラグインオブジェクト（２点型）のハンドルをドラッグして変形するとき、
ドラッグしてマウスボタンを離しただけでは再描画されず、
ボタンを離した位置からマウスを数ピクセル移動すると再描画されるという症状が出ます。

Rotate, HMove, DelObject, SetSelect, SetDSelectを使ってるプラグインで、
症状が出るようです。(文字を水平に描くためにそれらのサブルーチンを使ってます。)

このままでも使えてるのですが、なんか気持ち悪いです。
どなたか回避方法をご存知ありませんか。

Nurbsを始める前にNurbsをつくる公式を理解する必要が有ると思います。
これはあちこちのサイトで書かれております。かなり、きついです。
それからVWのNurbsの理解も...。
単に3次元の円弧をつくりたいというのであれば、3D多角形で代用された方がよさそうです。角角するのがいやというのであれば仕方がないですが...。

masafumiです。

>高望みなのですが、スクリプトでNurbsを扱えるようになりたいと考えています。

目標が有ることは素晴らしいことだと思います。
継続は力なり、諦めないことが大切だと思っています。

>10.5になっての機能の追加はあったのでしょうか？

VectorScript 10.5 Function Reference の Objects - NURBS を見てみると B-bas さんが
書いている関数の他に下記の関数が有ります。

（関数と日本語訳の部分をReferenceからコピーしました。）
ConvertToNURBS : ハンドルで指定した図形をNURBS図形やNURBS図形のグループに変換します
CreateLoftSurfaces:曲線の交点のグループに補間法を用いることでNURBS曲面を作成します
CreateOffsetNurbsObjectHandle:ハンドルで指定したNURBS図形オフセットしてNURBS図形を
新規に作成し、そのハンドルを返します
CreateSurfacefromCurvesNetwork:選択されている交差した曲線からNURBS曲面を作成します
DrawNurbsObject :NURBS図形を描画します
GetNurbsObjectDistanceFromPoint:NURBS図形と点の間の距離を返します
GetParameterOnNurbsCurve:NURBS曲線のハンドルと点から、点を投影して確定された点のパラ
メータを返します。この関数はまた、点が投影されたNURBS曲線の番号も返します

これらが追加になったものと考えられますね。（Nurbsは使ったことが無いので良く解りません。）

masafumiさん、重ねてありがとうございました。

高望みなのですが、スクリプトでNurbsを扱えるようになりたいと考えています。
9.5ではファンクション･レファレンスに下の16項目があがっていますが、
10.5になっての機能の追加はあったのでしょうか？
ご存知の方お知らせください。

NURBS　Function Reference
ﾊﾊﾊﾊﾊCreateNurbsCurve
ﾊﾊﾊﾊﾊCreateNurbsSurface
ﾊﾊﾊﾊﾊNurbsCurveEvalPt
ﾊﾊﾊﾊﾊNurbsCurveGetNumPieces
ﾊﾊﾊﾊﾊNurbsCurveType
ﾊﾊﾊﾊﾊNurbsDegree
ﾊﾊﾊﾊﾊNurbsDelVertex
ﾊﾊﾊﾊﾊNurbsGetNumPts
ﾊﾊﾊﾊﾊNurbsGetPt3D
ﾊﾊﾊﾊﾊNurbsGetWeight
ﾊﾊﾊﾊﾊNurbsKnot
ﾊﾊﾊﾊﾊNurbsNumKnots
ﾊﾊﾊﾊﾊNurbsSetKnot
ﾊﾊﾊﾊﾊNurbsSetPt3D
ﾊﾊﾊﾊﾊNurbsSetWeight
ﾊﾊﾊﾊﾊNurbsSurfaceEvalPt

こんばんは、masafumi です。

>「Extrude...」となっています(9.5E)。
>この点々は　and Edit を省略したものでしたか・・・

少し違います。補足しますと「Extrude...」と点々のあるメニューはそのメニューを
クリックするとダイアログボックスが表示されると言う意味です。
VW 9.5E でも Appendix.html の Menu Command 欄の「Extrude...」の右側にある Selector 欄
に「Extrude and Edit」と書いていると思います。この Selector 欄が DoMenuTextByName の
最初のパラメータになります。