Script談話室バックナンバー2003-2004

Re5: PIOのパラメータを書き換える   石男
email:  Thu Jul 15 14:28:29 2004

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


Re4: PIOのパラメータを書き換える   与太郎
email:  Thu Jul 15 13:52:19 2004

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

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


Re3: PIOのパラメータを書き換える(赤ペン後)   石男
email:  Thu Jul 15 9:19:19 2004

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

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


業務連絡   管理人
email:
manager@vwch.infonav.net  Wed Jul 14 23:38:12 2004

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


Re2: PIOのパラメータを書き換える(赤ペン後)   与太郎
email:  Wed Jul 14 17:48:59 2004

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

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

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


グループやシンボルの中で選択図形を処理するスクリプト(2)   与太郎
email:  Mon Jul 12 17:46:32 2004

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


グループやシンボルの中で選択図形を処理するスクリプト   与太郎
email:  Sun Jul 11 13:23:29 2004

いままで見て見ぬ振りをしていましたが、
グループやシンボルの中で、選択図形を処理するスクリプトは、組み込みサブ
ルーチンでは作れません。たとえば、
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にすれば、別の処理
をするスクリプトを書くときは、そこだけの変更で済みます。


↓名前を忘れてました。   与太郎
email:  Fri Jul 9 10:48:00 2004

...


Re3:選択図形のフォントを変更するスクリプト  
email:  Fri Jul 9 10:46:02 2004

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

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


Re:ふうりんさんごめんなさい。   ふうりん
email:  Thu Jul 8 23:30:22 2004

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

でも、ダブルクリックでできるので、
とっても便利に使えるスクリプトだと思います!

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


ふうりんさんごめんなさい。   与太郎
email:  Thu Jul 8 20:01:06 2004

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


Re2:選択図形のフォントを変更するスクリプト   与太郎
email:  Thu Jul 8 18:53:42 2004

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

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

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

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

procedure SetFont;
{ アクティブレイヤの選択図形のフォントとサイズを変更する }
{ 選択図形がないときは、デフォルト・フォントとサイズを変更する }
{ VW9以降に対応 }
const
FontName = 'MS P明朝';
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);

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


Re:選択図形のフォントを変更するスクリプト   ふうりん
email:  Thu Jul 8 2:33:35 2004

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

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

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

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


選択図形のフォントを変更するスクリプト   与太郎
email:  Wed Jul 7 21:59:42 2004

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

procedure SetFont;
{ アクティブレイヤの選択図形のフォントを変更する }
{ 選択図形がないときは、デフォルト・フォントを変更する }
const
FontName = 'MS P明朝';
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でフォントを設定できれば簡単だったのですが、どう
やら駄目みたいです。フォントメニューだと文字の一部だけ別のフォント
に変えられますが、スクリプトでは文字の選択部分が判らないので、難し
いです。
一応、これで完成ということにします。


デフォルト・フォントを設定するスクリプト   与太郎
email:  Wed Jul 7 20:01:27 2004

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

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

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('MS Pゴシック'));
とか、
TextFont(GetFontID('MS P明朝'));
のようなスクリプトを、コマンド名をフォント名と同じにして、Vector
Scriptコマンドとして作成します。
コマンドパレットの名前は、「フォント設定」とします。

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


自己レスですが、   与太郎
email:  Tue Jul 6 17:21:13 2004

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


レイヤにデータベースを割り当てる。   与太郎
email:  Sun Jul 4 20:41:33 2004

レイヤにデータベース(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), '」レイヤーのX、Yの倍率 ='), 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);


Re^3:win版カスタムダイアログをEnterキーで終了するには?  vv
email:  Wed Jun 23 11:01:38 2004

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

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


Re2:win版カスタムダイアログをEnterキーで終了するには?   与太郎
email:  Tue Jun 22 18:52:37 2004

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

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

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


Re:win版カスタムダイアログをEnterキーで終了するには?  vv
email:  Tue Jun 22 16:46:47 2004

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

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

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

以下に訂正しました。

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

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

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


win版カスタムダイアログをEnterキーで終了するには?   与太郎
email:  Tue Jun 22 13:00:17 2004

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

問題は、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);


Re.: PIOのパラメータを書き換える   石男
email:  Tue Jun 15 9:32:35 2004

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


PIOのパラメータを書き換える   与太郎
email:  Mon Jun 14 20:24:18 2004

石男さん、
>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の最後のパラメータは怪しい...)


Re^4:DoMenuTextBynameの件(スクリプトで合成コマンドを実行する)  vv
email:  Mon Jun 14 15:29:52 2004

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

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

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

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


Re^3:DoMenuTextBynameの件(スクリプトで合成コマンドを実行する)   与太郎
email:  Mon Jun 14 14:15:20 2004

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


Re^3:DoMenuTextBynameの件   石男
email:  Mon Jun 14 14:00:41 2004

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


Re^2:DoMenuTextBynameの件(スクリプトで合成コマンドを実行する)  vv
email:  Mon Jun 14 13:19:14 2004

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

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

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

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

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


Re:DoMenuTextBynameの件(スクリプトで合成コマンドを実行する)   与太郎
email:  Mon Jun 14 10:54:28 2004

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

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

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


以前書き込まれた   石男
email:  Mon Jun 14 9:38:03 2004

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


Re^2.: DoMenuTextBynameの件  vv
email:  Mon Jun 14 9:12:45 2004

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


Re.: DoMenuTextBynameの件   石男
email:  Mon Jun 14 8:55:00 2004

図形の合成は以下のもので出来ます。ただし、前処理と後処理のことは考慮していません。前処理で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 ) ;


DoMenuTextBynameの件  vv
email:  Sat Jun 12 17:33:16 2004

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

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

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

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


ファイル間でビューをコピーするスクリプト   与太郎
email:  Mon Jun 7 20:51:45 2004

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

実行方法
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);


タブ区切りファイルから文字列データを読み込む(3)   与太郎
email:  Tue Jun 1 11:20:24 2004

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

修正した関数です。
{ 文字列の先頭からタブまでの文字列を返します }
{ 同時に、元の文字列から、その文字列とタブ1個を削除します }
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}


タブ区切りファイルから文字列データを読み込む(2)   与太郎
email:  Mon May 31 19:50:44 2004

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

{ 文字列の先頭からタブまでの文字列を返します }
{ 同時に、元の文字列から、その文字列とタブ1個を削除します }
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で1行全体を変数に読み込んで、
strData:= ReadStrToTab(「変数」);
とすれば、strDataに先頭のデータが入り、「変数」からそのデータと1個のタブが
削除されます。
データが数値なら、
numData:= Str2Num(ReadStrToTab(「変数」));
です。
当然ながら、1行の長さは、タブを含めて255バイト以内です。


タブ区切りファイルから文字列データを読み込む   与太郎
email:  Sun May 30 21:30:16 2004

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


Re^2:3Dのベクトル自作関数   石男
email:  Sat May 29 8:56:55 2004

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


Re:3Dのベクトル自作関数   与太郎
email:  Fri May 28 21:43:38 2004

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

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

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

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

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


3Dのベクトル自作関数   石男
email:  Fri May 28 16:57:40 2004

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

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


Re.^7: 3Dのスクリプトについて質問   与太郎
email:  Thu May 27 19:41:54 2004

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

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

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


Re.^6: 3Dのスクリプトについて質問   石男
email:  Thu May 27 16:12:29 2004

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


Set3DRot と SetRot3D の違い   与太郎
email:  Thu May 27 10:22:04 2004

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

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

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


Re.^5: 3Dのスクリプトについて質問   与太郎
email:  Wed May 26 18:36:37 2004

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

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

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


Re.^4: 3Dのスクリプトについて質問   石男
email:  Wed May 26 13:57:19 2004

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以降のレファレンスではサポートしている図形が違うような感じです。


Re.^3: 3Dのスクリプトについて質問   与太郎
email:  Wed May 26 11:30:38 2004

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

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

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

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


Re.^2: 3Dのスクリプトについて質問   石男
email:  Wed May 26 11:03:56 2004

以下、蛇足です。
>1. 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ぐらいです。この組み合わせでなんとかするぐらいです。


Re.: 3Dのスクリプトについて質問   石男
email:  Wed May 26 9:23:37 2004

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


3Dのスクリプトについて質問   与太郎
email:  Tue May 25 21:23:55 2004

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

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

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


Re:残念ですが   与太郎
email:  Tue May 18 12:45:52 2004

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


残念ですが   辺境地のコンサル
email:
fwhd4139@mb.infoweb.ne.jp  Tue May 18 8:45:01 2004

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


Re.2: 柱状体の断面図形を名前で参照する   与太郎
email:  Tue May 18 8:09:41 2004

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

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


訂正:こんなん出ました(型枠面積)   与太郎
email:  Mon May 17 18:49:22 2004

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


Re.: 柱状体の断面図形を名前で参照する   石男
email:  Mon May 17 16:48:58 2004

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


柱状体の断面図形を名前で参照する   与太郎
email:  Mon May 17 8:45:38 2004

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

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


こんなん出ました(型枠面積)   与太郎
email:  Mon May 17 8:12:34 2004

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

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

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

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


RE9:重複図形を削除するスクリプト(アイデア)  masafumi
email:  Fri May 14 23:47:48 2004

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

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


RE8:重複図形を削除するスクリプト(アイデア)   与太郎
email:  Fri May 14 22:17:39 2004

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

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

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

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


RE7:重複図形を削除するスクリプト(アイデア)   与太郎
email:  Thu May 13 19:48:52 2004


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

が正しいです。


RE6:重複図形を削除するスクリプト(アイデア)   与太郎
email:  Thu May 13 19:41:51 2004

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. それをy座標(下側)でソートした後、x座標(左側)でソートする。
4. y座標を比べて、高さの差がゼロ(または誤差の範囲内)なら2つの線は同一線上にあるので、
5. x座標で線が他の線に含まれるか判断し、
6. 含まれる方の(短い)線を消す。

角度でソート
角度でループ
_座標変換
_y座標でソート
_y座標でループ
__x座標でソート
__x座標でループ
___比較および削除

で可能です(たぶん)。


RE5:重複図形を削除するスクリプト(バグ付き)  masafumi
email:  Wed May 12 22:23:53 2004

こんばんは、masafumiです。

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

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

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

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

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

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

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

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

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

> 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;
>
> {その後で中心座標が同じ直線が複数有る時、角度によるソート}
> {っん、他の図形でも再ソートが必要そう・・・。ソートの条件はどうする?}

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

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

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


RE4:重複図形を削除するスクリプト(バグ付き)   石男
email:  Wed May 12 15:59:20 2004

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


RE3:重複図形を削除するスクリプト(バグ付き)   与太郎
email:  Tue May 11 23:18:01 2004

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

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

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

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

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

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

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


RE2:重複図形を削除するスクリプト(バグ付き)  masafumi
email:  Tue May 11 21:20:40 2004

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

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

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

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

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

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

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

む〜ん、10日程早くUPしてくれていたら、GWはもっとゆったりと休めたのに・・・
中心座標でソートするなんて考えても見ませんでした。ちなみに私の試作品では上の作業
に5時間掛かりました(泣き)。

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


RE:重複図形を削除するスクリプト(バグ付き)  masafumi
email:  Tue May 11 21:20:01 2004

{
アクティブレイヤの選択図形の中から重複図形を削除します。
3D図形、グループ図形は対象外です。
図形属性の比較はしていません。(手抜きです)
配列の制限から、同じタイプの図形は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;

{****************************** XY座標を計算 *****************************}
{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;

{*********************** 2点の角度を取得 ******************************}
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;

{**************************** Y座標ソート ******************************}
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 }

{**************************** X座標ソート ******************************}
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);
_{2つの図形を比較・分岐処理}
_if (tp1 = tp2) & EqualRect(Lx11, Ly11, Lx12, Ly12, Lx21, Ly21, Lx22, Ly22) then
_begin
__case tp1 of
__2: begin{Line}
___{2直線の始点の座標と終点の座標とを比較}
___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,'3D図形、グループ図形は対象外です。');
___ 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}

___{中心座標の同じ直線が3個以上の時、角度を使用して再ソート}
___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);


重複図形を削除するスクリプト(バグ付き)   与太郎
email:  Sat May 8 17:51:44 2004

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

{
アクティブレイヤの重複図形を削除します。
3D図形、グループ図形は対象外です。
図形属性の比較はしていません。(手抜きです)
配列の制限から、同じタイプの図形は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('アクティブレイヤ上の重複図形を削除します。3D図形、グループ図形は対象外です。');
_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);


お久しぶりです。   与太郎
email:  Sat May 8 12:59:37 2004

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

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


「図形情報をワークシートに関連付ける」について  ARcoating
email:  Fri May 7 11:18:32 2004

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


反転文字について   与太郎
email:  Thu May 6 20:42:17 2004

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

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


反転文字に移動するスクリプト(バグ修正)   与太郎
email:  Sat May 1 9:38:39 2004

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

{ 反転文字に移動し、選択状態にします。 }
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);


反転文字に移動するスクリプト   与太郎
email:  Fri Apr 30 22:33:48 2004

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

{ 反転文字に移動し、選択状態にします。 }
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);


Re:反転文字をカウントする。(ForEachObjectInList の使い方)   与太郎
email:  Fri Apr 30 9:46:47 2004

ハンドルに 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);

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


Re.^3:ForEachObjectInList の使い方は?   石男
email:  Thu Apr 29 8:45:07 2004

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


Re.2:ForEachObjectInList の使い方は?   与太郎
email:  Wed Apr 28 18:09:39 2004

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

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

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


Re.:ForEachObjectInList の使い方は?   石男
email:  Wed Apr 28 13:48:46 2004

シンボルの中までは探索していないようですが、参考になるでしょうか?
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 ) ;


反転文字をカウントする。(ForEachObjectInList の使い方は?)   与太郎
email:  Wed Apr 21 20:32:49 2004

最近のVW談話室の質問だったんですが、
環境設定で文字の反転禁止を設定していると、文字を反転しても正常に表示されますが、
他人にデータを渡すときに、相手側が反転禁止になっているとはかぎりません。
文字を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 を修正しました。   与太郎
email:  Tue Apr 13 22:03:05 2004

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


 
email:  Tue Apr 13 22:00:26 2004

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;{ 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);

いつも長レスでスイマセン(与太郎)


Re21:床面積算定スクリプトの件  ARcoating
email:  Sun Apr 11 11:30:06 2004

とりあえず、4月1日時点での面積辺長スタンプをバージョン1としてベクターに
登録させてもらいました。
みなさん、よかったら使ってみてください。
ちなみに、WIN版VW10で作ってますが、MACでも使えると思います。

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


Re:寸法線の寸法をワークシートに関連付ける方法  ARcoating
email:  Sun Apr 11 11:18:45 2004

与太郎さんへ

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

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

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

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


Re:プラグインオブジェクトあれこれ   与太郎
email:  Sat Apr 10 13:05:43 2004

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

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

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


Re:プラグインオブジェクトあれこれ   石男
email:  Sat Apr 10 11:21:55 2004

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


Re:プラグインオブジェクトあれこれ   与太郎
email:  Sat Apr 10 10:08:06 2004

石男さんへ、

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

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


プラグインオブジェクトあれこれ   石男
email:  Sat Apr 10 9:16:38 2004

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

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


Re:中身が濃すぎます。   与太郎
email:  Fri Apr 9 23:44:41 2004

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


半角カタカナはインターネットでは禁止です。   与太郎
email:  Fri Apr 9 23:07:43 2004

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

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


中身が濃すぎます。  A&B
email:  Fri Apr 9 23:02:24 2004

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



Re:寸法線の寸法をワークシートに関連付ける方法   与太郎
email:  Fri Apr 9 22:45:27 2004

ARcoatingさんへ、

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


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

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


>>A列、B列を非表示にして管理情報を書き込んでいます。

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


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

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

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

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

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

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

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

 ↓

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

 ↓

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

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

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

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

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

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


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


Re:寸法線の寸法をワークシートに関連付ける方法  ARcoating
email:  Fri Apr 9 12:11:50 2004

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

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

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

■名前の案

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

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

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


■コマンドの案

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

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

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



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


Re:寸法線の寸法をワークシートに関連付ける方法   与太郎
email:  Thu Apr 8 22:28:19 2004

ARcoatingさんへ、

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

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


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


名前の案(漢字以外は半角文字です)

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

「表1−」 .:表の名前、ワークシート名と同じ必要はない。表面には出ないのでどんな名前でも良い(乱数でも)。
「表1−1」 :対象図形の名前、表の名前+番号。対象図形は四角形、多角形(三角形、台形、斜め四角形など)。
「表1−1A」:面積(文字)
「表1−1W」:幅寸法
「表1−1H」:高さ寸法
「表1−1N」:番号(文字)
「表1−1C」:番号(長円)
「表1−1S」:対角線



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

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


_ ┌───非表示列────┐
┌─┬────┬──────┬───┬─────┬───┬─────┬───┬───┬──────┬──────┐
│_│__A_│___B__│_C_│__D__│_E_│__F__│_G_│_H_│___J__│___K__│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│1│m2__│表1−___│No.│__W__│_x_│__H__│___│_=_│面積(m2)│合計(m2)│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│2│___1│_____2│___│_____│___│_____│___│___│______│______│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│3│ADN_│表1−1__│_1_│_2500│_x_│_2000│___│_=_│__5.00│______│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│4│ADN_│表1−2__│_2_│_3500│_x_│_2000│___│_=_│__7.00│______│
└─┴────┴──────┴───┴─────┴───┴─────┴───┴───┴──────┴──────┘
A1セル:面積の単位。
B1セル:表の名前。
A2セル:番号の初期値。
B2セル:最後に振った番号。
A3〜 :スタンプする項目。A:面積/D:寸法/N:番号
B3〜 :登録図形の名前。
B列の「表1-1」,「表1-2」はC列の「1」,「2」と末尾の数字を対応させますが、(登録時)
その後は番号を付け替えるなどして対応しなくなっても良しとします。


コマンドの案

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


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

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

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

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

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

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

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

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

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


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

図形を4個選択して、メニューコマンド「図形を面積表に登録...」を実行します。
新しい面積表が作られました。
┌─┬────┬──────┬───┬─────┬───┬─────┬───┬───┬──────┬──────┐
│_│__A_│___B__│_C_│__D__│_E_│__F__│_G_│_H_│___J__│___K__│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│1│m2__│表1−___│No.│__W__│_x_│__H__│___│_=_│面積(m2)│合計(m2)│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│2│___1│_____4│___│_____│___│_____│___│___│______│______│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│3│ADN_│表1−1__│_1_│_2500│_x_│_2000│___│_=_│__5.00│______│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│4│ADN_│表1−2__│_2_│_3500│_x_│_2000│___│_=_│__7.00│______│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│5│ADN_│表1−3__│_3_│_6000│_x_│_2500│___│_=_│_15.00│______│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│6│ADN_│表1−4__│_4_│_3000│_x_│_4500│___│_=_│_18.00│______│
└─┴────┴──────┴───┴─────┴───┴─────┴───┴───┴──────┴──────┘
登録直後はB列とC列の数字は一致しています。
登録順序が逆だったので、ワークシートの番号(C列)を変えます。

┌─┬────┬──────┬───┬─────┬───┬─────┬───┬───┬──────┬──────┐
│_│__A_│___B__│_C_│__D__│_E_│__F__│_G_│_H_│___J__│___K__│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│1│m2__│表1−___│No.│__W__│_x_│__H__│___│_=_│面積(m2)│合計(m2)│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│2│___1│_____4│___│_____│___│_____│___│___│______│______│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│3│ADN_│表1−1__│_4_│_2500│_x_│_2000│___│_=_│__5.00│______│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│4│ADN_│表1−2__│_3_│_3500│_x_│_2000│___│_=_│__7.00│______│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│5│ADN_│表1−3__│_2_│_6000│_x_│_2500│___│_=_│_15.00│______│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│6│ADN_│表1−4__│_1_│_3000│_x_│_4500│___│_=_│_18.00│______│
└─┴────┴──────┴───┴─────┴───┴─────┴───┴───┴──────┴──────┘
ワークシートの番号を書き直しました。
メニューコマンド「図形の番号を更新」を実行します。

┌─┬────┬──────┬───┬─────┬───┬─────┬───┬───┬──────┬──────┐
│_│__A_│___B__│_C_│__D__│_E_│__F__│_G_│_H_│___J__│___K__│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│1│m2__│表1−___│No.│__W__│_x_│__H__│___│_=_│面積(m2)│合計(m2)│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│2│___1│_____4│___│_____│___│_____│___│___│______│______│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│3│ADN_│表1−4__│_1_│_3000│_x_│_4500│___│_=_│_18.00│______│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│4│ADN_│表1−3__│_2_│_6000│_x_│_2500│___│_=_│_15.00│______│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│5│ADN_│表1−2__│_3_│_3500│_x_│_2000│___│_=_│__7.00│______│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│6│ADN_│表1−1__│_4_│_2500│_x_│_2000│___│_=_│__5.00│______│
└─┴────┴──────┴───┴─────┴───┴─────┴───┴───┴──────┴──────┘
ワークシートが並べ替えられました。
続いて別の図形を選択して、「図形を面積表に登録...」を実行します。

┌─┬────┬──────┬───┬─────┬───┬─────┬───┬───┬──────┬──────┐
│_│__A_│___B__│_C_│__D__│_E_│__F__│_G_│_H_│___J__│___K__│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│1│m2__│表1−___│No.│__W__│_x_│__H__│___│_=_│面積(m2)│合計(m2)│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│2│___1│_____5│___│_____│___│_____│___│___│______│______│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│3│ADN_│表1−4__│_1_│_3000│_x_│_4500│___│_=_│_18.00│______│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│4│ADN_│表1−3__│_2_│_6000│_x_│_2500│___│_=_│_15.00│______│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│5│ADN_│表1−2__│_3_│_3500│_x_│_2000│___│_=_│__7.00│______│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│6│ADN_│表1−1__│_4_│_2500│_x_│_2000│___│_=_│__5.00│______│
├─┼────┼──────┼───┼─────┼───┼─────┼───┼───┼──────┼──────┤
│7│ADN_│表1−5__│_5_│_2000│_x_│_4500│___│_=_│__9.00│______│
└─┴────┴──────┴───┴─────┴───┴─────┴───┴───┴──────┴──────┘
ワークシートに行が追加されます。


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


寸法線の寸法をワークシートに関連付ける方法  ARcoating
email:  Wed Apr 7 15:14:17 2004

イロイロなアイデアありがとうございます!
>寸法線にも名前を付けているのなら、
>四角形を変形後、寸法線も書き直すとか、
>ワークシートで表示形式を変更して書き直すことも可能です。
最初に四角形と寸法線をグループ化してあると同時に変更できるかなと思いました!
しかし、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_下記4種類をそのままコピペしてください。

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, 'W') ;
_SetWSCellFormula(hn2, 1, 3, 1, 3, 'x') ;
_SetWSCellFormula(hn2, 1, 4, 1, 4, 'H') ;
_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 );


Re:寸法線の寸法をワークシートに関連付ける方法   与太郎
email:  Wed Apr 7 14:06:02 2004

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

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

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

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

あと、

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

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

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

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

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

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


Re:寸法線の寸法をワークシートに関連付ける方法  ARcoating
email:  Wed Apr 7 13:17:48 2004

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


Re:寸法線の寸法をワークシートに関連付ける方法   与太郎
email:  Tue Apr 6 15:36:35 2004

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


Re:寸法線の寸法をワークシートに関連付ける方法  ARcoating
email:  Tue Apr 6 14:17:46 2004

与太郎さん、アドバイスありがとうございます。
「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 }


Re:寸法線の寸法をワークシートに関連付ける方法   与太郎
email:  Tue Apr 6 13:00:00 2004

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

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

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


寸法線の寸法をワークシートに関連付ける方法  ARcoating
email:  Tue Apr 6 10:13:04 2004

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

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


Re6:WS_to_GroupObj(ワークシートをグループ図形にするスクリプト)  ARcoating
email:  Mon Apr 5 3:24:15 2004

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


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


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

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


Re5:WS_to_GroupObj masafumi
email:  Mon Apr 5 0:47:36 2004

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

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

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


Re4:WS_to_GroupObj(ワークシートをグループ図形にするスクリプト)   与太郎
email:  Sun Apr 4 21:27:23 2004

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

プログラムの流れは単純なので、順を追ってゆけば理解できると思います。
苦労したのは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;{ 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 との違い   与太郎
email:  Sun Apr 4 21:08:20 2004

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

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

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

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


SetTextStyleのパラメータ   与太郎
email:  Sun Apr 4 21:04:15 2004

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

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

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

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


Re3:WS_to_GroupObj(ワークシートをグループ図形にするスクリプト)   与太郎
email:  Sun Apr 4 21:00:44 2004

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

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

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

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

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


Re2:WS_to_GroupObj A&B
email:  Sun Apr 4 20:35:26 2004

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



Re1:WS_to_GroupObj ARcoating
email:  Sun Apr 4 17:01:03 2004

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

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

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


今年度の目標は半分終わりました。   与太郎
email:  Sat Apr 3 22:02:10 2004

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

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

図形は「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;{ 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);


今年度の目標   ゲゲゲの与太郎
email:  Fri Apr 2 14:51:43 2004

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

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

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

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

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


与太郎さん、ごめんなさい。  A&B
email:  Thu Apr 1 19:14:37 2004

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

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


Re20:床面積算定スクリプトの件  ARcoating
email:  Thu Apr 1 15:03:56 2004

(ヘ。ヘ)

すいません、ゴンスケさんがコンスケさんになってました、、、。(>_<)


Re:寸法のフォントの大きさを変える方法  ARcoating
email:  Thu Apr 1 14:54:50 2004

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

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

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

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


Re19:床面積算定スクリプトの件   ゴンスケ
email:
gonsuke@spica.freemail.ne.jp  Thu Apr 1 14:17:23 2004

> コンスケさんのカッチョイイ面積表、機会があれば見せてください!ヘ(^o^)/

それがかっちょ悪いので、ARcoatingさんのスクリプトで..、と目論んでいる次第。(^^;)


Re:寸法のフォントの大きさを変える方法   与太郎
email:  Thu Apr 1 13:00:02 2004

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}


Re18:床面積算定スクリプトの件  ARcoating
email:  Wed Mar 31 16:00:03 2004

ゴンスケさん、どういたしまして!
コンスケさんのカッチョイイ面積表、機会があれば見せてください!ヘ(^o^)/
私のはどうも事務的な面積表になってしまってますんで、
できれば参考にさせて頂きたいです!


Re:寸法のフォントの大きさを変える方法  ARcoating
email:  Wed Mar 31 15:08:13 2004

早々の回答ありがとうございます!
すみません!!ちょっと説明不足でした、、。
フォント_サイズ規定値と同じ機能で私的にお気に入りの7pointと11pointを
作りたいと思い試行錯誤しておりました。AandAさんのOTでフォントサイズ
変更ツールがありましたが、寸法サイズが変更できませんでした、、。
ということで、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);


Re17:床面積算定スクリプトの件   ゴンスケ
email:
gonsuke@spica.freemail.ne.jp  Wed Mar 31 11:34:26 2004

ARcoatingさん、スクリプト公開ありがとうございました。
与太郎さんのアシストにも感謝。
これまでデータベースで面積算定していましたが、プレゼン用に使うには
オシャレじゃないので、とても役立ちます。
面積を拾う図形に名称をつけているので、このスクリプトを参考にさせていただいて、
図形の名称が書き込まれるスクリプトを書いてみたいものです。
もう10年以上プログラム書いてないし、Pascalもソースは読みやすいけれど、
書くのは嫌いだったし.....でも、やりたいことをやるためには、やっぱり
プログラミングは必要ですね。与太郎さんのおかげで活発化したこの談話室を見て
つくづく思います。


Re:ハッチングを生成するスクリプト   与太郎
email:  Wed Mar 31 8:23:42 2004

飯田さんへ

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

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





Re:ハッチングを生成するスクリプト  A&B
email:  Wed Mar 31 7:14:51 2004

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


Re:ハッチングを生成するスクリプト   飯田
email:  Tue Mar 30 20:11:05 2004

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

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

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



Re:寸法のフォントの大きさを変える方法   与太郎
email:  Tue Mar 30 19:51:55 2004

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


ハッチングを生成するスクリプト   与太郎
email:  Tue Mar 30 19:25:38 2004

飯田さん、
下のスクリプトをテキストファイルとして保存して、
「ファイル」-「取り込む」-「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 第1基準点 X:9.3 Y:5 第2基準点 Δ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);


寸法のフォントの大きさを変える方法   ARcoating(スクリプト初心者)
email:  Tue Mar 30 15:58:28 2004

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

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


Re:色とレイヤの自動変更  ARcoating
email:  Tue Mar 30 15:50:01 2004

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


Re:色とレイヤの自動変更   与太郎
email:  Tue Mar 30 15:08:26 2004

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

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


 
email:  Tue Mar 30 15:01:01 2004

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

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

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

{ サブルーチン --- 線色を変更します。(シンボル内は対象外です) }
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);

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


色とレイヤの自動変更     コニーネ
email:  Tue Mar 30 13:17:11 2004

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

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



AutoCAD-DWG 自動読込み   初心者です
email:  Tue Mar 30 12:16:52 2004

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


色とレイヤの自動変更  ARcoating
email:  Tue Mar 30 11:01:47 2004

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

■特定面地色の面地色を変換(赤色→黄色)

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 );


AutoCAD-DWG 自動読込み   与太郎
email:  Mon Mar 29 19:32:29 2004

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


色とレイヤの自動変更   コニーネ
email:  Mon Mar 29 18:43:48 2004

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


AutoCAD-DWG 自動読込み   初心者です
email:  Mon Mar 29 17:54:22 2004

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


Re16:床面積算定スクリプトの件  ARcoating
email:  Mon Mar 29 14:46:20 2004

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

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

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

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

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


Re15:床面積算定スクリプトの件  ARcoating
email:  Mon Mar 29 14:41:30 2004

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


Re14:床面積算定スクリプトの件   与太郎
email:  Mon Mar 29 12:47:14 2004

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

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

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


Re13:床面積算定スクリプトの件  ARcoating
email:  Sun Mar 28 2:16:26 2004

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


Re11:床面積算定スクリプトの件  ARcoating
email:  Thu Mar 25 15:35:58 2004

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

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

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


Re11:床面積算定スクリプトの件   与太郎
email:  Thu Mar 25 12:58:25 2004

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 が抜けているようです。


選択図形のクラスを取得するのにレイヤを検索した理由は   与太郎
email:  Thu Mar 25 12:40:01 2004

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. アクティブレイヤが2D表示である
場合です。
そうでない場合はアクティブレイヤ以外は無視できます。

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

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

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

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

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

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


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


Re10:床面積算定スクリプトの件  ARcoating
email:  Thu Mar 25 10:36:13 2004

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

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

|
{ Error: Identifier not declared. }

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


Re9:床面積算定スクリプトの件  ARcoating
email:  Thu Mar 25 10:28:10 2004

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

「サブルーチン内で外側の 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 );

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


Re8:床面積算定スクリプトの件   与太郎
email:  Thu Mar 25 9:47:28 2004

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 を付けます。


Re7:床面積算定スクリプトの件  ARcoating
email:  Thu Mar 25 1:16:47 2004

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

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

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


Re6:床面積算定スクリプトの件   与太郎
email:  Wed Mar 24 23:01:25 2004

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

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

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

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

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

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


 ken
email:  Wed Mar 24 18:07:31 2004

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


Re5:床面積算定スクリプトの件  ARcoating
email:  Wed Mar 24 1:01:02 2004

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

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

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


Re4:床面積算定スクリプトの件   与太郎
email:  Tue Mar 23 20:30:44 2004

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

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

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

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

■床面積算定スクリプト
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 );


Re3:床面積算定スクリプトの件  ARcoating
email:  Sun Mar 21 2:02:10 2004

与太郎さん、ありがとうございます!!
おかげさまで解決いたしたました!!
初歩的なミスでお恥ずかしい限りです。
このエラーで4時間ぐらい悪戦苦闘していまして、
最後の頼みの綱と思い書き込ませて頂きました。
本当に感謝感激です!。
あと、ほかにもエラー箇所がありましたので訂正した分を
無駄に長いスクリプト(^_^;)ですが、もう一度アップします。
■床面積算定スクリプト
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 );


Re2:床面積算定スクリプトの作り方教えてください。   与太郎
email:  Sat Mar 20 19:16:32 2004

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


Re:床面積算定スクリプトの作り方教えてください。   与太郎
email:  Sat Mar 20 19:01:02 2004

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


床面積算定スクリプトの作り方教えてください。   ARcoating(スクリプト初心者)
email:
ys337@yahoo.co.jp  Sat Mar 20 18:20:12 2004

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

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

■エラー内容
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 );

宜しくお願いします。〆


Error Outputファイル  n.okamoto
email:
nozomu@sky.zero.ad.jp  Thu Mar 18 18:51:02 2004

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


Re7:選択しているクラスを非表示に・・・   与太郎
email:  Mon Feb 23 12:55:52 2004

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

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) で取りだせます。

とりあえず終わりです。


Re6:選択しているクラスを非表示に・・・   与太郎
email:  Sun Feb 22 17:53:41 2004

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);としています。


Re5:選択しているクラスを非表示に・・・   与太郎
email:  Sat Feb 21 20:31:04 2004

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

選択したオブジェクトを現在のレイヤに移動するスクリプトは下のようになります。
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);



Re4:選択しているクラスを非表示に・・・   与太郎
email:  Fri Feb 20 21:11:19 2004

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

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

選択したオブジェクトの「レイヤ」を非表示にする
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);

今日はここまで...


Re3:選択しているクラスを非表示に・・・   与太郎
email:  Fri Feb 20 20:29:57 2004

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

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

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);


Re2:選択しているクラスを非表示に・・・   与太郎
email:  Wed Feb 18 22:25:39 2004

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

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


Re:選択しているクラスを非表示に・・・   与太郎
email:  Wed Feb 18 22:12:38 2004

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

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

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}

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

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

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

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

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



選択しているクラスを非表示に・・・  ken
email:
knk_net.hotmail.com  Wed Feb 18 15:52:05 2004

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


Re3:プラグインオブジェクトの再描画   与太郎
email:  Wed Jan 7 19:57:00 2004

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

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


Re2:プラグインオブジェクトの再描画   与太郎
email:  Wed Jan 7 12:54:00 2004

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


RE:プラグインオブジェクトの再描画  masafumi
email:  Wed Jan 7 9:06:54 2004

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

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

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


プラグインオブジェクトの再描画   与太郎
email:  Mon Jan 5 15:14:00 2004

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

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

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


Re.:Nurbs機能   石男
email:  Tue Dec 23 8:16:08 2003

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


RE:10.5のNurbs機能  masafumi
email:  Tue Dec 23 2:01:48 2003

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は使ったことが無いので良く解りません。)


10.5のNurbs機能  B-bas
email:  Mon Dec 22 18:49:37 2003

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


RE^2:矩形に穴を空けてから掃引  masafumi
email:  Mon Dec 22 0:43:57 2003

こんばんは、masafumi です。

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

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


RE:矩形に穴を空けてから掃引  B-bas
email:  Sun Dec 21 19:58:37 2003

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

疑問氷解しました。BeginXtrd〜EndXtrdの中で抜き型加工をして、
不要なパーツは消去しておけばいいと。
EndXtrdでくくるまで掃引は発生しないということでしたか、
BeginXtrdで始まると勘違いしました。

>「柱状体」というコマンドが有るのだろうか?
「Extrude...」となっています(9.5E)。
この点々は and Edit を省略したものでしたか・・・

DoMenuTextByName('Extrude and Edit',0);
は使えました。


RE:矩形に穴を空けてから掃引  masafumi
email:  Sun Dec 21 14:09:25 2003

こんにちは、B-basさん。
こんな感じではないでしょうか。

{**************** ここから **********************}
procedure test;
var
h:handle;
begin
BeginXtrd(0,100);
Rect(-200,200,200,-200);{平板}
Oval(-50,50,50,-50);{抜き型}
h:=LNewObj;{抜き型のハンドル}
DoMenuTextByName('Clip Surface',0);
DelObject(h);{抜き型に使用した円を削除}
EndXtrd;
end;
run(test);
{*************** ここまで ***********************}

>(DoMenuTextByName('Extrude',0);ではMenu cannot be foundとなります)

メニューに無い項目を参照しているって意味なのかな?

DoMenuTextByName('Extrude and Edit',0);
を使ってダイアログボックスを表示して奥行きを入力する方法は使えますね。

メニューも「モデル」→「柱状体」ではなく「モデル」→「柱状体...」となっています。
これは Windows 版だけなのかな?。それとも日本語版がそうなのか?。オリジナル版に
は「柱状体」というコマンドが有るのだろうか?・・・この辺のことは良く解りません。(^_^;
どなたかフォローお願いします。


矩形に穴を空けてから掃引  B-bas
email:  Sat Dec 20 21:27:23 2003

VSの独習を始めた新参ものです。よろしくねがいます。
以下のように掃引を試みましたがうまく行きません。
一体このような掃引は可能でしょうか?
(DoMenuTextByName('Extrude',0);ではMenu cannot be foundとなります)

procedure test;
var
h:handle;
begin
Rect(-200,200,200,-200);{平板}
Oval(-50,50,50,-50);{抜き型}
DoMenuTextByName('Clip Surface',0);{9.5E使用}
h:=LNewObj;{抜き型or抜かれた穴}
h:=PrevObj(h);{穴明き平板}

BeginXtrd(0,100);
SetSelect(h);{これでは掃引されない}
EndXtrd;
end;
run(test);


オフセット・ツールについて(下のレスです)   与太郎
email:  Tue Dec 16 18:06:27 2003

>オフセットは使っているのですが、一回一回数値を打ち込まないと行けないですよね。
毎回違う距離をオフセットしない限り、そんなことはないと思うのですが?


ありがとうございます。   ○
email:  Tue Dec 16 16:24:07 2003

オフセットは使っているのですが、一回一回数値を打ち込まないと行けないですよね。
jw_winはマウス操作を基本としているのですが、よく出来ていると思います。
図面を書くだけなら、抜群ですね。

三角定規のようなソフトです。


Re: 初心者ですいません。(『複線』について)   与太郎
email:  Tue Dec 16 12:29:55 2003

jw_winはよく知らないのですが、
オフセット・ツールで出来ると思います。
数値で指定するのと、マウスでクリックした位置に複製するのと、二通りの使い方ができます。
Scriptでオフセット・ツール以上のものを書くのは、簡単ではありません。
直線に限定したものなら、比較的簡単かも。


初心者ですいません。   ○
email:  Tue Dec 16 10:02:24 2003

vectorworksは平行線を引くのが、かなり面倒ですよね?
特に斜めの線に対しての平行線。

jw_winの『複線』ができるようなScriptって簡単に作れるんですか?

もしかして、フリーソフトとして、あったりします?
もしあるようなら、HPアドレスとか教えてください。

突然すいませんでした。


Re:教えてケロ -使用制限のロジック(期間限定)-   与太郎
email:  Fri Nov 7 21:05:58 2003

使用期限を切る方法は、簡単に書けます。

PROCEDURE サブルーチン;
CONST
DeadLine = 031107;{03/11/07}

VAR

function GetDate:longint;
{ 日付を6桁の数字で返します。2100年問題には対応しません。}
var
year,month,day:integer;
i, j, k:integer;
dateStr:string;
begin{GetDate}
dateStr:= Date(2, 0);
i:= 0; j:= 0; k:= 0;
for i:= 1 to Len(dateStr) do begin
if Copy(dateStr, i, 1) = '/' then begin
if j = 0 then j:= i
else if k = 0 then k:= i;
end;{if}
end;{for}
year:= Str2Num(Copy(dateStr, 1, j-1));
month:= Str2Num(Copy(dateStr, j+1, k-j-1));
day:= Str2Num(Copy(dateStr, k+1, Len(dateStr)-k));
GetDate:= 10000*year + 100*month + day;
end;{GetDate}

BEGIN{サブルーチン}
IF GetDate <= DeadLine THEN BEGIN

スクリプトの実行

END
ELSE BEGIN
AlrtDialog(Concat('使用期限が切れました云々'));
END;
END;{サブルーチン}
RUN(サブルーチン);


Re:教えてケロ -使用制限のロジック(回数制限)-   与太郎
email:  Fri Nov 7 19:53:35 2003

もっぱら個人で使うScriptしか作らないので、よくわかりませんが、
回数制限だと使用回数をどこかに保存する必要がありますね。
例ではワークシートに使用回数を書かれていますが、

CONST
MaxRunNum = 1000;


count:= GetCellNum(h,2,4);
LoadCell(2,4,Num2Str(0, count+1));
IF count <= MaxRunNum THEN BEGIN

スクリプトの実行

END
ELSE BEGIN
AlrtDialog(Concat('実行回数が', Num2Str(0, MaxRunNum), 'を越えました云々'));
END;

としたほうが良いでしょう。
しかし、保存場所がファイルにしろワークシートにしろ、消されたり修正されればそれまでなので、VectorScriptで回数制限を付けるのは難しいと思います。


Re:32,000文字の壁   与太郎
email:  Fri Nov 7 18:35:46 2003

SGさん、
32Kを超えるScriptとは、大作ですね!

VW8以降では、VectorScriptから他のテキストファイルを読み込めます。
{$INCLUDE ファイル名}を書いた位置に、その内容が挿入されるイメージです。
よく使うサブルーチンや定数定義を別ファイルにすれば、
他のScriptからコピー&ペーストせずに済むし、32Kの壁も問題なしです。
VectorScriptがVectorWorksを機能拡張するように、
自作サブルーチンの別ファイル化で、VectorScriptを機能拡張できます。

と他人に薦めながら、自分では出来てなかったりしますが。


Re:32,000文字の壁  SG
email:  Wed Nov 5 8:28:01 2003

やっぱりありました、TXTを流し込んだら、
後ろのほうが、切れてました。
与太郎さんの回避方法にしたいと思います。
ありがとうございました。


Re:32,000文字の壁   与太郎
email:  Tue Nov 4 18:21:44 2003

VSエディタの文字数制限のことですよね?
マニュアルで確認できませんでしたが、もしダメでも、
MC7以前なら外部コマンドにする、
VW8以降ならスクリプトを分割して {$INCLUDE} で読み込む、
で回避できます。


RE:GetEditRealの使用法     石井
email:  Tue Nov 4 15:32:26 2003

masafumiさん
どうもありがとうです
参考にさせていただきます


Pantherの「プレビュー」の検索は、   与太郎
email:  Tue Nov 4 15:20:00 2003

Appleの触れ込みどうり、早いですよ。
VectorScriptリファレンスでサブルーチンを探すのが楽になりました。
というか、今まで見逃していたサブルーチンがゴロゴロと...


32,000文字の壁   SG
email:  Tue Nov 4 12:26:44 2003

ベクターXになって、パスカルの
32,000文字の壁はなくなりましたか?


RE:GetEditRealの使用法  masafumi
email:  Tue Nov 4 12:17:04 2003

こんな感じですかねぇ。

{********************* ここから *******************************************}
PROCEDURE GetEditRealTest;
CONST {ダイアログ上の各アイテムIDを定数として定義}
kRealEditFieldID = 3;
VAR
ret:Boolean;
value:Real;
str:String;
aVerify:BOOLEAN;
aDialogID,aResult:LONGINT;

{ダイアログのコールバックルーチン}
{ダイアログのイベントは全てこの関数で一括して処理する}
PROCEDURE doDialogCallBack(VAR ioHitItem:LONGINT;inValue:LONGINT);
BEGIN
{ここに処理したい内容を書く}
{パラメータ 'Value' が取得したい値です。}
ret:=GetEditReal(aDialogID,kRealEditFieldID,1,value);
END;


BEGIN
{ダイアログのレイアウト作成}
aDialogID:=CreateLayout('ダイアログ',False,'OK','キャンセル');

{REAL 型編集フィールド作成}
CreateEditReal(aDialogID,kRealEditFieldID,1,3.1415,10);
SetFirstLayoutItem(aDialogID,kRealEditFieldID);

{ダイアログの整合性をチェック}
aVerify:=VerifyLayout(aDialogID);

{もしレイアウトに問題がなければ}
IF aVerify THEN
BEGIN {↓ダイアログイベントループ実行(OK 又はキャンセルが押されるまで)}

aResult:=RunLayoutDialog(aDialogID,doDialogCallBack);

IF aResult=1 THEN
begin

AlrtDialog('OKボタンが押されました。');

{ここで 'value' の値をチェックしています。}
if (ret=True) then
begin
str:=Concat('value = ',Num2Str(4,value));
AlrtDialog(str);
end;

end else IF aResult=2 THEN AlrtDialog('キャンセルボタンが押されました');

END;
END;
Run(GetEditRealTest);
{*********************** ここまで *****************************************}


GetEditRealの使用法   石井
email:  Tue Nov 4 9:55:00 2003

GetEditRealの使用法教えてください

GetEditRealを使ったサンプルあればお願いします。


教えてケロ   松原
email:  Fri Oct 31 20:03:24 2003


使用制限をつけるにはどうしますか?
ロジックを教えてください。

例1)

wide:=GetCellNum(h,2,4);

{** 回数制限プロテクト*****************************************}
IF wide = 0 then LoadCell(2,4,'1');
IF wide = 1 then LoadCell(2,4,'2');
IF wide = 2 then LoadCell(2,4,'3');
IF (wide = 0)or(wide=1)or(wide=2) then goto 1;
{** 回数制限プロテクト*****************************************}
{ここに使用回数を過ぎました処理。}

1:

例2)
{** 時限爆弾プロテクト*****************************************}
IF Copy(Date(2,0),1,7) = '2003/11' then goto 2;
IF Copy(Date(2,0),1,7) = '2003/12' then goto 2;
IF Copy(Date(2,0),1,5) = '03/11' then goto 2;
IF Copy(Date(2,0),1,5) = '03/12' then goto 2;
{** 時限爆弾プロテクト*****************************************}
{ここに使用期間を過ぎました処理。}

2:

この例だと、いんちきされると無限に使用されてしまいます。


下の書き込みは...   与太郎
email:  Fri Oct 31 17:48:50 2003

与太郎でした。失礼しました。


Re:線属性を教えてください   たけ
email:  Fri Oct 31 17:46:30 2003

たけさん、
今、マニュアルが手元にないので確かなことは言えませんが、
VectorScriptリファレンス(VWフォルダの中にあります)を開いて、
「Marker」で検索してみてください。


線属性を教えてください   たけ
email:  Fri Oct 31 17:23:53 2003

ArrowSize(2); {矢印の大きさ}
ArrowHead(15); {矢印の種類}
Mini CAD 7ではこれでしたが、

VECTOR WORKS10では
これに相当する命令はなんですか?


Re^4:面の色表示について   のり
email:  Wed Oct 29 11:11:29 2003

与太郎さん
面の地色で色表示すればよかったのですね。
白黒表示の時、白で表示することができました。
ありがとうございました。


Re^3:面の色表示について   与太郎
email:  Tue Oct 28 20:22:43 2003

のりさん、
確かに Script で作成すると白黒表示で黒い面になりますね。
手で描いて、VectorScript形式で書き出したのを見ると、

FillPat(1);
FillFore(7);
FillBack(7);
Rect(0.00,15.00,10.00,0.00);

とすれば良いようです。



Re:曲線の長さの取得方法を教えて下さい   石神
email:  Tue Oct 28 19:58:55 2003

与太郎さん
私のまちがいでした
Poly(0,0,200,40,100,-90);のところを
Poly(200,40,100,-90);にしたらうまくいきました
どうもありがとうでした



Re:曲線の長さの取得方法を教えて下さい   石神
email:  Tue Oct 28 18:38:14 2003

相対座標指定しなければならないので
'Smooth(2);'を使って長さを求めようかなぁー

ありがとうございます


Re^3:曲線の長さの取得方法を教えて下さい   与太郎
email:  Tue Oct 28 18:20:58 2003


石神さん、
相対座標指定はできませんが、サンプルを...

procedure test;
begin
BeginPoly;
MoveTo(0, 0);
ArcTo(200, 40, 0);{0 = 半径}
LineTo(300, -50);
EndPoly;
Message(HPerim(LNewObj));
end;
Run(test);


Re:面の色表示について     のり
email:  Tue Oct 28 0:46:26 2003

FillPatは2番の塗りつぶしにしています。
画面上ではカラーで表示し、打出しの時に白黒表示を使いたく思っています。
よろしくお願いします。


Re:曲線の長さの取得方法を教えて下さい   石神
email:  Tue Oct 28 0:11:54 2003

与太郎さん お世話になります
Scriptwで'HPerim()'を使い周長を取得し'Message()'で表示させました
表示させた値とマウスで図形を選択しプロパティにて周長を見ると値が違います。
その際 図形の曲線が変わります。
'hPerim()'の取得値は、曲線が変化する前の値だと思いますが????
VW Ver 9.0.1です
具体的には
BEGIN
Relative;
MoveTo(0,0);
Smooth(3);
Poly(0,0,200,40,100,-90);
h:=LNewObj;
x:=HPerim(h);
Message(x);
END;

よろしくお願いします



Re:面の色表示について   与太郎
email:  Mon Oct 27 21:58:37 2003

のりさん、
面の模様の設定 (FillPat) はどのようになってますか。


Re:曲線の長さの取得方法を教えて下さい   与太郎
email:  Mon Oct 27 21:45:10 2003

石神さん、
周長の取得方法は何ですか?
HPerim( ) ではダメでしょうか。

>また 画面にてマウスを図形に近づけると曲線が変わります。これってバグ?
>どうすればいいでしょか。助けて
図形はScriptで作成したものでしょうか?
VWのバージョンや作成方法がわからないと、なんとも答えようがありませんデス。



面の色表示について   のり
email:  Mon Oct 27 18:46:23 2003

はじめまして。Script初心者です。
初歩の質問で申し訳ないのですが、Scriptで四角形を作った時、面も色を色番号0番以外の
番号だと、環境設定-画面-白黒表示 にした時、面の色が「黒」になってしまいます。
普通に四角ツールを使って四角形を描き、面の色を黒(255番)以外にすれば 白黒表示
にした時、面の色は「白」で表示されます。Scriptで作った四角の面も「白」で表示
するためにはどうすればいいか分からず困っています。
どなたかお教えください。宜しくお願いします。
VW9.5を使っています。


曲線の長さの取得方法を教えて下さい   石神
email:  Mon Oct 27 18:29:07 2003

Script初心者です
多角形にスムージング "Smooth(3)"を適用して円弧ラインの周長を取得したところ
プロパティで見る周長とちがいます
また 画面にてマウスを図形に近づけると曲線が変わります。これってバグ?
どうすればいいでしょか。助けて




Re^2:直線作図の方法教えてください。   与太郎
email:  Fri Oct 24 17:59:14 2003

字下げをすると、こんな感じです。
タブの代りに_(アンダーバー)を使ってます。

Procedure test;
const
_AAA = 'AAA';
_BBB = 'BBB';
_A = 1;
_B = 2;
_C = 3;
_D = 4;
_E = 5;
_F = 6;
_G = 7;
_MaxNum = 7;
_
_Red = 1;
_Blue = 2;
_MaxColor = 2;
_
var
_x, y, z_:array[1..MaxNum] of real;
_cR, cG, cB_:array[1..MaxColor] of longint;
_
_procedure Draw3DPoly(p1, p2:integer);
_begin
__BeginPoly3D;
__Add3DPt(x[p1], y[p1], z[p1]);
__Add3DPt(x[p2], y[p2], z[p2]);
__EndPoly3D;
_end;
_
_procedure SetXYZ(index:integer; px, py, pz:real);
_begin
__x[index]:= px;
__y[index]:= py;
__z[index]:= pz;
_end;
_
_Procedure SetPenColor(col:integer);
_begin
__PenFore(cR[col], cG[col], cB[col]);
_end;
_
_procedure SetRGB(index:integer; r, g, b:longint);
_begin
__cR[index]:= r;
__cG[index]:= g;
__cB[index]:= b;
_end;
_
begin
_SetXYZ(A, 0, 0, 0);
_SetXYZ(B, 100, 100, 100);
_SetXYZ(C, 500, 100, 300);
_SetXYZ(D, 10, 10, 10);
_SetXYZ(E, 110, 110, 110);
_SetXYZ(F, 200, 200, 300);
_SetXYZ(G, 300, 300, 500);
_
_SetRGB(Red, 65535, 0, 0);
_SetRGB(blue, 0, 0, 65535);
_
_Layer(AAA);
_SetPenColor(Red);
_Draw3DPoly(A, B);
_Draw3DPoly(B, C);
_
_Layer(BBB);
_SetPenColor(Blue);
_Draw3DPoly(D, E);
_Draw3DPoly(F, G);
end;
Run(test);



Re:直線作図の方法教えてください。   与太郎
email:  Fri Oct 24 17:51:34 2003

たがさん、
Scriptで描きたいということですよネエ...

変数を使わないと、下のようになります。

Layer('AAA');
PenFore(65535,0,0);{R,G,Bの値、0〜5535}

BeginPoly3D;
Add3DPt(0,0,0);
Add3DPt(100,100,100);
EndPoly3D;

BeginPoly3D;
Add3DPt(100,100,100);
Add3DPt(500,100,300);
EndPoly3D;

Layer('BBB');
PenFore(0,0,65535);{R,G,Bの値、0〜5535}

BeginPoly3D;
Add3DPt(10,10,10);
Add3DPt(110,110,110);
EndPoly3D;

BeginPoly3D;
Add3DPt(200,200,300);
Add3DPt(300,300,500);
EndPoly3D;


変数を使うと、下のようになります。

Procedure test;
const
AAA = 'AAA';
BBB = 'BBB';
A = 1;
B = 2;
C = 3;
D = 4;
E = 5;
F = 6;
G = 7;
MaxNum = 7;

Red = 1;
Blue = 2;
MaxColor = 2;

var
x, y, z:array[1..MaxNum] of real;
cR, cG, cB:array[1..MaxColor] of longint;

procedure Draw3DPoly(p1, p2:integer);
begin
BeginPoly3D;
Add3DPt(x[p1], y[p1], z[p1]);
Add3DPt(x[p2], y[p2], z[p2]);
EndPoly3D;
end;

procedure SetXYZ(index:integer; px, py, pz:real);
begin
x[index]:= px;
y[index]:= py;
z[index]:= pz;
end;

Procedure SetPenColor(col:integer);
begin
PenFore(cR[col], cG[col], cB[col]);
end;

procedure SetRGB(index:integer; r, g, b:longint);
begin
cR[index]:= r;
cG[index]:= g;
cB[index]:= b;
end;

begin
SetXYZ(A, 0, 0, 0);
SetXYZ(B, 100, 100, 100);
SetXYZ(C, 500, 100, 300);
SetXYZ(D, 10, 10, 10);
SetXYZ(E, 110, 110, 110);
SetXYZ(F, 200, 200, 300);
SetXYZ(G, 300, 300, 500);

SetRGB(Red, 65535, 0, 0);
SetRGB(blue, 0, 0, 65535);

Layer(AAA);
SetPenColor(Red);
Draw3DPoly(A, B);
Draw3DPoly(B, C);

Layer(BBB);
SetPenColor(Blue);
Draw3DPoly(D, E);
Draw3DPoly(F, G);
end;
Run(test);

点が多くなると、変数を使った方が簡単になります。
点は A,B,C... でなく 1,2,3... としたほうが楽です。

参考書は「MiniCAD プログラミング入門」というのがあります。
とりあえず、VWのフォルダにあるVSマニュアルを読まれたら良いと思います。
また、VWファイルをVectorScript形式で書き出して、見てみるのも勉強になりますよ。


直線作図の方法教えてください。   たが
email:  Fri Oct 24 13:57:17 2003

script初心者です。
今自分が取り敢えずしたいことは、
以下のような事をしたいと思っています。
例で言います。
1 AAAというレイヤーを作成する。
2 BBBというレイヤーを作成する。
3 AAAというレイヤーに
  A(0,0,0)とB(100,100,100)を結ぶ赤色のポリラインを引く。
  次にB(100,100,100)とC(500,100,300)を結ぶポリラインを引く。
4 BBBというレイヤーというレイヤーに
  D(10,10,10)とE(110,110,110)を結ぶ青色のポリラインを引く。
  次にF(200,200,300)とG(300,300,500)を結ぶポリラインを引く。

よろしくお願いします。
また、初心者によく分かる本あれば教えてください。




Re.2: 構造体が使えるようになっていた   与太郎
email:  Thu Oct 2 18:42:38 2003

>石男 さん
VW9の和訳マニュアルを見ています。
Structureとか、Allocateとか、Cっぽくなってますね。
Char型配列は、String型のかわりに使えばメモリの節約になりそうです。
VW10の和訳マニュアルはないんですね。
英語マニュアルを読むしかないのか...
関数リファレンスなら何とかなりますが、長文はつらいです。


Re.: 構造体が使えるようになっていた   石男
email:  Thu Oct 2 10:27:26 2003

>与太郎 さん
Ver.9からの変更って結構ありますよ。日本版のマニュアルでは出ていないことが多い
ので御本家のマニュアルをDLした方がいいです。御本家のもVer.10からマニュアルが
がらりと変わりました。


構造体が使えるようになっていた   与太郎
email:  Wed Oct 1 19:50:10 2003

A&AのHPをのぞいていたら、VectorScript10の英語マニュアル発見。
その中にSTRUCTUREという項目が...
調べてみると、VS9からの機能でした。
Pascalのrecordを、VectorScriptではstructureと書き換えれば良いようです。
しかし、VS9からとはショックでした。
一応バージョンアップのたびに、新機能はチェックしていたつもりなのに...


教えてください!!  ryuta
email:
t1400062@iwate-u.ac.jp  Wed Sep 17 14:23:36 2003

Windows XPのパソコンにMinicad7をインストールしようとしたところ、
『VisualC++ Runtime Library
 Runtime Error!
 program:C:\MiniCAD7\Minidad.exe
 abnormal termination  』
というエラーがでてしまいました。どうすればいいのでしょうか。
プリンタドライバの設定はしてるのですが…


 mumu_m @ ezweb.ne.jp
email:  Thu Sep 11 15:17:58 2003

sasiburi desu ne
ima made ujang genki desu.kyou mo nihon no omoi o atama ni aru.hontoni nihon no omoi o wasureru koto ga dekinai.ima made mo ujang mada sigotosi nai.maresia mo mada kimattenai tabung 10 gatsu gurai.ima ujang no sigoto no baiku o baibaisuru.atode ujang no tsumori wa video kasetto ujang no paty o okurimasu.soste nihon no okashi hoshi demo indonesia arimasen.okashi wa sakana sei biru no tomodachi tabung syafrin shiteru.okutte kudasaionegaishimasu.


 mumu_m @ ezweb.ne.jp
email:  Thu Sep 11 15:17:56 2003

sasiburi desu ne
ima made ujang genki desu.kyou mo nihon no omoi o atama ni aru.hontoni nihon no omoi o wasureru koto ga dekinai.ima made mo ujang mada sigotosi nai.maresia mo mada kimattenai tabung 10 gatsu gurai.ima ujang no sigoto no baiku o baibaisuru.atode ujang no tsumori wa video kasetto ujang no paty o okurimasu.soste nihon no okashi hoshi demo indonesia arimasen.okashi wa sakana sei biru no tomodachi tabung syafrin shiteru.okutte kudasaionegaishimasu.


3D直線と3D多角形の交点を計算するスクリプト   与太郎
email:  Tue Sep 2 21:48:47 2003

仕事が暇だったので作ってみました。
結構いいもんができましたんで、発表させていただきます。
VW8以降で動くと思います。(VW8.5とVW10で動作確認しました。)

ライブラリとして保存するようにしていますので、{$INCLUDE :パス名}で参照すれば、
どのスクリプトからでも呼び出せます。
ArcTan2関数は、dXが極小の場合に除算エラーが出る可能性があります。
45°単位で条件分けすれば良いのですが、面倒なのでそのままにしてあります。
デバッグ用の Message が残っていますが、動作には影響ないと思います。

使うときは、行の先頭のアンダーバーをタブに置き換えてください。
(if文のネストが深く、字下げしないとわかりにくいので、こうしています。)

----- "Yotaro's-SubRoutin.vss" -----
( VectorWorksのPlug-insフォルダ内のincludesフォルダに保存してください。 )

{ -π 〜 +πの間の角度を返します。 }
function ArcTan2(dX, dY: real): real;
begin
_if dX > 0 then begin
__ArcTan2:= ArcTan(dY / dX);
_end
_else if dX = 0 then begin
__if dY < 0 then
___ArcTan2:= -Pi / 2
__else if dY = 0 then
___ArcTan2:= 0
__else{if dY > 0 then}
___ArcTan2:= Pi / 2;
_end
_else{ if dX < 0 then } begin
__ArcTan2:= ArcTan(dY / dX) + Pi;
_end;
end;{ArcTan2}

{ (x,y)を、(xc, yc)を中心にして、dA(red)だけ回転します。}
procedure RotPtR(var x, y:real; xc, yc, dA: real);{by Radian}
var
_a, l:real;
begin
_l:= Distance(x, y, xc, yc);
_a:= ArcTan2(x - xc, y - yc) + dA;
_x:= xc + l * Cos(a);
_y:= yc + l * Sin(a);
end;{RotPtR}

{2つの3D座標が等しいかどうか判定します。 }
function Equal3DPt(x1, y1, z1, x2, y2, z2:real):boolean;
begin
_if (x1 = x2) & (y1 = y2) & (z1 = z2) then
__Equal3DPt:= true
_else
__Equal3DPt:= false;
end; {Equal3DPt}


{ ここからが本体です }

{ 3D直線と3D多角形の交点を計算します。 }
function Closs3DLine3DPoly(x1, y1, z1:real; { x1, y1, z1 : 3D直線の始点の座標 }
___x2, y2, z2:real; { x2, y2, z2 : 3D直線の終点の座標 }
___hP:handle; { hP : 3D多角形のハンドル }
___var x3, y3, z3:real; { x3, y3, z3 : 交点の座標 }
___var inLine:boolean; { 交点が3D直線上にある場合は true を返す }
___var inPoly:boolean { 交点が3D多角形内を通る場合は true を返す }
___):boolean; { 3D直線と3D多角形が平行な場合は false を返す }

const
_X = 1;
_Y = 2;
_Z = 3;
_MaxVert = 1024; {3D多角形の頂点の上限}
_t3DPoly = 25; { 3D多角形のオブジェクトID }
_MinDZ = 0.000001; { 3D直線と3D多角形が平行かどうかを判定する基準値。単位によって変更が必要 }

var
_rotAng:array[X..Z] of real; { XYZ軸の回転角度(Radian) }
_error:boolean;
_vert:array[1..MaxVert+6, x..Z] of real; {座標変換用3D座標の配列}
_dX, dY, dZ, dZ2:real; { 交点計算の一時変数 }
_iV1, iV2, iV3, { 3D多角形のインデックス番号 }
_iP1, iP2, { 3D直線のインデックス番号 }
_iP:integer; { 交点のインデックス番号 }
_i:integer; { カウンタ変数 }
_n:integer; { 3D多角形の頂点の数 }
_h:handle;{ 2D多角形のハンドル }
_iX, iY, iZ:integer;
_x0, y0:real; { 原点の移動量 }

{ 配列vert内のiStart〜iEndまでの3D座標を、iP0を基準点に、xyzを回転軸にして、rot(rad)だけ回転します。 }
_procedure RotatePtByXYZ(iP0, iStart, iEnd, xyz:integer; rot:real);
_var
__i, i1, i2:integer;
_begin
__if xyz = X then begin
___i1:= Y; i2:= Z;
__end
__else if xyz = Y then begin
___i1:= X; i2:= Z;
__end
__else if xyz = Z then begin
___i1:= X; i2:= Y;
__end;
__for i:= iStart to iEnd do begin
___RotPtR(vert[i, i1],vert[i, i2], vert[iP0, i1], vert[iP0, i2], rot);
__end;
_end; {RotatePtByXYZ}

{ 配列vert内の2点が等しいかどうか判定します。 }
_function Equal3DPtByIndex(i1, i2:integer):boolean;
_begin
__if (vert[i1, X] = vert[i2, X]) & (vert[i1, Y] = vert[i2, Y]) & (vert[i1, Z] = vert[i2, Z]) then
___Equal3DPtByIndex:= true
__else
___Equal3DPtByIndex:= false;
_end; {Equal3DPtByIndex}

{ 配列vert内の1点に別の点を代入します。 }
_procedure LetXYZ(i, j:integer);
_begin
__vert[i, X]:= vert[j, X];
__vert[i, Y]:= vert[j, Y];
__vert[i, Z]:= vert[j, Z];
_end; {LetXYZ}

begin{Closs3DLine3DPoly}
_error:= true;
_GetOrigin(x0, y0);
_if Equal3DPt(x1, y1, z1, x2, y2, z2) then
__Message('3D直線の最初の点と最後の点が同じです。')
_else if GetType(hP) <> t3DPoly then
__Message('3D多角形のハンドルを渡してください')
_else begin
__n:= GetVertNum(hP);
__if n < 3 then
___Message('3D多角形の頂点は3個以上必要です。')
__else if MaxVert < n then
___Message(concat('3D多角形の頂点は', MaxVert, '個以下にしてください。'))
__else begin
___iV1:= n + 1;
___iV2:= iV1 + 1;
___iV3:= iV2 + 1;
___iP1:= iV3 + 1;
___iP2:= iP1 + 1;
___iP:= iP2 + 1;
___i:= 0;
___GetPolyPt3D(hP, i, vert[iV1, X], vert[iV1, Y], vert[iV1, Z]);
___LetXYZ(iV2, iV1);
___while Equal3DPtByIndex(iV1, iV2) & (i < n-1) do begin
____i:= i + 1;
____GetPolyPt3D(hP, i, vert[iV2, X], vert[iV2, Y], vert[iV2, Z]);
___end;
___if Equal3DPtByIndex(iV1, iV2) then
____Message('2つ目の頂点が得られませんでした。')
___else begin
____LetXYZ(iV3, iV1);
____while (Equal3DPtByIndex(iV1, iV3) | Equal3DPtByIndex(iV2, iV3)) & (i < n-1) do begin
_____i:= i + 1;
_____GetPolyPt3D(hP, i, vert[iV3, X], vert[iV3, Y], vert[iV3, Z]);
____end;
____if Equal3DPtByIndex(iV1, iV3) | Equal3DPtByIndex(iV2, iV3) then
_____Message('3つ目の頂点が得られませんでした。')
____else begin
_____error:= false;
____end;{if}
___end;{if}
__end;{if}
_end;{if}
_
_if error then
__Closs3DLine3DPoly:= false
_else begin
__for i:= 1 to n do
___GetPolyPt3D(hP, i-1, vert[i, X], vert[i, Y], vert[i, Z]);
__for i:= 1 to iV3 do begin
___vert[i, X]:= vert[i, X] - x0; { 原点補正(X) }
___vert[i, Y]:= vert[i, Y] - y0; { 原点補正(Y) }
__end;
__vert[iP1, X]:= x1; vert[iP1, Y]:= y1; vert[iP1, Z]:= z1;
__vert[iP2, X]:= x2; vert[iP2, Y]:= y2; vert[iP2, Z]:= z2;
__
__{ Z軸で回転 }
__rotAng[Z]:= ArcTan2(vert[iV2, X] - vert[iV1, X], vert[iV2, Y] - vert[iV1, Y]);
__RotatePtByXYZ(iV1, 1, iP2, Z, -rotAng[Z]);
__
__{ Y軸で回転 }
__rotAng[Y]:= ArcTan2(vert[iV2, X] - vert[iV1, X], vert[iV2, Z] - vert[iV1, Z]);
__RotatePtByXYZ(iV1, 1, iP2, Y, -rotAng[Y]);
__
__{ X軸で回転 }
__rotAng[X]:= ArcTan2(vert[iV3, Y] - vert[iV1, Y], vert[iV3, Z] - vert[iV1, Z]);
__RotatePtByXYZ(iV1, 1, iP2, X, -rotAng[X]);
__
__{ この時点で、多角形の頂点ののZ座標がすべて等しくなっているはず }
__
__dZ:= vert[iP2, Z] - vert[iP1, Z];
__if Abs(dZ) <= MinDZ then begin
___Message('3D直線と3D多角形が交わりませんでした。');
___Closs3DLine3DPoly:= false;
__end
__else begin
___Closs3DLine3DPoly:= true;
___
___{ 交点(p)を計算する }
___dX:= vert[iP2, X] - vert[iP1, X];
___dY:= vert[iP2, Y] - vert[iP1, Y];
___dZ2:= vert[iV1, Z] - vert[iP1, Z];
___vert[iP, X]:= vert[iP1, X] + dZ2 / dZ * dX;
___vert[iP, Y]:= vert[iP1, Y] + dZ2 / dZ * dY;
___vert[iP, Z]:= vert[iV1, Z];
___
___if ((vert[iP1, Z] <= vert[iV1, Z]) & (vert[iV1, Z] <= vert[iP2, Z]))
___ | ((vert[iP2, Z] <= vert[iV1, Z]) & (vert[iV1, Z] <= vert[iP1, Z])) then
____inLine:= true
___else
____inLine:= false; { 3D多角形は3D直線上にない }
___
___ClosePoly;
___BeginPoly;
___for i:= 1 to n do
____AddPoint(vert[i, X], vert[i, Y]);
___EndPoly;
___h:= LNewObj;
___if PtInPoly(vert[iP, X], vert[iP, Y], h) then
____inPoly:= true
___else
____inPoly:= false; { 3D直線は3D多角形内を通らない }
___DelObject(h);
___
___{ 交点(iP)を回転する }
___RotatePtByXYZ(iV1, iP, iP, X, rotAng[X]);
___RotatePtByXYZ(iV1, iP, iP, Y, rotAng[Y]);
___RotatePtByXYZ(iV1, iP, iP, Z, rotAng[Z]);
___x3:= vert[iP, X];
___y3:= vert[iP, Y];
___z3:= vert[iP, Z];
__end;{if}
_end;{if}
end;{Closs3DLine3DPoly}

----- "Yotaro's-SubRoutin.vss" 終わり -----


----- テスト用スクリプトコマンド -----
( リソースパレットで新規VectorScriptコマンドを作って、そこにペーストしてください。 )

procedure test;
{ 3D多角形と3D直線(頂点が2個の3D多角形)の交点に3D基準点を打ちます。 }
var
_hP, hL:handle;
_inLine, inPoly, clossed:boolean;
_x, y, x0, y0,
_x1, y1, z1, x2, y2, z2, x3, y3, z3:real;
_n:integer;
{DEBUG}
{$INCLUDE :Plug-ins:includes:Yotaro's-SubRoutin.vss}
begin
_Message('3D多角形をクリックしてください。');
_GetPt(x, y);
_hP:= PickObject(x, y);
_if (hP = nil) | (GetType(hP) <> 25) then
__Message('3D多角形のハンドルをを得られませんでした。')
_else begin
__Message('OK! 3D直線(3D多角形)をクリックしてください。');
__GetPt(x, y);
__hL:= PickObject(x, y);
__if (hL = nil) | (GetType(hL) <> 25) then
___Message('3D直線のハンドルをを得られませんでした。')
__else begin
___GetOrigin(x0, y0);
___n:= GetVertNum(hL);
___GetPolyPt3D(hL, 0, x1, y1, z1); x1:= x1 - x0; y1:= y1 - y0;
___GetPolyPt3D(hL, 1, x2, y2, z2); x2:= x2 - x0; y2:= y2 - y0;
___clossed:= Closs3DLine3DPoly(x1, y1, z1, x2, y2, z2, hP, x3, y3, z3, inLine, inPoly);
___if not clossed then
____Message('3D多角形と3D直線は交わりませんでした')
___else begin
____Locus3D(x3, y3, z3);
____ReDrawAll;
____if inLine then begin
_____if inPoly then
______Message('交点は3D直線上にあり、3D多角形内も通ります。')
_____else
______Message('交点は3D直線上にありますが、3D多角形内を通りません。');
____end
____else {if not inLine then} begin
_____if inPoly then
______Message('交点は3D直線上にはありませんが、3D多角形内を通ります。')
_____else
______Message('交点は3D直線上にはなく、3D多角形内も通りません。');
____end;
___end;
__end;
_end;
end;
Run(test);

----- テスト用スクリプトコマンド 終わり -----

以上、与太郎でした。


Re:3D基準点の座標の取得  kouichi
email:  Tue Aug 26 8:57:07 2003

与太郎さん、ありがとうございます。
>GetOrigin(x0, y0) で返った値をX座標とY座標から差し引けば、正しい値になると思います。
教えていただいたとおりやると正しい値がとれました。
ありがとうございました。


Re:3D基準点の座標の取得   与太郎
email:  Mon Aug 25 23:17:59 2003

原点を変更(移動)していませんか?
GetOrigin(x0, y0) で返った値をX座標とY座標から差し引けば、正しい値になると思います。
組込みサブルーチンの中には、戻ってきた座標値に、原点の移動分が反映されないものがあるので、
注意が必要です。
また、MC/VWのバージョンによって変更(修正)されてるサブルーチンもあります。
マニュアルに書いてあれば悩まないで済むのですが...



3D基準点の座標の取得  kouichi
email:  Mon Aug 25 11:10:55 2003

いつも拝見させて頂いてます。
3D基準点の座標を取得するのに GetLocus3D( objH , X , Y , Z ) ;
を使っているのですが、XとY座標が正しい値で取得できません。
どなたかご存知の方がいましたら、教えてください。
VW 10.1.3j Windows98SE
よろしくお願いします。


3次元空間の距離   石男
email:  Thu Aug 21 8:43:03 2003

一番簡単な方法は、求めたい3次元座標それぞれに3D基準点を打ち、三角関数で距離を
求めるやり方です。ただし、VWの3D図形の性質上、3D図形の辺上を認識出来ないので
各頂点のみとなります。
いずれにしましても、VWの3次元関係は力技になります。


3D多角形と3D直線の交点を計算するスクリプトは、   与太郎
email:  Wed Aug 20 23:57:10 2003

高度な数学を使わなくても、三角関数だけで書けると思います。
ポイントは、3D多角形が2D平面と平行になるように、3D多角形と3D直線を回転(座標変換)する
ことです。

手順は、
1. 3D多角形の最初の頂点を通るX軸かY軸を中心にして、二つ目の頂点のZ座標が最初の頂点と同
 じになうように3D多角形と3D直線を回転(座標変換)する。
2. Z軸を中心にして、二つの頂点がX軸かY軸と平行になるように回転(座標変換)する。
3. X軸かY軸を中心にして、3D多角形の三つ目の頂点のZ座標が二つの頂点と同じになうように回
 転(座標変換)する。
4. 交点を求める。
5. 順番、角度を逆にして、交点を回転(座標変換)する。
となります。

注意点は、
1. 三つの頂点が直線上に並んでいる場合、
2. 3D多角形と3D直線が交わらない場合、
の処理を考えておくことです。

3D直線が実際に3D多角形の中を通るかどうかの判定は、スクリプト内で2D多角形を生成して、
PtInPolyで調べます。


Re2:はじめまして   やべ
email:  Mon Aug 18 0:54:15 2003

線分の延長がある平面と交差する点の座標ですか。難しすぎる...。
VectorScriptにはこれを直接求める関数等はありません。
幾何的な手法を地道に書くしかないと思いますが...。

屋根の束の長さでも求めたいのでしょうか?
線分を面まで延長したい場合、
VectorWorksでモデリングするのも難しいですよね。
僕なら、セグメント延長ツールを持っているformZでモデリングしたあとに
VectorWorksに取り込んで使います。
スクリプト書くより簡単だと思います。(formZを持っていればの話ですが...。)
線分の長ささえ決まってしまえば、masafumiさんがおっしゃるように
長さを取得するのは簡単ですからね。


Re:はじめまして  masafumi
email:  Sun Aug 17 12:56:31 2003

こんにちは mituo さん。

>Vector Scriptを使って、三次元の平面と直線の交点、直線の始点とその交点までの
>距離を求めるには、どうすればよいのでしょうか?

単に直線と言うと2Dの直線を想像してしまいます。それだとたぶん出来ないと思います。
3D多角形で描いた直線で、両端の高さ(z値)が違っていれば出来ます。

> 交点の座標が分かれば、その点を3D基準点として線分の距離などをワークシート
>に返して利用できるのではないかと思っています。

この部分がちょっとわかりにくいですね。
おっしゃっている意味と違うかもしれませんが、3D多角形で描いた線分でしたら
交点を計算しなくても線分の長さは取れますよ。


はじめまして  mituo
email:  Sat Aug 16 13:15:02 2003

Vector Scriptを使って、三次元の平面と直線の交点、直線の始点とその交点までの
距離を求めるには、どうすればよいのでしょうか?
 交点の座標が分かれば、その点を3D基準点として線分の距離などをワークシート
に返して利用できるのではないかと思っています。
 初心者なゆえ、こんな質問をしてしまって申し訳ありませんが、よろしければ御
指導いただきたいと思います。


だめなんでしょうか?   若っ葉まーく
email:
hiyopiyo@d8.ne.jp  Mon Jun 30 19:15:16 2003

macでVW8を使ってます。Windowsでも使用できると助かるのですが、macのシリアルでは
利用できないのでしょうか?
どうすればいいのでしょうか、教えて下さい。


線に分解された多角形を元に戻すスクリプト   与太郎
email:  Sat Jun 7 11:37:07 2003

MiniCAD7用に作ったスクリプトを公開します。
他のCADのファイルを読み込んだとき、コンターが線に分解されてるのを直すために作りました。
VW8から10でも動きますが、VW9.5では線の色が白になってしまいます。(VW9.5のバグ?)
実行するときは、行の先頭の → を消してください。

→procedure Line2Poly;
→{ アクティブレイヤ上の多角形の最初の直線を選択してから実行してください。
→ 選択した直線と同じ線種、太さ、色、クラスの直線をつなげて多角形を生成します。
→}
→const
→ oLine = 2;
→ dirUp = 1;
→ dirDn = -1;
→var
→ dir :integer; {検索方向}
→ h :array[dirDn..dirUp] of handle; {検索用ハンドル}
→ h0, {最初の直線}
→ hEr, {削除待ち}
→ hp, {生成された多角形}
→ hL :handle; {アクティブレイヤ}
→ lName :string; {アクティブレイヤ名}
→ errors :boolean; {ループ終了フラグ}
→ c :integer; {頂点の数}
→ cc :longint; {選択状態の直線の数}
→ x, x0, x1, x2,
→ Y, y0, y1, y2 :real;
→ r0, g0, b0 :longint; {線の色}
→ lnWd0, {線の太さ}
→ lnPat0 :integer; {線種}
→ lnClass0 :string; {線のクラス名}

→procedure SwapR(var r1, r2: real);
→{ 2つの実数型変数のデータを入れ替えます。 }
→ var r :real;
→ begin
→ r:= r1;
→ r1:= r2;
→ r2:= r;
→ end;{SwapR}

→procedure GetAttrs;
→{ 図形の属性を取得します。 }
→ begin
→ lnWd0:= GetLW(h0);
→ lnPat0:= GetLS(h0);
→ GetPenFore(h0, r0, g0, b0);
→ lnClass0:= GetClass(h0);
→ end;{GetAttrs}

→procedure SetTools;
→{ ディフォルト属性を変更します。 }
→ begin
→ PenSize(lnWd0);
→ PenPat(lnPat0);
→ PenFore(r0, g0, b0);
→ NameClass(lnClass0);
→ end;{SetTools}

→function NextLine: handle;
→{ 選択状態の直線のハンドルを返します。 }
→ procedure NextLineSub;
→ begin
→ if h[dir] <> nil then begin
→ if dir = dirUp then
→ h[dir]:= PrevSObj(h[dir])
→ else {dir = dirDwn}
→ h[dir]:= NextSObj(h[dir]);
→ end;
→ end;{NextLineSub}
→ begin{NextLine}
→ NextLineSub;
→ if h[dir] = nil then begin
→ dir:= -dir;
→ NextLineSub;
→ end;
→ NextLine:= h[dir];
→ end;{NextLine}

→procedure NextPoint(x, y: real; var x0, y0: real; var errors: boolean);
→{ 座標(x, y) に一致する端点をもつ直線を検索し、反対側の端点の座標を得ます。
→ 端点の座標を得たあと、その直線を削除するためにハンドルをhErに保存します。
→ 検索対象は選択状態の直線です。
→ 検索中に、属性が一致しない直線を選択解除します。
→}
→ var
→ EndOfLine :boolean;
→ hdl, hd :handle;
→ r, g, b :longint;
→ lnClass :string;
→ lnWd, lnCol, lnPat :integer;
→ begin
→ errors:= false;
→ EndOfLine:= false;
→ hdl:= NextLine;
→ repeat
→ if hdl = nil then begin
→ EndOfLine:= true;
→ errors:= true;
→ end
→ else begin
→ lnWd:= GetLW(hdl);
→ lnPat:= GetLS(hdl);
→ GetPenFore(hdl, r, g, b);
→ lnClass:=GetClass(hdl);
→ if (lnWd = lnWd0) & (lnPat = lnPat0) & (r = r0) &
→ (g = g0) & (b = b0) & (lnClass = lnClass0) then begin
→ GetSegPt1(hdl, x0, y0);
→ if EqualPt(x, y, x0, y0) then begin
→ GetSegPt2(hdl, x0, y0);
→ SetDSelect(hdl);
→ cc:= cc - 1;
→ EndOfLine:= true;
→ end
→ else begin
→ GetSegPt2(hdl, x0, y0);
→ if EqualPt(x, y, x0, y0) then begin
→ GetSegPt1(hdl, x0, y0);
→ SetDSelect(hdl);
→ cc:= cc - 1;
→ EndOfLine:= true;
→ end
→ else begin
→ dir:= -dir; {検索方向を逆転}
→ hdl:= NextLine;
→ end;
→ end;
→ end
→ else begin
→ SetDSelect(hdl); {属性が一致しない直線を選択解除}
→ cc:= cc - 1;
→ dir:= -dir; {検索方向を逆転}
→ hdl:= NextLine;
→ end;
→ end;
→ until EndOfLine;
→ if hEr <> nil then
→ DelObject(hEr); {前回使用した直線を削除}
→ hEr:= hdl; {今回使用した直線を削除用ハンドルに保存}
→ h[-dir]:= h[dir]; {逆方向のハンドルに保存}
→ end;{NextPoint}

→begin{Line2Poly}
→ ClrMessage;
→ h0 := FSActLayer; { 線のハンドルを取得 }
→ if (h0 = nil) | (GetType(h0) <> oLine) then
→ AlrtDialog('アクティブレイヤ上で、多角形の最初の直線を選択してから実行してください。')
→ else begin
→ PushAttrs; { ツール設定を保存 }
→ GetAttrs;
→ SetTools;

→ DSelectAll;
→ hL:= GetLayer(h0); { = ActLayer }
→ lName:= GetLName(hL);
→ Message('直線を選択状態にしています...');
→ SelectObj((L=lName) & (T=Line));
→ cc:= Count((SEL=TRUE));

→ SetDSelect(h0); { 最初の線を検索対象から除外する }
→ GetSegPt1(h0, x1, y1);
→ GetSegPt2(h0, x2, y2);

→ dir:= dirUp; { 検索方向を設定 }
→ hEr:= nil;
→ h[dirDn]:= h0; { 下向きハンドルを設定 }
→ h[dirUp]:= h0; { 上向きハンドルを設定 }
→ NextPoint(x1, y1, x, y, errors);
→ if not errors then begin
→ SwapR(x1, x2);
→ SwapR(y1, y2);
→ end
→ else begin
→ h[dirDn]:= h0; { 下向きハンドルを再設定 }
→ h[dirUp]:= h0; { 上向きハンドルを再設定 }
→ NextPoint(x2, y2, x, y, errors);
→ end;
→ c:= 0; { カウンタ初期化 }
→ if not errors then begin
→ OpenPoly;
→ BeginPoly; { 多角形開始 }
→ AddPoint(x1, y1);
→ AddPoint(x2, y2);
→ c:= 2;
→ while not errors do begin
→ c:= c + 1;
→ Message(c, '/', cc);
→ AddPoint(x, y);
→ x0:= X;
→ y0:= Y;
→ NextPoint(x0, y0, x, y, errors);
→ end;
→ EndPoly; { 多角形終了 }
→ end;

→ DSelectAll;
→ if hEr <> nil then
→ DelObject(hEr); {最後に使用した直線を削除}
→ if c > 0 then begin
→ Message( c,'個の頂点を持つ多角形を作成しました。');
→ hp:= LNewObj;
→ SetSelect(hp); {生成された多角形を選択状態にする}
→ DelObject(h0); {最初の直線を削除}
→ end
→ else begin
→ Message('多角形を作成できませんでした!');
→ SetSelect(h0); {最初の直線を選択状態にする}
→ end;
→ PopAttrs; { ツール設定を復帰 }
→ ReDraw;
→ end;
→end;{Line2Poly}
→run(Line2Poly);

(与太郎)


データ量が多いときの処理   与太郎
email:  Tue Jun 3 15:02:34 2003

 バイクの羽田さん、CPUカードについての情報、ありがとうございます。
 与太郎のBlue Chip G4('98)は OS X では問題なくスリープから復帰しますが、OS 9 では
復帰できません。

 Script 談話室に少しは関係ある話題を一つ。
 JWC書出しで、設定ダイアログが表示されるまでの時間が、図形数の2乗以上の割合で
増加する事に気付きました(2178→5秒、4356→18秒、8712→70秒、17424→350秒)。
 先日、3万以上の線があるファイルを変換しようとして、30分くらい過ぎてもダイアロ
グが表示されなかったのがきっかけです。(強制終了しました。)
 それまで、そんなに大きいファイルを変換したことはありませんでした。それで数分だ
け考えて、図形数が32,767以上なので無限ループに入ったという仮説を立て、図面枠外の
図形を削除して25,000くらいにすると、無事変換できました(所要時間分10〜15分)。
 ところが後日、約32,000本の線があるファイルで試したところ、30分経ってもダイアロ
グは表示されません。(再び強制終了しました。)ということは、先ほどの仮説は見当は
ずれだったかも。それで図形(線)数を2倍づつ増やして測ったのが上の結果です。(時
計で測ったので、1, 2秒の誤差はあると思います。)34,848個は試す気になりませんでし
たが、32,000では2,000〜2,500秒と推定でき、後10分〜15分待っていれば良かったことに
なります。
 しかし、何故こうゆう結果になるのかは理解できません。ダイアログが表示されるまで
の処理は、使われている線の色や線種を調査しているんだと思っていたのですが、それな
ら処理時間は図形数に比例するはずです。図形毎に他の全図形と比較して、図形の重複を
調査すると、処理時間は図形数の2乗に比例するでしょうが、実際の増加率はもっと大き
いようです。一体どんなことが起こっているのでしょうか。(バグなら直してね)

 でも、上の結果は与太郎の環境特有のものかも知れません。大きなファイルをJWCに変
換した経験のある方はいらっしゃいませんか。ちなみに、上のテストはOS 9.1、仮想記憶
オン、メモリ割り当て54MB、図形は全て線で同じレイヤにあり、属性も同じにして実行し
ました。VWのバージョンは9.5か10です。(忘れました。)

 今回のことで、VectorScriptを書くときに注意したいことを2つ思い出しました。

1. for文のカウンタ変数はINTEGER型でなくLONGINT型を使用しないと、無限ループに
  入ることがある。

2. 処理に数十秒以上かかるときは、進捗状況を知らせないと、ユーザは不安になって強
  制終了する。

(与太郎)


あ、失礼!   バイクの羽田
email:  Sun Jun 1 0:51:05 2003

PowerLogix G3/500だけなのですね。256モジュールの動作が確認されたのは・・・。


RE: バイクの羽田さんへ   バイクの羽田
email:  Sun Jun 1 0:41:50 2003

>OS Xだと実メモリに関係なく、HDの容量が許す限りいくらでもアプリを起動できるのでは?
アプリの中で仮想メモリに預けてもいい部分と、物理メモリに置いておかないとまずい
部分があると思うのです。それはもちろんアプリごとに異なっているでしょうし、仮想
メモリの使い方が上手なアプリも下手なアプリもあると思います。
まあ、いずれにしてもメモリ不足では仕事になりませんね。自分も含めて・・・?

PowerLogix推奨のメモリ(高いです)なら、256モジュールの搭載が可能らしいです。


バイクの羽田さんへ   与太郎
email:  Sat May 31 10:35:06 2003

>Sonnetは512MBまでサポートしているのでPowerLogixをお使いですね?
>もし中古で購入されたなら、その可能性が僅かながらあります。新品は大丈夫のはずです。
はい、PowerLogixです。PowerLogixのホームページで注文して買いましたから、新品です。
Sonnetは512MBまでOKですか。後悔先に立たずです。でも購入時にはPowerLogixしかなか
ったかも。価格で決めたのかも知れませんが、記憶があやふやです。

>アプリが起動しないのはHDDの容量不足よりメモリ不足が主因だと思いますが?
OS Xだと実メモリに関係なく、HDの容量が許す限りいくらでもアプリを起動できるのでは?
実メモリが少ないと速度が遅くなったりするでしょうが。それと、アプリを切り替える時に、
HDのアクセスで延々と待たされることはあります。

最近はMacのメモリより、自前のメモリが不足気味だと思うことが度々あります。あと、昔は
マルチタスク(ラジオを聞きながら計算とか)もOKだったのですが、いまでは計算に集中す
ると耳はお留守です。まわりの話も聞こえません。集中力が増したんだと、人には言ってます。
(与太郎)


与太郎さんへ   バイクの羽田
email:  Sat May 31 0:34:00 2003

気になったのですが本来の話題ではないので簡潔に。

>メモリは192MBで、それ以上はG4カードのサポート外です。
Sonnetは512MBまでサポートしているのでPowerLogixをお使いですね?

>起動ボリュームは、起動直後には600MBぐらいの空き容量があるんですが、
>最近はゼロに近付くことも多く、これ以上アプリを起動出来ません、と言われます。
アプリが起動しないのはHDDの容量不足よりメモリ不足が主因だと思いますが?

>最近はClassicの調子が悪くて、スリープから復帰すると反応しなくなります。
PowerLogixはスリープに対応していないと言っています。

PowerLogixのCPUカードはメモリとの相性が厳しくて、動作確認されているメモリ以
外での動作保証をしていない製品もあります。フリーズはPBやOSが原因ではなく、
CPUカードとメモリの関連で発生していると思われます。私もPowerLogixを入れてい
ましたが、HDDが完全にクラッシュし、データ全てを失った経験があります。メーカ
に問い合わせたところ、少数だけ不具合のあるものが市場に出たと言っており、回収
されました。もし中古で購入されたなら、その可能性が僅かながらあります。新品は
大丈夫のはずです。


関数をいくつか   与太郎
email:  Tue May 20 20:03:19 2003

多角形が閉じてるか開いてるかを調べる組込み関数がないので、作ってみました。

function Closed(hPoly: handle): boolean; {多角形が閉じていればTRUEを返します。}
var
fPat:integer;
begin
fPat:= GetFPat(hPoly);
SetFPat(hPoly, 0);
if HArea(hPoly) = 0 then
Closed:= false
else
Closed:= true;
SetFPat(hPoly, fPat);
end; {Closed}


標準のArcTanでは-90°〜+90°の間の角度しか返ってきません。ArcTan2関数は、-180°〜+180°の
間の角度をラジアンで返します。

function ArcTan2(dX, dY :real) :real;
begin
if Abs(dX) < Abs(dY) then begin
if dY < 0 then begin
ArcTan2:= -Pi/2 - ArcTan(dX/dY);
end
else {if 0 < dY then} begin
ArcTan2:= Pi/2 - ArcTan(dX/dY);
end;
end
else {if absX >= absY then} begin
if 0 < dX then begin
ArcTan2:= ArcTan(dY/dX);
end
else {if dX < 0 then} begin
if 0 < dY then begin
ArcTan2:= Pi + ArcTan(dY/dX);
end
else {if dY <= 0 then} begin
ArcTan2:= -Pi + ArcTan(dY/dX);
end;
end;
end;
end; {ArcTan2}


xc, yc を中心にして、x, y の座標を dA だけ回転させます。ArcTan2を呼び出しています。

procedure RotatePointByRad(var x, y:real; xc, yc, dA: real);
var
a, l:real;
begin
l:= Distance(x, y, xc, yc);
a:= ArcTan2(x - xc, y - yc) + dA;
x:= xc + l * Cos(a);
y:= yc + l * Sin(a);
end;{RotatePointByRad}

procedure RotatePointByDeg(var x, y:real; xc, yc, dA: real);
var
a, l:real;
begin
l:= Distance(x, y, xc, yc);
a:= ArcTan2(x - xc, y - yc) + Deg2Rad(dA);
x:= xc + l * Cos(a);
y:= yc + l * Sin(a);
end;{RotatePointByDeg}

(与太郎)


Re2:一度に仰山(ぎょうさん)のレイヤを作る方法   与太郎
email:  Wed May 7 20:11:54 2003

トトロ様、レスありがとうございました。
テキストだけでワークシートをうまく説明できたか自信がなかったので、
与太郎が訳の分からんことを書いていると、みなさんに思われたかなと、
思ってました。

VectorWorksに図形を入力するなら、大抵この方法が使えます。
(基準点、多角形、シンボル配置など)
ついでに図形オブジェクトの線種、クラス、レイヤ、名前なども設定できます。

表形式でデータを貰ったときは、この方法なら転記ミスがありませんし、
データを手打ちする場合も、表形式だとチェックし易いです。

図形によって入力形式が分からないときは、
自分で同じ種類の図形を描いて、VectorScript形式で書き出したファイルを、
エディタで開いてみれば、理解できると思います。
VectorScriptファイルの最初の部分にはVectorWorksの設定とかが書いてあって、
最後の方に図形描画コマンドがあります。(与太郎)


Re:一度に仰山(ぎょうさん)のレイヤを作る方法   トトロ
email:
totoro63@mail.goo.ne.jp  Tue May 6 20:53:59 2003

与太郎さん...裏技(?)の紹介ありがとうございます。
早速使わせていただこうと思います。m(^^)m


一度に仰山(ぎょうさん)のレイヤを作る方法   与太郎
email:  Sat May 3 12:58:01 2003

連休中ですが、しっかり仕事中の与太郎です。気分転換に掲示板を覗いていますが、
新しい書込みがなくて寂しいので、書かせていただきます。

この掲示板のバックナンバーに、一度に大量のレイヤを生成するスクリプトがありますが、
与太郎が大量のレイヤを作るときは、
ExcelとテキストエディタでVectorScript形式ファイル(テキストファイル)を作って、
メニューコマンド「ファイル」-「取り込む」-「VectorScript...」で読み込みます。

たとえば、No.1 〜 No.50までの測量断面ごとにレイヤを作るときは、
1. A列(A2〜A51)に1 〜 50までの数字を入れる。
2. B2セルに = "Layer('No." & A2 & "');" を入力する。計算結果は Layer('No.1'); となる。
3. B2をコピーしてB3〜B51にペーストする。計算結果は Layer('No.2'); 〜 Layer('No.50'); となる。
4. B2〜B51をコピーし、テキストエディタの新規ファイルにペーストして、保存する。
  こうして出来たファイルは、コマンドを並べただけですが、立派なVectorScript形式ファイルです。
5. そのファイルをVectorWorksで取り込めば、No.1〜 No.50 のレイヤが作られます。

例:(スペースで位置をあわせているので、変な表示になってるかもしれませんが、
   ワープロかエディタにコピーして、等幅フォントに設定すればきちんと表示されます。)

[ A ][   B    ]

[1] レイヤ名 レイヤ生成コマンド

[2]   1 Layer('No.1');・・・・・・・・・・結果
="Layer('No."&A2&"');"・・・・・・式

[3]  2 Layer('No.2');
="Layer('No."&A3&"');"



[51] 50 Layer('No.50');
="Layer('No."&A51&"');"

この方法だと、レイヤが何百とあっても、数分で出来てしまいます。
Excelだと、最初の行に1を入れて、オプション+ドラッグで2 〜 50まで自動入力できます。

ワークシートやファイルからデータを取り込んでレイヤを生成するスクリプトを作ろうと思わないでも
なかったのですが、結局作らないまま今日に至っています。
データを作る手間でVectorScriptファイルが出来てしまうので、スクリプトを作る必要もなかったのです。


与太郎はレイヤの高さ設定を仕事では使ってないんですが、
最近、管理人さんの本を読んで刺激されて、自分なりに「小住宅の設計」をやってみました。
それでレイヤの高さや縮尺を一度に設定するためにExcelシートを下のようにしました。

A列:レイヤ名
B列:レイヤ縮尺(例:100)
C列:レイヤの下面(基面)高さ(H)
D列:レイヤの高さ(ΔH)
E列:レイヤの上面高さ
F列: = "Layer('" & An & "');" ・・・・・・・・・・・A列の名前のレイヤを生成
G列: = "SetScale(" & Bn &");" ・・・・・・・・・・・レイヤの縮尺を設定
H列: = "SetZVals(" & Cn & "," & Dn & ");" ・・・・・レイヤの高さを設定
I列:ShowLayer; または HideLayer;・・・・・・・・・・レイヤを表示または非表示
(An, Bn, Cn, Dn はセルの名前。例:A2, A3)

例:
  [ A ][ B ][ C ][ D ][ E ][ F ][ G   ][ H ][ I ]

[1] 名前 縮尺 H(下) dH H(上) レイヤ生成コマンド 縮尺設定コマンド 高さ設定コマンド レイヤ表示

[2] 1F 100 500 3000 3500 Layer('1F'); SetScale(100); SetZVals(500,3000); HideLayer;
=E2-C2 ="Layer('"&A2&"');" =SetScale("&B2&");" ="SetZVals("&C2&","&D2&");"

[3] 2F 100 3500 3000 6500 Layer('2F'); SetScale(100); SetZVals(3500,3000); ShowLayer;
=E2 =E3-C3 ="Layer('"&A3&"');" =SetScale("&B3&");" ="SetZVals("&C2&","&D3&");"


A列〜E列がを入力データ、F列〜I列がコマンドです。
I列には(引数がないので)直接コマンドを打ち込んでいます。
E列(レイヤの上面高さ)はレイヤ設定コマンドには必要ないのですが、
高さを計算するために使っています。
Excelを使うと、レイヤの高さを電卓を使わずに計算できて便利ですよ。

VectorWorksのワークシートでやってみたところ、文字列を「&」で繋げられないので、
Concat関数を探したのですが、VectorWorksのワークシートには文字列関数がないんですね。
それでA列に Layer( ' 、B列にレイヤ名、C列に ' ) ; として、
メニューコマンド「ファイル」-「取り出す」-「ワークシート...」でタブ区切り形式で保存し、
そのファイルを取り込んだら、ちゃんとレイヤが出来たではないですか。
じつは、文字列の中にタブがあるのでダメだと思って、試したことがなかったんです。
いままでの苦労は何だったんだろう、って苦労してませんけど、何でも試してみないとわかりません。
上の例は、下のようにすれば、VectorWorksのワークシートでも可能です。

A列:Layer ( '
B列:レイヤ名
C列:' ); SetScale(
D列:レイヤ縮尺
E列:); SetZVals(
F列:レイヤの下面(基面)高さ(H)
G列:, (コンマ)
H列:レイヤの高さ(ΔH)
I列:); ShowLayer; または ); HideLayer;
(レイヤの上面高さの列は、邪魔なので消しました。)

例:
   [ A ] [ B ] [ C ] [ D ] [ E ] [ F ] [ G ] [ H ] [ I ]

[1] Layer(' 1F '); SetScale( 100 ); SetZVals( 500 , 3000 ); ShowLayer;

[2] Layer(' 2F '); SetScale( 100 ); SetZVals( 3500 , 3000 ); HideLayer;

コマンド、パラメータ、セパレータ(コンマ)ごとに、左からセルに入れてゆくだけです。
人に説明するのは式がないほうが楽ですね。

Excelとちがってオプション+ドラッグが使えないので、たとえば 1〜50を入力するには、
1. B1セルに 1 を入れる。
2. B2セルに =1+B1 を入れる。
3. B2セルをコピーして、B3〜B50セルにペースト。
となります。それでもワークシートを使わないときより楽でしょう。
保存するときは「ワークシート...」ですが、読み込むときは「VectorScript...」なので注意してください。

VectorWorksのワークシートは使いにくいので、与太郎はExcelを使い続けます。
ですが万が一、Excelが使えないときでも、これなら安心です。
メモリ不足とか、Classicを起動したくないときなんか。(Excelは2001のClassic版です)
会社ではPowerBookG3('98)/233にG4カード(500MHz)を入れて、OSX(10.2)を使ってるんですが、
週に10回近くシステムが落ちます。
メモリは192MBで、それ以上はG4カードのサポート外です。
起動ボリュームは、起動直後には600MBぐらいの空き容量があるんですが、
最近はゼロに近付くことも多く、これ以上アプリを起動出来ません、と言われます。
パーティーションを4GBで切ってしまったのが敗因です。
アプリを入れることを考えてなかったんです。
OS8〜9のときはアプリ専用ボリュームを作っていたので、
OSXでも起動ボリュームにアプリを入れるつもりはなかったんですが、
OSX用のアプリはApplicationsフォルダに入れないといけないような気がして、
ついつい起動ボリュームにインストールしてしまったのでした。
最近はClassicの調子が悪くて、スリープから復帰すると反応しなくなります。
スリープ前にClassicを終了するようにしてますが、忘れることも多いです。
Classicの起動が早いのが救いです。
それから、VectorWorksにも変なところがあります。
MS明朝とMSゴシックの2バイト文字が、画面上で32ポイント以下だと文字化けするんです。
最初は○○SOFTのフォントだからOSXと相性が悪いのかと思ったのですが、
Excelでは普通に表示されています(当然か)。
それでVectorWorksのバグかとも思ったのですが、自宅でOSXで試すと正常に表示されてました。
何度もシステムを再インストールしていたり、
プリンタドライバ関係のファイル(すごく容量喰ってた)を勝手に捨てたり、
Windowsのフォント適当にを入れたりしてるので、システムは正常とはいいがたい状態です。
デベロッパーツールをインストールしたいし、
HDDを新品にしたら、それまでのトラブルがピタリと止んだ経験もるので(同じPBG3)、
そろそろHDDをフォーマットし直して、パーティーションを8GBに切り直し、
システムを再インストールしたほうが良いかもしれません。


ところで、Excelで上と同じようにすると、C列の最初の「'」が消えてしまいます。
テキストファイルに書き出して、VectorWorksで読み込むとエラーが出ます。
じつは「'」(シングルクォート) はExcelでは特別の意味を持っていて、
セルの最初の文字が「'」だと、そのセルは(数字が入っていても)文字列と判断されます。
その場合、「'」は表示されません。
試してみたところ、そのセルをコピーして他のアプリにペーストしても「'」が消えるようです。
仕方がないのでセルの先頭に「'」があるときは、「'」を二つ打っておきます。
これは、DOS時代のLotus-123あたりから引きずっている仕様です。(もしかして、もっと前から?
MultiplanかVisiCalcの頃かも。)過去の資産がありすぎて、今さら変えられないんでしょうね。


以上、VectorScript談話室というより、ワークシート談話室で失礼しました。
何かの参考になれば幸いです(与太郎)。


Re.8:ポリラインに3D図形を配置する   やべ
email:
yabe@ff.iij4u.or.jp  Fri Apr 25 0:58:12 2003

石男さん、masafumiさんありがとうございました。たった今、解決しました...。

僕が書いていたスクリプトでは、生成したオブジェクトを回転・移動するときに、後からできたオブジェクトがどんどん"遠いところへ飛んでいってしまう"ことが最大の問題だったんです。石男さんのを走らせてみると、ひとつずつちゃんと回転・移動して3Dポリラインの位置に行ってくれるという理想的な結果だったので大変参考になりました。ただ、ちょっと角度が違ってたんで修正しようとしたんですけど、僕にはどうしてもベクトルが理解できず無理だったので、三角関数でいくことにしました...。

問題は絶対座標と相対座標の指定が正しくないことでした。MoveToとMove、LineToとLineの使い方を正すことで解決しました。これで仕事が楽になります。ほんとにありがとうございました。

Procedure Line2Solid;{T.YABE 2003/04/25 0:27}
VAR
h,objH:HANDLE;
p1X,p1Y,p1Z,p2X,p2Y,p2Z:REAL;
dia1,dia2,Length1,a,b,c:REAL;
a1,a2,a3:REAL;
bunkatu:INTEGER;

Function rot(x1,y1,x2,y2 : Real) : Real;
VAR
tR : Real;
BEGIN
If x1 = x2 THEN tR := 90
ELSE tR := Rad2Deg(ArcTan((y2 - y1) / (x2 - x1)));
If ((tR = 90) & (y2 < y1)) Or (x2 < x1) THEN tR := -tR;
If x2 < x1 THEN
If y1 < y2 THEN tR := 180 - tR
ELSE
If 180 + tR <> 180 THEN tR := -(180 + tR)
ELSE tR := 180 + tR;
rot := tR;
END;

Function pitch(x1,y1,z1,x2,y2,z2 : Real) : Real;
VAR
tR : Real;
BEGIN
IF z1 = z2 THEN tR :=0
ELSE IF (z1<z2) THEN tR := Rad2Deg(ArcTan(abs(z2-z1)/(distance(x1,y1,x2,y2))))
ELSE tR:=-Rad2Deg(ArcTan(abs(z2-z1)/(distance(x1,y1,x2,y2))));
pitch := tR;
END;

BEGIN
h:=FSActLayer;
IF h<>NIL THEN
BEGIN
SetOriginAbsolute(0,0);
SetZVals(0,0);
dia1:=25; {ロッド直径}
dia2:=60;{ジョイント直径}
a:=180;
b:=40;
c:=12.5;
bunkatu:=8;
objH:=FSActLayer;
WHILE objH<>NIL DO
begin
PushAttrs;
NameClass('rod');
GetPolyPt3D(objH,#0,p1X,p1Y,p1Z);
GetPolyPt3D(objH,#1,p2X,p2Y,p2Z);
Length1:=sqrt(sqr(Distance(p1X,p1Y,p2X,p2Y))+sqr(abs(p1Z-p2Z)));
BeginSweep(0,360,360/bunkatu,0);
Locus(0,0);
BeginPoly;
OpenPoly;
Moveto(0,0);{絶対座標で指定}
Line(-dia2/2,0);
Line(0,a);
Line(c,b);
Line((dia2/2 )-(dia1/2)-c,0);
Line(0,Length1-a-a-b-b);
Line(-((dia2/2 )-(dia1/2)-c),0);
Line(-c,b);
Line(0,a);
Line(dia2/2,0);
EndPoly;
EndSweep;
a1:=pitch(p1X,p1Y,p1Z,p2X,p2Y,p2Z);
a2:=0;
a3:=rot(p1X,p1Y,p2X,p2Y);
SetRot3D(LNewObj,a1,a2,a3-90,0,0,0);
Move3DObj(LNewObj,p1X,p1Y,p1Z);
SetDSelect(LNewObj);
PopAttrs;
objH:=NextSObj(objH);
end;
Message('L=',Length1,'-->','a1=#',a1,'度',' ,','a2=#',a2,'度',' ,','a3=#',a3,'度');
END
ELSE
AlrtDialog('Select Objects!');
END;
RUN(Line2Solid);


Re2: プラグインオブジェクトで原点を得るには   与太郎
email:  Thu Apr 24 20:54:35 2003

石男様、早速のレスありがとうございます。

原点変更が反映されないのはバグじゃないかと思うのですが(そういう仕様にする理由が分からない)、
無理となれば他の方法を取るしかないですね。

プラグインオブジェクトの中で原点座標を得られないとすると、外部から入力するしかないのですが、
手入力はやっかいですね。
専用の原点変更コマンドを作って、その中でパラメータを変えるのがベストでしょうが、
とりあえずは原点変更をしないでおきます。


Re.7:ポリラインに3D図形を配置する   石男
email:  Thu Apr 24 18:09:43 2003

ごめんなさい、Move3DとMove3DObjがだぶっています。
どちらか一方を消してください。


Re.6:ポリラインに3D図形を配置する   石男
email:  Thu Apr 24 18:05:52 2003

3Dポリラインが2点で構成されていて、選択図形が全て3Dポリラインだったら
以下のScriptを走らせてみてください。本来ならベクトル型の変数を扱えばもっと
すっきりするはずなんですが、文学部デという訳でご勘弁を。更にやべさんの書きたい
回転体が複雑な為、簡単にしました。どうもリピート文の中でAbsoluteを使うとおかし
くなるみたいです。ですからAbsoluteを使わずに回転体を書いた方がいいようです。
取り敢えず、参考まで

Procedure Line2Solid;
Var
h : Handle ;
dia1, dia2 : Real ;
bunkatu : Integer ;
a , b , c : Real ;

myCount , i : Integer ;
p1 , p2 , p3 , p4 , p5 , p6 , p7 , p8 ,p9 : Vector ;
myDis , myAng , myAng1 : Real ;

Begin
h := FSActLayer ;
myCount := Count( (SEL=true)&(T=POLY3D) ) ;
If myCount > 0 Then
Begin
i := 0 ;
Repeat
i := i+1 ;
GetPolyPt3D( h , 0 , p1.x , p1.y , p1.z ) ;
GetPolyPt3D( h , 1 , p2.x , p2.y , p2.z ) ;

p3.x := p1.x ; p3.y := p1.y ; p3.z := 0 ;
p4.x := p2.x ; p4.y := p2.y ; p4.z := 0 ;
p5.x := p1.x ; p5.y := p1.z ; p3.z := 0 ;
p6.x := p2.x ; p6.y := p2.z ; p4.z := 0 ;

p7 := p4-p3 ;
p8 := p6-p5 ;
p9 := p2-p1 ;
myDis := Norm( p9 ) ;
myAng := Vec2Ang( p8 ) ;
myAng1 := Vec2Ang( p7 ) ;
Message( Concat( 'z角度=' , myAng , '距離=' , myDis , 'xy角度=' , myAng1 ) ) ;
dia1:=25; {ロッド直径}
dia2:=60;{ジョイント直径}
a:=180;
b:=40;
c:=12.5;
bunkatu:=8;
BeginSweep(0,360,360/bunkatu,0);

Locus(0,0);
Poly( 0 , 0 ,
-dia2/2 , 0 ,
-dia2/2 , myDis ,
0 , myDis ) ;
{BeginPoly;
OpenPoly;
MoveTo(0,0);
LineTo(-dia2/2,0);
LineTo(0,a);
LineTo(c,b);
LineTo((dia2/2 )-(dia1/2)-c,0);
LineTo(0,myDis-a-a-b-b);
LineTo(-((dia2/2 )-(dia1/2)-c),0);
LineTo(-c,b);
LineTo(0,a);
LineTo(dia2/2,0);
EndPoly;}
EndSweep;

Set3DRot( LNewObj , myAng , 0 , -90+myAng1 , 0 , 0 ,0 ) ;
Move3D( p1.x , p1.y , p1.z ) ;
Move3DObj( LNewObj , p1.x , p1.y , p1.z ) ;
h := NextSObj( h ) ;

until i = myCount ;
End Else
AlrtDialog('Select3DPoly') ;
End;
Run(Line2Solid);


Re.5:ポリラインに3D図形を配置する     やべ
email:  Thu Apr 24 13:11:27 2003

石男様ありがとうございます。
LNewObjしてもうまくいかないんです...。

"長さと方向"ならベクトルですよね。でもベクトルって全然理解してなくてよくわからないんですよ。2座標間にベクトルを設定する方法とか...。

Procedure Line2Solid;
VAR
h:HANDLE;
objH:HANDLE;
h2:HANDLE;
pX, pY, zValue: REAL;
p1X,p1Y,p1Z:REAL;
p2X,p2Y,p2Z:REAL;
plandist,Length1:real;
xDistance, yDistance, zDistance:REAL;
dia1,dia2:REAL;
bunkatu:INTEGER;
a,b,c:real;
a1,a2,a3:real;

Function rot(x1,y1,x2,y2 : Real) : Real;
VAR
tR : Real;
BEGIN
If x1 = x2 THEN tR := 90
ELSE tR := Rad2Deg(ArcTan((y2 - y1) / (x2 - x1)));
If ((tR = 90) & (y2 < y1)) Or (x2 < x1) THEN tR := -tR;
If x2 < x1 THEN
If y1 < y2 THEN tR := 180 - tR
ELSE
If 180 + tR <> 180 THEN tR := -(180 + tR)
ELSE tR := 180 + tR;
rot := tR;
END;

Function pitch(x1,y1,z1,x2,y2,z2 : Real) : Real;
VAR
tR : Real;
BEGIN
If z1 = z2 THEN
tR :=0
ELSE
IF (z1<z2) then tR := -Rad2Deg(ArcTan(abs(z2-z1)/(distance(x1,y1,x2,y2))))
ELSE tR := Rad2Deg(ArcTan(abs(z2-z1)/(distance(x1,y1,x2,y2))));

pitch := tR;
END;

BEGIN
h:=FSActLayer;
IF h<>NIL THEN
BEGIN
SetOriginAbsolute(0,0);
Absolute;
AngleVar;
dia1:=25; {ロッド直径}
dia2:=60;{ジョイント直径}
a:=180;
b:=40;
c:=12.5;
bunkatu:=8;
objH:=FSActLayer;
WHILE objH<>NIL DO
begin
PushAttrs;
NameClass('rod');
GetPolyPt3D(objH,#0,p1X,p1Y,p1Z);
GetPolyPt3D(objH,#1,p2X,p2Y,p2Z);
zDistance:=abs(p1Z-p2Z);
Length1:=sqrt(sqr(Distance(p1X,p1Y,p2X,p2Y))+sqr(zDistance));
BeginSweep(#0,#360,#360/bunkatu,0);
Relative;
Locus(0,0);
BeginPoly;
OpenPoly;
Move(0,0);
LineTo(-dia2/2,0);
LineTo(0,a);
LineTo(c,b);
LineTo((dia2/2 )-(dia1/2)-c,0);
LineTo(0,Length1-a-a-b-b);
LineTo(-((dia2/2 )-(dia1/2)-c),0);
LineTo(-c,b);
LineTo(0,a);
LineTo(dia2/2,0);
EndPoly;
EndSweep;

a1:=#0;
a2:=pitch(p1X,p1Y,p1Z,p2X,p2Y,p2z);
a3:=rot(p1X,p1Y,p2X,p2Y);
message('L=',Length1,'-->','a1=#',a1,'度',' ,','a2=#',a2,'度',' ,','a3=#',a3,'度');
Absolute;
h2:= LNewObj;
Set3DRot(h2,#0, #0,#-90, 0,0,0);
Set3DRot(h2,#0, #a2,#0, 0,0,0);
Set3DRot(h2,#0, #0,#a3, 0,0,0);
Move3DObj(h2,p1X,p1Y,p1Z);
SetDSelect(h2);
PopAttrs;
objH:=NextSObj(objH);
end;
END
ELSE
AlrtDialog('Select Objects!');
END;
RUN(Line2Solid);


Re.4:ポリラインに3D図形を配置する   石男
email:  Thu Apr 24 9:00:37 2003

>"直前に生成された図形のみに"
というのであれば、Move3Dでもいいのですが、LNewObjでハンドル指定してMove3DObj
の方が間違いないと思います。

ここのバックナンバーに私とトトロさんとのSet3DRot等のやりとりがあります。
参考にしてみてください。あと、最近わかったことですが、ベクトルを使用すると
面倒な計算が省けたりします...。


Re.: プラグインオブジェクトで原点を得るには   石男
email:  Thu Apr 24 8:53:01 2003

基本的にプラグインオブジェクトの外の情報を取るのは無理です。
さんざんやった結果です。


RE3:ポリラインに3D図形を配置する   やべ
email:
yabe@ff.iij4u.or.jp  Thu Apr 24 8:10:26 2003

masafumi様たびたびありがとうございます。
たしかにpitch関数を用意する必要は無かったのかもしれませんね...。引用してきたrot関数は正しく角度を計算しているようです。

問題なのはオブジェクトのハンドルの取得のしかたなのだと思います。LnewObjを使ってSet3DRotとMove3dobjをかける部分です。
1本だけ取得するとうまくいくのに、複数の図形を拾うと一つ前の図形も相対的に移動してしまうのです。うまく"直前に生成された図形のみに"相対的な移動を与える方法がわからないのですが、どうでしょうか?


プラグインオブジェクトで原点を得るには   与太郎
email:  Wed Apr 23 19:06:31 2003

与太郎です。
はじめて書込みいたします。

Y座標(原点からの高さ)を表示するプラグインオブジェクトを作ったのですが、
うまくいかないことがあります。

問題は、原点位置を移動しても、最初の原点からの高さが表示されることです。
プラグインオブジェクトの中で、GetCustomObjectInfoでオブジェクトのハンドルを取り、
GetSymLoc(objHd, x, y)でY座標を拾っています。
GetOrigin(x0, y0)で原点位置を得ようとしても、ゼロが返ってきます。

どなたか、良い方法をご存じありませんか?


RE3:ポリラインに3D図形を配置する  masafumi
email:  Wed Apr 23 18:45:21 2003

ども、masafumiです。こんな感じですかねぇ。

>Function pitch(x1,y1,z1,x2,y2,z2 : Real) : Real;
>VAR
> tR : Real;
>BEGIN
> If z1 = z2 THEN tR :=0
> ELSE
> IF (z1<z2) then tR := Tan(abs(z2-z1)/(distance(x1,y1,x2,y2)))* 180 / pi
> ELSE tR:= -Tan(abs(z2-z1)/(distance(x1,y1,x2,y2)))* 180 / pi;
> pitch := tR;
>END;

内で
> IF (z1<z2) then tR := Tan(abs(z2-z1)/(distance(x1,y1,x2,y2)))* 180 / pi

これは3Dポリラインの頂点間の勾配(角度)を求めているのですね。だとすると
この場合は rot と同様に Tan() じゃなくて ArcTan() を使用します(と思う)。
内容は rot と同様になりますので、ここでは

#0の頂点座標を仮に
xx1=0 , yy1=0 とすると
#1の頂点座標は

xx2=distance(x1,y1,x2,y2);
yy2=(z2-z1);

となり

pitch:=rot(xx1,yy1,xx2,yy2);

と rot関数を呼び出したほうが楽な気がします。
(ここまで pitch の検証、動作チェックはしていませんので悪しからず。)

ここからは z1,z2 に関しての疑問です。3Dポリラインを描いてデータパレットのz値
を変更すると全頂点の値が、変更した値に変わりますが・・・どうなんでしょう?。
(3Dポリラインは使用したことがないので理解できていません)

ですから、私の環境では
>GetPolyPt3D(objH,#0,p1X,p1Y,p1Z);
>GetPolyPt3D(objH,#1,p2X,p2Y,p2Z);

の所では常に p1z=p2z になり

> If z1 = z2 THEN tR :=0
の部分しか実行していませんでした。


>それとSet3DRot関数の使い方がいまいちよくわからないんですけど

これは私もお手上げです。(^_^)v


RE2:ポリラインに3D図形を配置する   やべ
email:
yabe@ff.iij4u.or.jp  Wed Apr 23 14:38:46 2003

masafumi様ありがとうございます。
3Dポリラインの回転を上から見たときの回転角と横から見たときの勾配と考えてこう書いたのです。
実はこのFunction部分はどこかから引用してきたものなのでよく理解していませんでした。
rotではなくpitchのほうの三角関数の計算は正しいかどうかわかりますか?
高校の数学教科書を引っ張り出してきて書いたのですがいまいち曖昧なので...。
それとSet3DRot関数の使い方がいまいちよくわからないんですけど...。



RE:ポリラインに3D図形を配置する  masafumi
email:  Wed Apr 23 13:56:35 2003

こんにちは、masafumi と言います。
3Dの部分は良く解りませんが、2Dのところで気になった点を少しだけ。

>Function pitch(x1,y1,z1,x2,y2,z2 : Real) : Real;
>VAR
>tR : Real;
>BEGIN
>If z1 = z2 THEN
>ELSE

ここの部分で

>tR :=0 
^^^^^^^↑ この位置(0の後ろ)に全角のスペースが有るためにエラーになります。

ここにUPする時のミスかな?。


Function rot(x1,y1,x2,y2 : Real) : Real; の中で y1=y2 の時

>ELSE tR := ArcTan((y2 - y1) / (x2 - x1)) * 180 / pi;

の行は tR=0 になると思いますが、実際は x1,x2 の値によって 0 又は 180
にならなければいけないのでは?。

それと

>ELSE tR := ArcTan((y2 - y1) / (x2 - x1)) * 180 / pi;

の部分ですが Vector Script には Rad2Deg関数が有りますので

ELSE tR := Rad2Deg(ArcTan((y2 - y1) / (x2 - x1)));

とした方がすっきりするかも。

ちなみに2点間の角度を求める時、私は下の様にしています。

Function rot(x1,y1,x2,y2 : Real) : Real;
VAR
objH:HANDLE;
BEGIN
MoveTo(x1,y1);
LineTo(x2,y2);
objH:=LNewObj;
rot:=HAngle(objH);
DelObject(objH);
END;

これで煩わしい角度計算を回避しています。
この方法でも最近のパソコンでは処理速度もあまり気にならないと思います。
私が気づいたのはこの位です。


ポリラインに3D図形を配置する   やべ
email:
yabe@ff.iij4u.or.jp  Wed Apr 23 0:32:22 2003

先輩〜!助けて下さい!もう少しなんですけどうまくいかないんです!
今作ってるScriptで、"3Dポリラインから長さと方向と位置を取得して3D図形を同じ位置に配置する"というものなんです。
とある建物のCGを作っているんですが大屋根のブレースを作るのが大変で、セグメント1本の3Dポリラインで表現された長さ4mぐらいのブレースが1700本ほどあるんです...。これを"太さ"のある表現にしたいのですが、屋根が3次元曲面なもんで1本づつ長さと角度が微妙に違うんです...。
下の製作途中を添削して修正できる方いませんでしょうか?

Procedure Line2Solid;
VAR
h:HANDLE;
objH:HANDLE;
pX, pY, zValue: REAL;
p1X,p1Y,p1Z:REAL;
p2X,p2Y,p2Z:REAL;
plandist,Length1:real;
xDistance, yDistance, zDistance:REAL;
dia1,dia2:REAL;
a,b,c:real;
a1,a2,a3:real;

Function rot(x1,y1,x2,y2 : Real) : Real;
VAR
tR : Real;
BEGIN
If x1 = x2 THEN tR := 90
ELSE tR := ArcTan((y2 - y1) / (x2 - x1)) * 180 / pi;
If ((tR = 90) & (y2 < y1)) Or (x2 < x1) THEN tR := -tR;
If x2 < x1 THEN
If y1 < y2 THEN tR := 180 - tR
ELSE
If 180 + tR <> 180 THEN tR := -(180 + tR)
ELSE tR := 180 + tR;
rot := tR;
END;

Function pitch(x1,y1,z1,x2,y2,z2 : Real) : Real;
VAR
tR : Real;
BEGIN
If z1 = z2 THEN
tR :=0 
ELSE
IF (z1<z2) then tR := Tan(abs(z2-z1)/(distance(x1,y1,x2,y2)))* 180 / pi
ELSE tR:=-Tan(abs(z2-z1)/(distance(x1,y1,x2,y2)))* 180 / pi;
pitch := tR;
END;

BEGIN
h:=FSActLayer;
IF h<>NIL THEN
BEGIN
Absolute;
AngleVar;
dia1:=25;
dia2:=60;
a:=130;
b:=70;
c:=13;
objH:=FSActLayer;
WHILE objH<>NIL DO
begin
PushAttrs;
NameClass('rod');
GetPolyPt3D(objH,#0,p1X,p1Y,p1Z);
GetPolyPt3D(objH,#1,p2X,p2Y,p2Z);
zDistance:=abs(p1Z-p2Z);
Length1:=sqrt(sqr(Distance(p1X,p1Y,p2X,p2Y))+sqr(zDistance));

BeginSweep(#0,#360,#60,0);
Relative;
Locus(0,0);
BeginPoly;
OpenPoly;
Move(0,0);
LineTo(-dia2/2,0);
LineTo(0,a);
LineTo(c,b);
LineTo((dia2/2 )-(dia1/2)-c,0);
LineTo(0,Length1-a-a-b-b);
LineTo(-((dia2/2 )-(dia1/2)-c),0);
LineTo(-c,b);
LineTo(0,a);
LineTo(dia2/2,0);
EndPoly;
EndSweep;
a1:=#0;
a2:=pitch(p1X,p1Y,p1Z,p2X,p2Y,p2z);
a3:=rot(p1X,p1Y,p2X,p2Y);
message('L=',Length1,'-->','a1=#',a1,'度',' ,','a2=#',a2,'度',' ,','a3=#',a3,'度');
Set3DRot(LNewObj,#0, #0,#-90, 0,0,0);
Set3DRot(LNewObj,#0, #a2,#0, 0,0,0);
Set3DRot(LNewObj,#0, #0,#a3, 0,0,0);
Move3DObj(LNewObj,p1X,p1Y,p1Z);
PopAttrs;
SetDSelect(LNewObj);
objH:=NextSObj(objH);
end;
END
ELSE
AlrtDialog('Select Objects!');
END;
RUN(Line2Solid);


下の書き込み   目には目を!
email:  Mon Mar 31 1:46:17 2003

ddo.jpというサイトが無料でドメインサービスをしているんですが、そこに登録して
いる人ですね。

ddo.jpの持ち主に連絡して、下記ドメインの持ち主の情報をもらいましょう。
多大なる迷惑を被っているということをお伝えして、当該ドメインを削除してもらいま
しょう。

書き込みをした本人は、もしフトドキな行為をしている自覚があるなら、こちらが
行動する前に、謝罪と、書込み削除依頼をしてください。


管理人さんには書き込みに関するログ情報の収集をお願い致します。


RE(2): モダンダイアログ   カオタカ
email:  Sun Feb 2 15:47:15 2003

陰陽師さん,お返事ありがとうございます.
サンプルを用いてサブルーチンを勉強します.

>編集できないフィールドを作成する「CreateStaticText」を使っても,
>ダイアログ内に文字が現れません.

間違いの原因がわかりました.シングルクオートが抜けてました.
単なるミスです.お騒がせして申し訳ありません.


RE: モダンダイアログ     陰陽師
email:
hagimori@daiken.co.jp  Sun Feb 2 11:34:57 2003

下のサンプルの10〜13行目は下記のように読み換えて下さい

procedure DlgCallback(var Item,Value: Longint);
begin
Check := ItemSel(CheckBoxID);
end;


RE: モダンダイアログ   陰陽師
email:
hagimori@daiken.co.jp  Sun Feb 2 10:46:42 2003

>編集できないフィールドを作成する「CreateStaticText」を使っても,
>ダイアログ内に文字が現れません.

CreatXXX() と SetBelowItem() を対で記述していますか?

>前回書かせて頂いた「サブルーチンを二つ…」のほうは,未だにできていませんが...

プログラムを出来るだけ短い単位に分割する事には、大きなメリットがあります

 1. サブルーチン化により、プログラム中で似たようなコードを何度も記述しなくとも
  良くなり、プログラム全体の長さや作成時間が短縮できる
 2. プログラム自体が読みやすくなる
 3. プログラムを最小単位に分割することにより、バグが紛れ込みにくくなる
  同時にバグの検証が容易になる 等々...

是非サブルーチン化を心掛けて下さい。以下は、サンプルです

Procedure TestDlg;
const
CheckBoxID = 3;
StaticTextID = 4;
var
DlgJust,Check: Boolean;
DialogID,Result: LongInt;
JudgeValue: String;
H: Handle;

procedure DlgCallback(var Item,Value: Longint);
begin
Check := ItemSel(3);
end;

procedure CreateDlg;
begin
DialogID := CreateLayout('TestDialog',False,'OK','Cancel');
CreateCheckBox(DialogID,CheckBoxID,'CheckBox');
SetFirstLayoutItem(DialogID,CheckBoxID);
CreateStaticText(dialogID,StaticTextID,'Test_StaticText',15);
SetBelowItem(dialogID, CheckBoxID, StaticTextID,0,0);
DlgJust:=VerifyLayout(DialogID);
if DlgJust then
Result := RunLayoutDialog(DialogID,DlgCallback);
end;

procedure Judge;
begin
if Check then
JudgeValue := 'チェックあり'
else
JudgeValue := 'チェックなし';
end;

procedure Alrt;
begin
SysBeep;
AlrtDialog('ワークシートをアクティブにしてください!');
end;

begin
CreateDlg;
if Result = 1 then
begin
H := ActSSheet;
if H<>nil then
begin
Judge;
LoadCell(1,1,JudgeValue);
end else
Alrt;
end;
end;
Run(TestDlg);


モダンダイアログ   カオタカ
email:  Sat Feb 1 17:29:35 2003

カオタカです.
モダンダイアログについて聞きたいことがあります.
編集できないフィールドを作成する「CreateStaticText」を使っても,ダイアログ内に文字が現れません.
見つけたサンプルを実行してみても,文字が出てきません.
原因がわからないので,誰かアドバイスをお願いします.

前回書かせて頂いた「サブルーチンを二つ…」のほうは,未だにできていませんが,違うやり方でそれなりに納得のいくものに仕上がりました.
お手数かけました.m(_ _)m


サブルーチンを二つ使用したい   カオタカ
email:  Fri Jan 31 3:21:11 2003

石男さん,いろいろとありがとうございます.
石男さんから頂いたサンプルと,モダンダイアログのサンプルをみつけたので,それをうまく組み合わせて,私なりにカスタマイズしています.
ちょっとわからないことが発生したので,質問させていただきます.
サブルーチンを二つ作り(一つは,モダンダイアログの内部機能を設定するもの,もう一つは,チェックの有無をワークシートに返すというもの),その二つを呼びたいのですが,後者のほうがうまくいかず,チェックの有無に関係なく「なし」というふうに返ってきます.( コンパイルはしています )
以下にプログラムの最後を載せます.
どこにおかしいところが存在するのか,指摘して頂きたいと思います.
よろしくお願いします.
−− 定義 −−
verify : Boolean
result , aresult : Longint
mdaialogcallback , wsheetはサブルーチンのタイトル
( 前者が内部機能であり,後者がチェックの有無です )
myresult := ItemSel ( * ) ( ←これはサンプルのマネをして,wsheetの中にあります )

verify := VerifyLayout(dialogID);
IF verify THEN
BEGIN
result := RunLayoutDialog ( dialogID , mdaialogcallback );
IF result=1 THEN
BEGIN
aresult := RunLayoutDialog ( dialogID , wsheet );
IF myresult = true THEN
BEGIN
LoadCell ( 3 , 4 , 'あり');
END ELSE
BEGIN
LoadCell ( 3 , 4 , 'なし' );
END;
END;
END;
END; {メインプログラムの最初のBeginに対応}
run(test_modandialog);


Re^2:初動バグ   石男
email:  Thu Jan 30 17:44:44 2003

>masafumiさん、KANABUNさん
ありがとうございます、なるほど!分りました。
ToolPlugInの初動と同じような処理をすればいいのでしょうね。

それと、座標を指定してその上の図形のハンドルを返す関数は、PickObjectしか無いで
すよね?


RE:初動バグ  masafumi
email:  Thu Jan 30 14:25:48 2003

>最初のワンクリック前に0,0を取得済みとしてします現象をわりと高い頻度で経験してます。

そうなんですか。私の環境では一度も体験したことが無いです。
Windows版だからなのかな?。利用頻度が少ないからなのか?。

と言う理由で石男さん、分岐するかリピートで脱出するか。ですね。


初動バグ  KANABUN
email:  Thu Jan 30 13:44:58 2003

もあります。
最初のワンクリック前に0,0を取得済みとしてします現象をわりと高い頻度で経験してます。
これは解決策無しで、0,0を勝手に拾った場合のエラー分岐を付けるか、0,0の場合のリピートを
組み込むことで解消してます。
取得方法は私もmasafumiさんのようにGetPtでxy座標を取ってPickObjectへ代入する方法です。


RE^1:PickObjectのテスト(初めて使ったら)  masafumi
email:  Thu Jan 30 11:43:22 2003

>勝手にx=0,y=0の座標を拾ってしまうみたいです

x,y の取得方法が原因だと思います。
こんな感じで試して見てください。

{************* PickObjectのテスト **************}
procedure PickObject_Test;
var
objH:Handle;
x,y :Real;
begin
GetPt(x,y);
objH:=PickObject(x,y);

message('x= ',x,' y= ',y,' objH= ',objH);
wait(2);
clrmessage;
end;
run(PickObject_Test);
{***************** ここまで ********************}


初めて使ったら   石男
email:  Thu Jan 30 9:46:53 2003

初めて使ったら、PickObject(x,y:Real):Handle;が上手く動作しません。
勝手にx=0,y=0の座標を拾ってしまうみたいです。
なにか解決策はないでしょうか?

VectorWorks9.5.1 Mac


VectorScriptサンプル   石男
email:  Thu Jan 30 9:31:03 2003

http://www.nemetschek.net/support/custom/vscript/example.html
ここです。              


Re(4):Scriptの限界?の続き   カオタカ
email:  Wed Jan 29 18:33:43 2003

石男さん,いろいろとアドバイスを頂き,本当にありがとうございます.
いろいろなサンプルを見て勉強していきます.
もうひとついうと,Nemetscheck社のサイトが見つかりません.
教えていただけないでしょうか?
よろしくお願いします.


Re^3:Scriptの限界?の続き   石男
email:  Wed Jan 29 15:20:19 2003

え〜と、サブルーチンDriveDialogはNemetscheck社のサンプルです。
>SetdownDialogC」は何を行っているのですか?
というより、まずはここでアイテムの結果を取得することだけを覚えてください。
>「DialogOK:=false;」は何を行っているのですか?
は単にBoolean型の変数の「DialogOK」を初期化しているだけです。

カオタカさんは初心者ですので、とにかくマネしてみてください。なかなか、サンプルを見る機会が少ないでしょうが、御本家のサイトにいくとVectorScriptのサンプルがあります。なんでも良いからいっぱい見ましょう、そして作りましょう。そのうち
中身を追い掛けられるようになります。


Re(2):Scriptの限界?の続き   カオタカ
email:  Wed Jan 29 14:54:38 2003

石男さん,お返事ありがとうございます.
サンプルは,私がやりたかったことです.
サンプルを参考にさせて頂きたいのですが,少し理解できない部分があるのでお尋ねします.

Subの「SetdownDialogC」は何を行っているのですか?
Mainの「DialogOK:=false;」は何を行っているのですか?

まだまだ初心者でありますので,お手数ですが返答のほう,よろしくお願いします.


Re: Scriptの限界?の続き   石男
email:  Wed Jan 29 9:59:23 2003

Scriptの限界は自分限界だとつくづく感じている今日この頃です。
モダンダイアログはアイテムが簡単に作れる反面、後処理が面倒です。以下、サンプル
です。ワークシートをアクティブにした上で使ってください。なお、LoadCellは今後
無くなる関数ですので、他のものに置き換えをお勧めします。

Procedure Test ;
Var
dialogOK , myResult : Boolean ;
lEditID , lmtestResult : Longint ;

{-------------Sub-------------}
Procedure DriveDialog( Var item : Longint ; data : Longint ) ;
Begin
CASE item OF

SetdownDialogC : Begin
myResult := itemsel( 3 ) ;{チェックボックスの選択状態を返す}
SysBeep ;
End ; {end dialog clean up}


End ; {end CASE}
End ;
{============Main================}
Begin
dialogOK:= false ;
{ダイアログの設定}
lEditID := CreateLayout( 'M.Dialog_Test' , false , 'OK' , 'Cancel' ) ;
{アイテムの作成}
CreateCheckBox( lEditID , 3 , 'CheckTest' ) ;
{アイテムの配置}
SetFirstLayoutItem( lEditID , 3 ) ;
{// this verifies the dialog definition is a good one }
dialogOK := VerifyLayout( lEditID ) ;
If dialogOK Then
Begin
{// the RunLayoutDialog returns 1 or 2 indicating which control was pressed to exit }
lmtestResult := RunLayoutDialog( lEditID , DriveDialog ) ;
If ( lmtestResult=1 ) Then{ダイアログのOKを押した後の処理}
Begin
If ( myResult = true ) Then{チェックボックスを押した後の処理}
Begin
LoadCell( 1 , 1 , 'チェックあり') ;
End Else{チェックボックスを押さない後の処理}
Begin
LoadCell( 1 , 1 , 'チェックなし') ;
End ;
End ;

End ;
End ;
Run( Test ) ;


Scriptの限界?の続き   カオタカ
email:  Wed Jan 29 0:10:52 2003

続きです.
チェックボックスを作成し,チェックが入ったらワークシートのセルに「チェックあり」,なければ「チェックなし」という言葉を入れたい.
そこで,IF文を用いたところエラーになりました.

checkboxID=*  (*はアイテム番号です.)


If ItemSel(*) then
begin
LoadCell(3,4,'あり');
end
else begin
LoadCell(3,4,'なし');
end;


上記したものが何個か続きます.
さらに,IF文のなかにIF文を用いています.
ひょうとして…これが原因なのでしょうか?




Scriptの限界?   カオタカ
email:  Tue Jan 28 23:28:30 2003

カオタカです.
ちょっと聞きたいんですけど,Scriptはどこまで書けるのですか?
少し長めのScriptを組み,コンパイルに成功し,実行しようとしたことろ,
エラーが生じてVectorが閉じられました.
いったい,限界(?)はどこなんでしょうか?
私がやっていたことは,”モダンダイアログに記入(チェックボックスにチェックを入れたり,編集フィールドに文字列を書いたりなど)した結果を,ワークシートに返す”というようなことです.


RE^3:言葉の意味   カオタカ
email:  Tue Jan 28 16:34:43 2003

石男さん,お返事が大変遅くなりすみません.
お返事を頂いてから勉強をし,ようやくモダンダイアログの使い方がわかってきたように思います.
これから先,わからないことが出てくると思います.
そのときは質問させて頂くとおもいますので,
どうかよろしくお願いします.m(_ _)m


Re.^2: 言葉の意味   石男
email:  Sat Jan 25 18:27:56 2003

追加です、モダンダイアログの説明がVW9.5の「VectorScriptlanguage.pdf」にきちん
と書いてあります...。一度読みましょう。


Re.: 言葉の意味   石男
email:  Sat Jan 25 18:21:04 2003

>ダイアログID,アイテムID
そのままです、ダイアログの識別番号、アイテムの識別番号です。
少し古い本ですが、「MiniCADプログラミング入門」を一読ください。
Scriptの基本が学べます。
それと、ここのバックナンバーも合わせて読んでみてください。目的のことが書いてな
いかもしれませんが、勉強にはなります。


言葉の意味   カオタカ
email:  Sat Jan 25 13:04:53 2003

カオタカです.
初歩的?基本的?なことかもしれませんが,ちょっと言葉の意味を聞きたいと思います.
「CreatePushButton」や「CreateRadioButton」などのあとにくる,ダイアログID,アイテムIDというのは何を指すのでしょうか.
教えて頂けないでしょうか.
お願いします.



RE(2): セルの幅の変更   カオタカ
email:  Fri Jan 24 16:12:00 2003

>NewSprdSheet() の最後のパラメーターの値を True にしてください
こちらのことなんですけど,できました.
ワークシートが作業画面上にでてきてくれました.
ありがとうございました.


RE(2): セルの幅の変更   カオタカ
email:  Fri Jan 24 16:00:26 2003

あっ,セル幅の変更はうまくいきました.
感謝の意を表すのを忘れていました.
申し訳ありませんでした._(._.)_
陰陽師さん,本当にありがとうございました.


RE(2): セルの幅の変更   カオタカ
email:  Fri Jan 24 15:55:24 2003

陰陽師さん,お返事ありがとうございます.
>LoadCell() の前に、SprdWidth() を記述していますか?
記述してみました.
SprdWidth()の括弧内に入した数値の8倍の値が出てきました.
括弧内に10を入れるとセル幅は,80ポイントとして出てきました.

>NewSprdSheet() の最後のパラメーターの値を True にしてください
こっちのほうなんですけど,まだまだ初心者の身でして,どうすればいいのかイマイチ
理解できません.
具体的なアドバイスを頂けませんか?
お願い致しますm(_ _)m.


RE: セルの幅の変更   陰陽師
email:
hagimori@daiken.co.jp  Fri Jan 24 14:45:35 2003

>新しいワークシートを作成するときに,作業画面上に現したいのですが現れてきません

NewSprdSheet() の最後のパラメーターの値を True にしてください

>「SprdWidth」を用いてセルの幅を設定すると,単位がポイントになっておらず,セル幅
>がとても大きくなってしまいます.どうすれば単位をうまく合わせられるのでしょうか?
                  ↓
LoadCell() の前に、SprdWidth() を記述していますか?


セルの幅の変更   カオタカ
email:  Fri Jan 24 0:23:57 2003

よく見ると「を作成するとき,」というふうに,頭が抜けている….
「プログラムを作成するとき,」の間違いです.
すみません.


セルの幅の変更   カオタカ
email:  Wed Jan 22 21:12:12 2003

ワークシートのセルの幅についてお尋ねします.
セルの幅を設定する「SprdWidth」がありますが,数値の単位がポイントになっています.
を作成するとき,上記した「SprdWidth」を用いてセルの幅を設定すると,単位がポイントになっておらず,セル幅がとても大きくなってしまいます.どうすれば単位をうまく合わせられるのでしょうか?
もう一つ聞きたいことがあります.新しいワークシートを作成するときに,作業画面上に現したいのですが現れてきません.いろいろと試行錯誤しているのですが,うまくいきません・・・誰か,誰か助けてください.
お願いします.


Re^2:ツールからプラグインオブジェクト   石男
email:  Sat Jan 18 13:50:46 2003

>箱だけ(おそらくグループ)のプラグインオブジェクトを用意しておいて、そこへ
>3Dシンボルを画面上でクリックすることで一体化する事をやってのけてます
すごい、すごい。アイデア次第という訳ですか...。


Reツールからプラグインオブジェクト  KANABUN
email:  Sat Jan 18 12:36:30 2003

VSについてですが、あらかじめプラグインオブジェクトを作って置かないとコードからは呼べないのではないでしょうか?
実はにたような事を試した事があります。
プラグインオブジェクトのコード内でシンボルフォルダとシンボルを製作してそれをプラグインオブジェクト内で表示するというものです。私の技量では上手くいきませんでした。

ひょっとしたらこれら全ては何らかの方法で可能なのかもしれません。
カフェテラスにあるジュリアンさんのアニメーションワークスを試してみて思いました。
アニメーションワークスでは、箱だけ(おそらくグループ)のプラグインオブジェクトを用意しておいて、そこへ3Dシンボルを画面上でクリックすることで一体化する事をやってのけてます。
アイデア次第では他のアプローチもあるかもしれません。
風邪ひいてしんどいです。仕事も山積み...。


ツールからプラグインオブジェクト   石男
email:  Fri Jan 17 14:05:08 2003

サブルーチンでプラグインオブジェクトを作り?ツールのメインプログラムで、それを
呼ぶことって出来ませんか?コンパイルは通るのですが、図形を描画してくれません。
誰かこんなことやっていませんか?


延長ツール  youya
email:
hi68_tentsu@nifty.com  Mon Jan 6 18:10:33 2003

みなさん
あけましておめでとうございます
本年もよろしくお願いいたします

masafumiさん、延長ツール使用してみました
望んでいた通りのツールで感激致しました
有難うございました



延長ツール  you-ya
email:
hi68_tentsu@nifty.com  Mon Dec 30 1:10:31 2002

masafumiさん、助かります是非試してみます。
有難うございました。
また感想等お知らせいたします。
良いお年を!


RE:^1 延長ツール  masafumi
email:  Sun Dec 29 2:35:46 2002

作ってみました。テスト不十分ですが、よろしければ使ってみて下さい。
下記にUPしました。

http://www5c.biglobe.ne.jp/~masafumi/index.html

「目次」→「ソフト」で「すべてを延長.vsm」 をダウンロードして下さい。


延長ツール  you-ya
email:
hi68_tentsu@nifty.com  Thu Dec 26 14:49:41 2002

VectorWorksの方でも質問させて頂きましたが
VW9.5 WINを使用していますyou-yaと申します。
過去に一度だけ違う質問をさせて頂いた事があります。
今回は
バラバラの長さの線分(平行)を基準線にまとめて延長出来るツール
通り芯などを寸法の加減でもう少し延長したい時
基準線にまとめて延長できるツールって出来ないでしょうか?

バックナンバーも調べてみましたが、探せませんでした。
スクリプトは理解出来ず勉強停滞中です。
他力本願ですいません。


3D多角形の頂点の数   石男
email:  Wed Dec 25 9:24:48 2002

レファレンスをひっくり返しても探し当てられなかったので、エラーが出たらループを
抜け3D多角形の頂点の数を返すもの作りました。作ってから、ここのバックナンバーを
を見て唖然としました。GetVertNumで3D多角形の頂点の数を返すじゃないですか...。
まあ、それでもこんな使い方も出来るということで...。

Procedure Test ;
Var
h : Handle ;
x , y , z : Real ;
i : Integer ;
myError : Boolean ;

Begin
h := FsactLayer ;
i := 0 ;
myError := false ;
Repeat
GetPolyPt3D( h , i , x , y , z ) ;
myError := FndError ;
If myError = false Then
Begin
Message( Concat( 'i=' , i , ' x=' , x , ' y=' , y , ' z=' , z ) ) ;
i := i + 1 ;
End Else
Begin
i := i-1 ;
Message( Concat( 'i=' , i ) ) ;
End ;
until myError = true ;

End ;
Run( Test ) ;


RE^2:3Dの配列複製   匠
email:  Thu Dec 19 11:16:23 2002

masafumiさん,遅くなってすみません.
「配列複製のテスト」は,私のやりたいことです.
あと,このz軸方向への移動量をダイアログにすればよいので,それは自分でします.
この,3Dの配列複製の方法について案を出して頂いたmasafumiさんに感謝します.



おっしゃるとおりです(RE:3Dの配列複製?)  masafumi
email:  Sun Dec 15 22:59:08 2002

出来ることなら題名は内容が理解できる様にして頂けると、バックナンバー検索時に
検索しやすくなりますよ。

>私は立方体を描きそれをx,y軸方向へは移動せず,z軸方向へ移動させたいのです.
>ん〜と,つまり,同じ大きさの立方体を,ある間隔でz軸方向にいくつか並べたいのです.

こんな感じの事がやりたいのでしょうか?。

{******************** 配列複製のテスト ***********************************}
{画面上で3D図形を選択してから実行して下さい}
Procedure Duplicate_Test;
Var
i :Integer;
objH:Handle;
dz :Real;
Begin

for i:=1 to 5 do
begin

Duplicate(0, 0); {選択されている図形を複製し、指定した位置に移動させます。}
objH:=FSActLayer; {選択されている最上位の図形のハンドルを取得}
dz:=5000;
Move3DObj(objH,0,0,dz);

end;

End;
Run(Duplicate_Test);


おっしゃるとおりです   匠
email:  Sun Dec 15 16:25:30 2002

masafumiさん,お返事ありがとうございます.
意図がわかりにくくて申し訳ありませんでした.m(_ _)m
改めまして質問です.
複製方法の一つに

Duplicate(offsetDX, offsetDY:REAL);

がありますが,これは複製を行った後x,y軸方向への移動量を入力します.
私は立方体を描きそれをx,y軸方向へは移動せず,z軸方向へ移動させたいのです.
ん〜と,つまり,同じ大きさの立方体を,ある間隔でz軸方向にいくつか並べたいのです.
意図とすることが伝われば幸いです.
私も,masafumiさんのおっしゃられたことを参考に勉強していきます.
よろしくお願い致します.


(RE:配列複製)訂正です。  masafumi
email:  Sat Dec 14 22:26:58 2002

>メニューの「編集」→「配列複写」

ではなくて「編集」→「配列複製」です。


お願いします(RE:配列複製)  masafumi
email:  Sat Dec 14 22:06:21 2002

はじめまして、匠さん。

>配列複写を組みたいのですが,その方法がわかりません.

これだけでは、質問の意図がわかりにくいですよ。
メニューの「編集」→「配列複写」のダイアログをプログラムから呼び出したいのでしたら

DoMenuTextByName('Duplicate Array',0);

でダイアログを表示できます。
また、プログラムで配列複写と同様のことをするには、

FOR文、REPEAT-UNTIL 文、WHILE-DO 文

等を使って自分でコードを書くことになります。


お願いします   匠
email:  Thu Dec 12 17:17:39 2002

初めまして.ただいまプログラム勉強中の匠です.
配列複写を組みたいのですが,その方法がわかりません.
誰か私に手を差し延べて頂けないでしょうか?
お願い致します.


Re.:自己レス   石男
email:  Fri Oct 25 17:34:44 2002

やはり単位設定や縮尺に左右されて各条件の設定をしました。
これしかないですよね。


単位設定や縮尺に左右されず   石男
email:  Fri Oct 25 15:13:33 2002

長い題名で済みません。
文字のサイズは、単位設定や縮尺に左右されず9ポイントと指定すればどんな設定でも
同じ大きさで出てきますが、Scriptで書く図形もどんな設定にも左右されない大きさに
書くことは可能でしょうか?


Re^2:円弧半径   あずま
email:
azuma@lemon.ifnet.or.jp  Sat Oct 12 18:36:03 2002

plugramerさん、ありがとうございます。レスが遅くなってしまってすみませんでし
た。

HCenterは素直に「図形の情報」のところに分類してくれていればもう少し早く解決
していたかもしれないと思いました。とまどってるのはわたくしだけ?

Get2DPtはいろいろな場面で使えそうですね。でも具体的にどの図形タイプにつかえ
るのかとかは実験してみないとわからない、というのはもうそろそろくたびれてきて
しまいました(歳のせいかも、、、)。Scriptにはこういうパターンが多すぎだと思
います。
マニュアルには2D図形としか書かれていないけどその図形タイプは何なのか、頂点番
号はどういう基準で振られるのか、といったこともきちんと書いておいてほしいです。

それから円弧角はGetArcでも得られるようですがこの手続きで中心座標や半径がわかるべきだと思います。一番それらしい名前だと思うし、、、

なんだかグチだらけになってしまいました。しつれいしました。


Re^2:円弧半径(訂正)  plugramer
email:  Sat Oct 12 14:28:46 2002

あずまさん、失礼。
自己レス見ていませんでした。m(_._)m

KANABUNさん
Get2DPt( h, 3, x3, y3 );
で終端座標を得れば、円弧角も計算できるという分けですね。


Re^2:円弧半径(訂正)  plugramer
email:  Fri Oct 11 23:49:26 2002

すみません余計なものが入ってしまいました。
最後の三行のみ書き込みです。


Re^2:円弧半径  plugramer
email:
someda@cwlaputa.com  Fri Oct 11 23:47:24 2002

REAL
REAL
REAL
REAL
REAL
REAL
REAL
REAL
BOOLEAN
1番目の四角形の左上のX座標
1番目の四角形の左上のY座標
1番目の四角形の右下のX座標
PROCEDURE HCenter(h:HANDLE;VAR x,y:REAL);
は試されましたでしょうか?。
機能的に変わっていなければこれで中心座標が返って来るかと思います。


Re^2:円弧半径   石男
email:  Mon Oct 7 9:18:42 2002

いや〜、 KANABUNさんありがとうございました。
こうゆうやり方があるんですね、目から鱗でした。
それ以前の問題で、円弧半径を取得出来る関数を作って欲しいですね。


Re:円弧半径   あずま
email:
azuma@lemon.ifnet.or.jp  Sun Oct 6 15:34:39 2002

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

v.9.5上でGet2DPtを試してみました。すごくスマートでいいですね。さっそくこっち
のやりかたに変更させてもらいます。Get2DPtは以前使ってみてうまく動作してくれ
なかったので無意識のうちにこれはダメの烙印を押してしまっていました。時がたて
ばいろいろかわってくるはずなのにこういう意識の持ち方はダメですよね。ひとり
じゃきっと気付けませんでした。

で、V.8.5でもためしてみましたが、やはりこちらではうまく動いてくれませんでし
た。Get2DPtの関数自体はあるようですが、、、


すいません、管理人様  KANABUN
email:  Sun Oct 6 14:22:00 2002

OSXのモジラから投稿したのですが、再読み込みされなくて2度投稿してしまいました。
管理人様、お手数で申し訳ありませんが、削除をお願い致します。


円弧半径  KANABUN
email:  Sun Oct 6 14:16:53 2002

ですが、以下のサブプーチン使ってます。
以前はHwidth/2でいけたのですが、9から無理になりました。

{----------------- Arc_R----------------------}
Function Arc_R( h : handle ) : real ;
Var
x1, y1, x2, y2 : real ;
begin
Get2DPt( h, 1, x1, y1 );
Get2DPt( h, 2, x2, y2 );
Arc_R := distance( x1, y1, x2, y2);
end ;


Re:円弧図形   あずま
email:
azuma@lemon.ifnet.or.jp  Sat Oct 5 19:13:09 2002

山本さん、はじめまして。
スクリプトで自由曲線を描く方法ということでしたら、BeginPolyとEndPolyの間で
ArcToを使って曲線の頂点を追加していけばできます。
スクリプトではなく一般的な使い方ということでしたら、『円弧指定による曲線』ツー
ルをつかえば曲線が描けます。
ひょっとしたらご質問の意図からはずれた回答かも、、、


Re.:円弧の半径   あずま
email:
azuma@lemon.ifnet.or.jp  Sat Oct 5 19:09:57 2002

石男さん、ありがとうございます。
やっぱりなさそうですね、、、どういう理由でないのか不思議ですよね。
もう少し粘って探ってみますが、、、


円弧図形   山本
email:
yamamomo@lapis.plala.or.jp  Sat Oct 5 15:07:54 2002

VW9.5windows使っています。円弧や円を図形ではなく曲線で表示出来ないでしょうか?回答よろしくおねがいします。


Re.:円弧の半径   石男
email:  Sat Oct 5 9:10:55 2002

任意の円弧の半径を直接取得する関数はないですよ、多分。よくArcToを使用していま
すが、やはり力技で半径をだしています。1/4円弧しか使わないので...。
それ以外の円弧は使っていません。
>円弧を多角形に変換して頂点座標を調べて半径を求める
きっと、こうゆうやり方しかないと思いますが。


Re:円弧の中心座標   あずま
email:
azuma@lemon.ifnet.or.jp  Fri Oct 4 20:14:43 2002

管理人さま、やさしいフォローありがとうございます(涙)。
でもさらに基本的なことでわからないことができてしまいました、、、
こんどは円弧の半径を出す方法がわかりません(泣)。

とりあえず円弧を多角形に変換して頂点座標を調べて半径を求める、というやり方でな
んとかしのぎましたが、こんなやりかたゼッタイまちがってますよね、、、


Re:円弧の中心座標   管理人
email:
manager@vwch.infonav.net  Fri Oct 4 18:07:24 2002

あずまさんの質問に答えられるのはあずまさんだけ...m(^_^)m
どんどん、ここで自問自答していただきますように...m(_._)m
得した気分の管理人でした。


Re:円弧の中心座標   あずま
email:
azuma@lemon.ifnet.or.jp  Fri Oct 4 0:56:15 2002

自己レスです、、、

HCenterをつかったらあっけなくできました。
いままでの長年の苦労はなんだったのだろう、、、、、
思い込みというのはおそろしいもんだとおもいました。
それから他人の目にこういう悩みをさらけだしてみると妙に客観的になれて自分で解決できたりするもんだとあらためて思いました。
おさわがせいたしました。

あ、でもSetArcの動きはやっぱり変ですよね?


円弧の中心座標   あずま
email:
azuma@lemon.ifnet.or.jp  Thu Oct 3 13:00:30 2002

会員番号396番のあずまです。
教えていただきたいことがありますのでよろしくおねがいいたします。

実は円弧の中心座標をスクリプト(v9以上)で求める方法がわかりません。
あまりにも基本的なことなのでたぶんわたくしの単純な思い違いだと思うのですが自
力ではいつまでたっても解決できそうもないのでお解りの方よろしくお願い致します。

実はv8.5までは自分なりの変則的なやりかたで何となくすっきりしないままでしたが
なんとか対応してきたのですが、v9になってからそのワザが使えなくなってしまい行
き詰まってしまいました。

そのやりかたは円弧にハンドルを渡しSetArcで円弧角を360°に変更してからXCenter
とYCenterで中心座標を得る、というものでした。ところがv9以降SetArcで円弧角を
変更するとなぜか円弧の中心がずれるうえに半径までかわってしまうようになりこの
ワザが使えなくなってしまいました。

たとえば適当に円弧を描きアクティブにしておきながら

procedure enko;
var
h:handle;
begin
h:=FSActLayer;
SetArc(h,0,90);
end;
run(enko);

を実行していただくとわかると思うのですが円弧の中心と半径がなぜか変わってしま
うのです。

このような状況ですのでこれにかわる円弧の中心座標の求め方があれば教えて下さい。
ダイレクトに求められる関数があるといいのですが、、、
よろしくおねがいいたします。


 mune
email:  Fri Sep 20 12:56:08 2002

さっそくの御回答ありがとうございます。(v v);
昨晩悪戦苦闘した結果、もう一度最初からタイプしてみたら、
なんとか動くようになりました。環境はwin98SE,会社ではNT4.0を
使ってます。Vectorは9.5.1です。ランタイムエラーが出た原因は結局不明
でしたが、カスタムダイアログは設定がシビアみたいです。
将来は、VECTORでDRACADコマンドを作ることが夢なので、これからも
がんばります。(建築設計をやってますので)


RE:カスタムダイアログができません。   なか
email:
n_home@plum.freemail.ne.jp  Fri Sep 20 8:34:24 2002

プログラムは問題ないと思いますよ。
ただ、メッセージ文が、このままでは表示されませんので、
Message('アイテムタイプ',itemtype);
の上にClrDialog;をいれるといいです。

もしかして、MacOSX10.2をつかっているんすか?

muneさんの環境を公表すると、もっと解るかもしれませんね。
私の動作確認環境はMacOS9.2.1上でVectorWorks v9.5.2です。


カスタムダイアログができません。  mune
email:  Thu Sep 19 20:51:00 2002

カスタムダイアログにTRYしてますが、うまくいきません。C++のRunTime Error
に悩まされてます。何か根本的にいけないことがあるのでしょうか。
どうもGetFileldとitemSelを作動させるとクラッシュするみたいです。また、EndDialog
のあとにClrDialogをいれてもクラッシュします。原因究明の為下のような最も単純なものを作成しましたが、作動しません。
Procedure TEST;
VAR i, item,cx,cy,x1,x2,y1,y2:INTEGER;
itemtype:INTEGER;
BEGIN

GetScreen(x1,y1,x2,y2);
cx:=(x1+x2)/2;
cy:=(y1+y2)/2;

BeginDialog(1,1,cx-100,cy-100,cx+100,cy+100);

AddButton('ボタン',1,3,20,20,100,40);
AddButton('ボタン',2,3,20,45,100,65);
AddButton('ボタン',3,3,20,70,100,90);
AddButton('OK',4,1,20,170,100,190);

EndDialog;
GetDialog(1);

REPEAT
DialogEvent(item);
IF (item>=1) AND (item<=3) THEN
BEGIN
FOR i:=1TO 3 DO
BEGIN
SetItem(i,FALSE);
END;
SetItem(item,TRUE);
END;
UNTIL (item=4);

Message(item);
iF ItemSel(1) THEN itemtype:=1;
iF ItemSel(2) THEN itemtype:=2;
iF ItemSel(3) THEN itemtype:=3;
Message('アイテムタイプ',itemtype);

END;
Run(TEST);


RE:破線の書き方教えてください。    masafumi
email:  Thu Aug 1 17:06:21 2002

こんにちは、papaxさん。

簡単ですが、線種のチェック用サンプルです。
図形を選択してから実行して下さい。
メッセージウィンドウに表示された数字と属性パレットの線種の並びを比較
すると理解できると思います。

{******************** 線種チェック用 *******************}
procedure chk_SetLS;
var
i,ret:Integer;
objH :Handle;
begin
{図形のハンドルを取得}
objH := FSActLayer;
ret:=GetLS(objH); {現在の設定値を取得}

for i:=2 downto -10 do
begin
SetLS(objH,i); {線の種類を変更}
ReDraw;
message(i);
wait(1);
clrmessage;
end;

SetLS(objH,ret); {線の種類を元に戻す}
ReDraw;

end;
run(chk_SetLS);
{--------------------- ここまで -------------------------}


破線の書き方教えてください。  papax
email:
papax@m2.catvmics.ne.jp  Wed Jul 31 21:53:57 2002

はじめまして。先日プログラミング入門を買って、ただいま勉強中です。とりあえず一通り読んだのですが、破線の書き方がわかりません。初歩的な質問ですみませんがよろしくお願いいたします。


復活!   管理人
email:
manager@vwch.infonav.net  Sun Jun 30 0:00:53 2002

Script談話室、復活できました。
ご利用下さい。